diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..0b277fd3 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,40 @@ +# Cygwin git and github for windows differ in their eol convention: Github for +# windows uses crlf, but cygwin git uses LF. +# Since we want the same enlistment to work both ways, we need to specify and stick +# with end of line convention for all files. +# Therefore we choose LF for all files except windows command scripts. + +* text=auto + +*.md text eol=lf +*.c text eol=lf +*.h text eol=lf +*.Mod text eol=lf +*.mod text eol=lf +*.Lola text eol=lf +*.lola text eol=lf +*.make text eol=lf +*makefile text eol=lf +*.sh text eol=lf +.git* text eol=lf + +*.cmd text eol=crlf + + +# Symbol files are binaries +*.sym binary + +# Other binaries (these are not normally checked in.) +*.o binary +*.obj binary +*stackdump binary +*exe binary + +# Provide type information to improve block annotation in git diff output. +*.Mod diff=pascal +*.c diff=cpp +*.h diff=cpp + +# Set the language to Oberon +*.Mod linguist-language=Oberon +*.mod linguist-language=Oberon diff --git a/.gitconfig b/.gitconfig new file mode 100644 index 00000000..e97fe66d --- /dev/null +++ b/.gitconfig @@ -0,0 +1,10 @@ +[core] + repositoryformatversion = 0 + filemode = true + bare = false + logallrefupdates = true + ignorecase = true + autocrlf = true +# safecrlf = false +[push] + default = simple diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..19fc1ede --- /dev/null +++ b/.gitignore @@ -0,0 +1,46 @@ +/*.sublime-* +/Configuration.Mod +/Configuration.Make +/build/* +/install/* +/*.exe +/*.obj +/*.[cho] +/*.lib +/*.map +/*.sym +/*.asm +/*.mod +/Errors.Txt +/Errors.txt +/olang +/src/test/**/*.exe +/src/test/**/*.c +/src/test/**/*.h +/src/test/**/*.o +/src/test/**/*.obj +/src/test/**/*.sym +**/*.stackdump +!/src/test/confidence/**/expected +/src/test/confidence/**/input +/src/test/confidence/**/result +/src/test/confidence/**/result-* +/src/test/confidence/**/*[^.]* +/src/test/confidence/**/*.asm +/src/test/confidence/**/*.s +/src/test/confidence/**/*.map +/bootstrap/*/SYSTEM.[ch] +/bootstrap/*/Errors.Txt +/bootstrap/*/WindowsWrapper.h +/.DS_store +**/.DS_store +**/*.dSYM +**/.tmp.* +/*.pdb +/*.ilk +/t/* +/triage/BasicTypeSize.md +/triage/Roadmap.md +triage/system/* +tags +voc diff --git a/COMPILE b/COMPILE deleted file mode 100644 index b10eddef..00000000 --- a/COMPILE +++ /dev/null @@ -1,21 +0,0 @@ -currently three bootstrap static binaries provided, for x86_64, x86, and armv6j_hardfp (works on raspberry pi) gnu/linux targets. - -0) prerequisites: libc6-dev on debian, glibc-devel, glibc-static on fedora. - -1) make with corresponding makefile - if it's rasp pi or other armhf platform then do - # make -f makefile.gcc.armv6j_hardfp - if it's x86 then - # make -f makefile.gcc.x86 - and if it's x86_64, then default makefile is for this platform - # make - - (theoretically you can also change TARCH in makefile and type make) - -2) # sudo make install - -this will install voc in /opt/voc- and create /opt/voc symlink to it. - -add /opt/voc/bin to your PATH and enjoy, compile, have fun! - --- noch diff --git a/README.md b/README.md deleted file mode 100644 index 8e35d61f..00000000 --- a/README.md +++ /dev/null @@ -1,67 +0,0 @@ - -vishap oberon compiler -====================== - -How to install -============== - -just cd into source directory and type - ->make -f makefile.linux.gcc.x86_64 - -if you are on linux x86_64 system and you want voc to use gcc as backend. - -otherwise use corresponding makefile. - -then type - ->sudo make install - -- or see COMPILE file. - -How to use -========== - -Type voc and it'll show you help. - -voc -M will compile your module and link it statically to libVishapOberon. -voc -m will link the module dynamically. - -If you have more than one module, and you want them to be compiled into elf filethen: -Let's assume we have module M0 which imports M1; - ->voc -l M1.Mod -s M0.Mod -M - -Here -l is a global option. -Module M1 will be compiled with -s option, i. e. sym file will be generated. - -Module M0 will be compiled and linked statically. - -In case you have modules in different directories, like "ui", "logic", "math", then you need to export MODULES environment variable like this: - ->export MODULES=".:ui:logic:math" - -and after call voc - ->voc -s ui0.Mod - -Otherwise you can use full path: - ->voc -s ui/ui0.Mod - -build rpm -========= - -if you'd like to build an rpm installer, then - -* compress sources as voc-1.0.src.tar.bz2 - assuming you in voc directory -> cd .. -> tar -jcvpf voc-1.0.src.tar.bz2 voc -* put them to ~/rpmbuild/SOURCES (on some systems as root to /usr/src/redhat/SOURCES/) or other similar location. -> mkdir -p ~/rpmbuild/SOURCES -> cp voc-1.0.src.tar.bz2 ~/rpmbuild/SOURCES -* cd to voc directory and run -> rpmbuild -ba voc.spec - -this should create voc rpm installers. diff --git a/ReadMe.md b/ReadMe.md new file mode 100644 index 00000000..95d7f840 --- /dev/null +++ b/ReadMe.md @@ -0,0 +1,305 @@ +![Build status](https://brownsmeet.com/githubhook/vishaps-status) + +# Ѵishap Oberon + +[Ѵishap Oberon](https://vishap.oberon.am/) is a free and open source (GPLv3) +implementation of the Oberon-2 language and libraries for use on +conventional operating systems such as Linux, BSD, Android, Mac and Windows. + +Vishap's Oberon Compiler (voc) uses a C backend (gcc, clang, tcc or msc) to compile +Oberon programs under Unix, Mac or Windows. Vishap Oberon includes +libraries from the Ulm, oo2c and Ofront Oberon compilers, as well as +default libraries complying with the Oakwood Guidelines for Oberon-2 compilers. + +### Contents + +    [**Installation**](#installation)
+    [**Compiling a 'Hello' application**](#a-hello-application)
+    [**License**](#license)
+    [**Platform support and porting**](#platform-support-and-porting)
+    [**Language support and libraries**](#language-support-and-libraries)
+    [**History**](#history)
+    [**Roadmap**](#roadmap)
+    [**Contributors**](#contributors)
+    [**Origin of the name "Ѵishap Oberon"**](#origin-of-the-name-Ѵishap-oberon)
+    [**References**](#references)
+ + +## Installation + +It is easy to install the Oberon compiler and libraries +with the following simple steps: + + 1. Install pre-requisites such as git, gcc, static C libraries, diff utils. + 2. Clone the repository: `git clone https://github.com/vishaps/voc`. + 3. Optionally `export CC=clang` or `export CC=tcc`. + 4. run `make full`. + 5. Optionally install to a system directory such as /opt or /usr/local/share with `make install` (might be with sudo). + 6. Set your PATH variable to include the compiler binary. + +These are detailed below: + + +#### 1. Install prerequisites + +| Platform | Packages | +| --------- | ------------ | +| Debian/Ubuntu/Mint ... | `apt-get install git` | +| Fedora/RHEL/CentOS ... | `yum install git gcc glibc-static` (`dnf` instead of `yum` on recent Fedoras) | +| FreeBSD/OpenBSD/NetBSD | `pkg install git` | +| OpenSUSE | `zypper install gcc git-core make glibc-devel-static` | +| Cygwin | use setup-x86[_x64] to add packages git, make, diffutils and gcc-core | +| Darwin | type 'git' at the command line and accept the prompt to install it. | + +More details, including for MingW and MS C, in [**Installation**](/doc/Installation.md). + + +#### 2. Clone and build the compiler and libraries + +1. `git clone https://github.com/vishaps/voc` +2. `cd voc` +3. `make full` + +`make full` will create an installation directory under your local repository at voc/install. + +`mmake full` runs `ldconfig` to configure the linker to find libraries in voc/install, but you +need to update your program search PATH yourself (see step 4 below). + + + +#### 3. Optionally install to a system directory + +Run `make install` as root to copy the voc/install directory to the appropriate directory +for your OS as follows: + +| System | Where `make install` puts the installation | +| ------- | -------------------------------------- | +| Linux | `/opt/voc` | +| BSD | `/usr/local/share/voc` | +| Windows | See [**Windows installation**](/doc/Winstallation.md) | +| Termux | `/data/data/com.termux/files/opt/voc` | + +`make install` updates `ldconfg` with the new library locations. + + +#### 4. Set your PATH environment variable + +Since there are so many ways that different systems and users manage their PATHs, we leave +it to you to update your path to include the compiler binary. + +Both `make full` and `make install` display instructions on setting the path specific to your +system. + +For reference this will be: + +| Installation choice | Set path | +| --------- | -------------------------------------- | +| Just `make full` | `export PATH="your-repository-clone/install/bin:$PATH"` | +| `make install` on Linux | `export PATH="/opt/voc/bin:$PATH"` | +| `make install` on BSD | `export PATH="/usr/local/share/voc/bin:$PATH"` | +| `make install` on Windows | See [**Windows installation**](/doc/Winstallation.md) | +| `make install` on Termux | `export PATH="/data/data/com.termux/files/opt/voc/bin:$PATH"` | + +Also see [**Installation**](/doc/Installation.md). + +The compiler finds the rest of the installation based on the location from which it is loaded. + + +## A 'Hello' application + +Anything appended to Oberon.Log is automatically written to stdout, so the +following conventional Oberon program will display 'Hello.': + +```Modula-2 +MODULE hello; + IMPORT Oberon, Texts; + VAR W: Texts.Writer; +BEGIN + Texts.OpenWriter(W); + Texts.WriteString(W, "Hello."); Texts.WriteLn(W); + Texts.Append(Oberon.Log, W.buf) +END hello. +``` + +Alternatively the Oakwood module Out can be used to write directly to stdout: + +```Modula-2 +MODULE hello; + IMPORT Out; +BEGIN + Out.String("Hello."); Out.Ln +END hello. +``` + +Compile as follows: + + voc hello.mod -m + +The -m parameter tells voc that this is a main module, and to generate an +executable binary. + +Execute as usual on Linux (`./hello`) or Windows (`hello`). + +For more details on compilation, see [**Compiling**](/doc/Compiling.md). + +### Viewing the interfaces of included modules. + +In order to see the definition of a module's interface, use the "showdef" program. + +``` +$ showdef Out +DEFINITION Out; + + VAR + IsConsole-: BOOLEAN; + + PROCEDURE Char(ch: CHAR); + PROCEDURE Flush; + PROCEDURE Int(x: INT64; n: INT64); + PROCEDURE Ln; + PROCEDURE LongReal(x: LONGREAL; n: INT16); + PROCEDURE Open; + PROCEDURE Real(x: REAL; n: INT16); + PROCEDURE String(str: ARRAY OF CHAR); + +END Out. +``` + + +## License + +Vishap Oberon's frontend and C backend engine is a fork of Josef Templ’s Ofront, which has been released +under the FreeBSD License. Unlike Ofront, Vishap Oberon does not include the Oberon v4 GUI environment. + +The Ulm Oberon Library and the Ooc libraries are distributed under GPL. Proprietry code +using these libraries may not be statically linked. + +Voc tools are distributed under GPLv3. + +Most of the runtime in libVishapOberon is distributed under GPLv3 with runtime exception. + + +## Platform support and porting + +Vishap Oberon supports 32 and 64 bit little-endian architectures including Intel x86 and x86_64, 32 bit arm and aarch64. + +It compiles under gcc, clang, tcc and Microsoft Visual C. + +Installation supports GNU/Linux, MAC OSX, BSD and Windows (native and cygwin). + +A C program (src/tools/make/configure.c) detects the details of the C compiler +and operating system on which it is running. + +The following systems are recognised: + + - Linux, including Ubuntu and Centos derivatives. + - The BSDs, including OpenBSD and FreeBSD. + - Cygwin under Windows, MingW under Cygwin, Bash on Ubuntu on Windows. + +Additionally a Windows .cmd is provided for building with Microsoft C. + +For details, including how to add support for unrecognised systems, see +[**Porting**](/doc/Porting.md). + + +## Language support and libraries + +Vishap Oberon supports the Oberon 2 programming language, including type-bound procedures. SYSTEM.Mod includes additional functionality and some changes for 64 bit support. + +#### Integer and set type sizes: + +| Type | -O2 option (default) | -OC option | +| --- | --- | --- | +| SHORTINT | 8 bit | 16 bit | +| INTEGER | 16 bit | 32 bit | +| LONGINT | 32 bit | 64 bit | +| SET | 32 bit | 64 bit | + +#### Libraries + +Included libraries ease porting of code from the major Oberon systems: + + - Oberon V4 and S3 compatible library set. + - Ooc (optimizing oberon-2 compiler) library port. + - Ulm’s Oberon system library port. + - Oakwood standard libraries. + - Some other freely redistributable libraries. + +Oakwood libraries are supported for both -O2 and -OC options, whereas the ULM, OOC and ETH system 3 libraries are only available on -O2 (default) compilations. + + +Vishap Oberon also supports some features of Oberon-07. + + +See also [**Features**](/doc/Features.md). + + +## Contributors + +Joseph Templ developed ofront as a tool to translate Oberon-2 programs into semantically equivalent +C programs. It was Copyrighted in 1995, and transferred to the Free BSD license in 2012. + +From Joseph's github repository: + +> Design and implementation of ofront is due to Josef Templ ... ofront has been based in part on Regis Crelier's PhD thesis and Stefan Gehring's diploma thesis, both at ETH Zurich, Institute for Computer Systems. + +Norayr Chilingarian forked ofront in 2013, porting extensive libraries from [ULM Oberon](http://www.mathematik.uni-ulm.de/oberon/), [OO2C](https://github.com/Spirit-of-Oberon/oo2c) and ETH Oberon System 3, and adding support for more platforms including 64 bit systems. + +David Brown has worked on adding support for more platforms incuding windows using MSC, cygwin or mingw since January 2016. More recently he has generalised basic type support within the compiler to allow e.g. 64 bit LONGINT on 32 bit systems, and 32 bit LONGINT on 64 bit systems. + +## Oberon + +Oberon is a programming language, an operating system and a graphical +user interface. Originally designed and implemented by by Niklaus Wirth and +Jürg Gutknecht at ETH Zürich in the late 1980s, it demonstrates that the +fundamentals of a modern OS and GUI can be implemented in clean and simple code +orders of magnitude smaller than found in contemporary systems. + +The Oberon programming language is an evolution of the Pascal and Modula +languages. While it adds garbage collection, extensible types and (in +Oberon-2) type-bound procedures, it is also simplified following the principals +of Einstein and Antoine de Saint-Exupéry: + +> Make it as simple as possible, but not simpler. (Albert Einstein) + +> Perfection is finally attained not when there is no longer anything to add, but +> when there is no longer anything to take away. (Antoine de Saint-Exupéry, +> translated by Lewis Galantière.) + +## Origin of the name "Ѵishap Oberon" + +Vishaps are dragons inhabiting the Armenian Highlands. +We decided to name the project “Vishap” because ties between compilers and dragons have ancient traditions. + +Also, Vishaps are known in tales, fiction. [This page](http://blog.fogus.me/2015/04/27/six-works-of-computer-science-fiction/) refers to some technologies as “computer science fiction”. Among them to Oberon. This brings another meaning, Oberon is like aliens, ghosts. And Vishaps. + +## References + +###### Oberon + - [The History of Modula-2 and Oberon](http://people.inf.ethz.ch/wirth/Articles/Modula-Oberon-June.pdf) + - [The Programming Language Oberon](https://www.inf.ethz.ch/personal/wirth/Oberon/Oberon.Report.pdf) + - [Project Oberon: The Design of an Operating System and Compiler ](https://people.inf.ethz.ch/wirth/ProjectOberon1992.pdf) + - [Oberon - the Overlooked Jewel](http://pascal.hansotten.com/uploads/oberonpi/Oberon%20article.pdf) + +###### Oberon 2 + - [Differences between Oberon and Oberon-2](https://citeseerx.ist.psu.edu/document?repid=rep1&type=pdf&doi=89e5bd3cf006bde4821599cdc57a37de5dc84bcd) + - [The Programming Language Oberon-2](http://www.ssw.uni-linz.ac.at/Research/Papers/Oberon2.pdf) + - [Programming in Oberon. Steps beyond Pascal and Modula](https://people.inf.ethz.ch/wirth/ProgInOberonWR.pdf) + - [The Oakwood Guidelines for Oberon-2 Compiler Developers](http://www.math.bas.bg/bantchev/place/oberon/oakwood-guidelines.pdf) + +###### Oberon 07 + - [Difference between Oberon-07 and Oberon](https://www.inf.ethz.ch/personal/wirth/Oberon/Oberon07.pdf) + - [The Programming Language Oberon-07](https://www.inf.ethz.ch/personal/wirth/Oberon/Oberon07.Report.pdf) + - [Programming in Oberon - a Tutorial](https://www.inf.ethz.ch/personal/wirth/Oberon/PIO.pdf) + +###### Links + - [Niklaus Wirth's personal page at ETH Zurich](https://www.inf.ethz.ch/personal/wirth/) + - [Selected articles by Niklaus Wirth](https://people.inf.ethz.ch/wirth/SelectedArticles.pdf) + - [ETH Oberon publications page](https://web.archive.org/web/20191207155011/http://www.ethoberon.ethz.ch/books.html) + - [Joseph Templ's ofront on github](https://github.com/jtempl/ofront) + - [Software Templ OG](http://www.software-templ.com) + + +## History + +See [**History**](/doc/History.md). diff --git a/bootstrap/SYSTEM.c b/bootstrap/SYSTEM.c new file mode 100644 index 00000000..2952bb66 --- /dev/null +++ b/bootstrap/SYSTEM.c @@ -0,0 +1,227 @@ +/* +* 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" +#include "stdarg.h" +#include + + +// Procedure verions of SYSTEM.H versions used when a multiply accessed +// parameter has side effects. + + + + +INT64 SYSTEM_DIV(INT64 x, INT64 y) +{ + if (x == 0) return 0; + if (x >= 0) + if (y >= 0) {return x/y;} + else {return -((x-y-1)/(-y));} + else + if (y >= 0) {return -((y-x-1)/y);} + else {return (-x)/(-y);} +} + +INT64 SYSTEM_MOD(INT64 x, INT64 y) +{ + if (x == 0) return 0; + if (x >= 0) + if (y >= 0) {return x % y;} + else {return (y+1) + ((x-1) % (-y));} + else + if (y >= 0) {return (y-1) - ((-x-1) % y);} + else {return -((-x) % (-y));} +} + +INT64 SYSTEM_ENTIER(double x) +{ + INT64 y; + if (x >= 0) + return (INT64)x; + else { + y = (INT64)x; + if (y <= x) return y; else return y - 1; + } +} + + + +void SYSTEM_INHERIT(ADDRESS *t, ADDRESS *t0) +{ + t -= __TPROC0OFF; + t0 -= __TPROC0OFF; + while (*t0 != __EOM) {*t = *t0; t--; t0--;} +} + + +void SYSTEM_ENUMP(void *adr, ADDRESS n, void (*P)()) +{ + while (n > 0) { + P((ADDRESS)(*((void**)(adr)))); + adr = ((void**)adr) + 1; + n--; + } +} + +void SYSTEM_ENUMR(void *adr, ADDRESS *typ, ADDRESS size, ADDRESS n, void (*P)()) +{ + ADDRESS *t, off; + typ++; + while (n > 0) { + t = typ; + off = *t; + while (off >= 0) {P(*(ADDRESS*)((char*)adr+off)); t++; off = *t;} + adr = ((char*)adr) + size; + n--; + } +} + +extern void Heap_Lock(); +extern void Heap_Unlock(); + +SYSTEM_PTR SYSTEM_NEWARR(ADDRESS *typ, ADDRESS elemsz, int elemalgn, int nofdim, int nofdyn, ...) +{ + ADDRESS nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; + va_list ap; + va_start(ap, nofdyn); + nofelems = 1; + while (nofdim > 0) { + nofelems = nofelems * va_arg(ap, ADDRESS); nofdim--; + if (nofelems <= 0) __HALT(-20); + } + va_end(ap); + dataoff = nofdyn * sizeof(ADDRESS); + if (elemalgn > sizeof(ADDRESS)) { + n = dataoff % elemalgn; + if (n != 0) dataoff += elemalgn - n; + } + size = dataoff + nofelems * elemsz; + Heap_Lock(); + if (typ == NIL) { + /* element typ does not contain pointers */ + x = Heap_NEWBLK(size); + } + else if (typ == (ADDRESS*)POINTER__typ) { + /* element type is a pointer */ + x = Heap_NEWBLK(size + nofelems * sizeof(ADDRESS)); + p = (ADDRESS*)(ADDRESS)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(ADDRESS); p++; n++;} + *p = - (nofelems + 1) * sizeof(ADDRESS); /* sentinel */ + x[-1] -= nofelems * sizeof(ADDRESS); + } + 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 = Heap_NEWBLK(size + nptr * sizeof(ADDRESS)); + p = (ADDRESS*)(ADDRESS)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(ADDRESS); /* sentinel */ + x[-1] -= nptr * sizeof(ADDRESS); + } + if (nofdyn != 0) { + /* setup len vector for index checks */ + va_start(ap, nofdyn); + p = x; + while (nofdyn > 0) {*p = va_arg(ap, ADDRESS); p++, nofdyn--;} + va_end(ap); + } + Heap_Unlock(); + return x; +} + +typedef void (*SystemSignalHandler)(INT32); // = Platform_SignalHandler + +#ifndef _WIN32 + // Unix signal handling + SystemSignalHandler handler[10] = {0}; // Adjust the array size to include signal 11 + + void segfaultHandler(int signal) { + __HALT(-10); + } + // Revised signal handler to accommodate additional signals like SIGSEGV + void signalHandler(int s) { + if ((s >= 2 && s <= 4) || s == 11) { // Include SIGSEGV (usually signal 11) + if (handler[s-2]) { + handler[s-2](s); + } + } + // Ignore other signals + } + + void SystemSetHandler(int s, ADDRESS h) { + if ((s >= 2 && s <= 4) || s == 11) { + int needtosetsystemhandler = handler[s-2] == 0; + handler[s-2] = (SystemSignalHandler)h; + if (needtosetsystemhandler) { + signal(s, signalHandler); + } + } + } + + void setupAutomaticSegfaultHandler() { + SystemSetHandler(11, (ADDRESS)segfaultHandler); // Register handler for SIGSEGV + } + +#else + // Windows system remains as is since Windows does not use SIGSEGV in the same way + #include "WindowsWrapper.h" + + SystemSignalHandler SystemInterruptHandler = 0; + SystemSignalHandler SystemQuitHandler = 0; + BOOL ConsoleCtrlHandlerSet = FALSE; + + BOOL WINAPI SystemConsoleCtrlHandler(DWORD ctrlType) { + if ((ctrlType == CTRL_C_EVENT) || (ctrlType == CTRL_BREAK_EVENT)) { + if (SystemInterruptHandler) { + SystemInterruptHandler(2); // SIGINT + return TRUE; + } + } else { + if (SystemQuitHandler) { + SystemQuitHandler(3); // SIGQUIT + return TRUE; + } + } + return FALSE; + } + void EnsureConsoleCtrlHandler() { + if (!ConsoleCtrlHandlerSet) { + SetConsoleCtrlHandler(SystemConsoleCtrlHandler, TRUE); + ConsoleCtrlHandlerSet = TRUE; + } + } + + void SystemSetInterruptHandler(ADDRESS h) { + EnsureConsoleCtrlHandler(); + SystemInterruptHandler = (SystemSignalHandler)h; + } + + void SystemSetQuitHandler(ADDRESS h) { + EnsureConsoleCtrlHandler(); + SystemQuitHandler = (SystemSignalHandler)h; + } + +#endif + diff --git a/bootstrap/SYSTEM.h b/bootstrap/SYSTEM.h new file mode 100644 index 00000000..39d594ed --- /dev/null +++ b/bootstrap/SYSTEM.h @@ -0,0 +1,337 @@ +#ifndef SYSTEM__h +#define SYSTEM__h + + +// 64 bit system detection + +#if (__SIZEOF_POINTER__ == 8) || defined (_LP64) || defined(__LP64__) || defined(_WIN64) + #define o__64 +#endif + + +// Declare memcpy in a way compatible with C compilers intrinsic +// built in implementations. + +#if defined (o__64) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + #if defined(__OpenBSD__) + typedef unsigned long size_t; + #else + typedef unsigned int size_t; + #endif +#endif + +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, size_t size); +#if defined _MSC_VER +#define alloca _alloca +#endif +void *alloca(size_t size); + + +// Declare fixed size versions of basic intger types + +#if defined (o__64) && !defined(_WIN64) + // LP64 + typedef long INT64; + typedef unsigned long UINT64; +#else + // ILP32 or LLP64 + typedef long long INT64; + typedef unsigned long long UINT64; +#endif + +typedef int INT32; +typedef unsigned int UINT32; + +typedef short int INT16; +typedef unsigned short int UINT16; + +typedef signed char INT8; +typedef unsigned char UINT8; + + +// The compiler uses 'import' and 'export' which translate to 'extern' and +// nothing respectively. + +#define import extern +#define export + + + +// Known constants + +#define NIL ((void*)0) +#define __MAXEXT 16 +#define POINTER__typ ((ADDRESS*)(1)) // not NIL and not a valid type + + +// Oberon types + +typedef INT8 BOOLEAN; +typedef INT8 SYSTEM_BYTE; +typedef UINT8 CHAR; +typedef float REAL; +typedef double LONGREAL; +typedef void* SYSTEM_PTR; + + + +// 'ADDRESS' is a synonym for an integer of pointer size + +#if defined (o__64) + #define ADDRESS INT64 +#else + #define ADDRESS INT32 +#endif + + + +// ---------------------------------------------------------------------- +// ---------------------------------------------------------------------- + + + +// OS Memory allocation interfaces are in PlatformXXX.Mod + +extern ADDRESS Platform_OSAllocate (ADDRESS size); +extern void Platform_OSFree (ADDRESS addr); + + +// Assertions and Halts + +extern void Modules_Halt(INT32 x); +extern void Modules_AssertFail(INT32 x); + +#define __HALT(x) Modules_Halt((INT32)(x)) +#define __ASSERT(cond, x) if (!(cond)) Modules_AssertFail((INT32)(x)) + + +// Index checking + +static inline INT64 __XF(INT64 i, UINT64 ub) { + if (i < 0 || (UINT64)i >= ub) __HALT(-2); + return i; +} +#define __X(i, ub) (((i) >= 0 && (i) < (ub)) ? (i) : (__HALT(-2),0)) + +// Range checking, and checked SHORT and CHR functions + +static inline INT64 __RF(UINT64 i, UINT64 ub) {if (i >= ub) {__HALT(-8);} return i;} +#define __R(i, ub) (((i)<(ub))?i:(__HALT(-8),0)) +#define __SHORT(x, ub) ((int)((UINT64)(x)+(ub)<(ub)+(ub)?(x):(__HALT(-8),0))) +#define __SHORTF(x, ub) ((int)(__RF((x)+(ub),(ub)+(ub))-(ub))) +#define __CHR(x) ((CHAR)__R(x, 256)) +#define __CHRF(x) ((CHAR)__RF(x, 256)) + + + +// Signal handling in SYSTEM.c + +#ifndef _WIN32 + extern void SystemSetHandler(int s, ADDRESS h); +#else + extern void SystemSetInterruptHandler(ADDRESS h); + extern void SystemSetQuitHandler (ADDRESS h); +#endif + + + +// String comparison + +static inline int __str_cmp(CHAR *x, CHAR *y){ + INT64 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 __STRCMP(a,b) __str_cmp((CHAR*)(a), (CHAR*)(b)) + + + +// Inline string, record and array copy + +#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ + while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} +#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) +#define __DEL(x) + + +/* SYSTEM ops */ + +#define __VAL(t, x) (*(t*)&(x)) + +#define __GET(a, x, t) x=*(t*)(ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(ADDRESS)(a)=x + +#define __LSHL(x, n, s) ((INT##s)((UINT##s)(x)<<(n))) +#define __LSHR(x, n, s) ((INT##s)((UINT##s)(x)>>(n))) +#define __LSH(x, n, s) ((n)>=0? __LSHL(x, n, s): __LSHR(x, -(n), s)) + +#define __ROTL(x, n, s) ((INT##s)((UINT##s)(x)<<(n)|(UINT##s)(x)>>(s-(n)))) +#define __ROTR(x, n, s) ((INT##s)((UINT##s)(x)>>(n)|(UINT##s)(x)<<(s-(n)))) +#define __ROT(x, n, s) ((n)>=0? __ROTL(x, n, s): __ROTR(x, -(n), s)) + +#define __ASHL(x, n) ((INT64)(x)<<(n)) +#define __ASHR(x, n) ((INT64)(x)>>(n)) +#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) +static inline INT64 SYSTEM_ASH(INT64 x, INT64 n) {return __ASH(x,n);} +#define __ASHF(x, n) SYSTEM_ASH((INT64)(x), (INT64)(n)) + +#define __MOVE(s, d, n) memcpy((char*)(ADDRESS)(d),(char*)(ADDRESS)(s),n) + + +extern INT64 SYSTEM_DIV(INT64 x, INT64 y); +#define __DIVF(x, y) SYSTEM_DIV(x, y) +#define __DIV(x, y) (((x)>0 && (y)>0) ? (x)/(y) : __DIVF(x, y)) + + +extern INT64 SYSTEM_MOD(INT64 x, INT64 y); +#define __MODF(x, y) SYSTEM_MOD(x, y) +#define __MOD(x, y) (((x)>0 && (y)>0) ? (x)%(y) : __MODF(x, y)) + + +extern INT64 SYSTEM_ENTIER (double x); +#define __ENTIER(x) SYSTEM_ENTIER(x) + + +#define __ABS(x) (((x)<0)?-(x):(x)) + +static inline INT32 SYSTEM_ABS64(INT64 i) {return i >= 0 ? i : -i;} +static inline INT64 SYSTEM_ABS32(INT32 i) {return i >= 0 ? i : -i;} +#define __ABSF(x) ((sizeof(x) <= 4) ? SYSTEM_ABS32(x) : SYSTEM_ABS64(x)) + +static inline double SYSTEM_ABSD(double i) {return i >= 0.0 ? i : -i;} +#define __ABSFD(x) SYSTEM_ABSD(x) + +#define __CAP(ch) ((CHAR)((ch)&0x5f)) +#define __ODD(x) ((x)&1) + +#define __IN(x, s, size) (((unsigned int)(x))>(x))&1)) +// todo tested versions of SETOF and SETRNG: check that x, l and h fit size +#define __SETOF(x, size) ((UINT##size)1<<(x)) +#define __SETRNG(l, h, size) ((~(UINT##size)0<<(l))&~(UINT##size)0>>(size-1-(h))) + +#define __MASK(x, m) ((x)&~(m)) +#define __BIT(x, n) (*(UINT64*)(x)>>(n)&1) + + + +// Runtime checks + +#define __RETCHK __retchk: __HALT(-3); return 0; +#define __CASECHK __HALT(-4) +#define __WITHCHK __HALT(-7) + + +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(ADDRESS)typ##__typ) +#define __TYPEOF(p) (*(((ADDRESS**)(p))-1)) +#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) + + +#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);*((typ*)p) + + + +// Module entry/registration/exit + +extern void Heap_REGCMD(); +extern SYSTEM_PTR Heap_REGMOD(); +extern void Heap_REGTYP(); +extern void Heap_INCREF(); + +#define __DEFMOD static void *m; if (m!=0) {return m;} +#define __REGCMD(name, cmd) Heap_REGCMD(m, (CHAR*)name, cmd) +#define __REGMOD(name, enum) if (m==0) {m = Heap_REGMOD((CHAR*)name,enum);} +#define __ENDMOD return m +#define __MODULE_IMPORT(name) Heap_INCREF(name##__init()) + + + +// Main module initialisation, registration and finalisation + +extern void Modules_Init(INT32 argc, ADDRESS argv); +extern void Heap_FINALL(); + +extern void setupAutomaticSegfaultHandler(); +#ifndef _WIN32 +#define __INIT(argc, argv) static void *m; setupAutomaticSegfaultHandler(); Modules_Init(argc, (ADDRESS)&argv); +#else +#define __INIT(argc, argv) static void *m; Modules_Init(argc, (ADDRESS)&argv); +#endif +#define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) +#define __FINI Heap_FINALL(); return 0 + + +// Memory allocation + +extern SYSTEM_PTR Heap_NEWBLK (ADDRESS size); +extern SYSTEM_PTR Heap_NEWREC (ADDRESS tag); +extern SYSTEM_PTR SYSTEM_NEWARR(ADDRESS*, ADDRESS, int, int, int, ...); + +#define __SYSNEW(p, len) p = Heap_NEWBLK((ADDRESS)(len)) +#define __NEW(p, t) p = Heap_NEWREC((ADDRESS)t##__typ) +#define __NEWARR SYSTEM_NEWARR + + + +/* Type handling */ + +extern void SYSTEM_INHERIT(ADDRESS *t, ADDRESS *t0); +extern void SYSTEM_ENUMP (void *adr, ADDRESS n, void (*P)()); +extern void SYSTEM_ENUMR (void *adr, ADDRESS *typ, ADDRESS size, ADDRESS n, void (*P)()); + + +#define __TDESC(t, m, n) \ + static struct t##__desc { \ + ADDRESS tproc[m]; /* Proc for each ptr field */ \ + ADDRESS tag; \ + ADDRESS next; /* Module table type list points here */ \ + ADDRESS level; \ + ADDRESS module; \ + char name[24]; \ + ADDRESS basep[__MAXEXT]; /* List of bases this extends */ \ + ADDRESS reserved; \ + ADDRESS blksz; /* xxx_typ points here */ \ + ADDRESS ptr[n+1]; /* Offsets of ptrs up to -ve sentinel */ \ + } t##__desc + +#define __BASEOFF (__MAXEXT+1) // blksz as index to base. +#define __TPROC0OFF (__BASEOFF+24/sizeof(ADDRESS)+5) // blksz as index to tproc IFF m=1. +#define __EOM 1 +#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size +#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (ADDRESS)(n), P) +#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (ADDRESS)(size), (ADDRESS)(n), P) + +#define __INITYP(t, t0, level) \ + t##__typ = (ADDRESS*)&t##__desc.blksz; \ + memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(ADDRESS)); \ + t##__desc.basep[level] = (ADDRESS)t##__typ; \ + t##__desc.module = (ADDRESS)m; \ + if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ + t##__desc.blksz = (t##__desc.blksz+5*sizeof(ADDRESS)-1)/(4*sizeof(ADDRESS))*(4*sizeof(ADDRESS)); \ + Heap_REGTYP(m, (ADDRESS)&t##__desc.next); \ + SYSTEM_INHERIT(t##__typ, t0##__typ) + +// Oberon-2 type bound procedures support +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((ADDRESS)*(typ-(__TPROC0OFF+num))))parlist + + + + +#endif diff --git a/bootstrap/WindowsWrapper.h b/bootstrap/WindowsWrapper.h new file mode 100644 index 00000000..b72c815a --- /dev/null +++ b/bootstrap/WindowsWrapper.h @@ -0,0 +1,10 @@ +// WindowsWrapper.h +// +// Includes Windows.h while avoiding conflicts with Oberon types. + + +#define BOOLEAN _BOOLEAN +#define CHAR _CHAR +#include +#undef BOOLEAN +#undef CHAR diff --git a/bootstrap/unix-44/Compiler.c b/bootstrap/unix-44/Compiler.c new file mode 100644 index 00000000..4460479d --- /dev/null +++ b/bootstrap/unix-44/Compiler.c @@ -0,0 +1,213 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspamS */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "OPB.h" +#include "OPC.h" +#include "OPM.h" +#include "OPP.h" +#include "OPT.h" +#include "OPV.h" +#include "Platform.h" +#include "Strings.h" +#include "VT100.h" +#include "extTools.h" + + + + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len); +export void Compiler_Module (BOOLEAN *done); +static void Compiler_PropagateElementaryTypeSizes (void); +export void Compiler_Translate (void); +static void Compiler_Trap (INT32 sig); + + +void Compiler_Module (BOOLEAN *done) +{ + BOOLEAN ext, new; + OPT_Node p = NIL; + OPP_Module(&p, OPM_Options); + if (OPM_noerr) { + OPV_Init(); + OPT_InitRecno(); + OPV_AdrAndSize(OPT_topScope); + OPT_Export(&ext, &new); + if (OPM_noerr) { + OPM_OpenFiles((void*)OPT_SelfName, 256); + OPM_DeleteObj((void*)OPT_SelfName, 256); + OPC_Init(); + OPV_Module(p); + if (OPM_noerr) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" Main program.", 16); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + if (new) { + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" New symbol file.", 19); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_RegisterNewSym(); + } else if (ext) { + OPM_LogWStr((CHAR*)" Extended symbol file.", 24); + OPM_RegisterNewSym(); + } + } + } else { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } + OPM_CloseFiles(); + OPT_Close(); + OPM_LogWLn(); + *done = OPM_noerr; +} + +static void Compiler_PropagateElementaryTypeSizes (void) +{ + OPT_Struct adrinttyp = NIL; + OPT_sysptrtyp->size = OPM_AddressSize; + OPT_sysptrtyp->idfp = OPT_sysptrtyp->form; + OPM_FPrint(&OPT_sysptrtyp->idfp, OPT_sysptrtyp->size); + OPT_adrtyp->size = OPM_AddressSize; + OPT_adrtyp->idfp = OPT_adrtyp->form; + OPM_FPrint(&OPT_adrtyp->idfp, OPT_adrtyp->size); + adrinttyp = OPT_IntType(OPM_AddressSize); + OPT_adrtyp->strobj = adrinttyp->strobj; + OPT_sinttyp = OPT_IntType(OPM_ShortintSize); + OPT_inttyp = OPT_IntType(OPM_IntegerSize); + OPT_linttyp = OPT_IntType(OPM_LongintSize); + OPT_sintobj->typ = OPT_sinttyp; + OPT_intobj->typ = OPT_inttyp; + OPT_lintobj->typ = OPT_linttyp; + switch (OPM_SetSize) { + case 4: + OPT_settyp = OPT_set32typ; + break; + default: + OPT_settyp = OPT_set64typ; + break; + } + OPT_setobj->typ = OPT_settyp; + if (__STRCMP(OPM_Model, "C") == 0) { + OPT_cpbytetyp->strobj->name[4] = 0x00; + } else { + OPT_cpbytetyp->strobj->name[4] = '@'; + } +} + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len) +{ + OPT_Link l = NIL; + CHAR fn[64]; + Platform_FileIdentity id; + objectnames[0] = 0x00; + l = OPT_Links; + while (l != NIL) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".sym", 5, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".o", 3, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + Strings_Append((CHAR*)" ", 2, (void*)objectnames, objectnames__len); + Strings_Append(fn, 64, (void*)objectnames, objectnames__len); + } else { + OPM_LogVT100((CHAR*)"91m", 4); + OPM_LogWStr((CHAR*)"Link warning: a local symbol file is present for module ", 57); + OPM_LogWStr(l->name, 256); + OPM_LogWStr((CHAR*)", but local object file '", 26); + OPM_LogWStr(fn, 64); + OPM_LogWStr((CHAR*)"' is missing.", 14); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_LogWLn(); + } + } + l = l->next; + } +} + +void Compiler_Translate (void) +{ + BOOLEAN done; + CHAR linkfiles[2048]; + if (OPM_OpenPar()) { + for (;;) { + OPM_Init(&done); + if (!done) { + return; + } + OPM_InitOptions(); + Compiler_PropagateElementaryTypeSizes(); + Heap_GC(0); + Compiler_Module(&done); + if (!done) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Module compilation failed.", 27); + OPM_LogWLn(); + Platform_Exit(1); + } + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + if (!__IN(10, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + Compiler_FindLocalObjectFiles((void*)linkfiles, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), linkfiles, 2048); + } + } + } + } + } +} + +static void Compiler_Trap (INT32 sig) +{ + Heap_FINALL(); + if (sig == 3) { + Platform_Exit(0); + } else { + if (sig == 4) { + OPM_LogWStr((CHAR*)" --- Oberon compiler internal error", 36); + OPM_LogWLn(); + } + Platform_Exit(2); + } +} + + +export int main(int argc, char **argv) +{ + __INIT(argc, argv); + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPP); + __MODULE_IMPORT(OPT); + __MODULE_IMPORT(OPV); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(VT100); + __MODULE_IMPORT(extTools); + __REGMAIN("Compiler", 0); + __REGCMD("Translate", Compiler_Translate); +/* BEGIN */ + Platform_SetInterruptHandler(Compiler_Trap); + Platform_SetQuitHandler(Compiler_Trap); + Platform_SetBadInstructionHandler(Compiler_Trap); + Compiler_Translate(); + __FINI; +} diff --git a/bootstrap/unix-44/Configuration.c b/bootstrap/unix-44/Configuration.c new file mode 100644 index 00000000..fa87c9de --- /dev/null +++ b/bootstrap/unix-44/Configuration.c @@ -0,0 +1,24 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + +export CHAR Configuration_versionLong[76]; + + + + + +export void *Configuration__init(void) +{ + __DEFMOD; + __REGMOD("Configuration", 0); +/* BEGIN */ + __MOVE("2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 76); + __ENDMOD; +} diff --git a/bootstrap/unix-44/Configuration.h b/bootstrap/unix-44/Configuration.h new file mode 100644 index 00000000..c3c54eed --- /dev/null +++ b/bootstrap/unix-44/Configuration.h @@ -0,0 +1,15 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Configuration__h +#define Configuration__h + +#include "SYSTEM.h" + + +import CHAR Configuration_versionLong[76]; + + +import void *Configuration__init(void); + + +#endif // Configuration diff --git a/bootstrap/unix-44/Files.c b/bootstrap/unix-44/Files.c new file mode 100644 index 00000000..54341368 --- /dev/null +++ b/bootstrap/unix-44/Files.c @@ -0,0 +1,1097 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_BufDesc { + Files_File f; + BOOLEAN chg; + INT32 org, size; + SYSTEM_BYTE data[4096]; + } Files_BufDesc; + +typedef + Files_BufDesc *Files_Buffer; + +typedef + CHAR Files_FileName[256]; + +typedef + struct Files_FileDesc { + Files_FileName workName, registerName; + BOOLEAN tempFile; + Platform_FileIdentity identity; + INT32 fd, len, pos; + Files_Buffer bufs[4]; + INT16 swapper, state; + struct Files_FileDesc *next; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + Files_Buffer buf; + INT32 org, offset; + } Files_Rider; + + +export INT16 Files_MaxPathLength, Files_MaxNameLength; +static Files_FileDesc *Files_files; +static INT16 Files_tempno; +static CHAR Files_HOME[1024]; +static struct { + ADDRESS len[1]; + CHAR data[1]; +} *Files_SearchPath; + +export ADDRESS *Files_FileDesc__typ; +export ADDRESS *Files_BufDesc__typ; +export ADDRESS *Files_Rider__typ; + +static void Files_Assert (BOOLEAN truth); +export Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +static Files_File Files_CacheEntry (Platform_FileIdentity identity); +export void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +export void Files_Close (Files_File f); +static void Files_CloseOSFile (Files_File f); +static void Files_Create (Files_File f); +export void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +static void Files_Deregister (CHAR *name, ADDRESS name__len); +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode); +static void Files_Finalize (SYSTEM_PTR o); +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len); +static void Files_Flush (Files_Buffer buf); +export void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +export void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len); +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len); +export INT32 Files_Length (Files_File f); +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len); +export Files_File Files_New (CHAR *name, ADDRESS name__len); +export Files_File Files_Old (CHAR *name, ADDRESS name__len); +export INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +export void Files_Purge (Files_File f); +export void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +export void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +export void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +export void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +export void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +export void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +export void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +export void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_Register (Files_File f); +export void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len); +export void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +export void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +export void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +export void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +export void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +export void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +export void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +export void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +export void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +export void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +export void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); + +#define Files_IdxTrap() __HALT(-1) + +static void Files_Assert (BOOLEAN truth) +{ + if (!truth) { + Out_Ln(); + __ASSERT(truth, 0); + } +} + +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode) +{ + __DUP(s, s__len, CHAR); + Out_Ln(); + Out_String((CHAR*)"-- ", 4); + Out_String(s, s__len); + Out_String((CHAR*)": ", 3); + if (f != NIL) { + if (f->registerName[0] != 0x00) { + Out_String(f->registerName, 256); + } else { + Out_String(f->workName, 256); + } + if (f->fd != 0) { + Out_String((CHAR*)", f.fd = ", 10); + Out_Int(f->fd, 1); + } + } + if (errcode != 0) { + Out_String((CHAR*)", errcode = ", 13); + Out_Int(errcode, 1); + } + Out_Ln(); + __HALT(99); + __DEL(s); +} + +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 i, j, ld, ln; + __DUP(dir, dir__len, CHAR); + __DUP(name, name__len, CHAR); + ld = Strings_Length(dir, dir__len); + ln = Strings_Length(name, name__len); + while ((ld > 0 && dir[__X(ld - 1, dir__len)] == '/')) { + ld -= 1; + } + if (((ld + ln) + 2) > dest__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + i = 0; + while (i < ld) { + dest[__X(i, dest__len)] = dir[__X(i, dir__len)]; + i += 1; + } + if (i > 0) { + dest[__X(i, dest__len)] = '/'; + i += 1; + } + j = 0; + while (j < ln) { + dest[__X(i, dest__len)] = name[__X(j, name__len)]; + i += 1; + j += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(dir); + __DEL(name); +} + +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len) +{ + INT16 i, n; + __DUP(finalName, finalName__len, CHAR); + if (finalName[0] == '/') { + __COPY(finalName, name, name__len); + } else { + Files_MakeFileName(Platform_CWD, 256, finalName, finalName__len, (void*)name, name__len); + } + i = Strings_Length(name, name__len) - 1; + while ((i > 0 && name[__X(i, name__len)] != '/')) { + i -= 1; + } + if ((i + 16) >= name__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + Files_tempno += 1; + n = Files_tempno; + name[__X(i + 1, name__len)] = '.'; + name[__X(i + 2, name__len)] = 't'; + name[__X(i + 3, name__len)] = 'm'; + name[__X(i + 4, name__len)] = 'p'; + name[__X(i + 5, name__len)] = '.'; + i += 6; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = '.'; + i += 1; + n = Platform_PID; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = 0x00; + __DEL(finalName); +} + +static void Files_Deregister (CHAR *name, ADDRESS name__len) +{ + Platform_FileIdentity identity; + Files_File osfile = NIL; + INT16 error; + __DUP(name, name__len, CHAR); + if (Platform_IdentifyByName(name, name__len, &identity, Platform_FileIdentity__typ) == 0) { + osfile = (Files_File)Files_files; + while ((osfile != NIL && !Platform_SameFile(osfile->identity, identity))) { + osfile = (Files_File)osfile->next; + } + if (osfile != NIL) { + __ASSERT(!osfile->tempFile, 0); + __ASSERT(osfile->fd >= 0, 0); + __MOVE(osfile->workName, osfile->registerName, 256); + Files_GetTempName(osfile->registerName, 256, (void*)osfile->workName, 256); + osfile->tempFile = 1; + osfile->state = 0; + error = Platform_Rename((void*)osfile->registerName, 256, (void*)osfile->workName, 256); + if (error != 0) { + Files_Err((CHAR*)"Couldn't rename previous version of file being registered", 58, osfile, error); + } + } + } + __DEL(name); +} + +static void Files_Create (Files_File f) +{ + BOOLEAN done; + INT16 error; + CHAR err[32]; + if (f->fd == -1) { + if (f->state == 1) { + Files_GetTempName(f->registerName, 256, (void*)f->workName, 256); + f->tempFile = 1; + } else { + __ASSERT(f->state == 2, 0); + Files_Deregister(f->registerName, 256); + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } + error = Platform_Unlink((void*)f->workName, 256); + error = Platform_New((void*)f->workName, 256, &f->fd); + done = error == 0; + if (done) { + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->state = 0; + f->pos = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + } else { + if (Platform_NoSuchDirectory(error)) { + __MOVE("no such directory", err, 18); + } else if (Platform_TooManyFiles(error)) { + __MOVE("too many files open", err, 20); + } else { + __MOVE("file not created", err, 17); + } + Files_Err(err, 32, f, error); + } + } +} + +static void Files_Flush (Files_Buffer buf) +{ + INT16 error; + Files_File f = NIL; + if (buf->chg) { + f = buf->f; + Files_Create(f); + if (buf->org != f->pos) { + error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); + } + error = Platform_Write(f->fd, (ADDRESS)buf->data, buf->size); + if (error != 0) { + Files_Err((CHAR*)"error writing file", 19, f, error); + } + f->pos = buf->org + buf->size; + buf->chg = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + if (error != 0) { + Files_Err((CHAR*)"error identifying file", 23, f, error); + } + } +} + +void Files_Close (Files_File f) +{ + INT32 i; + INT16 error; + if (f->state != 1 || f->registerName[0] != 0x00) { + Files_Create(f); + i = 0; + while ((i < 4 && f->bufs[__X(i, 4)] != NIL)) { + Files_Flush(f->bufs[__X(i, 4)]); + i += 1; + } + } +} + +INT32 Files_Length (Files_File f) +{ + return f->len; +} + +Files_File Files_New (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + __DUP(name, name__len, CHAR); + __NEW(f, Files_FileDesc); + f->workName[0] = 0x00; + __COPY(name, f->registerName, 256); + f->fd = -1; + f->state = 1; + f->len = 0; + f->pos = 0; + f->swapper = -1; + __DEL(name); + return f; +} + +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len) +{ + INT16 i; + CHAR ch; + i = 0; + if (Files_SearchPath == NIL) { + if (*pos == 0) { + dir[0] = '.'; + i = 1; + *pos += 1; + } + } else { + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (ch == ' ' || ch == ';') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + if (ch == '~') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (Files_HOME[__X(i, 1024)] != 0x00) { + dir[__X(i, dir__len)] = Files_HOME[__X(i, 1024)]; + i += 1; + } + if ((((((ch != '/' && ch != 0x00)) && ch != ';')) && ch != ' ')) { + while ((i > 0 && dir[__X(i - 1, dir__len)] != '/')) { + i -= 1; + } + } + } + while ((ch != 0x00 && ch != ';')) { + dir[__X(i, dir__len)] = ch; + i += 1; + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + while ((i > 0 && dir[__X(i - 1, dir__len)] == ' ')) { + i -= 1; + } + } + dir[__X(i, dir__len)] = 0x00; +} + +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + ch = name[0]; + while ((ch != 0x00 && ch != '/')) { + i += 1; + ch = name[__X(i, name__len)]; + } + return ch == '/'; +} + +static Files_File Files_CacheEntry (Platform_FileIdentity identity) +{ + Files_File f = NIL; + INT16 i, error; + f = (Files_File)Files_files; + while (f != NIL) { + if (Platform_SameFile(identity, f->identity)) { + if (!Platform_SameFileTime(identity, f->identity)) { + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + f->swapper = -1; + f->identity = identity; + error = Platform_Size(f->fd, &f->len); + } + return f; + } + f = (Files_File)f->next; + } + return NIL; +} + +Files_File Files_Old (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + INT32 fd; + INT16 pos; + BOOLEAN done; + CHAR dir[256], path[256]; + INT16 error; + Platform_FileIdentity identity; + __DUP(name, name__len, CHAR); + if (name[0] != 0x00) { + if (Files_HasDir((void*)name, name__len)) { + dir[0] = 0x00; + __COPY(name, path, 256); + } else { + pos = 0; + Files_ScanPath(&pos, (void*)dir, 256); + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + for (;;) { + error = Platform_OldRW((void*)path, 256, &fd); + done = error == 0; + if ((!done && Platform_TooManyFiles(error))) { + Files_Err((CHAR*)"too many files open", 20, f, error); + } + if ((!done && Platform_Inaccessible(error))) { + error = Platform_OldRO((void*)path, 256, &fd); + done = error == 0; + } + if ((!done && !Platform_Absent(error))) { + Out_String((CHAR*)"Warning: Files.Old ", 20); + Out_String(name, name__len); + Out_String((CHAR*)" error = ", 10); + Out_Int(error, 0); + Out_Ln(); + } + if (done) { + error = Platform_Identify(fd, &identity, Platform_FileIdentity__typ); + f = Files_CacheEntry(identity); + if (f != NIL) { + error = Platform_Close(fd); + __DEL(name); + return f; + } else { + __NEW(f, Files_FileDesc); + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->fd = fd; + f->state = 0; + f->pos = 0; + f->swapper = -1; + error = Platform_Size(fd, &f->len); + __COPY(name, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + f->identity = identity; + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + __DEL(name); + return f; + } + } else if (dir[0] == 0x00) { + __DEL(name); + return NIL; + } else { + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + } + } else { + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Files_Purge (Files_File f) +{ + INT16 i; + Platform_FileIdentity identity; + INT16 error; + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + if (f->fd != -1) { + error = Platform_Truncate(f->fd, 0); + error = Platform_Seek(f->fd, 0, Platform_SeekSet); + } + f->pos = 0; + f->len = 0; + f->swapper = -1; + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_SetMTime(&f->identity, Platform_FileIdentity__typ, identity); +} + +void Files_GetDate (Files_File f, INT32 *t, INT32 *d) +{ + Platform_FileIdentity identity; + INT16 error; + Files_Create(f); + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_MTimeAsClock(identity, &*t, &*d); +} + +INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ) +{ + Files_Assert((*r).offset <= 4096); + return (*r).org + (*r).offset; +} + +void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos) +{ + INT32 org, offset, i, n; + Files_Buffer buf = NIL; + INT16 error; + if (f != NIL) { + if (pos > f->len) { + pos = f->len; + } else if (pos < 0) { + pos = 0; + } + offset = __MASK(pos, -4096); + org = pos - offset; + i = 0; + while ((((i < 4 && f->bufs[__X(i, 4)] != NIL)) && org != f->bufs[__X(i, 4)]->org)) { + i += 1; + } + if (i < 4) { + if (f->bufs[__X(i, 4)] == NIL) { + __NEW(buf, Files_BufDesc); + buf->chg = 0; + buf->org = -1; + buf->f = f; + f->bufs[__X(i, 4)] = buf; + } else { + buf = f->bufs[__X(i, 4)]; + } + } else { + f->swapper = __MASK(f->swapper + 1, -4); + buf = f->bufs[__X(f->swapper, 4)]; + Files_Flush(buf); + } + if (buf->org != org) { + if (org == f->len) { + buf->size = 0; + } else { + Files_Create(f); + if (f->pos != org) { + error = Platform_Seek(f->fd, org, Platform_SeekSet); + } + error = Platform_ReadBuf(f->fd, (void*)buf->data, 4096, &n); + if (error != 0) { + Files_Err((CHAR*)"read from file not done", 24, f, error); + } + f->pos = org + n; + buf->size = n; + } + buf->org = org; + buf->chg = 0; + } + } else { + buf = NIL; + org = 0; + offset = 0; + } + Files_Assert(offset <= 4096); + (*r).buf = buf; + (*r).org = org; + (*r).offset = offset; + (*r).eof = 0; + (*r).res = 0; +} + +void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + INT32 offset; + Files_Buffer buf = NIL; + buf = (*r).buf; + offset = (*r).offset; + if ((*r).org != buf->org) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= buf->size); + if (offset < buf->size) { + *x = buf->data[__X(offset, 4096)]; + (*r).offset = offset + 1; + } else if ((*r).org + offset < buf->f->len) { + Files_Set(&*r, r__typ, (*r).buf->f, (*r).org + offset); + *x = (*r).buf->data[0]; + (*r).offset = 1; + } else { + *x = 0x00; + (*r).eof = 1; + } +} + +void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + Files_Read(&*r, r__typ, &*x); +} + +void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + restInBuf = buf->size - offset; + if (restInBuf == 0) { + (*r).res = n; + (*r).eof = 1; + return; + } else if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&buf->data[__X(offset, 4096)], (ADDRESS)&x[__X(xpos, x__len)], min); + offset += min; + (*r).offset = offset; + xpos += min; + n -= min; + Files_Assert(offset <= 4096); + } + (*r).res = 0; + (*r).eof = 0; +} + +Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ) +{ + return (*r).buf->f; +} + +void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x) +{ + Files_Buffer buf = NIL; + INT32 offset; + buf = (*r).buf; + offset = (*r).offset; + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset < 4096); + buf->data[__X(offset, 4096)] = x; + buf->chg = 1; + if (offset == buf->size) { + buf->size += 1; + buf->f->len += 1; + } + (*r).offset = offset + 1; + (*r).res = 0; +} + +void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= 4096); + restInBuf = 4096 - offset; + if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&x[__X(xpos, x__len)], (ADDRESS)&buf->data[__X(offset, 4096)], min); + offset += min; + (*r).offset = offset; + Files_Assert(offset <= 4096); + if (offset > buf->size) { + buf->f->len += offset - buf->size; + buf->size = offset; + } + xpos += min; + n -= min; + buf->chg = 1; + } + (*r).res = 0; +} + +void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res) +{ + __DUP(name, name__len, CHAR); + Files_Deregister(name, name__len); + *res = Platform_Unlink((void*)name, name__len); + __DEL(name); +} + +void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res) +{ + INT32 fdold, fdnew, n; + INT16 error, ignore; + Platform_FileIdentity oldidentity, newidentity; + CHAR buf[4096]; + __DUP(old, old__len, CHAR); + __DUP(new, new__len, CHAR); + error = Platform_IdentifyByName(old, old__len, &oldidentity, Platform_FileIdentity__typ); + if (error == 0) { + error = Platform_IdentifyByName(new, new__len, &newidentity, Platform_FileIdentity__typ); + if ((error != 0 && !Platform_SameFile(oldidentity, newidentity))) { + Files_Delete(new, new__len, &error); + } + error = Platform_Rename((void*)old, old__len, (void*)new, new__len); + if (!Platform_DifferentFilesystems(error)) { + *res = error; + __DEL(old); + __DEL(new); + return; + } else { + error = Platform_OldRO((void*)old, old__len, &fdold); + if (error != 0) { + *res = 2; + __DEL(old); + __DEL(new); + return; + } + error = Platform_New((void*)new, new__len, &fdnew); + if (error != 0) { + error = Platform_Close(fdold); + *res = 3; + __DEL(old); + __DEL(new); + return; + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + while (n > 0) { + error = Platform_Write(fdnew, (ADDRESS)buf, n); + if (error != 0) { + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + } + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + if (n == 0) { + error = Platform_Unlink((void*)old, old__len); + *res = 0; + } else { + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + } + } else { + *res = 2; + } + __DEL(old); + __DEL(new); +} + +void Files_Register (Files_File f) +{ + INT16 idx, errcode; + Files_File f1 = NIL; + if ((f->state == 1 && f->registerName[0] != 0x00)) { + f->state = 2; + } + Files_Close(f); + if (f->registerName[0] != 0x00) { + Files_Deregister(f->registerName, 256); + Files_Rename(f->workName, 256, f->registerName, 256, &errcode); + if (errcode != 0) { + Files_Err((CHAR*)"Couldn't rename temp name as register name", 43, f, errcode); + } + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } +} + +void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res) +{ + __DUP(path, path__len, CHAR); + *res = Platform_Chdir((void*)path, path__len); + __DEL(path); +} + +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len) +{ + INT32 i, j; + if (!Platform_LittleEndian) { + i = src__len; + j = 0; + while (i > 0) { + i -= 1; + dest[__X(j, dest__len)] = src[__X(i, src__len)]; + j += 1; + } + } else { + __MOVE((ADDRESS)src, (ADDRESS)dest, src__len); + } +} + +void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x) +{ + Files_Read(&*R, R__typ, (CHAR*)(void*)&*x); +} + +void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x) +{ + CHAR b[2]; + Files_ReadBytes(&*R, R__typ, (void*)b, 2, 2); + *x = (INT16)b[0] + __ASHL((INT16)b[1], 8); +} + +void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + *x = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); +} + +void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x) +{ + CHAR b[4]; + INT32 l; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + l = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); + *x = (UINT32)l; +} + +void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + Files_FlipBytes((void*)b, 4, (void*)&*x, 4); +} + +void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x) +{ + CHAR b[8]; + Files_ReadBytes(&*R, R__typ, (void*)b, 8, 8); + Files_FlipBytes((void*)b, 8, (void*)&*x, 8); +} + +void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&ch); + x[__X(i, x__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&x[__X(i, x__len)]); + i += 1; + } while (!(x[__X(i - 1, x__len)] == 0x00 || x[__X(i - 1, x__len)] == 0x0a)); + if (x[__X(i - 1, x__len)] == 0x0a) { + i -= 1; + } + if ((i > 0 && x[__X(i - 1, x__len)] == 0x0d)) { + i -= 1; + } + x[__X(i, x__len)] = 0x00; +} + +void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len) +{ + INT8 s, b; + INT64 q; + s = 0; + q = 0; + Files_Read(&*R, R__typ, (void*)&b); + while (b < 0) { + q += (INT64)__ASH(((INT16)b + 128), s); + s += 7; + Files_Read(&*R, R__typ, (void*)&b); + } + q += (INT64)__ASH((__MASK(b, -64) - __ASHL(__ASHR(b, 6), 6)), s); + Files_Assert(x__len <= 8); + __MOVE((ADDRESS)&q, (ADDRESS)x, x__len); +} + +void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x) +{ + Files_Write(&*R, R__typ, __VAL(CHAR, x)); +} + +void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x) +{ + CHAR b[2]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + Files_WriteBytes(&*R, R__typ, (void*)b, 2, 2); +} + +void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x) +{ + CHAR b[4]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + b[2] = __CHR(__ASHR(x, 16)); + b[3] = __CHR(__ASHR(x, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x) +{ + CHAR b[4]; + INT32 i; + UINT64 y; + y = x; + i = __VAL(INT32, y); + b[0] = __CHR(i); + b[1] = __CHR(__ASHR(i, 8)); + b[2] = __CHR(__ASHR(i, 16)); + b[3] = __CHR(__ASHR(i, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x) +{ + CHAR b[4]; + Files_FlipBytes((void*)&x, 4, (void*)b, 4); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x) +{ + CHAR b[8]; + Files_FlipBytes((void*)&x, 8, (void*)b, 8); + Files_WriteBytes(&*R, R__typ, (void*)b, 8, 8); +} + +void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + while (x[__X(i, x__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&*R, R__typ, (void*)x, x__len * 1, i + 1); +} + +void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x) +{ + while (x < -64 || x > 63) { + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128) + 128)); + x = __ASHR(x, 7); + } + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128))); +} + +void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len) +{ + __COPY(f->workName, name, name__len); +} + +static void Files_CloseOSFile (Files_File f) +{ + Files_File prev = NIL; + INT16 error; + if (Files_files == (void *) f) { + Files_files = f->next; + } else { + prev = (Files_File)Files_files; + while ((prev != NIL && prev->next != (void *) f)) { + prev = (Files_File)prev->next; + } + if (prev->next != NIL) { + prev->next = f->next; + } + } + error = Platform_Close(f->fd); + f->fd = -1; + f->state = 1; + Heap_FileCount -= 1; +} + +static void Files_Finalize (SYSTEM_PTR o) +{ + Files_File f = NIL; + INT32 res; + f = (Files_File)(ADDRESS)o; + if (f->fd >= 0) { + Files_CloseOSFile(f); + if (f->tempFile) { + res = Platform_Unlink((void*)f->workName, 256); + } + } +} + +void Files_SetSearchPath (CHAR *path, ADDRESS path__len) +{ + __DUP(path, path__len, CHAR); + if (Strings_Length(path, path__len) != 0) { + Files_SearchPath = __NEWARR(NIL, 1, 1, 1, 1, ((ADDRESS)((Strings_Length(path, path__len) + 1)))); + __COPY(path, Files_SearchPath->data, Files_SearchPath->len[0]); + } else { + Files_SearchPath = NIL; + } + __DEL(path); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Files_SearchPath); +} + +__TDESC(Files_FileDesc, 1, 4) = {__TDFLDS("FileDesc", 564), {540, 544, 548, 552, -20}}; +__TDESC(Files_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 4112), {0, -8}}; +__TDESC(Files_Rider, 1, 1) = {__TDFLDS("Rider", 20), {8, -8}}; + +export void *Files__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("Files", EnumPtrs); + __INITYP(Files_FileDesc, Files_FileDesc, 0); + __INITYP(Files_BufDesc, Files_BufDesc, 0); + __INITYP(Files_Rider, Files_Rider, 0); +/* BEGIN */ + Files_tempno = -1; + Heap_FileCount = 0; + Files_HOME[0] = 0x00; + Platform_GetEnv((CHAR*)"HOME", 5, (void*)Files_HOME, 1024); + Files_MaxPathLength = Platform_MaxPathLength(); + Files_MaxNameLength = Platform_MaxNameLength(); + __ENDMOD; +} diff --git a/bootstrap/unix-44/Files.h b/bootstrap/unix-44/Files.h new file mode 100644 index 00000000..ccdabcc2 --- /dev/null +++ b/bootstrap/unix-44/Files.h @@ -0,0 +1,70 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Files__h +#define Files__h + +#include "SYSTEM.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_FileDesc { + INT32 _prvt0; + char _prvt1[560]; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + char _prvt0[15]; + } Files_Rider; + + +import INT16 Files_MaxPathLength, Files_MaxNameLength; + +import ADDRESS *Files_FileDesc__typ; +import ADDRESS *Files_Rider__typ; + +import Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +import void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +import void Files_Close (Files_File f); +import void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +import void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +import void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +import INT32 Files_Length (Files_File f); +import Files_File Files_New (CHAR *name, ADDRESS name__len); +import Files_File Files_Old (CHAR *name, ADDRESS name__len); +import INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +import void Files_Purge (Files_File f); +import void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +import void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +import void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +import void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +import void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +import void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +import void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +import void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_Register (Files_File f); +import void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +import void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +import void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +import void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +import void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +import void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +import void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +import void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +import void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +import void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +import void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +import void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void *Files__init(void); + + +#endif // Files diff --git a/bootstrap/unix-44/Heap.c b/bootstrap/unix-44/Heap.c new file mode 100644 index 00000000..42552415 --- /dev/null +++ b/bootstrap/unix-44/Heap.c @@ -0,0 +1,799 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +struct Heap__1 { + CHAR ch; + SYSTEM_PTR p; +}; + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + struct Heap_FinDesc *Heap_FinNode; + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_FinDesc { + Heap_FinNode next; + INT32 obj; + BOOLEAN marked; + Heap_Finalizer finalize; + } Heap_FinDesc; + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + INT32 reserved1, reserved2; + } Heap_ModuleDesc; + + +export SYSTEM_PTR Heap_modules; +static INT32 Heap_freeList[10]; +static INT32 Heap_bigBlocks; +export INT32 Heap_allocated; +static BOOLEAN Heap_firstTry; +static INT16 Heap_ldUnit; +export INT32 Heap_heap; +static INT32 Heap_heapMin, Heap_heapMax; +export INT32 Heap_heapsize, Heap_heapMinExpand; +static Heap_FinNode Heap_fin; +static INT16 Heap_lockdepth; +static BOOLEAN Heap_interrupted; +export INT16 Heap_FileCount; + +export ADDRESS *Heap_ModuleDesc__typ; +export ADDRESS *Heap_CmdDesc__typ; +export ADDRESS *Heap_FinDesc__typ; +export ADDRESS *Heap__1__typ; + +static void Heap_CheckFin (void); +static void Heap_ExtendHeap (INT32 blksz); +export void Heap_FINALL (void); +static void Heap_Finalize (void); +export INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +export void Heap_GC (BOOLEAN markStack); +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len); +export void Heap_INCREF (Heap_Module m); +export void Heap_InitHeap (void); +export void Heap_Lock (void); +static void Heap_Mark (INT32 q); +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len); +static void Heap_MarkP (SYSTEM_PTR p); +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len); +export SYSTEM_PTR Heap_NEWBLK (INT32 size); +export SYSTEM_PTR Heap_NEWREC (INT32 tag); +static INT32 Heap_NewChunk (INT32 blksz); +export void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +export SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +export void Heap_REGTYP (Heap_Module m, INT32 typ); +export void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +static void Heap_Scan (void); +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len); +export void Heap_Unlock (void); + +extern void *Heap__init(); +extern ADDRESS Modules_MainStackFrame; +extern ADDRESS Platform_OSAllocate(ADDRESS size); +#define Heap_HeapModuleInit() Heap__init() +#define Heap_ModulesHalt(code) Modules_Halt(code) +#define Heap_ModulesMainStackFrame() Modules_MainStackFrame +#define Heap_OSAllocate(size) Platform_OSAllocate(size) +#define Heap_uLE(x, y) ((size_t)x <= (size_t)y) +#define Heap_uLT(x, y) ((size_t)x < (size_t)y) + +void Heap_Lock (void) +{ + Heap_lockdepth += 1; +} + +void Heap_Unlock (void) +{ + Heap_lockdepth -= 1; + if ((Heap_interrupted && Heap_lockdepth == 0)) { + Heap_ModulesHalt(-9); + } +} + +SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) +{ + Heap_Module m; + if (__STRCMP(name, "Heap") == 0) { + __SYSNEW(m, 48); + } else { + __NEW(m, Heap_ModuleDesc); + } + m->types = 0; + m->cmds = NIL; + __COPY(name, m->name, 20); + m->refcnt = 0; + m->enumPtrs = enumPtrs; + m->next = (Heap_Module)(ADDRESS)Heap_modules; + Heap_modules = (SYSTEM_PTR)m; + return (void*)m; +} + +INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len) +{ + Heap_Module m, p; + __DUP(name, name__len, CHAR); + m = (Heap_Module)(ADDRESS)Heap_modules; + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + p = m; + m = m->next; + } + if ((m != NIL && m->refcnt == 0)) { + if (m == (Heap_Module)(ADDRESS)Heap_modules) { + Heap_modules = (SYSTEM_PTR)m->next; + } else { + p->next = m->next; + } + __DEL(name); + return 0; + } else { + if (m == NIL) { + __DEL(name); + return -1; + } else { + __DEL(name); + return m->refcnt; + } + } + __RETCHK; +} + +void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd) +{ + Heap_Cmd c; + if (__STRCMP(m->name, "Heap") == 0) { + __SYSNEW(c, 32); + } else { + __NEW(c, Heap_CmdDesc); + } + __COPY(name, c->name, 24); + c->cmd = cmd; + c->next = m->cmds; + m->cmds = c; +} + +void Heap_REGTYP (Heap_Module m, INT32 typ) +{ + __PUT(typ, m->types, INT32); + m->types = typ; +} + +void Heap_INCREF (Heap_Module m) +{ + m->refcnt += 1; +} + +static INT32 Heap_NewChunk (INT32 blksz) +{ + INT32 chnk, blk, end; + chnk = Heap_OSAllocate(blksz + 12); + if (chnk != 0) { + blk = chnk + 12; + end = blk + blksz; + __PUT(chnk + 4, end, INT32); + __PUT(blk, blk + 4, INT32); + __PUT(blk + 4, blksz, INT32); + __PUT(blk + 8, -4, INT32); + __PUT(blk + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = blk; + Heap_heapsize += blksz; + if (Heap_uLT(blk + 4, Heap_heapMin)) { + Heap_heapMin = blk + 4; + } + if (Heap_uLT(Heap_heapMax, end)) { + Heap_heapMax = end; + } + } + return chnk; +} + +static void Heap_ExtendHeap (INT32 blksz) +{ + INT32 size, chnk, j, next; + if (Heap_uLT(Heap_heapMinExpand, blksz)) { + size = blksz; + } else { + size = Heap_heapMinExpand; + } + chnk = Heap_NewChunk(size); + if (chnk != 0) { + if (Heap_uLT(chnk, Heap_heap)) { + __PUT(chnk, Heap_heap, INT32); + Heap_heap = chnk; + } else { + j = Heap_heap; + __GET(j, next, INT32); + while ((next != 0 && Heap_uLT(next, chnk))) { + j = next; + __GET(j, next, INT32); + } + __PUT(chnk, next, INT32); + __PUT(j, chnk, INT32); + } + } else if (!Heap_firstTry) { + Heap_heapMinExpand = 16; + } +} + +SYSTEM_PTR Heap_NEWREC (INT32 tag) +{ + INT32 i, i0, di, blksz, restsize, t, adr, end, next, prev; + SYSTEM_PTR new; + Heap_Lock(); + __GET(tag, blksz, INT32); + i0 = __LSH(blksz, -Heap_ldUnit, 32); + i = i0; + if (i < 9) { + adr = Heap_freeList[i]; + while (adr == 0) { + i += 1; + adr = Heap_freeList[i]; + } + } + if (i < 9) { + __GET(adr + 12, next, INT32); + Heap_freeList[i] = next; + if (i != i0) { + di = i - i0; + restsize = __ASHL(di, 4); + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + adr += restsize; + } + } else { + adr = Heap_bigBlocks; + prev = 0; + for (;;) { + if (adr == 0) { + if (Heap_firstTry) { + Heap_GC(1); + blksz += 16; + t = __LSH(Heap_allocated + blksz, -(2 + Heap_ldUnit), 32) * 80; + if (Heap_uLT(Heap_heapsize, t)) { + Heap_ExtendHeap(t - Heap_heapsize); + } + Heap_firstTry = 0; + new = Heap_NEWREC(tag); + if (new == NIL) { + Heap_ExtendHeap(blksz); + new = Heap_NEWREC(tag); + } + Heap_firstTry = 1; + Heap_Unlock(); + return new; + } else { + Heap_Unlock(); + return NIL; + } + } + __GET(adr + 4, t, INT32); + if (Heap_uLE(blksz, t)) { + break; + } + prev = adr; + __GET(adr + 12, adr, INT32); + } + restsize = t - blksz; + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + if (Heap_uLT(144, restsize)) { + __PUT(adr + 4, restsize, INT32); + } else { + __GET(adr + 12, next, INT32); + if (prev == 0) { + Heap_bigBlocks = next; + } else { + __PUT(prev + 12, next, INT32); + } + if (restsize != 0) { + di = __ASHR(restsize, 4); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + } + } + adr += restsize; + } + i = adr + 16; + end = adr + blksz; + while (Heap_uLT(i, end)) { + __PUT(i, 0, INT32); + __PUT(i + 4, 0, INT32); + __PUT(i + 8, 0, INT32); + __PUT(i + 12, 0, INT32); + i += 16; + } + __PUT(adr + 12, 0, INT32); + __PUT(adr, tag, INT32); + __PUT(adr + 4, 0, INT32); + __PUT(adr + 8, 0, INT32); + Heap_allocated += blksz; + Heap_Unlock(); + return (SYSTEM_PTR)(ADDRESS)(adr + 4); +} + +SYSTEM_PTR Heap_NEWBLK (INT32 size) +{ + INT32 blksz, tag; + SYSTEM_PTR new; + Heap_Lock(); + blksz = __ASHL(__ASHR(size + 31, 4), 4); + new = Heap_NEWREC((ADDRESS)&blksz); + tag = ((INT32)(ADDRESS)new + blksz) - 12; + __PUT(tag - 4, 0, INT32); + __PUT(tag, blksz, INT32); + __PUT(tag + 4, -4, INT32); + __PUT((INT32)(ADDRESS)new - 4, tag, INT32); + Heap_Unlock(); + return new; +} + +static void Heap_Mark (INT32 q) +{ + INT32 p, tag, offset, fld, n, tagbits; + if (q != 0) { + __GET(q - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(q - 4, tagbits + 1, INT32); + p = 0; + tag = tagbits + 4; + for (;;) { + __GET(tag, offset, INT32); + if (offset < 0) { + __PUT(q - 4, (tag + offset) + 1, INT32); + if (p == 0) { + break; + } + n = q; + q = p; + __GET(q - 4, tag, INT32); + tag -= 1; + __GET(tag, offset, INT32); + fld = q + offset; + __GET(fld, p, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)n, SYSTEM_PTR); + } else { + fld = q + offset; + __GET(fld, n, INT32); + if (n != 0) { + __GET(n - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(n - 4, tagbits + 1, INT32); + __PUT(q - 4, tag + 1, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)p, SYSTEM_PTR); + p = q; + q = n; + tag = tagbits; + } + } + } + tag += 4; + } + } + } +} + +static void Heap_MarkP (SYSTEM_PTR p) +{ + Heap_Mark((INT32)(ADDRESS)p); +} + +static void Heap_Scan (void) +{ + INT32 chnk, adr, end, start, tag, i, size, freesize; + Heap_bigBlocks = 0; + i = 1; + while (i < 9) { + Heap_freeList[i] = 0; + i += 1; + } + freesize = 0; + Heap_allocated = 0; + chnk = Heap_heap; + while (chnk != 0) { + adr = chnk + 12; + __GET(chnk + 4, end, INT32); + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + tag -= 1; + __PUT(adr, tag, INT32); + __GET(tag, size, INT32); + Heap_allocated += size; + adr += size; + } else { + __GET(tag, size, INT32); + freesize += size; + adr += size; + } + } + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len) +{ + INT32 i, j; + INT32 x; + j = l; + x = a[j]; + for (;;) { + i = j; + j = __ASHL(j, 1) + 1; + if ((j < r && Heap_uLT(a[j], a[j + 1]))) { + j += 1; + } + if (j > r || Heap_uLE(a[j], x)) { + break; + } + a[i] = a[j]; + } + a[i] = x; +} + +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len) +{ + INT32 l, r; + INT32 x; + l = __ASHR(n, 1); + r = n - 1; + while (l > 0) { + l -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } + while (r > 0) { + x = a[0]; + a[0] = a[r]; + a[r] = x; + r -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } +} + +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + INT32 chnk, end, adr, tag, next, i, ptr, size; + chnk = Heap_heap; + i = 0; + while (chnk != 0) { + __GET(chnk + 4, end, INT32); + adr = chnk + 12; + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + __GET(tag - 1, size, INT32); + adr += size; + ptr = adr + 4; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + } else { + __GET(tag, size, INT32); + ptr = adr + 4; + adr += size; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + if (Heap_uLT(cand[i], adr)) { + Heap_Mark(ptr); + } + } + if (Heap_uLE(end, cand[i])) { + adr = end; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_CheckFin (void) +{ + Heap_FinNode n; + INT32 tag; + n = Heap_fin; + while (n != NIL) { + __GET(n->obj - 4, tag, INT32); + if (!__ODD(tag)) { + n->marked = 0; + Heap_Mark(n->obj); + } else { + n->marked = 1; + } + n = n->next; + } +} + +static void Heap_Finalize (void) +{ + Heap_FinNode n, prev; + n = Heap_fin; + prev = NIL; + while (n != NIL) { + if (!n->marked) { + if (n == Heap_fin) { + Heap_fin = Heap_fin->next; + } else { + prev->next = n->next; + } + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + if (prev == NIL) { + n = Heap_fin; + } else { + n = n->next; + } + } else { + prev = n; + n = n->next; + } + } +} + +void Heap_FINALL (void) +{ + Heap_FinNode n; + while (Heap_fin != NIL) { + n = Heap_fin; + Heap_fin = Heap_fin->next; + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + } +} + +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + SYSTEM_PTR frame; + INT32 nofcand; + INT32 inc, sp, p, stack0; + struct Heap__1 align; + if (n > 0) { + Heap_MarkStack(n - 1, cand, cand__len); + if (n > 100) { + return; + } + } + if (n == 0) { + nofcand = 0; + sp = (ADDRESS)&frame; + stack0 = Heap_ModulesMainStackFrame(); + inc = (ADDRESS)&align.p - (ADDRESS)&align; + if (Heap_uLT(stack0, sp)) { + inc = -inc; + } + while (sp != stack0) { + __GET(sp, p, INT32); + if ((Heap_uLE(Heap_heapMin, p) && Heap_uLT(p, Heap_heapMax))) { + if (nofcand == cand__len) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + nofcand = 0; + } + cand[nofcand] = p; + nofcand += 1; + } + sp += inc; + } + if (nofcand > 0) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + } + } +} + +void Heap_GC (BOOLEAN markStack) +{ + Heap_Module m; + INT32 i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23; + INT32 cand[10000]; + Heap_Lock(); + m = (Heap_Module)(ADDRESS)Heap_modules; + while (m != NIL) { + if (m->enumPtrs != NIL) { + (*m->enumPtrs)(Heap_MarkP); + } + m = m->next; + } + if (markStack) { + 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; + for (;;) { + i0 += 1; + i1 += 2; + i2 += 3; + i3 += 4; + i4 += 5; + i5 += 6; + i6 += 7; + i7 += 8; + i8 += 9; + i9 += 10; + i10 += 11; + i11 += 12; + i12 += 13; + i13 += 14; + i14 += 15; + i15 += 16; + i16 += 17; + i17 += 18; + i18 += 19; + i19 += 20; + i20 += 21; + i21 += 22; + i22 += 23; + i23 += 24; + if ((i0 == -99 && i15 == 24)) { + Heap_MarkStack(32, (void*)cand, 10000); + break; + } + } + 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) { + return; + } + } + Heap_CheckFin(); + Heap_Scan(); + Heap_Finalize(); + Heap_Unlock(); +} + +void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) +{ + Heap_FinNode f; + __NEW(f, Heap_FinDesc); + f->obj = (INT32)(ADDRESS)obj; + f->finalize = finalize; + f->marked = 1; + f->next = Heap_fin; + Heap_fin = f; +} + +void Heap_InitHeap (void) +{ + Heap_heap = 0; + Heap_heapsize = 0; + Heap_allocated = 0; + Heap_lockdepth = 0; + Heap_heapMin = -1; + Heap_heapMax = 0; + Heap_bigBlocks = 0; + Heap_heapMinExpand = 128000; + Heap_ldUnit = 4; + Heap_heap = Heap_NewChunk(128000); + __PUT(Heap_heap, 0, INT32); + Heap_firstTry = 1; + Heap_freeList[9] = 1; + Heap_FileCount = 0; + Heap_modules = NIL; + Heap_fin = NIL; + Heap_interrupted = 0; + Heap_HeapModuleInit(); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Heap_modules); + P(Heap_fin); +} + +__TDESC(Heap_ModuleDesc, 1, 2) = {__TDFLDS("ModuleDesc", 48), {0, 28, -12}}; +__TDESC(Heap_CmdDesc, 1, 1) = {__TDFLDS("CmdDesc", 32), {0, -8}}; +__TDESC(Heap_FinDesc, 1, 1) = {__TDFLDS("FinDesc", 16), {0, -8}}; +__TDESC(Heap__1, 1, 1) = {__TDFLDS("", 8), {4, -8}}; + +export void *Heap__init(void) +{ + __DEFMOD; + __REGMOD("Heap", EnumPtrs); + __REGCMD("FINALL", Heap_FINALL); + __REGCMD("InitHeap", Heap_InitHeap); + __REGCMD("Lock", Heap_Lock); + __REGCMD("Unlock", Heap_Unlock); + __INITYP(Heap_ModuleDesc, Heap_ModuleDesc, 0); + __INITYP(Heap_CmdDesc, Heap_CmdDesc, 0); + __INITYP(Heap_FinDesc, Heap_FinDesc, 0); + __INITYP(Heap__1, Heap__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/Heap.h b/bootstrap/unix-44/Heap.h new file mode 100644 index 00000000..3cde1c3b --- /dev/null +++ b/bootstrap/unix-44/Heap.h @@ -0,0 +1,73 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#ifndef Heap__h +#define Heap__h + +#include "SYSTEM.h" + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + char _prvt0[8]; + } Heap_ModuleDesc; + + +import SYSTEM_PTR Heap_modules; +import INT32 Heap_allocated; +import INT32 Heap_heap; +import INT32 Heap_heapsize, Heap_heapMinExpand; +import INT16 Heap_FileCount; + +import ADDRESS *Heap_ModuleDesc__typ; +import ADDRESS *Heap_CmdDesc__typ; + +import void Heap_FINALL (void); +import INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +import void Heap_GC (BOOLEAN markStack); +import void Heap_INCREF (Heap_Module m); +import void Heap_InitHeap (void); +import void Heap_Lock (void); +import SYSTEM_PTR Heap_NEWBLK (INT32 size); +import SYSTEM_PTR Heap_NEWREC (INT32 tag); +import void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +import SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +import void Heap_REGTYP (Heap_Module m, INT32 typ); +import void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +import void Heap_Unlock (void); +import void *Heap__init(void); + + +#endif // Heap diff --git a/bootstrap/unix-44/Modules.c b/bootstrap/unix-44/Modules.c new file mode 100644 index 00000000..535721e8 --- /dev/null +++ b/bootstrap/unix-44/Modules.c @@ -0,0 +1,506 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export INT16 Modules_res; +export CHAR Modules_resMsg[256]; +export Heap_ModuleName Modules_imported, Modules_importing; +export INT32 Modules_MainStackFrame; +export INT16 Modules_ArgCount; +export INT32 Modules_ArgVector; +export CHAR Modules_BinaryDir[1024]; + + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +export void Modules_AssertFail (INT32 code); +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len); +static void Modules_DisplayHaltCode (INT32 code); +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len); +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len); +export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +export void Modules_GetIntArg (INT16 n, INT32 *val); +export void Modules_Halt (INT32 code); +export void Modules_Init (INT32 argc, INT32 argvadr); +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len); +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len); +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len); +export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_errch (CHAR c); +static void Modules_errint (INT32 l); +static void Modules_errstring (CHAR *s, ADDRESS s__len); + +extern void Heap_InitHeap(); +extern void *Modules__init(void); +#define Modules_InitHeap() Heap_InitHeap() +#define Modules_ModulesInit() Modules__init() +#define Modules_modules() (Heap_Module)Heap_modules + +void Modules_Init (INT32 argc, INT32 argvadr) +{ + Modules_MainStackFrame = argvadr; + Modules_ArgCount = __VAL(INT16, argc); + __GET(argvadr, Modules_ArgVector, INT32); + Modules_InitHeap(); + Modules_ModulesInit(); +} + +typedef + CHAR (*argptr__15)[1024]; + +void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len) +{ + argptr__15 arg = NIL; + if (n < Modules_ArgCount) { + __GET(Modules_ArgVector + __ASHL(n, 2), arg, argptr__15); + __COPY(*arg, val, val__len); + } +} + +void Modules_GetIntArg (INT16 n, INT32 *val) +{ + CHAR s[64]; + INT32 k, d, i; + s[0] = 0x00; + Modules_GetArg(n, (void*)s, 64); + i = 0; + if (s[0] == '-') { + i = 1; + } + k = 0; + d = (INT16)s[__X(i, 64)] - 48; + while ((d >= 0 && d <= 9)) { + k = k * 10 + d; + i += 1; + d = (INT16)s[__X(i, 64)] - 48; + } + if (s[0] == '-') { + k = -k; + i -= 1; + } + if (i > 0) { + *val = k; + } +} + +INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len) +{ + INT16 i; + CHAR arg[256]; + __DUP(s, s__len, CHAR); + i = 0; + Modules_GetArg(i, (void*)arg, 256); + while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) { + i += 1; + Modules_GetArg(i, (void*)arg, 256); + } + __DEL(s); + return i; +} + +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return i; +} + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + if ((j > 0 && d[__X(j - 1, d__len)] != c)) { + d[__X(j, d__len)] = c; + j += 1; + } + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + if (c == 0x00) { + __DEL(s); + return 0; + } + i = 0; + while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return s[__X(i, s__len)] == c; +} + +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len) +{ + __DUP(d, d__len, CHAR); + if (d[0] == 0x00) { + __DEL(d); + return 0; + } + if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) { + __DEL(d); + return 1; + } + if (d[__X(1, d__len)] == ':') { + __DEL(d); + return 1; + } + __DEL(d); + return 0; +} + +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + __DUP(s, s__len, CHAR); + if (Modules_IsAbsolute(s, s__len)) { + __COPY(s, d, d__len); + } else { + __COPY(Platform_CWD, d, d__len); + Modules_AppendPart('/', s, s__len, (void*)d, d__len); + } + __DEL(s); +} + +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len) +{ + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __DEL(s); + return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0; +} + +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len) +{ + INT16 j; + __DUP(s, s__len, CHAR); + __DUP(p, p__len, CHAR); + j = 0; + while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) { + d[__X(j, d__len)] = s[__X(*i, s__len)]; + *i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) { + *i += 1; + } + __DEL(s); + __DEL(p); +} + +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + CHAR part[1024]; + __DUP(s, s__len, CHAR); + i = 0; + j = 0; + while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) { + i += 1; + d[__X(j, d__len)] = '/'; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (s[__X(i, s__len)] != 0x00) { + Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024); + if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) { + Modules_AppendPart('/', part, 1024, (void*)d, d__len); + } + } + __DEL(s); +} + +typedef + CHAR pathstring__12[4096]; + +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len) +{ + pathstring__12 arg0, pathlist, pathdir, tempstr; + INT16 i, j, k; + BOOLEAN present; + if (Modules_ArgCount < 1) { + binarydir[0] = 0x00; + return; + } + Modules_GetArg(0, (void*)arg0, 4096); + i = 0; + while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) { + i += 1; + } + if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') { + Modules_Trim(arg0, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } else { + Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096); + i = 0; + present = 0; + while ((!present && pathlist[__X(i, 4096)] != 0x00)) { + Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096); + Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096); + Modules_Trim(pathdir, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } + } + if (present) { + k = Modules_CharCount(binarydir, binarydir__len); + while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) { + k -= 1; + } + if (k == 0) { + binarydir[__X(k, binarydir__len)] = 0x00; + } else { + binarydir[__X(k - 1, binarydir__len)] = 0x00; + } + } else { + binarydir[0] = 0x00; + } +} + +Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len) +{ + Heap_Module m = NIL; + CHAR bodyname[64]; + Heap_Command body; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + m = m->next; + } + if (m != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + } else { + Modules_res = 1; + __COPY(name, Modules_importing, 20); + __MOVE(" module \"", Modules_resMsg, 10); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + } + __DEL(name); + return m; +} + +Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len) +{ + Heap_Cmd c = NIL; + __DUP(name, name__len, CHAR); + c = mod->cmds; + while ((c != NIL && __STRCMP(c->name, name) != 0)) { + c = c->next; + } + if (c != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + __DEL(name); + return c->cmd; + } else { + Modules_res = 2; + __MOVE(" command \"", Modules_resMsg, 11); + __COPY(name, Modules_importing, 20); + Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all) +{ + Heap_Module m = NIL, p = NIL; + INT32 refcount; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + if (all) { + Modules_res = 1; + __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34); + } else { + refcount = Heap_FreeModule(name, name__len); + if (refcount == 0) { + Modules_res = 0; + } else { + if (refcount < 0) { + __MOVE("module not found", Modules_resMsg, 17); + } else { + __MOVE("clients of this module exist", Modules_resMsg, 29); + } + Modules_res = 1; + } + } + __DEL(name); +} + +static void Modules_errch (CHAR c) +{ + INT16 e; + e = Platform_Write(1, (ADDRESS)&c, 1); +} + +static void Modules_errstring (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + Modules_errch(s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +static void Modules_errint (INT32 l) +{ + if (l < 0) { + Modules_errch('-'); + l = -l; + } + if (l >= 10) { + Modules_errint(__DIV(l, 10)); + } + Modules_errch(__CHR((int)__MOD(l, 10) + 48)); +} + +static void Modules_DisplayHaltCode (INT32 code) +{ + switch (code) { + case -1: + Modules_errstring((CHAR*)"Assertion failure.", 19); + break; + case -2: + Modules_errstring((CHAR*)"Index out of range.", 20); + break; + case -3: + Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49); + break; + case -4: + Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47); + break; + case -5: + Modules_errstring((CHAR*)"Type guard failed.", 19); + break; + case -6: + Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49); + break; + case -7: + Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32); + break; + case -8: + Modules_errstring((CHAR*)"Value out of range.", 20); + break; + case -9: + Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60); + break; + case -10: + Modules_errstring((CHAR*)"NIL access.", 12); + break; + case -11: + Modules_errstring((CHAR*)"Alignment error.", 17); + break; + case -12: + Modules_errstring((CHAR*)"Divide by zero.", 16); + break; + case -13: + Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31); + break; + case -14: + Modules_errstring((CHAR*)"Invalid function argument.", 27); + break; + case -15: + Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52); + break; + case -20: + Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60); + break; + default: + break; + } +} + +void Modules_Halt (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Terminated by Halt(", 20); + Modules_errint(code); + Modules_errstring((CHAR*)"). ", 4); + if (code < 0) { + Modules_DisplayHaltCode(code); + } + Modules_errstring(Platform_NL, 3); + Platform_Exit(code); +} + +void Modules_AssertFail (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Assertion failure.", 19); + if (code != 0) { + Modules_errstring((CHAR*)" ASSERT code ", 14); + Modules_errint(code); + Modules_errstring((CHAR*)".", 2); + } + Modules_errstring(Platform_NL, 3); + if (code > 0) { + Platform_Exit(code); + } else { + Platform_Exit(-1); + } +} + + +export void *Modules__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Modules", 0); +/* BEGIN */ + Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024); + __ENDMOD; +} diff --git a/bootstrap/unix-44/Modules.h b/bootstrap/unix-44/Modules.h new file mode 100644 index 00000000..26d86b38 --- /dev/null +++ b/bootstrap/unix-44/Modules.h @@ -0,0 +1,31 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Modules__h +#define Modules__h + +#include "SYSTEM.h" +#include "Heap.h" + + +import INT16 Modules_res; +import CHAR Modules_resMsg[256]; +import Heap_ModuleName Modules_imported, Modules_importing; +import INT32 Modules_MainStackFrame; +import INT16 Modules_ArgCount; +import INT32 Modules_ArgVector; +import CHAR Modules_BinaryDir[1024]; + + +import INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +import void Modules_AssertFail (INT32 code); +import void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +import void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +import void Modules_GetIntArg (INT16 n, INT32 *val); +import void Modules_Halt (INT32 code); +import void Modules_Init (INT32 argc, INT32 argvadr); +import Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +import Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +import void *Modules__init(void); + + +#endif // Modules diff --git a/bootstrap/unix-44/OPB.c b/bootstrap/unix-44/OPB.c new file mode 100644 index 00000000..913fbf2d --- /dev/null +++ b/bootstrap/unix-44/OPB.c @@ -0,0 +1,2592 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + + +static INT16 OPB_exp; +static INT64 OPB_maxExp; + + +export void OPB_Assign (OPT_Node *x, OPT_Node y); +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static INT16 OPB_BoolToInt (BOOLEAN b); +export void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +static void OPB_CharToString (OPT_Node n); +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode); +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo); +export void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +static void OPB_CheckProc (OPT_Struct x, OPT_Object y); +static void OPB_CheckPtr (OPT_Node x, OPT_Node y); +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x); +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp); +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y); +export void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +static void OPB_Convert (OPT_Node *x, OPT_Struct typ); +export void OPB_DeRef (OPT_Node *x); +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar); +export OPT_Node OPB_EmptySet (void); +export void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +export void OPB_Field (OPT_Node *x, OPT_Object y); +export void OPB_In (OPT_Node *x, OPT_Node y); +export void OPB_Index (OPT_Node *x, OPT_Node y); +export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +static BOOLEAN OPB_IntToBool (INT64 i); +export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +export void OPB_MOp (INT8 op, OPT_Node *x); +export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +export OPT_Node OPB_NewIntConst (INT64 intval); +export OPT_Node OPB_NewLeaf (OPT_Object obj); +export OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +export OPT_Node OPB_NewString (OPS_String str, INT64 len); +export OPT_Node OPB_Nil (void); +static BOOLEAN OPB_NotVar (OPT_Node x); +export void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +export void OPB_OptIf (OPT_Node *x); +export void OPB_Param (OPT_Node ap, OPT_Object fp); +export void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +export void OPB_Return (OPT_Node *x, OPT_Object proc); +export void OPB_SetElem (OPT_Node *x); +static void OPB_SetIntType (OPT_Node node); +export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static void OPB_SetSetType (OPT_Node node); +export void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +export void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +export void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +export void OPB_StaticLink (INT8 dlev); +export void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +static void OPB_err (INT16 n); +static INT64 OPB_log (INT64 x); + + +static void OPB_err (INT16 n) +{ + OPM_err(n); +} + +OPT_Node OPB_NewLeaf (OPT_Object obj) +{ + OPT_Node node = NIL; + switch (obj->mode) { + case 1: + node = OPT_NewNode(0); + node->readonly = (obj->vis == 2 && obj->mnolev < 0); + break; + case 2: + node = OPT_NewNode(1); + break; + case 3: + node = OPT_NewNode(7); + node->conval = OPT_NewConst(); + __GUARDEQP(node->conval, OPT_ConstDesc) = *obj->conval; + break; + case 5: + node = OPT_NewNode(8); + break; + case 6: case 7: case 8: case 9: case 10: + node = OPT_NewNode(9); + break; + default: + node = OPT_NewNode(0); + OPB_err(127); + break; + } + node->obj = obj; + node->typ = obj->typ; + return node; +} + +void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = OPT_notyp; + node->left = *x; + node->right = y; + *x = node; +} + +void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y) +{ + if (*x == NIL) { + *x = y; + } else { + (*last)->link = y; + } + while (y->link != NIL) { + y = y->link; + } + *last = y; +} + +static INT16 OPB_BoolToInt (BOOLEAN b) +{ + if (b) { + return 1; + } else { + return 0; + } + __RETCHK; +} + +static BOOLEAN OPB_IntToBool (INT64 i) +{ + return i != 0; +} + +OPT_Node OPB_NewBoolConst (BOOLEAN boolval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_booltyp; + x->conval = OPT_NewConst(); + x->conval->intval = OPB_BoolToInt(boolval); + return x; +} + +void OPB_OptIf (OPT_Node *x) +{ + OPT_Node if_ = NIL, pred = NIL; + if_ = (*x)->left; + while (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + *x = if_->right; + return; + } else if (if_->link == NIL) { + *x = (*x)->right; + return; + } else { + if_ = if_->link; + (*x)->left = if_; + } + } + pred = if_; + if_ = if_->link; + while (if_ != NIL) { + if (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + pred->link = NIL; + (*x)->right = if_->right; + return; + } else { + if_ = if_->link; + pred->link = if_; + } + } else { + pred = if_; + if_ = if_->link; + } + } +} + +OPT_Node OPB_Nil (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_niltyp; + x->conval = OPT_NewConst(); + x->conval->intval = 0; + return x; +} + +OPT_Node OPB_EmptySet (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_settyp; + x->conval = OPT_NewConst(); + x->conval->setval = 0x0; + return x; +} + +static void OPB_SetIntType (OPT_Node node) +{ + node->typ = OPT_IntType(OPT_IntSize(node->conval->intval)); +} + +static void OPB_SetSetType (OPT_Node node) +{ + INT32 i32; + __GET((ADDRESS)&node->conval->setval + 4, i32, INT32); + if (i32 == 0) { + node->typ = OPT_set32typ; + } else { + node->typ = OPT_set64typ; + } +} + +OPT_Node OPB_NewIntConst (INT64 intval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->intval = intval; + OPB_SetIntType(x); + return x; +} + +OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->realval = realval; + x->typ = typ; + x->conval->intval = -1; + return x; +} + +OPT_Node OPB_NewString (OPS_String str, INT64 len) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->typ = OPT_stringtyp; + x->conval->intval = -1; + x->conval->intval2 = OPM_Longint(len); + x->conval->ext = OPT_NewExt(); + __MOVE(str, *x->conval->ext, 256); + return x; +} + +static void OPB_CharToString (OPT_Node n) +{ + CHAR ch; + n->typ = OPT_stringtyp; + ch = __CHR(n->conval->intval); + n->conval->ext = OPT_NewExt(); + if (ch == 0x00) { + n->conval->intval2 = 1; + } else { + n->conval->intval2 = 2; + (*n->conval->ext)[1] = 0x00; + } + (*n->conval->ext)[0] = ch; + n->conval->intval = -1; + n->obj = NIL; +} + +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN OPB_NotVar (OPT_Node x) +{ + return (x->class >= 7 && ((x->class != 11 || x->subcl != 29) || x->left->class >= 7)); +} + +void OPB_DeRef (OPT_Node *x) +{ + OPT_Object strobj = NIL, bstrobj = NIL; + OPT_Struct typ = NIL, btyp = NIL; + typ = (*x)->typ; + if ((*x)->class >= 7) { + OPB_err(78); + } else if (typ->form == 11) { + if (typ == OPT_sysptrtyp) { + OPB_err(57); + } + btyp = typ->BaseTyp; + strobj = typ->strobj; + bstrobj = btyp->strobj; + if ((((((strobj != NIL && strobj->name[0] != 0x00)) && bstrobj != NIL)) && bstrobj->name[0] != 0x00)) { + btyp->pbused = 1; + } + OPB_BindNodes(3, btyp, &*x, NIL); + } else { + OPB_err(84); + } +} + +void OPB_Index (OPT_Node *x, OPT_Node y) +{ + INT16 f; + OPT_Struct typ = NIL; + f = y->typ->form; + if ((*x)->class >= 7) { + OPB_err(79); + } else if (f != 4 || __IN(y->class, 0x0300, 32)) { + OPB_err(80); + y->typ = OPT_inttyp; + } + if ((*x)->typ->comp == 2) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && (y->conval->intval < 0 || y->conval->intval >= (INT64)(*x)->typ->n))) { + OPB_err(81); + } + } else if ((*x)->typ->comp == 3) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && y->conval->intval < 0)) { + OPB_err(81); + } + } else { + OPB_err(82); + typ = OPT_undftyp; + } + OPB_BindNodes(4, typ, &*x, y); + (*x)->readonly = (*x)->left->readonly; +} + +void OPB_Field (OPT_Node *x, OPT_Object y) +{ + if ((*x)->class >= 7) { + OPB_err(77); + } + if ((y != NIL && __IN(y->mode, 0x2010, 32))) { + OPB_BindNodes(2, y->typ, &*x, NIL); + (*x)->obj = y; + (*x)->readonly = (*x)->left->readonly || (y->vis == 2 && y->mnolev < 0); + } else { + OPB_err(83); + (*x)->typ = OPT_undftyp; + } +} + +static struct TypTest__58 { + OPT_Node *x; + OPT_Object *obj; + BOOLEAN *guard; + struct TypTest__58 *lnk; +} *TypTest__58_s; + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1); + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1) +{ + OPT_Node node = NIL; + OPT_Struct t = NIL; + t = t0; + while ((((t != NIL && t != t1)) && t != OPT_undftyp)) { + t = t->BaseTyp; + } + if (t != t1) { + while ((((t1 != NIL && t1 != t0)) && t1 != OPT_undftyp)) { + t1 = t1->BaseTyp; + } + if (t1 == t0 || t0->form == 0) { + if (*TypTest__58_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__58_s->x, NIL); + (*TypTest__58_s->x)->readonly = (*TypTest__58_s->x)->left->readonly; + } else { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } + } else { + OPB_err(85); + } + } else if (t0 != t1) { + OPB_err(85); + } else if (!*TypTest__58_s->guard) { + if ((*TypTest__58_s->x)->class == 5) { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } else { + *TypTest__58_s->x = OPB_NewBoolConst(1); + } + } +} + +void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) +{ + struct TypTest__58 _s; + _s.x = x; + _s.obj = &obj; + _s.guard = &guard; + _s.lnk = TypTest__58_s; + TypTest__58_s = &_s; + if (OPB_NotVar(*x)) { + OPB_err(112); + } else if ((*x)->typ->form == 11) { + if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { + OPB_err(85); + } else if (obj->typ->form == 11) { + GTT__59((*x)->typ->BaseTyp, obj->typ->BaseTyp); + } else { + OPB_err(86); + } + } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { + GTT__59((*x)->typ, obj->typ); + } else { + OPB_err(87); + } + if (guard) { + (*x)->typ = obj->typ; + } else { + (*x)->typ = OPT_booltyp; + } + TypTest__58_s = _s.lnk; +} + +void OPB_In (OPT_Node *x, OPT_Node y) +{ + INT16 f; + INT64 k; + f = (*x)->typ->form; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((f == 4 && y->typ->form == 7)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (k < 0 || k >= (INT64)__ASHL(y->typ->size, 3)) { + OPB_err(202); + } else if (y->class == 7) { + (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval, 64)); + (*x)->obj = NIL; + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_err(92); + } + (*x)->typ = OPT_booltyp; +} + +static INT64 OPB_log (INT64 x) +{ + OPB_exp = 0; + if (x > 0) { + while (!__ODD(x)) { + x = __ASHR(x, 1); + OPB_exp += 1; + } + } + return x; +} + +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x) +{ + LONGREAL min, max, r; + if (f == 5) { + min = OPM_MinReal; + max = OPM_MaxReal; + } else { + min = OPM_MinLReal; + max = OPM_MaxLReal; + } + r = __ABS(x->realval); + if (r > max || r < min) { + OPB_err(nr); + x->realval = (LONGREAL)1; + } else if (f == 5) { + x->realval = x->realval; + } + x->intval = -1; +} + +static struct MOp__28 { + struct MOp__28 *lnk; +} *MOp__28_s; + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z); + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z) +{ + OPT_Node node = NIL; + node = OPT_NewNode(11); + node->subcl = op; + node->typ = typ; + node->left = z; + return node; +} + +void OPB_MOp (INT8 op, OPT_Node *x) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node z = NIL; + struct MOp__28 _s; + _s.lnk = MOp__28_s; + MOp__28_s = &_s; + z = *x; + if (z->class == 8 || z->class == 9) { + OPB_err(126); + } else { + typ = z->typ; + f = typ->form; + switch (op) { + case 33: + if (f == 2) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(98); + } + break; + case 6: + if (!__IN(f, 0x70, 32)) { + OPB_err(96); + } + break; + case 7: + if (__IN(f, 0xf0, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = -z->conval->intval; + OPB_SetIntType(z); + } + } else if (__IN(f, 0x60, 32)) { + z->conval->realval = -z->conval->realval; + } else { + if (z->typ->size == 8) { + z->conval->setval = ~z->conval->setval; + } else { + z->conval->setval = z->conval->setval ^ 0xffffffff; + } + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(97); + } + break; + case 21: + if (__IN(f, 0x70, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = __ABS(z->conval->intval); + OPB_SetIntType(z); + } + } else { + z->conval->realval = __ABS(z->conval->realval); + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + break; + case 22: + if (f == 3) { + if (z->class == 7) { + z->conval->intval = (INT16)__CAP(__CHR(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + z->typ = OPT_chartyp; + } + break; + case 23: + if (f == 4) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + z->typ = OPT_booltyp; + break; + case 24: + if ((((z->class == 7 && f == 3)) && z->conval->intval >= 32)) { + OPB_CharToString(z); + f = 8; + } + if (z->class < 7 || f == 8) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(127); + } + z->typ = OPT_adrtyp; + break; + case 25: + if ((f == 4 && z->class == 7)) { + if ((0 <= z->conval->intval && z->conval->intval <= -1)) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(219); + } + } else { + OPB_err(69); + } + z->typ = OPT_booltyp; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.MOp, op = ", 33); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + MOp__28_s = _s.lnk; +} + +static void OPB_CheckPtr (OPT_Node x, OPT_Node y) +{ + INT16 g; + OPT_Struct p = NIL, q = NIL, t = NIL; + g = y->typ->form; + if (g == 11) { + p = x->typ->BaseTyp; + q = y->typ->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + if (p->extlev < q->extlev) { + t = p; + p = q; + q = t; + } + while ((((p != q && p != NIL)) && p != OPT_undftyp)) { + p = p->BaseTyp; + } + if (p == NIL) { + OPB_err(100); + } + } else { + OPB_err(100); + } + } else if (g != 9) { + OPB_err(100); + } +} + +void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames) +{ + OPT_Struct ft = NIL, at = NIL; + while (fp != NIL) { + if (ap != NIL) { + ft = fp->typ; + at = ap->typ; + while ((ft->comp == 3 && at->comp == 3)) { + ft = ft->BaseTyp; + at = at->BaseTyp; + } + if (ft != at) { + if ((ft->form == 12 && at->form == 12)) { + if (ft->BaseTyp == at->BaseTyp) { + OPB_CheckParameters(ft->link, at->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(115); + } + } + if (fp->mode != ap->mode || (checkNames && __STRCMP(fp->name, ap->name) != 0)) { + OPB_err(115); + } + ap = ap->link; + } else { + OPB_err(116); + } + fp = fp->link; + } + if (ap != NIL) { + OPB_err(116); + } +} + +static void OPB_CheckProc (OPT_Struct x, OPT_Object y) +{ + if (__IN(y->mode, 0x04c0, 32)) { + if (y->mode == 6) { + if (y->mnolev == 0) { + y->mode = 7; + } else { + OPB_err(73); + } + } + if (x->BaseTyp == y->typ) { + OPB_CheckParameters(x->link, y->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(113); + } +} + +static struct ConstOp__13 { + OPT_Node *x; + INT16 *f; + OPT_Const *xval, *yval; + struct ConstOp__13 *lnk; +} *ConstOp__13_s; + +static INT16 ConstCmp__14 (void); + +static INT16 ConstCmp__14 (void) +{ + INT16 res; + switch (*ConstOp__13_s->f) { + case 0: + res = 9; + break; + case 1: case 3: case 4: + if ((*ConstOp__13_s->xval)->intval < (*ConstOp__13_s->yval)->intval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->intval > (*ConstOp__13_s->yval)->intval) { + res = 13; + } else { + res = 9; + } + break; + case 5: case 6: + if ((*ConstOp__13_s->xval)->realval < (*ConstOp__13_s->yval)->realval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->realval > (*ConstOp__13_s->yval)->realval) { + res = 13; + } else { + res = 9; + } + break; + case 2: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + case 7: + if ((*ConstOp__13_s->xval)->setval != (*ConstOp__13_s->yval)->setval) { + res = 10; + } else { + res = 9; + } + break; + case 8: + if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) < 0) { + res = 11; + } else if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) > 0) { + res = 13; + } else { + res = 9; + } + break; + case 9: case 11: case 12: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstCmp, f = ", 37); + OPM_LogWNum(*ConstOp__13_s->f, 0); + OPM_LogWLn(); + break; + } + (*ConstOp__13_s->x)->typ = OPT_booltyp; + return res; +} + +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y) +{ + INT16 f, g; + OPT_Const xval = NIL, yval = NIL; + INT64 xv, yv; + BOOLEAN temp; + struct ConstOp__13 _s; + _s.x = &x; + _s.f = &f; + _s.xval = &xval; + _s.yval = &yval; + _s.lnk = ConstOp__13_s; + ConstOp__13_s = &_s; + f = x->typ->form; + g = y->typ->form; + xval = x->conval; + yval = y->conval; + if (f != g) { + switch (f) { + case 3: + if (g == 8) { + OPB_CharToString(x); + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 4: + if (g == 4) { + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPT_IntType(x->typ->size); + } + } else if (g == 5) { + x->typ = OPT_realtyp; + xval->realval = xval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + xval->realval = xval->intval; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 5: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 6: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 5) { + y->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 8: + if (g == 3) { + OPB_CharToString(y); + g = 8; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(x, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + default: + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + break; + } + f = x->typ->form; + } + switch (op) { + case 1: + if (f == 4) { + xv = xval->intval; + yv = yval->intval; + if (((((xv == 0 || yv == 0) || (((xv > 0 && yv > 0)) && yv <= __DIV(9223372036854775807LL, xv))) || (((xv > 0 && yv < 0)) && yv >= __DIV((-9223372036854775807LL-1), xv))) || (((xv < 0 && yv > 0)) && xv >= __DIV((-9223372036854775807LL-1), yv))) || (((((((xv < 0 && yv < 0)) && xv != (-9223372036854775807LL-1))) && yv != (-9223372036854775807LL-1))) && -xv <= __DIV(9223372036854775807LL, -yv))) { + xval->intval = xv * yv; + OPB_SetIntType(x); + } else { + OPB_err(204); + } + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) <= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 / (LONGREAL)__ABS(yval->realval)) { + xval->realval = xval->realval * yval->realval; + OPB_CheckRealType(f, 204, xval); + } else { + OPB_err(204); + } + } else if (f == 7) { + xval->setval = (xval->setval & yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(101); + } + break; + case 2: + if (f == 4) { + if (yval->intval != 0) { + xval->realval = xval->intval / (REAL)yval->intval; + OPB_CheckRealType(5, 205, xval); + } else { + OPB_err(205); + xval->realval = (LONGREAL)1; + } + x->typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) >= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 * __ABS(yval->realval)) { + xval->realval = xval->realval / yval->realval; + OPB_CheckRealType(f, 205, xval); + } else { + OPB_err(205); + } + } else if (f == 7) { + xval->setval = xval->setval ^ yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(102); + } + break; + case 3: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __DIV(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(103); + } + break; + case 4: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __MOD(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(104); + } + break; + case 5: + if (f == 2) { + xval->intval = OPB_BoolToInt((OPB_IntToBool(xval->intval) && OPB_IntToBool(yval->intval))); + } else { + OPB_err(94); + } + break; + case 6: + if (f == 4) { + temp = (yval->intval >= 0 && xval->intval <= 9223372036854775807LL - yval->intval); + if (temp || (yval->intval < 0 && xval->intval >= (-9223372036854775807LL-1) - yval->intval)) { + xval->intval += yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(206); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 - yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 - yval->realval)) { + xval->realval = xval->realval + yval->realval; + OPB_CheckRealType(f, 206, xval); + } else { + OPB_err(206); + } + } else if (f == 7) { + xval->setval = xval->setval | yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(105); + } + break; + case 7: + if (f == 4) { + if ((yval->intval >= 0 && xval->intval >= (-9223372036854775807LL-1) + yval->intval) || (yval->intval < 0 && xval->intval <= 9223372036854775807LL + yval->intval)) { + xval->intval -= yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(207); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 + yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 + yval->realval)) { + xval->realval = xval->realval - yval->realval; + OPB_CheckRealType(f, 207, xval); + } else { + OPB_err(207); + } + } else if (f == 7) { + xval->setval = (xval->setval & ~yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(106); + } + break; + case 8: + if (f == 2) { + xval->intval = OPB_BoolToInt(OPB_IntToBool(xval->intval) || OPB_IntToBool(yval->intval)); + } else { + OPB_err(95); + } + break; + case 9: + xval->intval = OPB_BoolToInt(ConstCmp__14() == 9); + break; + case 10: + xval->intval = OPB_BoolToInt(ConstCmp__14() != 9); + break; + case 11: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 11); + } + break; + case 12: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 13); + } + break; + case 13: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 13); + } + break; + case 14: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 11); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstOp, op = ", 37); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + ConstOp__13_s = _s.lnk; +} + +static void OPB_Convert (OPT_Node *x, OPT_Struct typ) +{ + OPT_Node node = NIL; + INT16 f, g; + INT64 k; + LONGREAL r; + f = (*x)->typ->form; + g = typ->form; + if ((*x)->class == 7) { + if ((((f == 7 && g == 7)) && (*x)->typ->size > typ->size)) { + OPB_SetSetType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->setval = 0x0; + } + } else if (f == 4) { + if (g == 4) { + if ((*x)->typ->size > typ->size) { + OPB_SetIntType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->intval = 1; + } + } + } else if (__IN(g, 0x60, 32)) { + (*x)->conval->realval = (*x)->conval->intval; + (*x)->conval->intval = -1; + } else { + k = (*x)->conval->intval; + if (0 > k || k > 255) { + OPB_err(220); + } + } + } else if (__IN(f, 0x60, 32)) { + if (__IN(g, 0x60, 32)) { + OPB_CheckRealType(g, 203, (*x)->conval); + } else { + r = (*x)->conval->realval; + if (r < -9.22337203685478e+018 || r > 9.22337203685478e+018) { + OPB_err(203); + r = (LONGREAL)1; + } + (*x)->conval->intval = __SHORT(__ENTIER(r), 2147483648LL); + OPB_SetIntType(*x); + } + } + (*x)->obj = NIL; + } else if (((((*x)->class == 11 && (*x)->subcl == 20)) && ((INT16)(*x)->left->typ->form < f || f > g))) { + if ((*x)->left->typ == typ) { + *x = (*x)->left; + } + } else { + node = OPT_NewNode(11); + node->subcl = 20; + node->left = *x; + *x = node; + } + (*x)->typ = typ; +} + +static struct Op__38 { + INT16 *f, *g; + struct Op__38 *lnk; +} *Op__38_s; + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(12); + node->subcl = op; + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +{ + BOOLEAN ok, xCharArr, yCharArr; + xCharArr = (__IN((*x)->typ->comp, 0x0c, 32) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 8; + yCharArr = (__IN((*y)->typ->comp, 0x0c, 32) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 8; + if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + OPB_CharToString(*y); + *Op__38_s->g = 8; + yCharArr = 1; + } + if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + OPB_CharToString(*x); + *Op__38_s->f = 8; + xCharArr = 1; + } + ok = (xCharArr && yCharArr); + if (ok) { + if ((*Op__38_s->f == 8 && (*x)->conval->intval2 == 1)) { + (*x)->typ = OPT_chartyp; + (*x)->conval->intval = 0; + OPB_Index(&*y, OPB_NewIntConst(0)); + } else if ((*Op__38_s->g == 8 && (*y)->conval->intval2 == 1)) { + (*y)->typ = OPT_chartyp; + (*y)->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + } + return ok; +} + +void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y) +{ + INT16 f, g; + OPT_Node t = NIL, z = NIL; + OPT_Struct typ = NIL; + BOOLEAN do_; + INT64 val; + struct Op__38 _s; + _s.f = &f; + _s.g = &g; + _s.lnk = Op__38_s; + Op__38_s = &_s; + z = *x; + if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((z->class == 7 && y->class == 7)) { + OPB_ConstOp(op, z, y); + z->obj = NIL; + } else { + if (z->typ != y->typ) { + g = y->typ->form; + switch (z->typ->form) { + case 3: + if (z->class == 7) { + OPB_CharToString(z); + } else { + OPB_err(100); + } + break; + case 4: + if ((g == 4 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x70, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 7: + if ((g == 7 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (g == 7) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 5: + if (g == 4) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 6: + if (__IN(g, 0x70, 32)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&y, z->typ); + } else { + OPB_err(100); + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(z, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + case 8: + break; + case 13: + if (z->typ->comp == 4) { + OPB_err(100); + } + break; + default: + OPB_err(100); + break; + } + } + typ = z->typ; + f = typ->form; + g = y->typ->form; + switch (op) { + case 1: + do_ = 1; + if (f == 4) { + if (z->class == 7) { + val = z->conval->intval; + if (val == 1) { + do_ = 0; + z = y; + } else if (val == 0) { + do_ = 0; + } else if (OPB_log(val) == 1) { + t = y; + y = z; + z = t; + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } else if (y->class == 7) { + val = y->conval->intval; + if (val == 1) { + do_ = 0; + } else if (val == 0) { + do_ = 0; + z = y; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } + } else if (!__IN(f, 0xe1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 2: + if (f == 4) { + if ((y->class == 7 && y->conval->intval == 0)) { + OPB_err(205); + } + OPB_Convert(&z, OPT_realtyp); + OPB_Convert(&y, OPT_realtyp); + typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + if ((y->class == 7 && y->conval->realval == (LONGREAL)0)) { + OPB_err(205); + } + } else if ((f != 7 && f != 0)) { + OPB_err(102); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 3: + do_ = 1; + if (f == 4) { + if (y->class == 7) { + val = y->conval->intval; + if (val == 0) { + OPB_err(205); + } else if (val == 1) { + do_ = 0; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = -OPB_exp; + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(103); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 4: + if (f == 4) { + if (y->class == 7) { + if (y->conval->intval == 0) { + OPB_err(205); + } else if (OPB_log(y->conval->intval) == 1) { + op = 18; + y->conval->intval = __ASH(-1, OPB_exp); + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(104); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 5: + if (f == 2) { + if (z->class == 7) { + if (OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(94); + z->typ = OPT_undftyp; + } + break; + case 6: + if (!__IN(f, 0xf1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + do_ = 1; + if (f == 4) { + if ((z->class == 7 && z->conval->intval == 0)) { + do_ = 0; + z = y; + } + if ((y->class == 7 && y->conval->intval == 0)) { + do_ = 0; + } + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 7: + if (!__IN(f, 0xf1, 32)) { + OPB_err(106); + typ = OPT_undftyp; + } + if ((f != 4 || y->class != 7) || y->conval->intval != 0) { + NewOp__39(op, typ, &z, y); + } + break; + case 8: + if (f == 2) { + if (z->class == 7) { + if (!OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(95); + z->typ = OPT_undftyp; + } + break; + case 9: case 10: + if (__IN(f, 0x1aff, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPB_err(107); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 11: case 12: case 13: case 14: + if (__IN(f, 0x79, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ELSE in Op()", 13); + OPM_LogWLn(); + OPB_err(108); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", 32); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + Op__38_s = _s.lnk; +} + +void OPB_SetRange (OPT_Node *x, OPT_Node y) +{ + INT64 k, l; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if (((*x)->typ->form == 4 && y->typ->form == 4)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (0 > k || k > 63) { + OPB_err(202); + } + } + if (y->class == 7) { + l = y->conval->intval; + if (0 > l || l > 63) { + OPB_err(202); + } + } + if (((*x)->class == 7 && y->class == 7)) { + if (k <= l) { + (*x)->conval->setval = __SETRNG(k, l, 32); + OPB_SetSetType(*x); + } else { + OPB_err(201); + (*x)->conval->setval = __SETRNG(l, k, 32); + } + (*x)->obj = NIL; + } else { + OPB_BindNodes(10, OPT_settyp, &*x, y); + } + } else { + OPB_err(93); + } + (*x)->typ = OPT_settyp; +} + +void OPB_SetElem (OPT_Node *x) +{ + INT64 k; + if ((*x)->class == 8 || (*x)->class == 9) { + OPB_err(126); + } else if ((*x)->typ->form != 4) { + OPB_err(93); + } else if ((*x)->class == 7) { + k = (*x)->conval->intval; + if ((0 <= k && k <= 63)) { + (*x)->conval->setval = 0x0; + (*x)->conval->setval |= __SETOF(k,64); + } else { + OPB_err(202); + } + OPB_SetSetType(*x); + (*x)->obj = NIL; + } else { + OPB_Convert(&*x, OPT_settyp); + (*x)->typ = OPT_settyp; + } +} + +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) +{ + OPT_Struct y = NIL; + INT16 f, g; + OPT_Struct p = NIL, q = NIL; + y = ynode->typ; + f = x->form; + g = y->form; + if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { + OPB_err(126); + } + switch (f) { + case 0: case 8: + break; + case 1: + if (!((__IN(g, 0x1a, 32) && y->size == 1))) { + OPB_err(113); + } + break; + case 2: case 3: + if (g != f) { + OPB_err(113); + } + break; + case 4: case 7: + if (g != f || x->size < y->size) { + OPB_err(113); + } + break; + case 5: + if (!__IN(g, 0x30, 32)) { + OPB_err(113); + } + break; + case 6: + if (!__IN(g, 0x70, 32)) { + OPB_err(113); + } + break; + case 11: + if ((x == y || g == 9) || (x == OPT_sysptrtyp && g == 11)) { + } else if (g == 11) { + p = x->BaseTyp; + q = y->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + while ((((q != p && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + case 12: + if (ynode->class == 9) { + OPB_CheckProc(x, ynode->obj); + } else if (x == y || g == 9) { + } else { + OPB_err(113); + } + break; + case 10: case 9: + OPB_err(113); + break; + case 13: + x->pvused = 1; + if (x->comp == 2) { + if ((ynode->class == 7 && g == 3)) { + OPB_CharToString(ynode); + y = ynode->typ; + g = 8; + } + if (x == y) { + } else if ((((y->comp == 2 && y->BaseTyp == x->BaseTyp)) && y->n <= x->n)) { + } else if ((y->comp == 3 && y->BaseTyp == x->BaseTyp)) { + OPB_err(113); + } else if (x->BaseTyp == OPT_chartyp) { + if (g == 8) { + if (ynode->conval->intval2 > x->n) { + OPB_err(114); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else if (x->comp == 4) { + if (x == y) { + } else if (y->comp == 4) { + q = y->BaseTyp; + while ((((q != NIL && q != x)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.CheckAssign, f = ", 40); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } + if ((((((ynode->class == 7 && g < f)) && __IN(g, 0x30, 32))) && __IN(f, 0x70, 32))) { + OPB_Convert(&ynode, x); + } +} + +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo) +{ +} + +void OPB_StPar0 (OPT_Node *par0, INT16 fctno) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node x = NIL; + x = *par0; + f = x->typ->form; + switch (fctno) { + case 0: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + x->typ = OPT_notyp; + break; + case 1: + typ = OPT_notyp; + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + if (x->readonly) { + OPB_err(76); + } + f = x->typ->BaseTyp->comp; + if (__IN(f, 0x1c, 32)) { + if (f == 3) { + typ = x->typ->BaseTyp; + } + OPB_BindNodes(19, OPT_notyp, &x, NIL); + x->subcl = 1; + } else { + OPB_err(111); + } + } else { + OPB_err(111); + } + x->typ = typ; + break; + case 2: + OPB_MOp(21, &x); + break; + case 3: + OPB_MOp(22, &x); + break; + case 4: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 3) { + OPB_Convert(&x, OPT_inttyp); + } else { + OPB_err(111); + } + x->typ = OPT_inttyp; + break; + case 5: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x60, 32)) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + x->typ = OPT_linttyp; + break; + case 6: + OPB_MOp(23, &x); + break; + case 7: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(0); + break; + case 3: + x = OPB_NewIntConst(0); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(0); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MinReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MinLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 8: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(1); + break; + case 3: + x = OPB_NewIntConst(255); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(__ASHL(x->typ->size, 3) - 1); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MaxReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MaxLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 9: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x11, 32)) { + OPB_Convert(&x, OPT_chartyp); + } else { + OPB_err(111); + x->typ = OPT_chartyp; + } + break; + case 10: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, -1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 6) { + OPB_Convert(&x, OPT_realtyp); + } else { + OPB_err(111); + } + break; + case 11: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, 1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 5) { + OPB_Convert(&x, OPT_lrltyp); + } else if (f == 3) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + break; + case 13: case 14: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f != 4) { + OPB_err(111); + } else if (x->readonly) { + OPB_err(76); + } + break; + case 15: case 16: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (x->typ->form != 7) { + OPB_err(111); + x->typ = OPT_settyp; + } else if (x->readonly) { + OPB_err(76); + } + break; + case 17: + if (!__IN(x->typ->comp, 0x0c, 32)) { + OPB_err(131); + } + break; + case 18: + if ((x->class == 7 && f == 3)) { + OPB_CharToString(x); + f = 8; + } + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (((!__IN(x->typ->comp, 0x0c, 32) || x->typ->BaseTyp->form != 3) && f != 8)) { + OPB_err(111); + } + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if (x->typ->size < OPT_linttyp->size) { + OPB_Convert(&x, OPT_linttyp); + } + } else { + OPB_err(111); + x->typ = OPT_linttyp; + } + break; + case 20: + OPB_CheckLeaf(x, 0); + OPB_MOp(24, &x); + break; + case 12: + if (x->class != 8) { + OPB_err(110); + x = OPB_NewIntConst(1); + } else if (__IN(f, 0x18fe, 32) || __IN(x->typ->comp, 0x14, 32)) { + OPT_TypSize(x->typ); + x->typ->pvused = 1; + x = OPB_NewIntConst(x->typ->size); + } else { + OPB_err(111); + x = OPB_NewIntConst(1); + } + break; + case 21: + OPB_MOp(25, &x); + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (!__IN(f, 0x9a, 32)) { + OPB_err(111); + } + break; + case 24: case 25: case 28: case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + break; + case 26: case 27: + if ((f == 4 && x->class == 7)) { + if (x->conval->intval < 0 || x->conval->intval > -1) { + OPB_err(220); + } + } else { + OPB_err(69); + } + break; + case 29: + if (x->class != 8) { + OPB_err(110); + } else if (__IN(f, 0x0501, 32) || x->typ->comp == 3) { + OPB_err(111); + } + break; + case 30: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + } else { + OPB_err(111); + } + break; + case 32: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + x = OPB_NewBoolConst(0); + } else if (f != 2) { + OPB_err(120); + x = OPB_NewBoolConst(0); + } else { + OPB_MOp(33, &x); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.StPar0, fctno = ", 39); + OPM_LogWNum(fctno, 0); + OPM_LogWLn(); + break; + } + *par0 = x; +} + +static struct StPar1__53 { + struct StPar1__53 *lnk; +} *StPar1__53_s; + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right); + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->subcl = subcl; + node->left = left; + node->right = right; + return node; +} + +void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno) +{ + INT16 f, L; + OPT_Struct typ = NIL; + OPT_Node p = NIL, t = NIL; + struct StPar1__53 _s; + _s.lnk = StPar1__53_s; + StPar1__53_s = &_s; + p = *par0; + f = x->typ->form; + switch (fctno) { + case 13: case 14: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + p->typ = OPT_notyp; + } else { + if (x->typ != p->typ) { + if ((f == 4 && (x->class == 7 || (p->typ->form == 4 && x->typ->size <= p->typ->size)))) { + OPB_Convert(&x, p->typ); + } else { + OPB_err(111); + } + } + p = NewOp__54(19, fctno, p, x); + p->typ = OPT_notyp; + } + break; + case 15: case 16: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval >= (INT64)__ASHL(p->typ->size, 3)))) { + OPB_err(202); + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 17: + if (!(f == 4) || x->class != 7) { + OPB_err(69); + } else if (x->typ->size == 1) { + L = OPM_Integer(x->conval->intval); + typ = p->typ; + while ((L > 0 && __IN(typ->comp, 0x0c, 32))) { + typ = typ->BaseTyp; + L -= 1; + } + if (L != 0 || !__IN(typ->comp, 0x0c, 32)) { + OPB_err(132); + } else { + x->obj = NIL; + if (typ->comp == 3) { + while (p->class == 4) { + p = p->left; + x->conval->intval += 1; + } + p = NewOp__54(12, 19, p, x); + p->typ = OPT_linttyp; + } else { + p = x; + p->conval->intval = typ->n; + OPB_SetIntType(p); + } + } + } else { + OPB_err(132); + } + break; + case 18: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if ((__IN(x->typ->comp, 0x0c, 32) && x->typ->BaseTyp->form == 3)) { + if (x->readonly) { + OPB_err(76); + } + t = x; + x = p; + p = t; + p = NewOp__54(19, 18, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((p->class == 7 && x->class == 7)) { + if (-OPB_maxExp > x->conval->intval || x->conval->intval > OPB_maxExp) { + OPB_err(208); + p->conval->intval = 1; + } else if (x->conval->intval >= 0) { + if (__ABS(p->conval->intval) <= __DIV(9223372036854775807LL, (INT64)__ASH(1, x->conval->intval))) { + p->conval->intval = p->conval->intval * (INT64)__ASH(1, x->conval->intval); + } else { + OPB_err(208); + p->conval->intval = 1; + } + } else { + p->conval->intval = __ASH(p->conval->intval, x->conval->intval); + } + p->obj = NIL; + } else { + p = NewOp__54(12, 17, p, x); + p->typ = p->left->typ; + } + } else { + OPB_err(111); + } + break; + case 1: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp == 3) { + if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + } else { + OPB_err(111); + } + p->right = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(64); + } + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f != 4) { + OPB_err(111); + } else { + if (fctno == 22) { + p = NewOp__54(12, 27, p, x); + } else { + p = NewOp__54(12, 28, p, x); + } + p->typ = p->left->typ; + } + break; + case 24: case 25: case 26: case 27: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x18ff, 32)) { + if (fctno == 24 || fctno == 26) { + if (OPB_NotVar(x)) { + OPB_err(112); + } + t = x; + x = p; + p = t; + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 28: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(12, 26, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_booltyp; + break; + case 29: + if (((x->class == 8 || x->class == 9) || __IN(f, 0x0501, 32)) || x->typ->comp == 3) { + OPB_err(126); + } + OPT_TypSize(x->typ); + OPT_TypSize(p->typ); + if ((x->class != 7 && x->typ->size < p->typ->size)) { + OPB_err(-308); + } + if ((((x->class == 7 && x->typ->form == 4)) && p->typ->form == 4)) { + OPB_Convert(&x, p->typ); + } else { + t = OPT_NewNode(11); + t->subcl = 29; + t->left = x; + x = t; + x->typ = p->typ; + } + p = x; + break; + case 30: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(19, 30, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + p->link = x; + break; + case 32: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + break; + default: + OPB_err(64); + break; + } + *par0 = p; + StPar1__53_s = _s.lnk; +} + +void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n) +{ + OPT_Node node = NIL; + INT16 f; + OPT_Node p = NIL; + p = *par0; + f = x->typ->form; + if (fctno == 1) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp != 3) { + OPB_err(64); + } else if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + node = p->right; + while (node->link != NIL) { + node = node->link; + } + node->link = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(111); + } + } else if ((fctno == 31 && n == 2)) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + node = OPT_NewNode(19); + node->subcl = 31; + node->right = p; + node->left = p->link; + p->link = x; + p = node; + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + } else { + OPB_err(64); + } + *par0 = p; +} + +void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno) +{ + INT16 dim; + OPT_Node x = NIL, p = NIL; + p = *par0; + if (fctno <= 19) { + if ((fctno == 1 && p->typ != OPT_notyp)) { + if (p->typ->comp == 3) { + OPB_err(65); + } + p->typ = OPT_notyp; + } else if (fctno <= 12) { + if (parno < 1) { + OPB_err(65); + } + } else { + if (((fctno == 13 || fctno == 14) && parno == 1)) { + OPB_BindNodes(19, OPT_notyp, &p, OPB_NewIntConst(1)); + p->subcl = fctno; + p->right->typ = p->left->typ; + } else if ((fctno == 17 && parno == 1)) { + if (p->typ->comp == 3) { + dim = 0; + while (p->class == 4) { + p = p->left; + dim += 1; + } + OPB_BindNodes(12, OPT_linttyp, &p, OPB_NewIntConst(dim)); + p->subcl = 19; + } else { + p = OPB_NewIntConst(p->typ->n); + } + } else if (parno < 2) { + OPB_err(65); + } + } + } else if (fctno == 32) { + if (parno == 1) { + x = NIL; + OPB_BindNodes(28, OPT_notyp, &x, OPB_NewIntConst(0)); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else if (parno < 1) { + OPB_err(65); + } + } else { + if ((parno < 1 || (fctno > 21 && parno < 2)) || (fctno == 31 && parno < 3)) { + OPB_err(65); + } + } + *par0 = p; +} + +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar) +{ + INT16 f; + f = atyp->comp; + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((fvarpar && ftyp == OPT_bytetyp)) { + if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { + if (__IN(18, OPM_Options, 32)) { + OPB_err(-301); + } + } + } else if (__IN(f, 0x0c, 32)) { + if (ftyp->comp == 3) { + OPB_DynArrParCheck(ftyp, atyp, fvarpar); + } else if (ftyp != atyp) { + if ((((!fvarpar && ftyp->form == 11)) && atyp->form == 11)) { + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((ftyp->comp == 4 && atyp->comp == 4)) { + while ((((ftyp != atyp && atyp != NIL)) && atyp != OPT_undftyp)) { + atyp = atyp->BaseTyp; + } + if (atyp == NIL) { + OPB_err(113); + } + } else { + OPB_err(66); + } + } else { + OPB_err(66); + } + } + } else { + OPB_err(67); + } +} + +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp) +{ + if (fp->typ->form == 11) { + if ((*x)->class == 3) { + *x = (*x)->left; + } else { + OPB_err(71); + } + } +} + +void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar) +{ + if (((*x)->obj != NIL && __IN((*x)->obj->mode, 0x22c0, 32))) { + *fpar = (*x)->obj->link; + if ((*x)->obj->mode == 13) { + OPB_CheckReceiver(&(*x)->left, *fpar); + *fpar = (*fpar)->link; + } + } else if (((((*x)->class != 8 && (*x)->typ != NIL)) && (*x)->typ->form == 12)) { + *fpar = (*x)->typ->link; + } else { + OPB_err(121); + *fpar = NIL; + (*x)->typ = OPT_undftyp; + } +} + +void OPB_Param (OPT_Node ap, OPT_Object fp) +{ + OPT_Struct q = NIL; + if (fp->typ->form != 0) { + if (fp->mode == 2) { + if (OPB_NotVar(ap)) { + OPB_err(122); + } else { + OPB_CheckLeaf(ap, 0); + } + if (ap->readonly) { + OPB_err(76); + } + if (fp->typ->comp == 3) { + OPB_DynArrParCheck(fp->typ, ap->typ, 1); + } else if ((fp->typ->comp == 4 && ap->typ->comp == 4)) { + q = ap->typ; + while ((((q != fp->typ && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(111); + } + } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 11)) { + } else if ((ap->typ != fp->typ && !((((fp->typ->form == 1 && __IN(ap->typ->form, 0x1e, 32))) && ap->typ->size == 1)))) { + OPB_err(123); + } else if ((fp->typ->form == 11 && ap->class == 5)) { + OPB_err(123); + } + } else if (fp->typ->comp == 3) { + if ((ap->class == 7 && ap->typ->form == 3)) { + OPB_CharToString(ap); + } + if ((ap->typ->form == 8 && fp->typ->BaseTyp->form == 3)) { + } else if (ap->class >= 7) { + OPB_err(59); + } else { + OPB_DynArrParCheck(fp->typ, ap->typ, 0); + } + } else { + OPB_CheckAssign(fp->typ, ap); + } + } +} + +void OPB_StaticLink (INT8 dlev) +{ + OPT_Object scope = NIL; + scope = OPT_topScope; + while (dlev > 0) { + dlev -= 1; + scope->link->conval->setval |= __SETOF(3,64); + scope = scope->left; + } +} + +void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp) +{ + OPT_Struct typ = NIL; + OPT_Node p = NIL; + INT8 lev; + if ((*x)->class == 9) { + typ = (*x)->typ; + lev = (*x)->obj->mnolev; + if (lev > 0) { + OPB_StaticLink(OPT_topScope->mnolev - lev); + } + if ((*x)->obj->mode == 10) { + OPB_err(121); + } + } else if (((*x)->class == 2 && (*x)->obj->mode == 13)) { + typ = (*x)->typ; + (*x)->class = 9; + p = (*x)->left; + (*x)->left = NIL; + p->link = apar; + apar = p; + fp = (*x)->obj->link; + } else { + typ = (*x)->typ->BaseTyp; + } + OPB_BindNodes(13, typ, &*x, apar); + (*x)->obj = fp; +} + +void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc) +{ + OPT_Node x = NIL; + x = OPT_NewNode(18); + x->typ = OPT_notyp; + x->obj = proc; + x->left = *procdec; + x->right = stat; + *procdec = x; +} + +void OPB_Return (OPT_Node *x, OPT_Object proc) +{ + OPT_Node node = NIL; + if (proc == NIL) { + if (*x != NIL) { + OPB_err(124); + } + } else { + if (*x != NIL) { + OPB_CheckAssign(proc->typ, *x); + } else if (proc->typ != OPT_notyp) { + OPB_err(124); + } + } + node = OPT_NewNode(26); + node->typ = OPT_notyp; + node->obj = proc; + node->left = *x; + *x = node; +} + +void OPB_Assign (OPT_Node *x, OPT_Node y) +{ + OPT_Node z = NIL; + if ((*x)->class >= 7) { + OPB_err(56); + } + OPB_CheckAssign((*x)->typ, y); + if ((*x)->readonly) { + OPB_err(76); + } + if ((*x)->typ->comp == 4) { + if ((*x)->class == 5) { + z = (*x)->left; + } else { + z = *x; + } + if ((z->class == 3 && z->left->class == 5)) { + z->left = z->left->left; + } + if (((*x)->typ->strobj != NIL && (z->class == 3 || z->class == 1))) { + OPB_BindNodes(6, (*x)->typ, &z, NIL); + *x = z; + } + } else if (((((((*x)->typ->comp == 2 && (*x)->typ->BaseTyp == OPT_chartyp)) && y->typ->form == 8)) && y->conval->intval2 == 1)) { + y->typ = OPT_chartyp; + y->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + OPB_BindNodes(19, OPT_notyp, &*x, y); + (*x)->subcl = 0; +} + +void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ) +{ + OPT_Node node = NIL; + node = OPT_NewNode(14); + node->typ = typ; + node->conval = OPT_NewConst(); + node->conval->intval = typ->txtpos; + if (*inittd == NIL) { + *inittd = node; + } else { + (*last)->link = node; + } + *last = node; +} + + +export void *OPB__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPB", 0); +/* BEGIN */ + OPB_maxExp = OPB_log(4611686018427387904LL); + OPB_maxExp = OPB_exp; + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPB.h b/bootstrap/unix-44/OPB.h new file mode 100644 index 00000000..f66fcd66 --- /dev/null +++ b/bootstrap/unix-44/OPB.h @@ -0,0 +1,48 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPB__h +#define OPB__h + +#include "SYSTEM.h" +#include "OPS.h" +#include "OPT.h" + + + + +import void OPB_Assign (OPT_Node *x, OPT_Node y); +import void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +import void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +import void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +import void OPB_DeRef (OPT_Node *x); +import OPT_Node OPB_EmptySet (void); +import void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +import void OPB_Field (OPT_Node *x, OPT_Object y); +import void OPB_In (OPT_Node *x, OPT_Node y); +import void OPB_Index (OPT_Node *x, OPT_Node y); +import void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +import void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +import void OPB_MOp (INT8 op, OPT_Node *x); +import OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +import OPT_Node OPB_NewIntConst (INT64 intval); +import OPT_Node OPB_NewLeaf (OPT_Object obj); +import OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +import OPT_Node OPB_NewString (OPS_String str, INT64 len); +import OPT_Node OPB_Nil (void); +import void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +import void OPB_OptIf (OPT_Node *x); +import void OPB_Param (OPT_Node ap, OPT_Object fp); +import void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +import void OPB_Return (OPT_Node *x, OPT_Object proc); +import void OPB_SetElem (OPT_Node *x); +import void OPB_SetRange (OPT_Node *x, OPT_Node y); +import void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +import void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +import void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +import void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +import void OPB_StaticLink (INT8 dlev); +import void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +import void *OPB__init(void); + + +#endif // OPB diff --git a/bootstrap/unix-44/OPC.c b/bootstrap/unix-44/OPC.c new file mode 100644 index 00000000..7b92ccc1 --- /dev/null +++ b/bootstrap/unix-44/OPC.c @@ -0,0 +1,2025 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "OPM.h" +#include "OPT.h" + + +static INT16 OPC_indentLevel; +static INT8 OPC_hashtab[105]; +static CHAR OPC_keytab[50][9]; +static BOOLEAN OPC_GlbPtrs; +static CHAR OPC_BodyNameExt[13]; + + +export void OPC_Andent (OPT_Struct typ); +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); +export OPT_Object OPC_BaseTProc (OPT_Object obj); +export void OPC_BegBlk (void); +export void OPC_BegStat (void); +static void OPC_CProcDefs (OPT_Object obj, INT16 vis); +export void OPC_Case (INT64 caseVal, INT16 form); +static void OPC_CharacterLiteral (INT64 c); +export void OPC_Cmp (INT16 rel); +export void OPC_CompleteIdent (OPT_Object obj); +export void OPC_Constant (OPT_Const con, INT16 form); +static void OPC_DeclareBase (OPT_Object dcl); +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef); +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro); +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefAnonRecs (OPT_Node n); +export void OPC_DefineInter (OPT_Object proc); +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefineTProcTypes (OPT_Object obj); +static void OPC_DefineType (OPT_Struct str); +export void OPC_EndBlk (void); +export void OPC_EndBlk0 (void); +export void OPC_EndStat (void); +export void OPC_EnterBody (void); +export void OPC_EnterProc (OPT_Object proc); +export void OPC_ExitBody (void); +export void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign); +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign); +export void OPC_GenBdy (OPT_Node n); +static void OPC_GenDynTypes (OPT_Node n, INT16 vis); +export void OPC_GenEnumPtrs (OPT_Object var); +export void OPC_GenHdr (OPT_Node n); +export void OPC_GenHdrIncludes (void); +static void OPC_GenHeaderMsg (void); +export void OPC_Halt (INT32 n); +export void OPC_Ident (OPT_Object obj); +static void OPC_IdentList (OPT_Object obj, INT16 vis); +static void OPC_Include (CHAR *name, ADDRESS name__len); +static void OPC_IncludeImports (OPT_Object obj, INT16 vis); +export void OPC_Increment (BOOLEAN decrement); +export void OPC_Indent (INT16 count); +export void OPC_Init (void); +static void OPC_InitImports (OPT_Object obj); +static void OPC_InitKeywords (void); +export void OPC_InitTDesc (OPT_Struct typ); +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj); +export void OPC_IntLiteral (INT64 n, INT32 size); +export void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName); +static INT16 OPC_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN OPC_NeedsRetval (OPT_Object proc); +export INT32 OPC_NofPtrs (OPT_Struct typ); +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len); +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len); +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define); +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis); +static void OPC_PutBase (OPT_Struct typ); +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt); +static void OPC_RegCmds (OPT_Object obj); +export void OPC_SetInclude (BOOLEAN exclude); +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x); +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l); +export void OPC_TDescDecl (OPT_Struct typ); +export void OPC_TypeDefs (OPT_Object obj, INT16 vis); +export void OPC_TypeOf (OPT_Object ap); +static BOOLEAN OPC_Undefined (OPT_Object obj); + + +void OPC_Init (void) +{ + OPC_indentLevel = 0; + __MOVE("__init(void)", OPC_BodyNameExt, 13); +} + +void OPC_Indent (INT16 count) +{ + OPC_indentLevel += count; +} + +void OPC_BegStat (void) +{ + INT16 i; + i = OPC_indentLevel; + while (i > 0) { + OPM_Write(0x09); + i -= 1; + } +} + +void OPC_EndStat (void) +{ + OPM_Write(';'); + OPM_WriteLn(); +} + +void OPC_BegBlk (void) +{ + OPM_Write('{'); + OPM_WriteLn(); + OPC_indentLevel += 1; +} + +void OPC_EndBlk (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); + OPM_WriteLn(); +} + +void OPC_EndBlk0 (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); +} + +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x) +{ + CHAR ch; + INT16 i; + __DUP(s, s__len, CHAR); + ch = s[0]; + i = 0; + while (ch != 0x00) { + if (ch == '#') { + OPM_WriteInt(x); + } else { + OPM_Write(ch); + } + i += 1; + ch = s[__X(i, s__len)]; + } + __DEL(s); +} + +static INT16 OPC_Length (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + return i; +} + +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len) +{ + INT16 i, h; + i = 0; + h = 0; + while ((s[__X(i, s__len)] != 0x00 && i < 5)) { + h = 3 * h + (INT16)s[__X(i, s__len)]; + i += 1; + } + return (int)__MOD(h, 105); +} + +void OPC_Ident (OPT_Object obj) +{ + INT16 mode, level, h; + mode = obj->mode; + level = obj->mnolev; + if ((__IN(mode, 0x62, 32) && level > 0) || __IN(mode, 0x14, 32)) { + OPM_WriteStringVar((void*)obj->name, 256); + h = OPC_PerfectHash((void*)obj->name, 256); + if (OPC_hashtab[__X(h, 105)] >= 0) { + if (__STRCMP(OPC_keytab[__X(OPC_hashtab[__X(h, 105)], 50)], obj->name) == 0) { + OPM_Write('_'); + } + } + } else if ((mode == 5 && __IN(obj->typ->form, 0x90, 32))) { + if (obj->typ == OPT_adrtyp) { + OPM_WriteString((CHAR*)"ADDRESS", 8); + } else { + if (obj->typ->form == 4) { + OPM_WriteString((CHAR*)"INT", 4); + } else { + OPM_WriteString((CHAR*)"UINT", 5); + } + OPM_WriteInt(__ASHL(obj->typ->size, 3)); + } + } else { + if (mode != 5 || obj->linkadr != 2) { + if (mode == 13) { + OPC_Ident(obj->link->typ->strobj); + } else if (level < 0) { + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-level, 64)]->name, 256); + if (OPM_currFile == 0) { + OPT_GlbMod[__X(-level, 64)]->vis = 1; + } + } else { + OPM_WriteStringVar((void*)OPM_modName, 32); + } + OPM_Write('_'); + } else if (obj == OPT_sysptrtyp->strobj || obj == OPT_bytetyp->strobj) { + OPM_WriteString((CHAR*)"SYSTEM_", 8); + } + OPM_WriteStringVar((void*)obj->name, 256); + } +} + +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause) +{ + INT16 pointers; + *openClause = 0; + if (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->comp != 4)) { + if (__IN(typ->comp, 0x0c, 32)) { + OPC_Stars(typ->BaseTyp, &*openClause); + *openClause = typ->comp == 2; + } else if (typ->form == 12) { + OPM_Write('('); + OPM_Write('*'); + } else { + pointers = 0; + while (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->form == 11)) { + pointers += 1; + typ = typ->BaseTyp; + } + if (pointers > 0) { + if (typ->comp != 3) { + OPC_Stars(typ, &*openClause); + } + if (*openClause) { + OPM_Write('('); + *openClause = 0; + } + while (pointers > 0) { + OPM_Write('*'); + pointers -= 1; + } + } + } + } +} + +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef) +{ + OPT_Struct typ = NIL; + BOOLEAN varPar, openClause; + INT16 form, comp; + typ = dcl->typ; + varPar = ((dcl->mode == 2 && typ->comp != 2) || typ->comp == 3) || scopeDef; + OPC_Stars(typ, &openClause); + if (varPar) { + if (openClause) { + OPM_Write('('); + } + OPM_Write('*'); + } + if (dcl->name[0] != 0x00) { + OPC_Ident(dcl); + } + if ((varPar && openClause)) { + OPM_Write(')'); + } + openClause = 0; + for (;;) { + form = typ->form; + comp = typ->comp; + if (((typ->strobj != NIL && typ->strobj->name[0] != 0x00) || form == 10) || comp == 4) { + break; + } else if ((form == 11 && typ->BaseTyp->comp != 3)) { + openClause = 1; + } else if (form == 12 || __IN(comp, 0x0c, 32)) { + if (openClause) { + OPM_Write(')'); + openClause = 0; + } + if (form == 12) { + OPM_Write(')'); + OPC_AnsiParamList(typ->link, 0); + break; + } else if (comp == 2) { + OPM_Write('['); + OPM_WriteInt(typ->n); + OPM_Write(']'); + } + } else { + break; + } + typ = typ->BaseTyp; + } +} + +void OPC_Andent (OPT_Struct typ) +{ + if (typ->strobj == NIL || typ->align >= 65536) { + OPM_WriteStringVar((void*)OPM_modName, 32); + OPC_Str1((CHAR*)"__#", 4, __ASHR(typ->align, 16)); + } else { + OPC_Ident(typ->strobj); + } +} + +static BOOLEAN OPC_Undefined (OPT_Object obj) +{ + return obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (3 + OPM_currFile))) && obj->linkadr != 2); +} + +static void OPC_DeclareBase (OPT_Object dcl) +{ + OPT_Struct typ = NIL, prev = NIL; + OPT_Object obj = NIL; + INT16 nofdims; + INT32 off, n, dummy; + typ = dcl->typ; + prev = typ; + while ((((((((typ->strobj == NIL || typ->comp == 3) || OPC_Undefined(typ->strobj)) && typ->comp != 4)) && typ->form != 10)) && !((typ->form == 11 && typ->BaseTyp->comp == 3)))) { + prev = typ; + typ = typ->BaseTyp; + } + obj = typ->strobj; + if (typ->form == 10) { + OPM_WriteString((CHAR*)"void", 5); + } else if ((obj != NIL && !OPC_Undefined(obj))) { + OPC_Ident(obj); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"struct ", 8); + OPC_Andent(typ); + if ((prev->form != 11 && (obj != NIL || dcl->name[0] == 0x00))) { + if ((typ->BaseTyp != NIL && typ->BaseTyp->strobj->vis != 0)) { + OPM_WriteString((CHAR*)" { /* ", 7); + OPC_Ident(typ->BaseTyp->strobj); + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); + OPC_Indent(1); + } else { + OPM_Write(' '); + OPC_BegBlk(); + } + OPC_FieldList(typ, 1, &off, &n, &dummy); + OPC_EndBlk0(); + } + } else if ((typ->form == 11 && typ->BaseTyp->comp == 3)) { + typ = typ->BaseTyp->BaseTyp; + nofdims = 1; + while (typ->comp == 3) { + nofdims += 1; + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)"struct ", 8); + OPC_BegBlk(); + OPC_BegStat(); + OPC_Str1((CHAR*)"ADDRESS len[#]", 15, nofdims); + OPC_EndStat(); + OPC_BegStat(); + __NEW(obj, OPT_ObjDesc); + __NEW(obj->typ, OPT_StrDesc); + obj->typ->form = 13; + obj->typ->comp = 2; + obj->typ->n = 1; + obj->typ->BaseTyp = typ; + obj->mode = 4; + __MOVE("data", obj->name, 5); + obj->linkadr = 0; + OPC_DeclareBase(obj); + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + OPC_EndStat(); + OPC_EndBlk0(); + } +} + +INT32 OPC_NofPtrs (OPT_Struct typ) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n; + if ((typ->form == 11 && typ->sysflag == 0)) { + return 1; + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + n = OPC_NofPtrs(btyp); + } else { + n = 0; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + n = n + OPC_NofPtrs(fld->typ); + } else { + n += 1; + } + fld = fld->link; + } + return n; + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + return OPC_NofPtrs(btyp) * n; + } else { + return 0; + } + __RETCHK; +} + +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n, i; + if ((typ->form == 11 && typ->sysflag == 0)) { + OPM_WriteInt(adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + OPC_PutPtrOffsets(btyp, adr, &*cnt); + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + OPC_PutPtrOffsets(fld->typ, adr + fld->adr, &*cnt); + } else { + OPM_WriteInt(adr + fld->adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } + fld = fld->link; + } + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (OPC_NofPtrs(btyp) > 0) { + i = 0; + while (i < n) { + OPC_PutPtrOffsets(btyp, adr + i * btyp->size, &*cnt); + i += 1; + } + } + } +} + +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitTProcs(typ, obj->left); + if (obj->mode == 13) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITBP(", 10); + OPC_Ident(typ); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(obj); + OPC_Str1((CHAR*)", #)", 5, __ASHR(obj->adr, 16)); + OPC_EndStat(); + } + OPC_InitTProcs(typ, obj->right); + } +} + +static void OPC_PutBase (OPT_Struct typ) +{ + if (typ != NIL) { + OPC_PutBase(typ->BaseTyp); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)", ", 3); + } +} + +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName) +{ + OPT_Struct typ = NIL; + INT16 dim; + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + } + dim = 1; + typ = par->typ->BaseTyp; + while (typ->comp == 3) { + if (ansiDefine) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + } else { + OPM_WriteString((CHAR*)", ", 3); + } + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + dim += 1; + } +} + +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro) +{ + OPM_Write('('); + while (par != NIL) { + if (macro) { + OPM_WriteStringVar((void*)par->name, 256); + } else { + if ((par->mode == 1 && par->typ->form == 5)) { + OPM_Write('_'); + } + OPC_Ident(par); + } + if (par->typ->comp == 3) { + OPM_WriteString((CHAR*)", ", 3); + OPC_LenList(par, 0, 1); + } else if ((par->mode == 2 && par->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteStringVar((void*)par->name, 256); + OPM_WriteString((CHAR*)"__typ", 6); + } + par = par->link; + if (par != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static void OPC_DefineTProcTypes (OPT_Object obj) +{ + OPT_Object par = NIL; + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + par = obj->link; + while (par != NIL) { + OPC_DefineType(par->typ); + par = par->link; + } +} + +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DeclareTProcs(obj->left, &*empty); + if (obj->mode == 13) { + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + if (OPM_currFile == 0) { + if (obj->vis == 1) { + OPC_DefineTProcTypes(obj); + OPM_WriteString((CHAR*)"import ", 8); + *empty = 0; + OPC_ProcHeader(obj, 0); + } + } else { + *empty = 0; + OPC_DefineTProcTypes(obj); + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + } + OPC_DeclareTProcs(obj->right, &*empty); + } +} + +OPT_Object OPC_BaseTProc (OPT_Object obj) +{ + OPT_Struct typ = NIL, base = NIL; + INT32 mno; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + base = typ->BaseTyp; + mno = __ASHR(obj->adr, 16); + while ((base != NIL && mno < base->n)) { + typ = base; + base = typ->BaseTyp; + } + OPT_FindField(obj->name, typ, &obj); + return obj; +} + +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DefineTProcMacros(obj->left, &*empty); + if ((obj->mode == 13 && obj == OPC_BaseTProc(obj))) { + if (OPM_currFile == 1 || (OPM_currFile == 0 && obj->vis == 1)) { + OPM_WriteString((CHAR*)"#define __", 11); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_WriteString((CHAR*)" __SEND(", 9); + if (obj->link->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPC_Ident(obj->link); + OPM_Write(')'); + } else { + OPC_Ident(obj->link); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_Str1((CHAR*)", #, ", 6, __ASHR(obj->adr, 16)); + if (obj->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(obj->typ->strobj); + } + OPM_WriteString((CHAR*)"(*)", 4); + OPC_AnsiParamList(obj->link, 0); + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareParams(obj->link, 1); + OPM_Write(')'); + OPM_WriteLn(); + } + } + OPC_DefineTProcMacros(obj->right, &*empty); + } +} + +static void OPC_DefineType (OPT_Struct str) +{ + OPT_Object obj = NIL, field = NIL, par = NIL; + BOOLEAN empty; + if ((OPM_currFile == 1 || str->ref < 255) || (((OPM_currFile == 0 && str->strobj != NIL)) && str->strobj->vis == 1)) { + obj = str->strobj; + if (obj == NIL || OPC_Undefined(obj)) { + if (obj != NIL) { + if (obj->linkadr == 1) { + if (str->form != 11) { + OPM_Mark(244, str->txtpos); + obj->linkadr = 2; + } + } else { + obj->linkadr = 1; + } + } + if (str->comp == 4) { + if (str->BaseTyp != NIL) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while ((field != NIL && field->mode == 4)) { + if (field->vis != 0 || OPM_currFile == 1) { + OPC_DefineType(field->typ); + } + field = field->link; + } + } else if (str->form == 11) { + if (str->BaseTyp->comp != 4) { + OPC_DefineType(str->BaseTyp); + } + } else if (__IN(str->comp, 0x0c, 32)) { + if ((str->BaseTyp->strobj != NIL && str->BaseTyp->strobj->linkadr == 1)) { + OPM_Mark(244, str->txtpos); + str->BaseTyp->strobj->linkadr = 2; + } + OPC_DefineType(str->BaseTyp); + } else if (str->form == 12) { + if (str->BaseTyp != OPT_notyp) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while (field != NIL) { + OPC_DefineType(field->typ); + field = field->link; + } + } + } + if ((obj != NIL && OPC_Undefined(obj))) { + OPM_WriteString((CHAR*)"typedef", 8); + OPM_WriteLn(); + OPM_Write(0x09); + OPC_Indent(1); + obj->linkadr = 1; + OPC_DeclareBase(obj); + OPM_Write(' '); + obj->typ->strobj = NIL; + OPC_DeclareObj(obj, 0); + obj->typ->strobj = obj; + obj->linkadr = 3 + OPM_currFile; + OPC_EndStat(); + OPC_Indent(-1); + OPM_WriteLn(); + if (obj->typ->comp == 4) { + empty = 1; + OPC_DeclareTProcs(str->link, &empty); + OPC_DefineTProcMacros(str->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } else if ((obj->typ->form == 11 && obj->typ->BaseTyp->comp == 4)) { + empty = 1; + OPC_DeclareTProcs(obj->typ->BaseTyp->link, &empty); + OPC_DefineTProcMacros(obj->typ->BaseTyp->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } + } + } +} + +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len) +{ + INT16 i; + __DUP(y, y__len, CHAR); + i = 0; + while ((*x)[__X(i + 1, 256)] == y[__X(i, y__len)]) { + i += 1; + } + __DEL(y); + return y[__X(i, y__len)] == 0x00; +} + +static void OPC_CProcDefs (OPT_Object obj, INT16 vis) +{ + INT16 i; + OPT_ConstExt ext = NIL; + INT16 _for__7; + if (obj != NIL) { + OPC_CProcDefs(obj->left, vis); + if ((((obj->mode == 9 && (INT16)obj->vis >= vis)) && obj->adr == 1)) { + ext = obj->conval->ext; + i = 1; + if (((*ext)[1] != '#' && !(OPC_Prefixed(ext, (CHAR*)"extern ", 8) || OPC_Prefixed(ext, (CHAR*)"import ", 8)))) { + OPM_WriteString((CHAR*)"#define ", 9); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_Write(0x09); + } + _for__7 = (INT16)(*obj->conval->ext)[0]; + i = i; + while (i <= _for__7) { + OPM_Write((*obj->conval->ext)[__X(i, 256)]); + i += 1; + } + OPM_WriteLn(); + } + OPC_CProcDefs(obj->right, vis); + } +} + +void OPC_TypeDefs (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_TypeDefs(obj->left, vis); + if ((obj->mode == 5 && obj->typ->txtpos > 0)) { + OPC_DefineType(obj->typ); + } + OPC_TypeDefs(obj->right, vis); + } +} + +static void OPC_DefAnonRecs (OPT_Node n) +{ + OPT_Object o = NIL; + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if ((typ->strobj == NIL && (OPM_currFile == 1 || typ->ref < 255))) { + OPC_DefineType(typ); + __NEW(o, OPT_ObjDesc); + o->typ = typ; + o->name[0] = 0x00; + OPC_DeclareBase(o); + OPC_EndStat(); + OPM_WriteLn(); + } + n = n->link; + } +} + +void OPC_TDescDecl (OPT_Struct typ) +{ + INT32 nofptrs; + OPT_Object o = NIL; + OPC_BegStat(); + OPM_WriteString((CHAR*)"__TDESC(", 9); + OPC_Andent(typ); + OPC_Str1((CHAR*)", #", 4, typ->n + 1); + OPC_Str1((CHAR*)", #) = {__TDFLDS(", 18, OPC_NofPtrs(typ)); + OPM_Write('"'); + if (typ->strobj != NIL) { + OPM_WriteStringVar((void*)typ->strobj->name, 256); + } + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", 8, typ->size); + nofptrs = 0; + OPC_PutPtrOffsets(typ, 0, &nofptrs); + OPC_Str1((CHAR*)"#}}", 4, -((nofptrs + 1) * OPM_AddressSize)); + OPC_EndStat(); +} + +void OPC_InitTDesc (OPT_Struct typ) +{ + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITYP(", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + if (typ->BaseTyp != NIL) { + OPC_Andent(typ->BaseTyp); + } else { + OPC_Andent(typ); + } + OPC_Str1((CHAR*)", #)", 5, typ->extlev); + OPC_EndStat(); + if (typ->strobj != NIL) { + OPC_InitTProcs(typ->strobj, typ->link); + } +} + +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign) +{ + INT32 adr; + adr = off; + OPT_Align(&adr, align); + if ((*curAlign < align && gap - (adr - off) >= align)) { + gap -= (adr - off) + align; + OPC_BegStat(); + switch (align) { + case 2: + OPM_WriteString((CHAR*)"INT16", 6); + break; + case 4: + OPM_WriteString((CHAR*)"INT32", 6); + break; + case 8: + OPM_WriteString((CHAR*)"INT64", 6); + break; + default: + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected enclosing alignment in FillGap.", 43); + break; + } + OPC_Str1((CHAR*)" _prvt#", 8, *n); + *n += 1; + OPC_EndStat(); + *curAlign = align; + } + if (gap > 0) { + OPC_BegStat(); + OPC_Str1((CHAR*)"char _prvt#", 12, *n); + *n += 1; + OPC_Str1((CHAR*)"[#]", 4, gap); + OPC_EndStat(); + } +} + +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign) +{ + OPT_Object fld = NIL; + OPT_Struct base = NIL; + INT32 gap, adr, align, fldAlign; + fld = typ->link; + align = __MASK(typ->align, -65536); + if (typ->BaseTyp != NIL) { + OPC_FieldList(typ->BaseTyp, 0, &*off, &*n, &*curAlign); + } else { + *off = 0; + *n = 0; + *curAlign = 1; + } + while ((fld != NIL && fld->mode == 4)) { + if ((OPM_currFile == 0 && fld->vis == 0) || (((OPM_currFile == 1 && fld->vis == 0)) && typ->mno != 0)) { + fld = fld->link; + while ((((fld != NIL && fld->mode == 4)) && fld->vis == 0)) { + fld = fld->link; + } + } else { + adr = *off; + fldAlign = OPT_BaseAlignment(fld->typ); + OPT_Align(&adr, fldAlign); + gap = fld->adr - adr; + if (fldAlign > *curAlign) { + *curAlign = fldAlign; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + OPC_BegStat(); + OPC_DeclareBase(fld); + OPM_Write(' '); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + base = fld->typ; + fld = fld->link; + while ((((((((fld != NIL && fld->mode == 4)) && fld->typ == base)) && fld->adr == *off)) && ((OPM_currFile == 1 || fld->vis != 0) || fld->typ->strobj == NIL))) { + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + fld = fld->link; + } + OPC_EndStat(); + } + } + if (last) { + adr = typ->size - __ASHR(typ->sysflag, 8); + if (adr == 0) { + gap = 1; + } else { + gap = adr - *off; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + } +} + +static void OPC_IdentList (OPT_Object obj, INT16 vis) +{ + OPT_Struct base = NIL; + BOOLEAN first; + INT16 lastvis; + base = NIL; + first = 1; + while ((obj != NIL && obj->mode != 13)) { + if ((__IN(vis, 0x05, 32) || (vis == 1 && obj->vis != 0)) || (vis == 3 && !obj->leaf)) { + if (obj->typ != base || (INT16)obj->vis != lastvis) { + if (!first) { + OPC_EndStat(); + } + first = 0; + base = obj->typ; + lastvis = obj->vis; + OPC_BegStat(); + if ((vis == 1 && obj->vis != 0)) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((obj->mnolev == 0 && vis == 0)) { + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + } + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_WriteString((CHAR*)"double", 7); + } else { + OPC_DeclareBase(obj); + } + } else { + OPM_Write(','); + } + OPM_Write(' '); + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_Write('_'); + } + OPC_DeclareObj(obj, vis == 3); + if (obj->typ->comp == 3) { + OPC_EndStat(); + OPC_BegStat(); + base = OPT_adrtyp; + OPM_WriteString((CHAR*)"ADDRESS ", 9); + OPC_LenList(obj, 0, 1); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + base = NIL; + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + OPM_WriteString((CHAR*)" = NIL", 7); + } + } + obj = obj->link; + } + if (!first) { + OPC_EndStat(); + } +} + +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames) +{ + CHAR name[32]; + OPM_Write('('); + if (obj == NIL || obj->mode == 13) { + OPM_WriteString((CHAR*)"void", 5); + } else { + for (;;) { + OPC_DeclareBase(obj); + if (showParamNames) { + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + } else { + __COPY(obj->name, name, 32); + obj->name[0] = 0x00; + OPC_DeclareObj(obj, 0); + __COPY(name, obj->name, 256); + } + if (obj->typ->comp == 3) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + OPC_LenList(obj, 1, showParamNames); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ADDRESS *", 12); + if (showParamNames) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + } + } + if (obj->link == NIL || obj->link->mode == 13) { + break; + } + OPM_WriteString((CHAR*)", ", 3); + obj = obj->link; + } + } + OPM_Write(')'); +} + +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define) +{ + if (proc->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(proc->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(proc); + OPM_Write(' '); + OPC_AnsiParamList(proc->link, 1); + if (!define) { + OPM_Write(';'); + } + OPM_WriteLn(); +} + +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis) +{ + if (obj != NIL) { + OPC_ProcPredefs(obj->left, vis); + if ((((__IN(obj->mode, 0xc0, 32) && obj->vis >= vis)) && (obj->history != 4 || obj->mode == 6))) { + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + OPC_ProcPredefs(obj->right, vis); + } +} + +static void OPC_Include (CHAR *name, ADDRESS name__len) +{ + __DUP(name, name__len, CHAR); + OPM_WriteString((CHAR*)"#include ", 10); + OPM_Write('"'); + OPM_WriteStringVar((void*)name, name__len); + OPM_WriteString((CHAR*)".h", 3); + OPM_Write('"'); + OPM_WriteLn(); + __DEL(name); +} + +static void OPC_IncludeImports (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_IncludeImports(obj->left, vis); + if ((((obj->mode == 11 && obj->mnolev != 0)) && (INT16)OPT_GlbMod[__X(-obj->mnolev, 64)]->vis >= vis)) { + OPC_Include(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + } + OPC_IncludeImports(obj->right, vis); + } +} + +static void OPC_GenDynTypes (OPT_Node n, INT16 vis) +{ + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if (vis == 0 || typ->ref < 255) { + OPC_BegStat(); + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((typ->strobj != NIL && typ->strobj->mnolev > 0)) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_EndStat(); + } + n = n->link; + } +} + +void OPC_GenHdr (OPT_Node n) +{ + OPM_currFile = 0; + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 1); + OPM_WriteLn(); + OPC_GenDynTypes(n, 1); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 1); + OPM_WriteString((CHAR*)"import ", 8); + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPC_EndStat(); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#endif // ", 11); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteLn(); +} + +static void OPC_GenHeaderMsg (void) +{ + INT16 i; + OPM_WriteString((CHAR*)"/* ", 4); + OPM_WriteString((CHAR*)"voc", 4); + OPM_Write(' '); + OPM_WriteString(Configuration_versionLong, 76); + OPM_Write(' '); + i = 0; + while (i <= 31) { + if (__IN(i, OPM_Options, 32)) { + switch (i) { + case 0: + OPM_Write('x'); + break; + case 2: + OPM_Write('r'); + break; + case 3: + OPM_Write('t'); + break; + case 4: + OPM_Write('s'); + break; + case 5: + OPM_Write('p'); + break; + case 7: + OPM_Write('a'); + break; + case 9: + OPM_Write('e'); + break; + case 10: + OPM_Write('m'); + break; + case 13: + OPM_Write('S'); + break; + case 14: + OPM_Write('c'); + break; + case 15: + OPM_Write('M'); + break; + case 16: + OPM_Write('f'); + break; + case 17: + OPM_Write('F'); + break; + case 18: + OPM_Write('v'); + break; + default: + OPM_LogWStr((CHAR*)"( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg", 126); + OPM_LogWLn(); + break; + } + } + i += 1; + } + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); +} + +void OPC_GenHdrIncludes (void) +{ + OPM_currFile = 2; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#ifndef ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 1); + OPM_WriteLn(); +} + +void OPC_GenBdy (OPT_Node n) +{ + OPM_currFile = 1; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SHORTINT INT", 21); + OPM_WriteInt(__ASHL(OPT_sinttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define INTEGER INT", 21); + OPM_WriteInt(__ASHL(OPT_inttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define LONGINT INT", 21); + OPM_WriteInt(__ASHL(OPT_linttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SET UINT", 22); + OPM_WriteInt(__ASHL(OPT_settyp->size, 3)); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 0); + OPM_WriteLn(); + OPC_GenDynTypes(n, 0); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 0); + OPM_WriteLn(); +} + +static void OPC_RegCmds (OPT_Object obj) +{ + if (obj != NIL) { + OPC_RegCmds(obj->left); + if ((obj->mode == 7 && obj->history != 4)) { + if ((((obj->vis != 0 && obj->link == NIL)) && obj->typ == OPT_notyp)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__REGCMD(\"", 11); + OPM_WriteStringVar((void*)obj->name, 256); + OPM_WriteString((CHAR*)"\", ", 4); + OPC_Ident(obj); + OPM_Write(')'); + OPC_EndStat(); + } + } + OPC_RegCmds(obj->right); + } +} + +static void OPC_InitImports (OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitImports(obj->left); + if ((obj->mode == 11 && obj->mnolev != 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__MODULE_IMPORT(", 17); + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + OPM_Write(')'); + OPC_EndStat(); + } + OPC_InitImports(obj->right); + } +} + +void OPC_GenEnumPtrs (OPT_Object var) +{ + OPT_Struct typ = NIL; + INT32 n; + OPC_GlbPtrs = 0; + while (var != NIL) { + typ = var->typ; + if (OPC_NofPtrs(typ) > 0) { + if (!OPC_GlbPtrs) { + OPC_GlbPtrs = 1; + OPM_WriteString((CHAR*)"static void EnumPtrs(void (*P)(void*))", 39); + OPM_WriteLn(); + OPC_BegBlk(); + } + OPC_BegStat(); + if (typ->form == 11) { + OPM_WriteString((CHAR*)"P(", 3); + OPC_Ident(var); + OPM_Write(')'); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(&", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPM_WriteString((CHAR*)", 1, P)", 8); + } else if (typ->comp == 2) { + n = typ->n; + typ = typ->BaseTyp; + while (typ->comp == 2) { + n = n * typ->n; + typ = typ->BaseTyp; + } + if (typ->form == 11) { + OPM_WriteString((CHAR*)"__ENUMP(", 9); + OPC_Ident(var); + OPC_Str1((CHAR*)", #, P)", 8, n); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(", 9); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPC_Str1((CHAR*)", #, P)", 8, n); + } + } + OPC_EndStat(); + } + var = var->link; + } + if (OPC_GlbPtrs) { + OPC_EndBlk(); + OPM_WriteLn(); + } +} + +void OPC_EnterBody (void) +{ + OPM_WriteLn(); + OPM_WriteString((CHAR*)"export ", 8); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); + OPM_WriteLn(); + } else { + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteString(OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPM_WriteLn(); + } + OPC_BegBlk(); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); + } else { + OPM_WriteString((CHAR*)"__DEFMOD", 9); + } + OPC_EndStat(); + if ((__IN(10, OPM_Options, 32) && 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); + OPC_EndStat(); + } + OPC_InitImports(OPT_topScope->right); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); + } else { + OPM_WriteString((CHAR*)"__REGMOD(\"", 11); + } + OPM_WriteString(OPM_modName, 32); + if (OPC_GlbPtrs) { + OPM_WriteString((CHAR*)"\", EnumPtrs)", 13); + } else { + OPM_WriteString((CHAR*)"\", 0)", 6); + } + OPC_EndStat(); + if (__STRCMP(OPM_modName, "SYSTEM") != 0) { + OPC_RegCmds(OPT_topScope); + } +} + +void OPC_ExitBody (void) +{ + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI;", 8); + } else { + OPM_WriteString((CHAR*)"__ENDMOD;", 10); + } + OPM_WriteLn(); + OPC_EndBlk(); +} + +void OPC_DefineInter (OPT_Object proc) +{ + OPT_Object scope = NIL; + scope = proc->scope; + OPM_WriteString((CHAR*)"static ", 8); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPC_BegBlk(); + OPC_IdentList(proc->link, 3); + OPC_IdentList(scope->scope, 3); + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + OPC_EndBlk0(); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPM_WriteLn(); + OPC_ProcPredefs(scope->right, 0); + OPM_WriteLn(); +} + +BOOLEAN OPC_NeedsRetval (OPT_Object proc) +{ + return (proc->typ != OPT_notyp && !proc->scope->leaf); +} + +void OPC_EnterProc (OPT_Object proc) +{ + OPT_Object var = NIL, scope = NIL; + OPT_Struct typ = NIL; + INT16 dim; + if (proc->vis != 1) { + OPM_WriteString((CHAR*)"static ", 8); + } + OPC_ProcHeader(proc, 1); + OPC_BegBlk(); + scope = proc->scope; + OPC_IdentList(scope->scope, 0); + if (!scope->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } + if (OPC_NeedsRetval(proc)) { + OPC_BegStat(); + OPC_Ident(proc->typ->strobj); + OPM_WriteString((CHAR*)" __retval", 10); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((var->typ->comp == 2 && var->mode == 1)) { + OPC_BegStat(); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__copy", 7); + OPC_EndStat(); + } + var = var->link; + } + var = proc->link; + while (var != NIL) { + if ((((__IN(var->typ->comp, 0x0c, 32) && var->mode == 1)) && var->typ->sysflag == 0)) { + OPC_BegStat(); + if (var->typ->comp == 2) { + OPM_WriteString((CHAR*)"__DUPARR(", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + } else { + OPM_WriteString((CHAR*)"__DUP(", 7); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + typ = var->typ->BaseTyp; + dim = 1; + while (typ->comp == 3) { + OPM_WriteString((CHAR*)" * ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + typ = typ->BaseTyp; + dim += 1; + } + OPM_WriteString((CHAR*)", ", 3); + if (typ->strobj == NIL) { + OPM_Mark(200, typ->txtpos); + } else { + OPC_Ident(typ->strobj); + } + } + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + if (!scope->leaf) { + var = proc->link; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (__IN(var->typ->comp, 0x0c, 32)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } else if (var->mode != 2) { + OPM_Write('&'); + } + OPC_Ident(var); + if (var->typ->comp == 3) { + typ = var->typ; + dim = 0; + do { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + } while (!(typ->comp != 3)); + } else if ((var->mode == 2 && var->typ->comp == 4)) { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_EndStat(); + } + var = var->link; + } + var = scope->scope; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (var->typ->comp != 2) { + OPM_Write('&'); + } else { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPC_Ident(var); + OPC_EndStat(); + } + var = var->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_Write('&'); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } +} + +void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet) +{ + OPT_Object var = NIL; + BOOLEAN indent; + indent = eoBlock; + if ((implicitRet && proc->typ != OPT_notyp)) { + OPM_Write(0x09); + OPM_WriteString((CHAR*)"__RETCHK;", 10); + OPM_WriteLn(); + } else if (!eoBlock || implicitRet) { + if (!proc->scope->leaf) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteStringVar((void*)proc->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((((var->typ->comp == 3 && var->mode == 1)) && var->typ->sysflag == 0)) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteString((CHAR*)"__DEL(", 7); + OPC_Ident(var); + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + } + if (eoBlock) { + OPC_EndBlk(); + OPM_WriteLn(); + } else if (indent) { + OPC_BegStat(); + } +} + +void OPC_CompleteIdent (OPT_Object obj) +{ + INT16 comp, level; + level = obj->mnolev; + if (obj->adr == 1) { + if (obj->typ->comp == 4) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__", 3); + } else { + OPM_WriteString((CHAR*)"(*(", 4); + OPC_Ident(obj->typ->strobj); + OPM_WriteString((CHAR*)"*)&", 4); + OPC_Ident(obj); + OPM_Write(')'); + } + } else if ((level != OPM_level && level > 0)) { + comp = obj->typ->comp; + if ((obj->mode != 2 && comp != 3)) { + OPM_Write('*'); + } + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)"->", 3); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } +} + +void OPC_TypeOf (OPT_Object ap) +{ + INT16 i; + __ASSERT(ap->typ->comp == 4, 0); + if (ap->mode == 2) { + if ((INT16)ap->mnolev != OPM_level) { + OPM_WriteStringVar((void*)ap->scope->name, 256); + OPM_WriteString((CHAR*)"_s->", 5); + OPC_Ident(ap); + } else { + OPC_Ident(ap); + } + OPM_WriteString((CHAR*)"__typ", 6); + } else if (ap->typ->strobj != NIL) { + OPC_Ident(ap->typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + } else { + OPC_Andent(ap->typ); + } +} + +void OPC_Cmp (INT16 rel) +{ + switch (rel) { + case 9: + OPM_WriteString((CHAR*)" == ", 5); + break; + case 10: + OPM_WriteString((CHAR*)" != ", 5); + break; + case 11: + OPM_WriteString((CHAR*)" < ", 4); + break; + case 12: + OPM_WriteString((CHAR*)" <= ", 5); + break; + case 13: + OPM_WriteString((CHAR*)" > ", 4); + break; + case 14: + OPM_WriteString((CHAR*)" >= ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Cmp, rel = ", 34); + OPM_LogWNum(rel, 0); + OPM_LogWLn(); + break; + } +} + +static void OPC_CharacterLiteral (INT64 c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", 3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l) +{ + INT32 i; + INT16 c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (INT16)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write(__CHR(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write(__CHR(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write(__CHR(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + +void OPC_Case (INT64 caseVal, INT16 form) +{ + CHAR ch; + OPM_WriteString((CHAR*)"case ", 6); + switch (form) { + case 3: + OPC_CharacterLiteral(caseVal); + break; + case 4: + OPM_WriteInt(caseVal); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Case, form = ", 36); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } + OPM_WriteString((CHAR*)": ", 3); +} + +void OPC_SetInclude (BOOLEAN exclude) +{ + if (exclude) { + OPM_WriteString((CHAR*)" &= ~", 6); + } else { + OPM_WriteString((CHAR*)" |= ", 5); + } +} + +void OPC_Increment (BOOLEAN decrement) +{ + if (decrement) { + OPM_WriteString((CHAR*)" -= ", 5); + } else { + OPM_WriteString((CHAR*)" += ", 5); + } +} + +void OPC_Halt (INT32 n) +{ + OPC_Str1((CHAR*)"__HALT(#)", 10, n); +} + +void OPC_IntLiteral (INT64 n, INT32 size) +{ + if ((((size > 4 && n <= 2147483647)) && n > (-2147483647-1))) { + OPM_WriteString((CHAR*)"((INT", 6); + OPM_WriteInt(__ASHL(size, 3)); + OPM_WriteString((CHAR*)")(", 3); + OPM_WriteInt(n); + OPM_WriteString((CHAR*)"))", 3); + } else { + OPM_WriteInt(n); + } +} + +void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim) +{ + INT64 d; + d = dim; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPC_CompleteIdent(obj); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + } else { + OPM_WriteInt(array->n); + } +} + +void OPC_Constant (OPT_Const con, INT16 form) +{ + INT16 i; + UINT64 s; + INT64 hex; + BOOLEAN skipLeading; + switch (form) { + case 1: + OPM_WriteInt(con->intval); + break; + case 2: + OPM_WriteInt(con->intval); + break; + case 3: + OPC_CharacterLiteral(con->intval); + break; + case 4: + OPM_WriteInt(con->intval); + break; + case 5: + OPM_WriteReal(con->realval, 'f'); + break; + case 6: + OPM_WriteReal(con->realval, 0x00); + break; + case 7: + OPM_WriteString((CHAR*)"0x", 3); + skipLeading = 1; + s = con->setval; + i = 64; + do { + hex = 0; + do { + i -= 1; + hex = __ASHL(hex, 1); + if (__IN(i, s, 64)) { + hex += 1; + } + } while (!(__MASK(i, -8) == 0)); + if (hex != 0 || !skipLeading) { + OPM_WriteHex(hex); + skipLeading = 0; + } + } while (!(i == 0)); + if (skipLeading) { + OPM_Write('0'); + } + break; + case 8: + OPC_StringLiteral(*con->ext, 256, con->intval2 - 1); + break; + case 9: + OPM_WriteString((CHAR*)"NIL", 4); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Constant, form = ", 40); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } +} + +static struct InitKeywords__46 { + INT8 *n; + struct InitKeywords__46 *lnk; +} *InitKeywords__46_s; + +static void Enter__47 (CHAR *s, ADDRESS s__len); + +static void Enter__47 (CHAR *s, ADDRESS s__len) +{ + INT16 h; + __DUP(s, s__len, CHAR); + h = OPC_PerfectHash((void*)s, s__len); + OPC_hashtab[__X(h, 105)] = *InitKeywords__46_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__46_s->n, 50)], 9); + *InitKeywords__46_s->n += 1; + __DEL(s); +} + +static void OPC_InitKeywords (void) +{ + INT8 n, i; + struct InitKeywords__46 _s; + _s.n = &n; + _s.lnk = InitKeywords__46_s; + InitKeywords__46_s = &_s; + n = 0; + i = 0; + while (i <= 104) { + OPC_hashtab[__X(i, 105)] = -1; + i += 1; + } + Enter__47((CHAR*)"ADDRESS", 8); + Enter__47((CHAR*)"INT16", 6); + Enter__47((CHAR*)"INT32", 6); + Enter__47((CHAR*)"INT64", 6); + Enter__47((CHAR*)"INT8", 5); + Enter__47((CHAR*)"UINT16", 7); + Enter__47((CHAR*)"UINT32", 7); + Enter__47((CHAR*)"UINT64", 7); + Enter__47((CHAR*)"UINT8", 6); + Enter__47((CHAR*)"asm", 4); + Enter__47((CHAR*)"auto", 5); + Enter__47((CHAR*)"break", 6); + Enter__47((CHAR*)"case", 5); + Enter__47((CHAR*)"char", 5); + Enter__47((CHAR*)"const", 6); + Enter__47((CHAR*)"continue", 9); + Enter__47((CHAR*)"default", 8); + Enter__47((CHAR*)"do", 3); + Enter__47((CHAR*)"double", 7); + Enter__47((CHAR*)"else", 5); + Enter__47((CHAR*)"enum", 5); + Enter__47((CHAR*)"extern", 7); + Enter__47((CHAR*)"export", 7); + Enter__47((CHAR*)"float", 6); + Enter__47((CHAR*)"for", 4); + Enter__47((CHAR*)"fortran", 8); + Enter__47((CHAR*)"goto", 5); + Enter__47((CHAR*)"if", 3); + Enter__47((CHAR*)"import", 7); + Enter__47((CHAR*)"int", 4); + Enter__47((CHAR*)"long", 5); + Enter__47((CHAR*)"register", 9); + Enter__47((CHAR*)"return", 7); + Enter__47((CHAR*)"short", 6); + Enter__47((CHAR*)"signed", 7); + Enter__47((CHAR*)"sizeof", 7); + Enter__47((CHAR*)"size_t", 7); + Enter__47((CHAR*)"static", 7); + Enter__47((CHAR*)"struct", 7); + Enter__47((CHAR*)"switch", 7); + Enter__47((CHAR*)"typedef", 8); + Enter__47((CHAR*)"union", 6); + Enter__47((CHAR*)"unsigned", 9); + Enter__47((CHAR*)"void", 5); + Enter__47((CHAR*)"volatile", 9); + Enter__47((CHAR*)"while", 6); + InitKeywords__46_s = _s.lnk; +} + + +export void *OPC__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPT); + __REGMOD("OPC", 0); + __REGCMD("BegBlk", OPC_BegBlk); + __REGCMD("BegStat", OPC_BegStat); + __REGCMD("EndBlk", OPC_EndBlk); + __REGCMD("EndBlk0", OPC_EndBlk0); + __REGCMD("EndStat", OPC_EndStat); + __REGCMD("EnterBody", OPC_EnterBody); + __REGCMD("ExitBody", OPC_ExitBody); + __REGCMD("GenHdrIncludes", OPC_GenHdrIncludes); + __REGCMD("Init", OPC_Init); +/* BEGIN */ + OPC_InitKeywords(); + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPC.h b/bootstrap/unix-44/OPC.h new file mode 100644 index 00000000..3bfd88b8 --- /dev/null +++ b/bootstrap/unix-44/OPC.h @@ -0,0 +1,49 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPC__h +#define OPC__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPC_Andent (OPT_Struct typ); +import OPT_Object OPC_BaseTProc (OPT_Object obj); +import void OPC_BegBlk (void); +import void OPC_BegStat (void); +import void OPC_Case (INT64 caseVal, INT16 form); +import void OPC_Cmp (INT16 rel); +import void OPC_CompleteIdent (OPT_Object obj); +import void OPC_Constant (OPT_Const con, INT16 form); +import void OPC_DefineInter (OPT_Object proc); +import void OPC_EndBlk (void); +import void OPC_EndBlk0 (void); +import void OPC_EndStat (void); +import void OPC_EnterBody (void); +import void OPC_EnterProc (OPT_Object proc); +import void OPC_ExitBody (void); +import void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +import void OPC_GenBdy (OPT_Node n); +import void OPC_GenEnumPtrs (OPT_Object var); +import void OPC_GenHdr (OPT_Node n); +import void OPC_GenHdrIncludes (void); +import void OPC_Halt (INT32 n); +import void OPC_Ident (OPT_Object obj); +import void OPC_Increment (BOOLEAN decrement); +import void OPC_Indent (INT16 count); +import void OPC_Init (void); +import void OPC_InitTDesc (OPT_Struct typ); +import void OPC_IntLiteral (INT64 n, INT32 size); +import void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +import BOOLEAN OPC_NeedsRetval (OPT_Object proc); +import INT32 OPC_NofPtrs (OPT_Struct typ); +import void OPC_SetInclude (BOOLEAN exclude); +import void OPC_TDescDecl (OPT_Struct typ); +import void OPC_TypeDefs (OPT_Object obj, INT16 vis); +import void OPC_TypeOf (OPT_Object ap); +import void *OPC__init(void); + + +#endif // OPC diff --git a/bootstrap/unix-44/OPM.c b/bootstrap/unix-44/OPM.c new file mode 100644 index 00000000..bcb39247 --- /dev/null +++ b/bootstrap/unix-44/OPM.c @@ -0,0 +1,1183 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Files.h" +#include "Modules.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" +#include "Texts.h" +#include "VT100.h" + +typedef + CHAR OPM_FileName[32]; + + +static CHAR OPM_currentComment[256]; +static BOOLEAN OPM_hasComment; +static CHAR OPM_SourceFileName[256]; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static INT16 OPM_GlobalAddressSize; +export INT16 OPM_AddressSize; +static INT16 OPM_GlobalAlignment; +export INT16 OPM_Alignment; +export UINT32 OPM_GlobalOptions, OPM_Options; +export INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +export INT64 OPM_MaxIndex; +export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +export BOOLEAN OPM_noerr; +export INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +export INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +export CHAR OPM_modName[32]; +export CHAR OPM_objname[64]; +static INT32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; +static Texts_Reader OPM_inR; +static Texts_Text OPM_Log, OPM_Errors; +static Files_Rider OPM_oldSF, OPM_newSF; +static Files_Rider OPM_R[3]; +static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; +static INT16 OPM_S; +export CHAR OPM_InstallDir[1024]; +export CHAR OPM_ResourceDir[1024]; + + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F); +export void OPM_CloseFiles (void); +export void OPM_CloseOldSym (void); +export void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +export void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +export void OPM_FPrint (INT32 *fp, INT64 val); +export void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +export void OPM_FPrintReal (INT32 *fp, REAL val); +export void OPM_FPrintSet (INT32 *fp, UINT64 val); +static void OPM_FindInstallDir (void); +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos); +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len); +export void OPM_Get (CHAR *ch); +export void OPM_GetComment (CHAR *text, ADDRESS text__len); +export void OPM_Init (BOOLEAN *done); +export void OPM_InitOptions (void); +export INT16 OPM_Integer (INT64 n); +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len); +export void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +static void OPM_LogErrMsg (INT16 n); +export void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +export void OPM_LogW (CHAR ch); +export void OPM_LogWLn (void); +export void OPM_LogWNum (INT64 i, INT64 len); +export void OPM_LogWStr (CHAR *s, ADDRESS s__len); +export INT32 OPM_Longint (INT64 n); +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len); +export void OPM_Mark (INT16 n, INT32 pos); +export void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +export void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +export void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +export BOOLEAN OPM_OpenPar (void); +export void OPM_RegisterNewSym (void); +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len); +static void OPM_ShowLine (INT64 pos); +export INT64 OPM_SignedMaximum (INT32 bytecount); +export INT64 OPM_SignedMinimum (INT32 bytecount); +export void OPM_StoreComment (CHAR *text, ADDRESS text__len); +export void OPM_SymRCh (CHAR *ch); +export INT32 OPM_SymRInt (void); +export INT64 OPM_SymRInt64 (void); +export void OPM_SymRLReal (LONGREAL *lr); +export void OPM_SymRReal (REAL *r); +export void OPM_SymRSet (UINT64 *s); +export void OPM_SymWCh (CHAR ch); +export void OPM_SymWInt (INT64 i); +export void OPM_SymWLReal (LONGREAL lr); +export void OPM_SymWReal (REAL r); +export void OPM_SymWSet (UINT64 s); +export void OPM_Write (CHAR ch); +export void OPM_WriteHex (INT64 i); +export void OPM_WriteInt (INT64 i); +export void OPM_WriteLn (void); +export void OPM_WriteReal (LONGREAL r, CHAR suffx); +export void OPM_WriteString (CHAR *s, ADDRESS s__len); +export void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +export BOOLEAN OPM_eofSF (void); +export void OPM_err (INT16 n); + +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s + +void OPM_LogW (CHAR ch) +{ + Out_Char(ch); +} + +void OPM_LogWStr (CHAR *s, ADDRESS s__len) +{ + __DUP(s, s__len, CHAR); + Out_String(s, s__len); + __DEL(s); +} + +void OPM_LogWNum (INT64 i, INT64 len) +{ + Out_Int(i, len); +} + +void OPM_LogWLn (void) +{ + Out_Ln(); +} + +void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len) +{ + __DUP(vt100code, vt100code__len, CHAR); + if ((Out_IsConsole && !__IN(16, OPM_Options, 32))) { + VT100_SetAttr(vt100code, vt100code__len); + } + __DEL(vt100code); +} + +void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len) +{ + __DUP(modname, modname__len, CHAR); + OPM_LogWStr((CHAR*)"Compiling ", 11); + OPM_LogWStr(modname, modname__len); + if (__IN(18, OPM_Options, 32)) { + OPM_LogWStr((CHAR*)", s:", 5); + OPM_LogWNum(__ASHL(OPM_ShortintSize, 3), 1); + OPM_LogWStr((CHAR*)" i:", 4); + OPM_LogWNum(__ASHL(OPM_IntegerSize, 3), 1); + OPM_LogWStr((CHAR*)" l:", 4); + OPM_LogWNum(__ASHL(OPM_LongintSize, 3), 1); + OPM_LogWStr((CHAR*)" adr:", 6); + OPM_LogWNum(__ASHL(OPM_AddressSize, 3), 1); + OPM_LogWStr((CHAR*)" algn:", 7); + OPM_LogWNum(__ASHL(OPM_Alignment, 3), 1); + } + OPM_LogW('.'); + __DEL(modname); +} + +void OPM_StoreComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_currentComment[__X(i, 256)] = text[__X(i, text__len)]; + i += 1; + } + OPM_currentComment[__X(i, 256)] = 0x00; + OPM_hasComment = 1; + __DEL(text); +} + +void OPM_GetComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + if (OPM_hasComment) { + i = 0; + while ((((i < text__len && i < 256)) && OPM_currentComment[__X(i, 256)] != 0x00)) { + text[__X(i, text__len)] = OPM_currentComment[__X(i, 256)]; + i += 1; + } + text[__X(i, text__len)] = 0x00; + OPM_hasComment = 0; + } else { + text[0] = 0x00; + } +} + +INT64 OPM_SignedMaximum (INT32 bytecount) +{ + INT64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + return result - 1; +} + +INT64 OPM_SignedMinimum (INT32 bytecount) +{ + return -OPM_SignedMaximum(bytecount) - 1; +} + +INT32 OPM_Longint (INT64 n) +{ + return __VAL(INT32, n); +} + +INT16 OPM_Integer (INT64 n) +{ + return __VAL(INT16, n); +} + +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 1; + while (s[__X(i, s__len)] != 0x00) { + switch (s[__X(i, s__len)]) { + case 'p': + OPM_Options = OPM_Options ^ 0x20; + break; + case 'a': + OPM_Options = OPM_Options ^ 0x80; + break; + case 'r': + OPM_Options = OPM_Options ^ 0x04; + break; + case 't': + OPM_Options = OPM_Options ^ 0x08; + break; + case 'x': + OPM_Options = OPM_Options ^ 0x01; + break; + case 'e': + OPM_Options = OPM_Options ^ 0x0200; + break; + case 's': + OPM_Options = OPM_Options ^ 0x10; + break; + case 'F': + OPM_Options = OPM_Options ^ 0x020000; + break; + case 'm': + OPM_Options = OPM_Options ^ 0x0400; + break; + case 'M': + OPM_Options = OPM_Options ^ 0x8000; + break; + case 'S': + OPM_Options = OPM_Options ^ 0x2000; + break; + case 'c': + OPM_Options = OPM_Options ^ 0x4000; + break; + case 'f': + OPM_Options = OPM_Options ^ 0x010000; + break; + case 'V': + OPM_Options = OPM_Options ^ 0x040000; + break; + case 'O': + if (i + 1 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); + OPM_LogWLn(); + } else { + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); + } + i += 1; + } + break; + case 'A': + if (i + 2 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-M option requires two following digits.", 41); + OPM_LogWLn(); + } else { + OPM_AddressSize = (INT16)s[__X(i + 1, s__len)] - 48; + OPM_Alignment = (INT16)s[__X(i + 2, s__len)] - 48; + i += 2; + } + break; + default: + OPM_LogWStr((CHAR*)" warning: option ", 19); + OPM_LogW('-'); + OPM_LogW(s[__X(i, s__len)]); + OPM_LogWStr((CHAR*)" ignored", 9); + OPM_LogWLn(); + break; + } + i += 1; + } + __DEL(s); +} + +BOOLEAN OPM_OpenPar (void) +{ + CHAR s[256]; + if (Modules_ArgCount == 1) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Oberon-2 compiler v", 20); + OPM_LogWStr(Configuration_versionLong, 76); + OPM_LogW('.'); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Based on Ofront by J. Templ and Software Templ OEG.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Further development by Norayr Chilingarian, David Brown and others.", 68); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Loaded from ", 13); + OPM_LogWStr(Modules_BinaryDir, 1024); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Usage:", 7); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWStr((CHAR*)"voc", 4); + OPM_LogWStr((CHAR*)" options {files {options}}.", 28); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options:", 9); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Run time safety", 18); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -p Initialise pointers to NIL. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -a Halt on assertion failures. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -r Halt on range check failures.", 39); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -t Halt on type guard failure. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -x Halt on index out of range. On by default.", 52); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Symbol file management", 25); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -e Allow extension of old symbol file.", 45); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -s Allow generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -F Force generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" C compiler and linker control", 32); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -m This module is main. Link dynamically.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -M This module is main. Link statically.", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -S Don't call C compiler", 31); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -c Don't link.", 21); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Miscellaneous", 16); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -f Disable VT100 control characters in status output.", 60); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -V Display compiler debugging messages.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Size model for elementary types (default O2)", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Target machine address size and alignment (default is that of the running compiler binary)", 93); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86).", 79); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm).", 97); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms).", 71); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"All options are off by default, except where noted above.", 58); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Initial options specify defaults for all files.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options following a filename are specific to that file.", 56); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Repeating an option toggles its value.", 39); + OPM_LogWLn(); + return 0; + } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; + OPM_S = 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __MOVE(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; + return 1; + } + __RETCHK; +} + +void OPM_InitOptions (void) +{ + CHAR s[256]; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __MOVE(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); + } + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 4; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + __MOVE(OPM_InstallDir, OPM_ResourceDir, 1024); + if (OPM_ResourceDir[0] != 0x00) { + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + } + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); +} + +void OPM_Init (BOOLEAN *done) +{ + Texts_Text T = NIL; + INT32 beg, end, time; + CHAR s[256]; + *done = 0; + OPM_curpos = 0; + if (OPM_S >= Modules_ArgCount) { + return; + } + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + __NEW(T, Texts_TextDesc); + Texts_Open(T, s, 256); + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" ", 3); + __COPY(s, OPM_SourceFileName, 256); + if (T->len == 0) { + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" not found.", 12); + OPM_LogWLn(); + } else { + Texts_OpenReader(&OPM_inR, Texts_Reader__typ, T, 0); + *done = 1; + } + OPM_S += 1; + OPM_level = 0; + OPM_noerr = 1; + OPM_errpos = OPM_curpos; + OPM_lasterrpos = OPM_curpos - 10; + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; +} + +void OPM_Get (CHAR *ch) +{ + OPM_curpos = Texts_Pos(&OPM_inR, Texts_Reader__typ); + Texts_Read(&OPM_inR, Texts_Reader__typ, &*ch); + if ((*ch < 0x09 && !OPM_inR.eot)) { + *ch = ' '; + } +} + +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len) +{ + INT16 i, j; + CHAR ch; + __DUP(ext, ext__len, CHAR); + i = 0; + for (;;) { + ch = name[__X(i, name__len)]; + if (ch == 0x00) { + break; + } + FName[__X(i, FName__len)] = ch; + i += 1; + } + j = 0; + do { + ch = ext[__X(j, ext__len)]; + FName[__X(i, FName__len)] = ch; + i += 1; + j += 1; + } while (!(ch == 0x00)); + __DEL(ext); +} + +static void OPM_LogErrMsg (INT16 n) +{ + INT16 l; + Texts_Scanner S; + CHAR c; + if (n >= 0) { + OPM_LogVT100((CHAR*)"31m", 4); + OPM_LogWStr((CHAR*)" err ", 7); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + OPM_LogVT100((CHAR*)"35m", 4); + OPM_LogWStr((CHAR*)" warning ", 11); + n = -n; + OPM_LogVT100((CHAR*)"0m", 3); + } + OPM_LogWNum(n, 1); + OPM_LogWStr((CHAR*)" ", 3); + if (OPM_Errors == NIL) { + __NEW(OPM_Errors, Texts_TextDesc); + Texts_Open(OPM_Errors, (CHAR*)"Errors.Txt", 11); + } + Texts_OpenScanner(&S, Texts_Scanner__typ, OPM_Errors, 0); + do { + l = S.line; + Texts_Scan(&S, Texts_Scanner__typ); + } while (!((((l != S.line && S.class == 3)) && S.i == n) || S.eot)); + if (!S.eot) { + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + while ((!S.eot && c >= ' ')) { + Out_Char(c); + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + } + } +} + +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos) +{ + CHAR ch, cheol; + if (pos < (INT64)OPM_ErrorLineStartPos) { + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; + } + if (pos < (INT64)OPM_ErrorLineLimitPos) { + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); + return; + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineLimitPos); + Files_Read(&*r, r__typ, (void*)&ch); + while (((INT64)OPM_ErrorLineLimitPos < pos && !(*r).eof)) { + OPM_ErrorLineStartPos = OPM_ErrorLineLimitPos; + OPM_ErrorLineNumber += 1; + while ((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) { + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + } + cheol = ch; + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + if ((cheol == 0x0d && ch == 0x0a)) { + OPM_ErrorLineLimitPos += 1; + Files_Read(&*r, r__typ, (void*)&ch); + } + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); +} + +static void OPM_ShowLine (INT64 pos) +{ + Files_File f = NIL; + Files_Rider r; + CHAR line[1023]; + INT16 i; + CHAR ch; + f = Files_Old(OPM_SourceFileName, 256); + OPM_FindLine(f, &r, Files_Rider__typ, pos); + i = 0; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + while ((((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) && i < 1022)) { + line[__X(i, 1023)] = ch; + i += 1; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + } + line[__X(i, 1023)] = 0x00; + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWNum(OPM_ErrorLineNumber, 4); + OPM_LogWStr((CHAR*)": ", 3); + OPM_LogWStr(line, 1023); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 7); + if (pos >= (INT64)OPM_ErrorLineLimitPos) { + pos = OPM_ErrorLineLimitPos - 1; + } + i = __SHORTF(OPM_Longint(pos - (INT64)OPM_ErrorLineStartPos), 32768); + while (i > 0) { + OPM_LogW(' '); + i -= 1; + } + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogW('^'); + OPM_LogVT100((CHAR*)"0m", 3); +} + +void OPM_Mark (INT16 n, INT32 pos) +{ + if (pos == -1) { + pos = 0; + } + if (n >= 0) { + OPM_noerr = 0; + if (pos < OPM_lasterrpos || OPM_lasterrpos + 9 < pos) { + OPM_lasterrpos = pos; + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + if (n < 249) { + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + OPM_LogErrMsg(n); + } else if (n == 255) { + OPM_LogWStr((CHAR*)"pos", 4); + OPM_LogWNum(pos, 6); + OPM_LogWStr((CHAR*)" pc ", 6); + OPM_LogWNum(OPM_breakpc, 1); + } else if (n == 254) { + OPM_LogWStr((CHAR*)"pc not found", 13); + } else { + OPM_LogWStr(OPM_objname, 64); + if (n == 253) { + OPM_LogWStr((CHAR*)" is new, compile with option e", 31); + } else if (n == 252) { + OPM_LogWStr((CHAR*)" is redefined, compile with option s", 37); + } else if (n == 251) { + OPM_LogWStr((CHAR*)" is redefined (private part only), compile with option s", 57); + } else if (n == 250) { + OPM_LogWStr((CHAR*)" is no longer visible, compile with option s", 45); + } else if (n == 249) { + OPM_LogWStr((CHAR*)" is not consistently imported, recompile imports", 49); + } + } + } + } else { + if (pos >= 0) { + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + } + OPM_LogErrMsg(n); + if (pos < 0) { + OPM_LogWLn(); + } + } +} + +void OPM_err (INT16 n) +{ + OPM_Mark(n, OPM_errpos); +} + +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len) +{ + INT16 i; + INT32 l; + __ASSERT(__MASK(bytes__len, -4) == 0, 0); + i = 0; + while (i < bytes__len) { + __GET((ADDRESS)&bytes[__X(i, bytes__len)], l, INT32); + *fp = __ROTL((INT32)((UINT32)*fp ^ (UINT32)l), 1, 32); + i += 4; + } +} + +void OPM_FPrint (INT32 *fp, INT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintSet (INT32 *fp, UINT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintReal (INT32 *fp, REAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 4); +} + +void OPM_FPrintLReal (INT32 *fp, LONGREAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_SymRCh (CHAR *ch) +{ + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); +} + +INT32 OPM_SymRInt (void) +{ + INT32 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 4); + return k; +} + +INT64 OPM_SymRInt64 (void) +{ + INT64 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 8); + return k; +} + +void OPM_SymRSet (UINT64 *s) +{ + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&*s, 8); +} + +void OPM_SymRReal (REAL *r) +{ + Files_ReadReal(&OPM_oldSF, Files_Rider__typ, &*r); +} + +void OPM_SymRLReal (LONGREAL *lr) +{ + Files_ReadLReal(&OPM_oldSF, Files_Rider__typ, &*lr); +} + +void OPM_CloseOldSym (void) +{ + Files_Close(Files_Base(&OPM_oldSF, Files_Rider__typ)); +} + +void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done) +{ + CHAR tag, ver; + OPM_FileName fileName; + INT16 res; + OPM_oldSFile = NIL; + *done = 0; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_oldSFile = Files_Old(fileName, 32); + *done = OPM_oldSFile != NIL; + if (*done) { + Files_Set(&OPM_oldSF, Files_Rider__typ, OPM_oldSFile, 0); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&tag); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&ver); + if (tag != 0xf7 || ver != 0x84) { + if (!__IN(4, OPM_Options, 32)) { + OPM_err(-306); + } + OPM_CloseOldSym(); + *done = 0; + } + } +} + +BOOLEAN OPM_eofSF (void) +{ + return OPM_oldSF.eof; +} + +void OPM_SymWCh (CHAR ch) +{ + Files_Write(&OPM_newSF, Files_Rider__typ, ch); +} + +void OPM_SymWInt (INT64 i) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, i); +} + +void OPM_SymWSet (UINT64 s) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, (INT64)s); +} + +void OPM_SymWReal (REAL r) +{ + Files_WriteReal(&OPM_newSF, Files_Rider__typ, r); +} + +void OPM_SymWLReal (LONGREAL lr) +{ + Files_WriteLReal(&OPM_newSF, Files_Rider__typ, lr); +} + +void OPM_RegisterNewSym (void) +{ + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { + Files_Register(OPM_newSFile); + } +} + +void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".sym", 5); + Files_Delete(fn, 32, &res); +} + +void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".o", 3); + Files_Delete(fn, 32, &res); +} + +void OPM_NewSym (CHAR *modName, ADDRESS modName__len) +{ + OPM_FileName fileName; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_newSFile = Files_New(fileName, 32); + if (OPM_newSFile != NIL) { + Files_Set(&OPM_newSF, Files_Rider__typ, OPM_newSFile, 0); + Files_Write(&OPM_newSF, Files_Rider__typ, 0xf7); + Files_Write(&OPM_newSF, Files_Rider__typ, 0x84); + } else { + OPM_err(153); + } +} + +void OPM_Write (CHAR ch) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, ch); +} + +void OPM_WriteString (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteStringVar (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteHex (INT64 i) +{ + CHAR s[3]; + INT32 digit; + digit = __ASHR(__SHORT(i, 2147483648LL), 4); + if (digit < 10) { + s[0] = __CHR(48 + digit); + } else { + s[0] = __CHR(87 + digit); + } + digit = __MASK(__SHORT(i, 2147483648LL), -16); + if (digit < 10) { + s[1] = __CHR(48 + digit); + } else { + s[1] = __CHR(87 + digit); + } + s[2] = 0x00; + OPM_WriteString(s, 3); +} + +void OPM_WriteInt (INT64 i) +{ + CHAR s[26]; + INT64 i1, k; + if ((i == OPM_SignedMinimum(2) || i == OPM_SignedMinimum(4)) || i == OPM_SignedMinimum(8)) { + OPM_Write('('); + OPM_WriteInt(i + 1); + OPM_WriteString((CHAR*)"-1)", 4); + } else { + i1 = __ABS(i); + if (i1 <= 2147483647) { + k = 0; + } else { + __MOVE("LL", s, 3); + k = 2; + } + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + while (i1 > 0) { + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + } + if (i < 0) { + s[__X(k, 26)] = '-'; + k += 1; + } + while (k > 0) { + k -= 1; + OPM_Write(s[__X(k, 26)]); + } + } +} + +void OPM_WriteReal (LONGREAL r, CHAR suffx) +{ + Texts_Writer W; + Texts_Text T = NIL; + Texts_Reader R; + CHAR s[32]; + CHAR ch; + INT16 i; + if ((((r < OPM_SignedMaximum(OPM_LongintSize) && r > OPM_SignedMinimum(OPM_LongintSize))) && r == (__SHORT(__ENTIER(r), 2147483648LL)))) { + if (suffx == 'f') { + OPM_WriteString((CHAR*)"(REAL)", 7); + } else { + OPM_WriteString((CHAR*)"(LONGREAL)", 11); + } + OPM_WriteInt(__SHORT(__ENTIER(r), 2147483648LL)); + } else { + Texts_OpenWriter(&W, Texts_Writer__typ); + if (suffx == 'f') { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 16); + } else { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 23); + } + __NEW(T, Texts_TextDesc); + Texts_Open(T, (CHAR*)"", 1); + Texts_Append(T, W.buf); + Texts_OpenReader(&R, Texts_Reader__typ, T, 0); + i = 0; + Texts_Read(&R, Texts_Reader__typ, &ch); + while (ch != 0x00) { + s[__X(i, 32)] = ch; + i += 1; + Texts_Read(&R, Texts_Reader__typ, &ch); + } + s[__X(i, 32)] = 0x00; + i = 0; + ch = s[0]; + while ((ch != 'D' && ch != 0x00)) { + i += 1; + ch = s[__X(i, 32)]; + } + if (ch == 'D') { + s[__X(i, 32)] = 'e'; + } + OPM_WriteString(s, 32); + } +} + +void OPM_WriteLn (void) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, 0x0a); +} + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F) +{ + Files_Rider R1; + CHAR buffer[4096]; + if (F != NIL) { + Files_Set(&R1, Files_Rider__typ, F, 0); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + while (4096 - R1.res > 0) { + Files_WriteBytes(&*R, R__typ, (void*)buffer, 4096, 4096 - R1.res); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + } + } +} + +void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len) +{ + OPM_FileName FName; + __COPY(moduleName, OPM_modName, 32); + OPM_HFile = Files_New((CHAR*)"", 1); + if (OPM_HFile != NIL) { + Files_Set(&OPM_R[0], Files_Rider__typ, OPM_HFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".c", 3); + OPM_BFile = Files_New(FName, 32); + if (OPM_BFile != NIL) { + Files_Set(&OPM_R[1], Files_Rider__typ, OPM_BFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".h", 3); + OPM_HIFile = Files_New(FName, 32); + if (OPM_HIFile != NIL) { + Files_Set(&OPM_R[2], Files_Rider__typ, OPM_HIFile, 0); + } else { + OPM_err(153); + } +} + +void OPM_CloseFiles (void) +{ + OPM_FileName FName; + INT16 res; + if (OPM_noerr) { + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWNum(Files_Pos(&OPM_R[1], Files_Rider__typ), 0); + OPM_LogWStr((CHAR*)" chars.", 8); + } + if (OPM_noerr) { + if (__STRCMP(OPM_modName, "SYSTEM") == 0) { + if (!__IN(10, OPM_Options, 32)) { + Files_Register(OPM_BFile); + } + } else if (!__IN(10, OPM_Options, 32)) { + OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); + Files_Register(OPM_HIFile); + Files_Register(OPM_BFile); + } else { + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".h", 3); + Files_Delete(FName, 32, &res); + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".sym", 5); + Files_Delete(FName, 32, &res); + Files_Register(OPM_BFile); + } + } + OPM_HFile = NIL; + OPM_BFile = NIL; + OPM_HIFile = NIL; + OPM_newSFile = NIL; + OPM_oldSFile = NIL; + Files_Set(&OPM_R[0], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[1], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[2], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_newSF, Files_Rider__typ, NIL, 0); + Files_Set(&OPM_oldSF, Files_Rider__typ, NIL, 0); +} + +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len) +{ + CHAR testpath[4096]; + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/lib/lib", 9, (void*)testpath, 4096); + Strings_Append((CHAR*)"voc", 4, (void*)testpath, 4096); + Strings_Append((CHAR*)"-O2.a", 6, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/include/Oberon.h", 20, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/sym/Files.sym", 17, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __DEL(s); + return 1; +} + +static void OPM_FindInstallDir (void) +{ + INT16 i; + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + Strings_Append((CHAR*)"/", 2, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)"voc", 4, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)".d", 3, (void*)OPM_InstallDir, 1024); + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + i = Strings_Length(OPM_InstallDir, 1024); + while ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] != '/')) { + i -= 1; + } + if ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] == '/')) { + OPM_InstallDir[__X(i - 1, 1024)] = 0x00; + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + } + __COPY("", OPM_InstallDir, 1024); +} + +static void EnumPtrs(void (*P)(void*)) +{ + __ENUMR(&OPM_inR, Texts_Reader__typ, 48, 1, P); + P(OPM_Log); + P(OPM_Errors); + __ENUMR(&OPM_oldSF, Files_Rider__typ, 20, 1, P); + __ENUMR(&OPM_newSF, Files_Rider__typ, 20, 1, P); + __ENUMR(OPM_R, Files_Rider__typ, 20, 3, P); + P(OPM_oldSFile); + P(OPM_newSFile); + P(OPM_HFile); + P(OPM_BFile); + P(OPM_HIFile); +} + + +export void *OPM__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(Texts); + __MODULE_IMPORT(VT100); + __REGMOD("OPM", EnumPtrs); + __REGCMD("CloseFiles", OPM_CloseFiles); + __REGCMD("CloseOldSym", OPM_CloseOldSym); + __REGCMD("InitOptions", OPM_InitOptions); + __REGCMD("LogWLn", OPM_LogWLn); + __REGCMD("RegisterNewSym", OPM_RegisterNewSym); + __REGCMD("WriteLn", OPM_WriteLn); +/* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; + OPM_FindInstallDir(); + OPM_hasComment = 0; + OPM_currentComment[0] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPM.h b/bootstrap/unix-44/OPM.h new file mode 100644 index 00000000..64c15a28 --- /dev/null +++ b/bootstrap/unix-44/OPM.h @@ -0,0 +1,76 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPM__h +#define OPM__h + +#include "SYSTEM.h" + + +import CHAR OPM_Model[10]; +import INT16 OPM_AddressSize, OPM_Alignment; +import UINT32 OPM_GlobalOptions, OPM_Options; +import INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +import INT64 OPM_MaxIndex; +import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +import BOOLEAN OPM_noerr; +import INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +import INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +import CHAR OPM_modName[32]; +import CHAR OPM_objname[64]; +import CHAR OPM_InstallDir[1024]; +import CHAR OPM_ResourceDir[1024]; + + +import void OPM_CloseFiles (void); +import void OPM_CloseOldSym (void); +import void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +import void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +import void OPM_FPrint (INT32 *fp, INT64 val); +import void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +import void OPM_FPrintReal (INT32 *fp, REAL val); +import void OPM_FPrintSet (INT32 *fp, UINT64 val); +import void OPM_Get (CHAR *ch); +import void OPM_GetComment (CHAR *text, ADDRESS text__len); +import void OPM_Init (BOOLEAN *done); +import void OPM_InitOptions (void); +import INT16 OPM_Integer (INT64 n); +import void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +import void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +import void OPM_LogW (CHAR ch); +import void OPM_LogWLn (void); +import void OPM_LogWNum (INT64 i, INT64 len); +import void OPM_LogWStr (CHAR *s, ADDRESS s__len); +import INT32 OPM_Longint (INT64 n); +import void OPM_Mark (INT16 n, INT32 pos); +import void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +import void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +import void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +import BOOLEAN OPM_OpenPar (void); +import void OPM_RegisterNewSym (void); +import INT64 OPM_SignedMaximum (INT32 bytecount); +import INT64 OPM_SignedMinimum (INT32 bytecount); +import void OPM_StoreComment (CHAR *text, ADDRESS text__len); +import void OPM_SymRCh (CHAR *ch); +import INT32 OPM_SymRInt (void); +import INT64 OPM_SymRInt64 (void); +import void OPM_SymRLReal (LONGREAL *lr); +import void OPM_SymRReal (REAL *r); +import void OPM_SymRSet (UINT64 *s); +import void OPM_SymWCh (CHAR ch); +import void OPM_SymWInt (INT64 i); +import void OPM_SymWLReal (LONGREAL lr); +import void OPM_SymWReal (REAL r); +import void OPM_SymWSet (UINT64 s); +import void OPM_Write (CHAR ch); +import void OPM_WriteHex (INT64 i); +import void OPM_WriteInt (INT64 i); +import void OPM_WriteLn (void); +import void OPM_WriteReal (LONGREAL r, CHAR suffx); +import void OPM_WriteString (CHAR *s, ADDRESS s__len); +import void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +import BOOLEAN OPM_eofSF (void); +import void OPM_err (INT16 n); +import void *OPM__init(void); + + +#endif // OPM diff --git a/bootstrap/unix-44/OPP.c b/bootstrap/unix-44/OPP.c new file mode 100644 index 00000000..ad4a370a --- /dev/null +++ b/bootstrap/unix-44/OPP.c @@ -0,0 +1,1881 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPB.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +struct OPP__1 { + INT32 low, high; +}; + +typedef + struct OPP__1 OPP_CaseTable[128]; + + +static INT8 OPP_sym, OPP_level; +static INT16 OPP_LoopLevel; +static OPT_Node OPP_TDinit, OPP_lastTDinit; +static INT16 OPP_nofFwdPtr; +static OPT_Struct OPP_FwdPtr[64]; + +export ADDRESS *OPP__1__typ; + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar); +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq); +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab); +static void OPP_CheckMark (INT8 *vis); +static void OPP_CheckSym (INT16 s); +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_); +static void OPP_ConstExpression (OPT_Node *x); +static void OPP_Element (OPT_Node *x); +static void OPP_Expression (OPT_Node *x); +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b); +static void OPP_Factor (OPT_Node *x); +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp); +export void OPP_Module (OPT_Node *prog, UINT32 opt); +static void OPP_PointerType (OPT_Struct *typ); +static void OPP_ProcedureDeclaration (OPT_Node *x); +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec); +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Sets (OPT_Node *x); +static void OPP_SimpleExpression (OPT_Node *x); +static void OPP_StandProcCall (OPT_Node *x); +static void OPP_StatSeq (OPT_Node *stat); +static void OPP_Term (OPT_Node *x); +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_err (INT16 n); +static void OPP_qualident (OPT_Object *id); +static void OPP_selector (OPT_Node *x); + + +static void OPP_err (INT16 n) +{ + OPM_err(n); +} + +static void OPP_CheckSym (INT16 s) +{ + if ((INT16)OPP_sym == s) { + OPS_Get(&OPP_sym); + } else { + OPM_err(s); + } +} + +static void OPP_qualident (OPT_Object *id) +{ + OPT_Object obj = NIL; + INT8 lev; + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if ((((OPP_sym == 18 && obj != NIL)) && obj->mode == 11)) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPT_FindImport(obj, &obj); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + obj = NIL; + } + } + if (obj == NIL) { + OPP_err(0); + obj = OPT_NewObj(); + obj->mode = 1; + obj->typ = OPT_undftyp; + obj->adr = 0; + } else { + lev = obj->mnolev; + if ((__IN(obj->mode, 0x06, 32) && lev != OPP_level)) { + obj->leaf = 0; + if (lev > 0) { + OPB_StaticLink(OPP_level - lev); + } + } + } + *id = obj; +} + +static void OPP_ConstExpression (OPT_Node *x) +{ + OPP_Expression(&*x); + if ((*x)->class != 7) { + OPP_err(50); + *x = OPB_NewIntConst(1); + } +} + +static void OPP_CheckMark (INT8 *vis) +{ + OPS_Get(&OPP_sym); + if (OPP_sym == 1 || OPP_sym == 7) { + if (OPP_level > 0) { + OPP_err(47); + } + if (OPP_sym == 1) { + *vis = 1; + } else { + *vis = 2; + } + OPS_Get(&OPP_sym); + } else { + *vis = 0; + } +} + +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_) +{ + OPT_Node x = NIL; + INT64 sf; + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + if (!OPT_SYSimported) { + OPP_err(135); + } + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + sf = x->conval->intval; + if (sf < 0 || sf > 1) { + OPP_err(220); + sf = 0; + } + } else { + OPP_err(51); + sf = 0; + } + *sysflag = OPM_Integer(sf); + OPP_CheckSym(23); + } else { + *sysflag = default_; + } +} + +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object fld = NIL, first = NIL, last = NIL, base = NIL; + OPT_Struct ftyp = NIL; + INT16 sysflag; + *typ = OPT_NewStr(13, 4); + (*typ)->BaseTyp = NIL; + OPP_CheckSysFlag(&sysflag, -1); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&base); + if ((base->mode == 5 && base->typ->comp == 4)) { + if (base->typ == *banned) { + OPP_err(58); + } else { + base->typ->pvused = 1; + (*typ)->BaseTyp = base->typ; + (*typ)->extlev = base->typ->extlev + 1; + (*typ)->sysflag = base->typ->sysflag; + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } + if (sysflag >= 0) { + (*typ)->sysflag = sysflag; + } + OPT_OpenScope(0, NIL); + first = NIL; + last = NIL; + for (;;) { + if (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + if ((*typ)->BaseTyp != NIL) { + OPT_FindField(OPS_name, (*typ)->BaseTyp, &fld); + if (fld != NIL) { + OPP_err(1); + } + } + OPT_Insert(OPS_name, &fld); + OPP_CheckMark(&fld->vis); + fld->mode = 4; + fld->link = NIL; + fld->typ = OPT_undftyp; + if (first == NIL) { + first = fld; + } + if (last == NIL) { + (*typ)->link = fld; + } else { + last->link = fld; + } + last = fld; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&ftyp, &*banned); + ftyp->pvused = 1; + if (ftyp->comp == 3) { + ftyp = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = ftyp; + first = first->link; + } + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + OPT_CloseScope(); +} + +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Node x = NIL; + INT64 n; + INT16 sysflag; + OPP_CheckSysFlag(&sysflag, 0); + if (OPP_sym == 25) { + *typ = OPT_NewStr(13, 3); + (*typ)->mno = 0; + (*typ)->sysflag = sysflag; + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + } else { + *typ = OPT_NewStr(13, 2); + (*typ)->sysflag = sysflag; + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + n = x->conval->intval; + if (n <= 0 || n > OPM_MaxIndex) { + OPP_err(63); + n = 1; + } + } else { + OPP_err(51); + n = 1; + } + (*typ)->n = OPM_Longint(n); + if (OPP_sym == 25) { + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + } else if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + if (OPP_sym != 25) { + OPP_ArrayType(&(*typ)->BaseTyp, &*banned); + } + } else { + OPP_err(35); + } + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(88); + } + } +} + +static void OPP_PointerType (OPT_Struct *typ) +{ + OPT_Object id = NIL; + *typ = OPT_NewStr(11, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + OPP_CheckSym(28); + if (OPP_sym == 38) { + OPT_Find(&id); + if (id == NIL) { + if (OPP_nofFwdPtr < 64) { + OPP_FwdPtr[__X(OPP_nofFwdPtr, 64)] = *typ; + OPP_nofFwdPtr += 1; + } else { + OPP_err(224); + } + (*typ)->link = OPT_NewObj(); + __COPY(OPS_name, (*typ)->link->name, 256); + (*typ)->BaseTyp = OPT_undftyp; + OPS_Get(&OPP_sym); + } else { + OPP_qualident(&id); + if (id->mode == 5) { + if (__IN(id->typ->comp, 0x1c, 32)) { + (*typ)->BaseTyp = id->typ; + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(52); + } + } + } else { + OPP_Type(&(*typ)->BaseTyp, &OPT_notyp); + if (!__IN((*typ)->BaseTyp->comp, 0x1c, 32)) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } +} + +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp) +{ + INT8 mode; + OPT_Object par = NIL, first = NIL, last = NIL, res = NIL; + OPT_Struct typ = NIL; + first = NIL; + last = *firstPar; + if (OPP_sym == 38 || OPP_sym == 60) { + for (;;) { + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + mode = 2; + } else { + mode = 1; + } + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &par); + OPS_Get(&OPP_sym); + par->mode = mode; + par->link = NIL; + if (first == NIL) { + first = par; + } + if (*firstPar == NIL) { + *firstPar = par; + } else { + last->link = par; + } + last = par; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else if (OPP_sym == 60) { + OPP_err(19); + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + if (((typ->comp == 2 || typ->comp == 4) && typ->strobj == NIL)) { + OPP_err(-309); + } + if (mode == 1) { + typ->pvused = 1; + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + } + OPP_CheckSym(22); + if (OPP_sym == 20) { + OPS_Get(&OPP_sym); + *resTyp = OPT_undftyp; + if (OPP_sym == 38) { + OPP_qualident(&res); + if (res->mode == 5) { + if (res->typ->form < 13) { + *resTyp = res->typ; + } else { + OPP_err(54); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + *resTyp = OPT_notyp; + } +} + +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object id = NIL; + *typ = OPT_undftyp; + if (OPP_sym < 30) { + OPP_err(12); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + if (id->mode == 5) { + if (id->typ == *banned) { + OPP_err(58); + } else { + *typ = id->typ; + } + } else { + OPP_err(52); + } + } else if (OPP_sym == 54) { + OPS_Get(&OPP_sym); + OPP_ArrayType(&*typ, &*banned); + } else if (OPP_sym == 55) { + OPS_Get(&OPP_sym); + OPP_RecordType(&*typ, &*banned); + OPB_Inittd(&OPP_TDinit, &OPP_lastTDinit, *typ); + OPP_CheckSym(41); + } else if (OPP_sym == 56) { + OPS_Get(&OPP_sym); + OPP_PointerType(&*typ); + } else if (OPP_sym == 61) { + OPS_Get(&OPP_sym); + *typ = OPT_NewStr(12, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPT_OpenScope(OPP_level, NIL); + OPP_FormalParameters(&(*typ)->link, &(*typ)->BaseTyp); + OPT_CloseScope(); + } else { + (*typ)->BaseTyp = OPT_notyp; + (*typ)->link = NIL; + } + } else { + OPP_err(12); + } + for (;;) { + if (((OPP_sym >= 39 && OPP_sym <= 42) || OPP_sym == 22) || OPP_sym == 64) { + break; + } + OPP_err(15); + if (OPP_sym == 38) { + break; + } + OPS_Get(&OPP_sym); + } +} + +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned) +{ + OPP_TypeDecl(&*typ, &*banned); + if (((((*typ)->form == 11 && (*typ)->BaseTyp == OPT_undftyp)) && (*typ)->strobj == NIL)) { + OPP_err(0); + } +} + +static void OPP_selector (OPT_Node *x) +{ + OPT_Object obj = NIL, proc = NIL; + OPT_Node y = NIL; + OPT_Struct typ = NIL; + OPS_Name name; + for (;;) { + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + for (;;) { + if (((*x)->typ != NIL && (*x)->typ->form == 11)) { + OPB_DeRef(&*x); + } + OPP_Expression(&y); + OPB_Index(&*x, y); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(23); + } else if (OPP_sym == 18) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __MOVE(OPS_name, name, 256); + OPS_Get(&OPP_sym); + if ((*x)->typ != NIL) { + if ((*x)->typ->form == 11) { + OPB_DeRef(&*x); + } + if ((*x)->typ->comp == 4) { + OPT_FindField(name, (*x)->typ, &obj); + OPB_Field(&*x, obj); + if ((obj != NIL && obj->mode == 13)) { + if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + y = (*x)->left; + if (y->class == 3) { + y = y->left; + } + if (y->obj != NIL) { + proc = OPT_topScope; + while ((proc->link != NIL && proc->link->mode != 13)) { + proc = proc->left; + } + if (proc->link == NIL || proc->link->link != y->obj) { + OPP_err(75); + } + typ = y->obj->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField((*x)->obj->name, typ->BaseTyp, &proc); + if (proc != NIL) { + (*x)->subcl = 1; + } else { + OPP_err(74); + } + } else { + OPP_err(75); + } + } + if ((obj->typ != OPT_notyp && OPP_sym != 30)) { + OPP_err(30); + } + } + } else { + OPP_err(53); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + OPB_DeRef(&*x); + } else if ((((((OPP_sym == 30 && (*x)->class < 7)) && (*x)->typ->form != 12)) && ((*x)->obj == NIL || (*x)->obj->mode != 13))) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 1); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } else { + break; + } + } +} + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar) +{ + OPT_Node apar = NIL, last = NIL; + *aparlist = NIL; + last = NIL; + if (OPP_sym != 22) { + for (;;) { + OPP_Expression(&apar); + if (fpar != NIL) { + OPB_Param(apar, fpar); + OPB_Link(&*aparlist, &last, apar); + fpar = fpar->link; + } else { + OPP_err(64); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + } + if (fpar != NIL) { + OPP_err(65); + } +} + +static void OPP_StandProcCall (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 m; + INT16 n; + m = __SHORT(__SHORT((*x)->obj->adr, 32768), 128); + n = 0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym != 22) { + for (;;) { + if (n == 0) { + OPP_Expression(&*x); + OPB_StPar0(&*x, m); + n = 1; + } else if (n == 1) { + OPP_Expression(&y); + OPB_StPar1(&*x, y, m); + n = 2; + } else { + OPP_Expression(&y); + OPB_StParN(&*x, y, m, n); + n += 1; + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(22); + } else { + OPS_Get(&OPP_sym); + } + OPB_StFct(&*x, m, n); + } else { + OPP_err(30); + } + if ((OPP_level > 0 && (m == 1 || m == 30))) { + OPT_topScope->link->leaf = 0; + } +} + +static void OPP_Element (OPT_Node *x) +{ + OPT_Node y = NIL; + OPP_Expression(&*x); + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_SetRange(&*x, y); + } else { + OPB_SetElem(&*x); + } +} + +static void OPP_Sets (OPT_Node *x) +{ + OPT_Node y = NIL; + if (OPP_sym != 24) { + OPP_Element(&*x); + for (;;) { + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + OPP_Element(&y); + OPB_Op(6, &*x, y); + } + } else { + *x = OPB_EmptySet(); + } + OPP_CheckSym(24); +} + +static void OPP_Factor (OPT_Node *x) +{ + OPT_Object fpar = NIL, id = NIL; + OPT_Node apar = NIL; + if (OPP_sym < 30) { + OPP_err(13); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + *x = OPB_NewLeaf(id); + OPP_selector(&*x); + if (((*x)->class == 9 && (*x)->obj->mode == 8)) { + OPP_StandProcCall(&*x); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPB_PrepCall(&*x, &fpar); + OPP_ActualParameters(&apar, fpar); + OPB_Call(&*x, apar, fpar); + OPP_CheckSym(22); + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + } else if (OPP_sym == 35) { + switch (OPS_numtyp) { + case 1: + *x = OPB_NewIntConst(OPS_intval); + (*x)->typ = OPT_chartyp; + break; + case 2: + *x = OPB_NewIntConst(OPS_intval); + break; + case 3: + *x = OPB_NewRealConst(OPS_realval, OPT_realtyp); + break; + case 4: + *x = OPB_NewRealConst(OPS_lrlval, OPT_lrltyp); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPP.Factor, OPS.numtyp = ", 44); + OPM_LogWNum(OPS_numtyp, 0); + OPM_LogWLn(); + break; + } + OPS_Get(&OPP_sym); + } else if (OPP_sym == 37) { + *x = OPB_NewString(OPS_str, OPS_intval); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 36) { + *x = OPB_Nil(); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + OPP_err(30); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 32) { + OPS_Get(&OPP_sym); + OPP_Sets(&*x); + } else if (OPP_sym == 33) { + OPS_Get(&OPP_sym); + OPP_Factor(&*x); + OPB_MOp(33, &*x); + } else { + OPP_err(13); + OPS_Get(&OPP_sym); + *x = NIL; + } + if (*x == NIL) { + *x = OPB_NewIntConst(1); + (*x)->typ = OPT_undftyp; + } +} + +static void OPP_Term (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 mulop; + OPP_Factor(&*x); + while ((1 <= OPP_sym && OPP_sym <= 5)) { + mulop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Factor(&y); + OPB_Op(mulop, &*x, y); + } +} + +static void OPP_SimpleExpression (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 addop; + if (OPP_sym == 7) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(7, &*x); + } else if (OPP_sym == 6) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(6, &*x); + } else { + OPP_Term(&*x); + } + while ((6 <= OPP_sym && OPP_sym <= 8)) { + addop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Term(&y); + OPB_Op(addop, &*x, y); + } +} + +static void OPP_Expression (OPT_Node *x) +{ + OPT_Node y = NIL; + OPT_Object obj = NIL; + INT8 relation; + OPP_SimpleExpression(&*x); + if ((9 <= OPP_sym && OPP_sym <= 14)) { + relation = OPP_sym; + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_Op(relation, &*x, y); + } else if (OPP_sym == 15) { + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_In(&*x, y); + } else if (OPP_sym == 16) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 0); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } +} + +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec) +{ + OPT_Object obj = NIL; + *typ = OPT_undftyp; + *rec = NIL; + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + *mode = 2; + } else { + *mode = 1; + } + __MOVE(OPS_name, name, 256); + OPP_CheckSym(38); + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if (obj == NIL) { + OPP_err(0); + } else if (obj->mode != 5) { + OPP_err(72); + } else { + *typ = obj->typ; + *rec = *typ; + if ((*rec)->form == 11) { + *rec = (*rec)->BaseTyp; + } + if (!((((*mode == 1 && (*typ)->form == 11)) && (*rec)->comp == 4) || (*mode == 2 && (*typ)->comp == 4))) { + OPP_err(70); + *rec = NIL; + } + if ((*rec != NIL && (*rec)->mno != OPP_level)) { + OPP_err(72); + *rec = NIL; + } + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + if (*rec == NIL) { + *rec = OPT_NewStr(13, 4); + (*rec)->BaseTyp = NIL; + } +} + +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b) +{ + if ((b->form == 11 && x->form == 11)) { + b = b->BaseTyp; + x = x->BaseTyp; + } + if ((b->comp == 4 && x->comp == 4)) { + do { + x = x->BaseTyp; + } while (!(x == NIL || x == b)); + } + return x == b; +} + +static struct ProcedureDeclaration__16 { + OPT_Node *x; + OPT_Object *proc, *fwd; + OPS_Name *name; + INT8 *mode, *vis; + BOOLEAN *forward; + struct ProcedureDeclaration__16 *lnk; +} *ProcedureDeclaration__16_s; + +static void Body__17 (void); +static void GetCode__19 (void); +static void GetParams__21 (void); +static void TProcDecl__23 (void); + +static void GetCode__19 (void) +{ + OPT_ConstExt ext = NIL; + INT16 n; + INT64 c; + ext = OPT_NewExt(); + (*ProcedureDeclaration__16_s->proc)->conval->ext = ext; + n = 0; + if (OPP_sym == 37) { + while (OPS_str[__X(n, 256)] != 0x00) { + (*ext)[__X(n + 1, 256)] = OPS_str[__X(n, 256)]; + n += 1; + } + (*ext)[0] = __CHR(n); + OPS_Get(&OPP_sym); + } else { + for (;;) { + if (OPP_sym == 35) { + c = OPS_intval; + n += 1; + if ((c < 0 || c > 255) || n == 256) { + OPP_err(64); + c = 1; + n = 1; + } + OPS_Get(&OPP_sym); + (*ext)[__X(n, 256)] = __CHR(c); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35) { + OPP_err(19); + } else { + (*ext)[0] = __CHR(n); + break; + } + } + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); +} + +static void GetParams__21 (void) +{ + (*ProcedureDeclaration__16_s->proc)->vis = *ProcedureDeclaration__16_s->vis; + (*ProcedureDeclaration__16_s->proc)->mode = *ProcedureDeclaration__16_s->mode; + (*ProcedureDeclaration__16_s->proc)->typ = OPT_notyp; + (*ProcedureDeclaration__16_s->proc)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->proc)->conval->setval = 0x0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_FormalParameters(&(*ProcedureDeclaration__16_s->proc)->link, &(*ProcedureDeclaration__16_s->proc)->typ); + } + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link, (*ProcedureDeclaration__16_s->fwd)->link, 1); + if ((*ProcedureDeclaration__16_s->proc)->typ != (*ProcedureDeclaration__16_s->fwd)->typ) { + OPP_err(117); + } + *ProcedureDeclaration__16_s->proc = *ProcedureDeclaration__16_s->fwd; + OPT_topScope = (*ProcedureDeclaration__16_s->proc)->scope; + if (*ProcedureDeclaration__16_s->mode == 10) { + (*ProcedureDeclaration__16_s->proc)->mode = 10; + } + } +} + +static void Body__17 (void) +{ + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + c = OPM_errpos; + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); + OPP_CheckSym(39); + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, *ProcedureDeclaration__16_s->proc); + *ProcedureDeclaration__16_s->x = procdec; + (*ProcedureDeclaration__16_s->x)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->x)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, (*ProcedureDeclaration__16_s->proc)->name) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } +} + +static void TProcDecl__23 (void) +{ + OPT_Object baseProc = NIL; + OPT_Struct objTyp = NIL, recTyp = NIL; + INT8 objMode; + OPS_Name objName; + OPS_Get(&OPP_sym); + *ProcedureDeclaration__16_s->mode = 13; + if (OPP_level > 0) { + OPP_err(73); + } + OPP_Receiver(&objMode, objName, &objTyp, &recTyp); + if (OPP_sym == 38) { + __MOVE(OPS_name, *ProcedureDeclaration__16_s->name, 256); + OPP_CheckMark(&*ProcedureDeclaration__16_s->vis); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp, &*ProcedureDeclaration__16_s->fwd); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp->BaseTyp, &baseProc); + if ((baseProc != NIL && baseProc->mode != 13)) { + baseProc = NIL; + } + if (*ProcedureDeclaration__16_s->fwd == baseProc) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mnolev != OPP_level)) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mode == 13)) && !__IN(1, (*ProcedureDeclaration__16_s->fwd)->conval->setval, 64))) { + *ProcedureDeclaration__16_s->proc = OPT_NewObj(); + (*ProcedureDeclaration__16_s->proc)->leaf = 1; + if ((*ProcedureDeclaration__16_s->fwd)->vis != *ProcedureDeclaration__16_s->vis) { + OPP_err(118); + } + } else { + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPP_err(1); + *ProcedureDeclaration__16_s->fwd = NIL; + } + OPT_OpenScope(0, NIL); + OPT_topScope->right = recTyp->link; + OPT_Insert(*ProcedureDeclaration__16_s->name, &*ProcedureDeclaration__16_s->proc); + recTyp->link = OPT_topScope->right; + OPT_CloseScope(); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, *ProcedureDeclaration__16_s->proc); + OPT_Insert(objName, &(*ProcedureDeclaration__16_s->proc)->link); + (*ProcedureDeclaration__16_s->proc)->link->mode = objMode; + (*ProcedureDeclaration__16_s->proc)->link->typ = objTyp; + GetParams__21(); + if (baseProc != NIL) { + if (objMode != baseProc->link->mode || !OPP_Extends(objTyp, baseProc->link->typ)) { + OPP_err(115); + } + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link->link, baseProc->link->link, 0); + if ((*ProcedureDeclaration__16_s->proc)->typ != baseProc->typ) { + OPP_err(117); + } + if ((((((baseProc->vis == 1 && (*ProcedureDeclaration__16_s->proc)->vis == 0)) && recTyp->strobj != NIL)) && recTyp->strobj->vis == 1)) { + OPP_err(109); + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(2,64); + } + if (!*ProcedureDeclaration__16_s->forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } +} + +static void OPP_ProcedureDeclaration (OPT_Node *x) +{ + OPT_Object proc = NIL, fwd = NIL; + OPS_Name name; + INT8 mode, vis; + BOOLEAN forward; + struct ProcedureDeclaration__16 _s; + _s.x = x; + _s.proc = &proc; + _s.fwd = &fwd; + _s.name = (void*)name; + _s.mode = &mode; + _s.vis = &vis; + _s.forward = &forward; + _s.lnk = ProcedureDeclaration__16_s; + ProcedureDeclaration__16_s = &_s; + proc = NIL; + forward = 0; + *x = NIL; + mode = 6; + if ((OPP_sym != 38 && OPP_sym != 30)) { + if (OPP_sym == 1) { + } else if (OPP_sym == 17) { + forward = 1; + } else if (OPP_sym == 6) { + mode = 10; + } else if (OPP_sym == 7) { + mode = 9; + } else { + OPP_err(38); + } + if ((__IN(mode, 0x0600, 32) && !OPT_SYSimported)) { + OPP_err(135); + } + OPS_Get(&OPP_sym); + } + if (OPP_sym == 30) { + TProcDecl__23(); + } else if (OPP_sym == 38) { + OPT_Find(&fwd); + __MOVE(OPS_name, name, 256); + OPP_CheckMark(&vis); + if ((vis != 0 && mode == 6)) { + mode = 7; + } + if ((fwd != NIL && (fwd->mnolev != OPP_level || fwd->mode == 8))) { + fwd = NIL; + } + if ((((fwd != NIL && __IN(fwd->mode, 0xc0, 32))) && !__IN(1, fwd->conval->setval, 64))) { + proc = OPT_NewObj(); + proc->leaf = 1; + if (fwd->vis != vis) { + OPP_err(118); + } + } else { + if (fwd != NIL) { + OPP_err(1); + fwd = NIL; + } + OPT_Insert(name, &proc); + } + if ((mode != 6 && OPP_level > 0)) { + OPP_err(73); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, proc); + proc->link = NIL; + GetParams__21(); + if (mode == 9) { + GetCode__19(); + } else if (!forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } + ProcedureDeclaration__16_s = _s.lnk; +} + +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab) +{ + OPT_Node x = NIL, y = NIL, lastlab = NIL; + INT16 i, f; + INT32 xval, yval; + *lab = NIL; + lastlab = NIL; + for (;;) { + OPP_ConstExpression(&x); + f = x->typ->form; + if (__IN(f, 0x18, 32)) { + xval = OPM_Longint(x->conval->intval); + } else { + OPP_err(61); + xval = 1; + } + if (f == 4) { + if (!(LabelTyp->form == 4) || LabelTyp->size < x->typ->size) { + OPP_err(60); + } + } else if ((INT16)LabelTyp->form != f) { + OPP_err(60); + } + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&y); + yval = OPM_Longint(y->conval->intval); + if (((INT16)y->typ->form != f && !((f == 4 && y->typ->form == 4)))) { + OPP_err(60); + } + if (yval < xval) { + OPP_err(63); + yval = xval; + } + } else { + yval = xval; + } + x->conval->intval2 = yval; + i = *n; + if (i < 128) { + for (;;) { + if (i == 0) { + break; + } + if (tab[__X(i - 1, 128)].low <= yval) { + if (tab[__X(i - 1, 128)].high >= xval) { + OPP_err(62); + } + break; + } + tab[__X(i, 128)] = tab[__X(i - 1, 128)]; + i -= 1; + } + tab[__X(i, 128)].low = xval; + tab[__X(i, 128)].high = yval; + *n += 1; + } else { + OPP_err(213); + } + OPB_Link(&*lab, &lastlab, x); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35 || OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } +} + +static struct StatSeq__30 { + INT32 *pos; + struct StatSeq__30 *lnk; +} *StatSeq__30_s; + +static void CasePart__31 (OPT_Node *x); +static void CheckBool__33 (OPT_Node *x); +static void SetPos__35 (OPT_Node x); + +static void CasePart__31 (OPT_Node *x) +{ + INT16 n; + INT32 low, high; + BOOLEAN e; + OPP_CaseTable tab; + OPT_Node cases = NIL, lab = NIL, y = NIL, lastcase = NIL; + OPP_Expression(&*x); + *StatSeq__30_s->pos = OPM_errpos; + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + } else if (!__IN((*x)->typ->form, 0x18, 32)) { + OPP_err(125); + } + OPP_CheckSym(25); + cases = NIL; + lastcase = NIL; + n = 0; + for (;;) { + if (OPP_sym < 40) { + OPP_CaseLabelList(&lab, (*x)->typ, &n, tab); + OPP_CheckSym(20); + OPP_StatSeq(&y); + OPB_Construct(17, &lab, y); + OPB_Link(&cases, &lastcase, lab); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + if (n > 0) { + low = tab[0].low; + high = tab[__X(n - 1, 128)].high; + if (high - low > 512) { + OPP_err(209); + } + } else { + low = 1; + high = 0; + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + OPM_Mark(-307, OPM_curpos); + } + OPB_Construct(16, &cases, y); + OPB_Construct(21, &*x, cases); + cases->conval = OPT_NewConst(); + cases->conval->intval = low; + cases->conval->intval2 = high; + if (e) { + cases->conval->setval = 0x02; + } else { + cases->conval->setval = 0x0; + } +} + +static void SetPos__35 (OPT_Node x) +{ + x->conval = OPT_NewConst(); + x->conval->intval = *StatSeq__30_s->pos; +} + +static void CheckBool__33 (OPT_Node *x) +{ + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + *x = OPB_NewBoolConst(0); + } else if ((*x)->typ->form != 2) { + OPP_err(120); + *x = OPB_NewBoolConst(0); + } + *StatSeq__30_s->pos = OPM_errpos; +} + +static void OPP_StatSeq (OPT_Node *stat) +{ + OPT_Object fpar = NIL, id = NIL, t = NIL, obj = NIL; + OPT_Struct idtyp = NIL; + BOOLEAN e; + OPT_Node s = NIL, x = NIL, y = NIL, z = NIL, apar = NIL, last = NIL, lastif = NIL; + INT32 pos; + OPS_Name name; + struct StatSeq__30 _s; + _s.pos = &pos; + _s.lnk = StatSeq__30_s; + StatSeq__30_s = &_s; + *stat = NIL; + last = NIL; + for (;;) { + x = NIL; + if (OPP_sym < 38) { + OPP_err(14); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 38)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + x = OPB_NewLeaf(id); + OPP_selector(&x); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if (OPP_sym == 9) { + OPP_err(34); + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if ((x->class == 9 && x->obj->mode == 8)) { + OPP_StandProcCall(&x); + if ((x != NIL && x->typ != OPT_notyp)) { + OPP_err(55); + } + } else { + OPB_PrepCall(&x, &fpar); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_ActualParameters(&apar, fpar); + OPP_CheckSym(22); + } else { + apar = NIL; + if (fpar != NIL) { + OPP_err(65); + } + } + OPB_Call(&x, apar, fpar); + if (x->typ != OPT_notyp) { + OPP_err(55); + } + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + pos = OPM_errpos; + } else if (OPP_sym == 45) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(26); + OPP_StatSeq(&y); + OPB_Construct(15, &x, y); + SetPos__35(x); + lastif = x; + while (OPP_sym == 43) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + OPP_CheckSym(26); + OPP_StatSeq(&z); + OPB_Construct(15, &y, z); + SetPos__35(y); + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 42) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + } + OPB_Construct(20, &x, y); + OPP_CheckSym(41); + OPB_OptIf(&x); + pos = OPM_errpos; + } else if (OPP_sym == 46) { + OPS_Get(&OPP_sym); + CasePart__31(&x); + OPP_CheckSym(41); + } else if (OPP_sym == 47) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(27); + OPP_StatSeq(&y); + OPB_Construct(22, &x, y); + OPP_CheckSym(41); + } else if (OPP_sym == 48) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&x); + if (OPP_sym == 44) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + } else { + OPP_err(44); + } + OPB_Construct(23, &x, y); + } else if (OPP_sym == 49) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&id); + if (!(id->typ->form == 4)) { + OPP_err(68); + } + OPP_CheckSym(34); + OPP_Expression(&y); + pos = OPM_errpos; + x = OPB_NewLeaf(id); + OPB_Assign(&x, y); + SetPos__35(x); + OPP_CheckSym(28); + OPP_Expression(&y); + pos = OPM_errpos; + if (y->class != 7) { + __MOVE("@@", name, 3); + OPT_Insert(name, &t); + __MOVE("@for", t->name, 5); + t->mode = 1; + t->typ = x->left->typ; + obj = OPT_topScope->scope; + if (obj == NIL) { + OPT_topScope->scope = t; + } else { + while (obj->link != NIL) { + obj = obj->link; + } + obj->link = t; + } + z = OPB_NewLeaf(t); + OPB_Assign(&z, y); + SetPos__35(z); + OPB_Link(&*stat, &last, z); + y = OPB_NewLeaf(t); + } else if (!(y->typ->form == 4) || y->typ->size > x->left->typ->size) { + OPP_err(113); + } + OPB_Link(&*stat, &last, x); + if (OPP_sym == 29) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&z); + } else { + z = OPB_NewIntConst(1); + } + pos = OPM_errpos; + x = OPB_NewLeaf(id); + if (z->conval->intval > 0) { + OPB_Op(12, &x, y); + } else if (z->conval->intval < 0) { + OPB_Op(14, &x, y); + } else { + OPP_err(63); + OPB_Op(14, &x, y); + } + OPP_CheckSym(27); + OPP_StatSeq(&s); + y = OPB_NewLeaf(id); + OPB_StPar1(&y, z, 13); + SetPos__35(y); + if (s == NIL) { + s = y; + } else { + z = s; + while (z->link != NIL) { + z = z->link; + } + z->link = y; + } + OPP_CheckSym(41); + OPB_Construct(22, &x, s); + } else { + OPP_err(38); + } + } else if (OPP_sym == 50) { + OPS_Get(&OPP_sym); + OPP_LoopLevel += 1; + OPP_StatSeq(&x); + OPP_LoopLevel -= 1; + OPB_Construct(24, &x, NIL); + OPP_CheckSym(41); + pos = OPM_errpos; + } else if (OPP_sym == 51) { + OPS_Get(&OPP_sym); + idtyp = NIL; + x = NIL; + for (;;) { + if (OPP_sym == 38) { + OPP_qualident(&id); + y = OPB_NewLeaf(id); + if ((((id != NIL && id->typ->form == 11)) && (id->mode == 2 || !id->leaf))) { + OPP_err(245); + } + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPP_qualident(&t); + if (t->mode == 5) { + if (id != NIL) { + idtyp = id->typ; + OPB_TypTest(&y, t, 0); + id->typ = t->typ; + } else { + OPP_err(130); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + OPP_err(38); + } + pos = OPM_errpos; + OPP_CheckSym(27); + OPP_StatSeq(&s); + OPB_Construct(15, &y, s); + SetPos__35(y); + if (idtyp != NIL) { + id->typ = idtyp; + idtyp = NIL; + } + if (x == NIL) { + x = y; + lastif = x; + } else { + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&s); + } else { + s = NIL; + } + OPB_Construct(27, &x, s); + OPP_CheckSym(41); + if (e) { + x->subcl = 1; + } + } else if (OPP_sym == 52) { + OPS_Get(&OPP_sym); + if (OPP_LoopLevel == 0) { + OPP_err(46); + } + OPB_Construct(25, &x, NIL); + pos = OPM_errpos; + } else if (OPP_sym == 53) { + OPS_Get(&OPP_sym); + if (OPP_sym < 39) { + OPP_Expression(&x); + } + if (OPP_level > 0) { + OPB_Return(&x, OPT_topScope->link); + } else { + OPB_Return(&x, NIL); + } + pos = OPM_errpos; + } + if (x != NIL) { + SetPos__35(x); + OPB_Link(&*stat, &last, x); + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym <= 38 || (45 <= OPP_sym && OPP_sym <= 53)) { + OPP_err(39); + } else { + break; + } + } + StatSeq__30_s = _s.lnk; +} + +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq) +{ + OPT_Struct typ = NIL; + OPT_Object obj = NIL, first = NIL, last = NIL; + OPT_Node x = NIL, lastdec = NIL; + INT16 i; + first = NIL; + last = NIL; + OPP_nofFwdPtr = 0; + for (;;) { + if (OPP_sym == 58) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->typ = OPT_sinttyp; + obj->mode = 1; + if (OPP_sym == 9) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else if (OPP_sym == 34) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else { + OPP_err(9); + x = OPB_NewIntConst(1); + } + obj->mode = 3; + obj->typ = x->typ; + obj->conval = x->conval; + OPP_CheckSym(39); + } + } + if (OPP_sym == 59) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + obj->mode = 5; + obj->typ = OPT_undftyp; + OPP_CheckMark(&obj->vis); + if (OPP_sym == 9) { + if (((((((((__STRCMP(obj->name, "SHORTINT") == 0 || __STRCMP(obj->name, "INTEGER") == 0) || __STRCMP(obj->name, "LONGINT") == 0) || __STRCMP(obj->name, "HUGEINT") == 0) || __STRCMP(obj->name, "REAL") == 0) || __STRCMP(obj->name, "LONGREAL") == 0) || __STRCMP(obj->name, "SET") == 0) || __STRCMP(obj->name, "CHAR") == 0) || __STRCMP(obj->name, "TRUE") == 0) || __STRCMP(obj->name, "FALSE") == 0) { + OPM_Mark(-310, OPM_curpos); + } + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else if (OPP_sym == 34 || OPP_sym == 20) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else { + OPP_err(9); + } + if (obj->typ->strobj == NIL) { + obj->typ->strobj = obj; + } + if (__IN(obj->typ->comp, 0x1c, 32)) { + i = 0; + while (i < OPP_nofFwdPtr) { + typ = OPP_FwdPtr[__X(i, 64)]; + i += 1; + if (__STRCMP(typ->link->name, obj->name) == 0) { + typ->BaseTyp = obj->typ; + typ->link->name[0] = 0x00; + } + } + } + OPP_CheckSym(39); + } + } + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->mode = 1; + obj->link = NIL; + obj->leaf = obj->vis == 0; + obj->typ = OPT_undftyp; + if (first == NIL) { + first = obj; + } + if (last == NIL) { + OPT_topScope->scope = obj; + } else { + last->link = obj; + } + last = obj; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + typ->pvused = 1; + if (typ->comp == 3) { + typ = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + OPP_CheckSym(39); + } + } + if (OPP_sym < 58 || OPP_sym > 60) { + break; + } + } + i = 0; + while (i < OPP_nofFwdPtr) { + if (OPP_FwdPtr[__X(i, 64)]->link->name[0] != 0x00) { + OPP_err(128); + } + OPP_FwdPtr[__X(i, 64)] = NIL; + i += 1; + } + OPT_topScope->adr = OPM_errpos; + *procdec = NIL; + lastdec = NIL; + while (OPP_sym == 61) { + OPS_Get(&OPP_sym); + OPP_ProcedureDeclaration(&x); + if (x != NIL) { + if (lastdec == NIL) { + *procdec = x; + } else { + lastdec->link = x; + } + lastdec = x; + } + OPP_CheckSym(39); + } + if (OPP_sym == 57) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&*statseq); + } else { + *statseq = NIL; + } + if ((OPP_level == 0 && OPP_TDinit != NIL)) { + OPP_lastTDinit->link = *statseq; + *statseq = OPP_TDinit; + } + OPP_CheckSym(41); +} + +void OPP_Module (OPT_Node *prog, UINT32 opt) +{ + OPS_Name impName, aliasName; + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + BOOLEAN done; + OPS_Init(); + OPP_LoopLevel = 0; + OPP_level = 0; + OPS_Get(&OPP_sym); + if (OPP_sym == 63) { + OPS_Get(&OPP_sym); + } else { + OPP_err(16); + } + if (OPP_sym == 38) { + OPM_LogCompiling(OPS_name, 256); + OPT_Init(OPS_name, opt); + OPS_Get(&OPP_sym); + OPP_CheckSym(39); + if (OPP_sym == 62) { + OPS_Get(&OPP_sym); + for (;;) { + if (OPP_sym == 38) { + __COPY(OPS_name, aliasName, 256); + __COPY(aliasName, impName, 256); + OPS_Get(&OPP_sym); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __COPY(OPS_name, impName, 256); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + } + OPT_Import(aliasName, impName, &done); + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(39); + } + if (OPM_noerr) { + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; + c = OPM_errpos; + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, NIL); + *prog = procdec; + (*prog)->conval = OPT_NewConst(); + (*prog)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, OPT_SelfName) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + if (OPP_sym != 18) { + OPP_err(18); + } + } + } else { + OPP_err(38); + } + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPP_TDinit); + P(OPP_lastTDinit); + __ENUMP(OPP_FwdPtr, 64, P); +} + +__TDESC(OPP__1, 1, 0) = {__TDFLDS("", 8), {-4}}; + +export void *OPP__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPP", EnumPtrs); + __INITYP(OPP__1, OPP__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPP.h b/bootstrap/unix-44/OPP.h new file mode 100644 index 00000000..3d8cefe8 --- /dev/null +++ b/bootstrap/unix-44/OPP.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPP__h +#define OPP__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPP_Module (OPT_Node *prog, UINT32 opt); +import void *OPP__init(void); + + +#endif // OPP diff --git a/bootstrap/unix-44/OPS.c b/bootstrap/unix-44/OPS.c new file mode 100644 index 00000000..a25a2c12 --- /dev/null +++ b/bootstrap/unix-44/OPS.c @@ -0,0 +1,666 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +export OPS_Name OPS_name; +export OPS_String OPS_str; +export INT16 OPS_numtyp; +export INT64 OPS_intval; +export REAL OPS_realval; +export LONGREAL OPS_lrlval; +static CHAR OPS_ch; + + +export void OPS_Get (INT8 *sym); +static void OPS_Identifier (INT8 *sym); +export void OPS_Init (void); +static void OPS_Number (void); +static void OPS_Str (INT8 *sym); +static void OPS_err (INT16 n); + + +static void OPS_err (INT16 n) +{ + OPM_err(n); +} + +static void OPS_Str (INT8 *sym) +{ + INT16 i; + CHAR och; + i = 0; + och = OPS_ch; + for (;;) { + OPM_Get(&OPS_ch); + if (OPS_ch == och) { + break; + } + if (OPS_ch < ' ') { + OPS_err(3); + break; + } + if (i == 255) { + OPS_err(241); + break; + } + OPS_str[__X(i, 256)] = OPS_ch; + i += 1; + } + OPM_Get(&OPS_ch); + OPS_str[__X(i, 256)] = 0x00; + OPS_intval = i + 1; + if (OPS_intval == 2) { + *sym = 35; + OPS_numtyp = 1; + OPS_intval = (INT16)OPS_str[0]; + } else { + *sym = 37; + } +} + +static void OPS_Identifier (INT8 *sym) +{ + INT16 i; + i = 0; + do { + OPS_name[__X(i, 256)] = OPS_ch; + i += 1; + OPM_Get(&OPS_ch); + } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256)); + if (i == 256) { + OPS_err(240); + i -= 1; + } + OPS_name[__X(i, 256)] = 0x00; + *sym = 38; +} + +static struct Number__6 { + struct Number__6 *lnk; +} *Number__6_s; + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex); +static LONGREAL Ten__9 (INT16 e); + +static LONGREAL Ten__9 (INT16 e) +{ + LONGREAL x, p; + x = (LONGREAL)1; + p = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + x = x * p; + } + e = __ASHR(e, 1); + if (e > 0) { + p = p * p; + } + } + return x; +} + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex) +{ + if (ch <= '9') { + return (INT16)ch - 48; + } else if (hex) { + return ((INT16)ch - 65) + 10; + } else { + OPS_err(2); + return 0; + } + __RETCHK; +} + +static void OPS_Number (void) +{ + INT16 i, m, n, d, e; + CHAR dig[24]; + LONGREAL f; + CHAR expCh; + BOOLEAN neg; + struct Number__6 _s; + _s.lnk = Number__6_s; + Number__6_s = &_s; + i = 0; + m = 0; + n = 0; + d = 0; + for (;;) { + if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) { + if (m > 0 || OPS_ch != '0') { + if (n < 24) { + dig[__X(n, 24)] = OPS_ch; + n += 1; + } + m += 1; + } + OPM_Get(&OPS_ch); + i += 1; + } else if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPS_ch = 0x7f; + break; + } else if (d == 0) { + d = i; + } else { + OPS_err(2); + } + } else { + break; + } + } + if (d == 0) { + if (n == m) { + OPS_intval = 0; + i = 0; + if (OPS_ch == 'X') { + OPM_Get(&OPS_ch); + OPS_numtyp = 1; + if (n <= 2) { + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else if (OPS_ch == 'H') { + OPM_Get(&OPS_ch); + OPS_numtyp = 2; + if (n <= 16) { + if ((n == 16 && dig[0] > '7')) { + OPS_intval = -1; + } + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 2; + while (i < n) { + d = Ord__7(dig[__X(i, 24)], 0); + i += 1; + if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (INT64)d; + } else { + OPS_err(203); + } + } + } + } else { + OPS_err(203); + } + } else { + f = (LONGREAL)0; + e = 0; + expCh = 'E'; + while (n > 0) { + n -= 1; + f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10; + } + if (OPS_ch == 'E' || OPS_ch == 'D') { + expCh = OPS_ch; + OPM_Get(&OPS_ch); + neg = 0; + if (OPS_ch == '-') { + neg = 1; + OPM_Get(&OPS_ch); + } else if (OPS_ch == '+') { + OPM_Get(&OPS_ch); + } + if (('0' <= OPS_ch && OPS_ch <= '9')) { + do { + n = Ord__7(OPS_ch, 0); + OPM_Get(&OPS_ch); + if (e <= __DIV(32767 - n, 10)) { + e = e * 10 + n; + } else { + OPS_err(203); + } + } while (!(OPS_ch < '0' || '9' < OPS_ch)); + if (neg) { + e = -e; + } + } else { + OPS_err(2); + } + } + e -= (i - d) - m; + if (expCh == 'E') { + OPS_numtyp = 3; + if ((-37 < e && e <= 38)) { + if (e < 0) { + OPS_realval = (f / (LONGREAL)Ten__9(-e)); + } else { + OPS_realval = (f * Ten__9(e)); + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 4; + if ((-307 < e && e <= 308)) { + if (e < 0) { + OPS_lrlval = f / (LONGREAL)Ten__9(-e); + } else { + OPS_lrlval = f * Ten__9(e); + } + } else { + OPS_err(203); + } + } + } + Number__6_s = _s.lnk; +} + +static struct Get__1 { + struct Get__1 *lnk; +} *Get__1_s; + +static void Comment__2 (void); + +static void Comment__2 (void) +{ + BOOLEAN isExported; + CHAR commentText[256]; + INT16 i, nestLevel; + CHAR prevCh, nextCh; + i = 0; + while (i <= 255) { + commentText[__X(i, 256)] = 0x00; + i += 1; + } + isExported = 0; + i = 0; + nestLevel = 1; + prevCh = 0x00; + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + isExported = 1; + OPM_Get(&OPS_ch); + if (OPS_ch == ')') { + commentText[0] = 0x00; + OPM_StoreComment(commentText, 256); + OPM_Get(&OPS_ch); + return; + } + } + while ((nestLevel > 0 && OPS_ch != 0x00)) { + if ((prevCh == '(' && OPS_ch == '*')) { + nestLevel += 1; + prevCh = 0x00; + } else if ((prevCh == '*' && OPS_ch == ')')) { + nestLevel -= 1; + if (nestLevel == 0) { + OPM_Get(&OPS_ch); + } else { + prevCh = 0x00; + } + } else { + if ((((isExported && nestLevel == 1)) && prevCh != 0x00)) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } + } + prevCh = OPS_ch; + } + if (nestLevel > 0) { + OPM_Get(&OPS_ch); + } + } + if (OPS_ch == 0x00) { + OPS_err(5); + } + if ((((((isExported && nestLevel == 0)) && prevCh != 0x00)) && prevCh != '*')) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } else { + OPM_LogWStr((CHAR*)"Truncating final comment character", 35); + OPM_LogWLn(); + } + } + if (isExported) { + if (i >= 256) { + OPM_LogWStr((CHAR*)"Warning: commentText overflow", 30); + OPM_LogWLn(); + i = 255; + } + commentText[__X(i, 256)] = 0x00; + OPM_StoreComment(commentText, 256); + } +} + +void OPS_Get (INT8 *sym) +{ + INT8 s; + struct Get__1 _s; + _s.lnk = Get__1_s; + Get__1_s = &_s; + OPM_errpos = OPM_curpos - 1; + while (OPS_ch <= ' ') { + if (OPS_ch == 0x00) { + *sym = 64; + Get__1_s = _s.lnk; + return; + } else { + OPM_Get(&OPS_ch); + } + } + switch (OPS_ch) { + case '"': case '\'': + OPS_Str(&s); + break; + case '#': + s = 10; + OPM_Get(&OPS_ch); + break; + case '&': + s = 5; + OPM_Get(&OPS_ch); + break; + case '(': + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + Comment__2(); + OPS_Get(&s); + } else { + s = 30; + } + break; + case ')': + s = 22; + OPM_Get(&OPS_ch); + break; + case '*': + s = 1; + OPM_Get(&OPS_ch); + break; + case '+': + s = 6; + OPM_Get(&OPS_ch); + break; + case ',': + s = 19; + OPM_Get(&OPS_ch); + break; + case '-': + s = 7; + OPM_Get(&OPS_ch); + break; + case '.': + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + s = 21; + } else { + s = 18; + } + break; + case '/': + s = 2; + OPM_Get(&OPS_ch); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + OPS_Number(); + s = 35; + break; + case ':': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 34; + } else { + s = 20; + } + break; + case ';': + s = 39; + OPM_Get(&OPS_ch); + break; + case '<': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 12; + } else { + s = 11; + } + break; + case '=': + s = 9; + OPM_Get(&OPS_ch); + break; + case '>': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 14; + } else { + s = 13; + } + break; + case 'A': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "ARRAY") == 0) { + s = 54; + } + break; + case 'B': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "BEGIN") == 0) { + s = 57; + } else if (__STRCMP(OPS_name, "BY") == 0) { + s = 29; + } + break; + case 'C': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "CASE") == 0) { + s = 46; + } else if (__STRCMP(OPS_name, "CONST") == 0) { + s = 58; + } + break; + case 'D': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "DO") == 0) { + s = 27; + } else if (__STRCMP(OPS_name, "DIV") == 0) { + s = 3; + } + break; + case 'E': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "END") == 0) { + s = 41; + } else if (__STRCMP(OPS_name, "ELSE") == 0) { + s = 42; + } else if (__STRCMP(OPS_name, "ELSIF") == 0) { + s = 43; + } else if (__STRCMP(OPS_name, "EXIT") == 0) { + s = 52; + } + break; + case 'F': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "FOR") == 0) { + s = 49; + } + break; + case 'I': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "IF") == 0) { + s = 45; + } else if (__STRCMP(OPS_name, "IN") == 0) { + s = 15; + } else if (__STRCMP(OPS_name, "IS") == 0) { + s = 16; + } else if (__STRCMP(OPS_name, "IMPORT") == 0) { + s = 62; + } + break; + case 'L': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "LOOP") == 0) { + s = 50; + } + break; + case 'M': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "MOD") == 0) { + s = 4; + } else if (__STRCMP(OPS_name, "MODULE") == 0) { + s = 63; + } + break; + case 'N': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "NIL") == 0) { + s = 36; + } + break; + case 'O': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "OR") == 0) { + s = 8; + } else if (__STRCMP(OPS_name, "OF") == 0) { + s = 25; + } + break; + case 'P': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "PROCEDURE") == 0) { + s = 61; + } else if (__STRCMP(OPS_name, "POINTER") == 0) { + s = 56; + } + break; + case 'R': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "RECORD") == 0) { + s = 55; + } else if (__STRCMP(OPS_name, "REPEAT") == 0) { + s = 48; + } else if (__STRCMP(OPS_name, "RETURN") == 0) { + s = 53; + } + break; + case 'T': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "THEN") == 0) { + s = 26; + } else if (__STRCMP(OPS_name, "TO") == 0) { + s = 28; + } else if (__STRCMP(OPS_name, "TYPE") == 0) { + s = 59; + } + break; + case 'U': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "UNTIL") == 0) { + s = 44; + } + break; + case 'V': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "VAR") == 0) { + s = 60; + } + break; + case 'W': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "WHILE") == 0) { + s = 47; + } else if (__STRCMP(OPS_name, "WITH") == 0) { + s = 51; + } + break; + case 'G': case 'H': case 'J': case 'K': case 'Q': + case 'S': case 'X': case 'Y': case 'Z': + OPS_Identifier(&s); + break; + case '[': + s = 31; + OPM_Get(&OPS_ch); + break; + case ']': + s = 23; + OPM_Get(&OPS_ch); + break; + case '^': + s = 17; + OPM_Get(&OPS_ch); + break; + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + OPS_Identifier(&s); + break; + case '{': + s = 32; + OPM_Get(&OPS_ch); + break; + case '|': + s = 40; + OPM_Get(&OPS_ch); + break; + case '}': + s = 24; + OPM_Get(&OPS_ch); + break; + case '~': + s = 33; + OPM_Get(&OPS_ch); + break; + case 0x7f: + s = 21; + OPM_Get(&OPS_ch); + break; + default: + s = 0; + OPM_Get(&OPS_ch); + break; + } + *sym = s; + Get__1_s = _s.lnk; +} + +void OPS_Init (void) +{ + OPS_ch = ' '; +} + + +export void *OPS__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __REGMOD("OPS", 0); + __REGCMD("Init", OPS_Init); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPS.h b/bootstrap/unix-44/OPS.h new file mode 100644 index 00000000..19e222ac --- /dev/null +++ b/bootstrap/unix-44/OPS.h @@ -0,0 +1,28 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPS__h +#define OPS__h + +#include "SYSTEM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +import OPS_Name OPS_name; +import OPS_String OPS_str; +import INT16 OPS_numtyp; +import INT64 OPS_intval; +import REAL OPS_realval; +import LONGREAL OPS_lrlval; + + +import void OPS_Get (INT8 *sym); +import void OPS_Init (void); +import void *OPS__init(void); + + +#endif // OPS diff --git a/bootstrap/unix-44/OPT.c b/bootstrap/unix-44/OPT.c new file mode 100644 index 00000000..72261b24 --- /dev/null +++ b/bootstrap/unix-44/OPT.c @@ -0,0 +1,2261 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_ExpCtxt { + INT32 reffp; + INT16 ref; + INT8 nofm; + INT8 locmno[64]; + } OPT_ExpCtxt; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_ImpCtxt { + INT32 nextTag, reffp; + INT16 nofr, minr, nofm; + BOOLEAN self; + OPT_Struct ref[255]; + OPT_Object old[255]; + INT32 pvfp[255]; + INT8 glbmno[64]; + } OPT_ImpCtxt; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused, fpdone, idfpdone; + INT32 idfp, pbfp, pvfp; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +export OPT_Object OPT_topScope; +export OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +export OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +export INT8 OPT_nofGmod; +export OPT_Object OPT_GlbMod[64]; +export OPS_Name OPT_SelfName; +export BOOLEAN OPT_SYSimported; +static OPT_Object OPT_universe, OPT_syslink; +static OPT_ImpCtxt OPT_impCtxt; +static OPT_ExpCtxt OPT_expCtxt; +static INT32 OPT_nofhdfld; +static BOOLEAN OPT_newsf, OPT_findpc, OPT_extsf, OPT_sfpresent, OPT_symExtended, OPT_symNew; +static INT32 OPT_recno; +export OPT_Link OPT_Links; + +export ADDRESS *OPT_ConstDesc__typ; +export ADDRESS *OPT_ObjDesc__typ; +export ADDRESS *OPT_StrDesc__typ; +export ADDRESS *OPT_NodeDesc__typ; +export ADDRESS *OPT_ImpCtxt__typ; +export ADDRESS *OPT_ExpCtxt__typ; +export ADDRESS *OPT_LinkDesc__typ; + +export void OPT_Align (INT32 *adr, INT32 base); +export INT32 OPT_BaseAlignment (OPT_Struct typ); +export void OPT_Close (void); +export void OPT_CloseScope (void); +static void OPT_DebugStruct (OPT_Struct btyp); +static void OPT_EnterBoolConst (OPS_Name name, INT32 value); +static void OPT_EnterProc (OPS_Name name, INT16 num); +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res); +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res); +export void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +export void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len); +export void OPT_FPrintObj (OPT_Object obj); +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par); +export void OPT_FPrintStr (OPT_Struct typ); +export void OPT_Find (OPT_Object *res); +export void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +export void OPT_FindImport (OPT_Object mod, OPT_Object *res); +export void OPT_IdFPrint (OPT_Struct typ); +export void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +static void OPT_InConstant (INT32 f, OPT_Const conval); +static OPT_Object OPT_InFld (void); +static void OPT_InLinks (void); +static void OPT_InMod (INT8 *mno); +static void OPT_InName (CHAR *name, ADDRESS name__len); +static OPT_Object OPT_InObj (INT8 mno); +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par); +static void OPT_InStruct (OPT_Struct *typ); +static OPT_Object OPT_InTProc (INT8 mno); +static OPT_Struct OPT_InTyp (INT32 tag); +export void OPT_Init (OPS_Name name, UINT32 opt); +export void OPT_InitRecno (void); +static void OPT_InitStruct (OPT_Struct *typ, INT8 form); +export void OPT_Insert (OPS_Name name, OPT_Object *obj); +export void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +export INT16 OPT_IntSize (INT64 n); +export OPT_Struct OPT_IntType (INT32 size); +export OPT_Const OPT_NewConst (void); +export OPT_ConstExt OPT_NewExt (void); +export OPT_Node OPT_NewNode (INT8 class); +export OPT_Object OPT_NewObj (void); +export OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +export void OPT_OpenScope (INT8 level, OPT_Object owner); +static void OPT_OutConstant (OPT_Object obj); +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void OPT_OutLinks (void); +static void OPT_OutMod (INT16 mno); +static void OPT_OutName (CHAR *name, ADDRESS name__len); +static void OPT_OutObj (OPT_Object obj); +static void OPT_OutSign (OPT_Struct result, OPT_Object par); +static void OPT_OutStr (OPT_Struct typ); +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj); +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len); +export OPT_Struct OPT_SetType (INT32 size); +export OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +export INT32 OPT_SizeAlignment (INT32 size); +export void OPT_TypSize (OPT_Struct typ); +static void OPT_err (INT16 n); + + +void OPT_InitRecno (void) +{ + OPT_recno = 0; +} + +static void OPT_err (INT16 n) +{ + OPM_err(n); +} + +INT16 OPT_IntSize (INT64 n) +{ + INT16 bytes; + if (n < 0) { + n = -(n + 1); + } + bytes = 1; + while ((bytes < 8 && __ASH(n, -(__ASHL(bytes, 3) - 1)) != 0)) { + bytes += 1; + } + return bytes; +} + +OPT_Struct OPT_IntType (INT32 size) +{ + if (size <= OPT_int8typ->size) { + return OPT_int8typ; + } + if (size <= OPT_int16typ->size) { + return OPT_int16typ; + } + if (size <= OPT_int32typ->size) { + return OPT_int32typ; + } + return OPT_int64typ; +} + +OPT_Struct OPT_SetType (INT32 size) +{ + if (size == OPT_set32typ->size) { + return OPT_set32typ; + } + return OPT_set64typ; +} + +OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir) +{ + INT16 i; + __ASSERT(x->form == 4, 0); + __ASSERT(x->BaseTyp == OPT_undftyp, 0); + __ASSERT(dir == 1 || dir == -1, 0); + if (dir > 0) { + if (x->size < OPT_sinttyp->size) { + return OPT_sinttyp; + } + if (x->size < OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size < OPT_linttyp->size) { + return OPT_linttyp; + } + return OPT_int64typ; + } else { + if (x->size > OPT_linttyp->size) { + return OPT_linttyp; + } + if (x->size > OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size > OPT_sinttyp->size) { + return OPT_sinttyp; + } + return OPT_int8typ; + } + __RETCHK; +} + +void OPT_Align (INT32 *adr, INT32 base) +{ + switch (base) { + case 2: + *adr += __MASK(*adr, -2); + break; + case 4: + *adr += __MASK(-*adr, -4); + break; + case 8: + *adr += __MASK(-*adr, -8); + break; + case 16: + *adr += __MASK(-*adr, -16); + break; + default: + break; + } +} + +INT32 OPT_SizeAlignment (INT32 size) +{ + INT32 alignment; + if (size < OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; + } + return alignment; +} + +INT32 OPT_BaseAlignment (OPT_Struct typ) +{ + INT32 alignment; + if (typ->form == 13) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPT_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPT_SizeAlignment(typ->size); + } + return alignment; +} + +void OPT_TypSize (OPT_Struct typ) +{ + INT16 f, c; + INT32 offset, size, base, fbase, off0; + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + if (typ == OPT_undftyp) { + OPM_err(58); + } else if (typ->size == -1) { + f = typ->form; + c = typ->comp; + if (c == 4) { + btyp = typ->BaseTyp; + if (btyp == NIL) { + offset = 0; + base = 1; + } else { + OPT_TypSize(btyp); + offset = btyp->size - __ASHR(btyp->sysflag, 8); + base = btyp->align; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + btyp = fld->typ; + OPT_TypSize(btyp); + size = btyp->size; + fbase = OPT_BaseAlignment(btyp); + OPT_Align(&offset, fbase); + fld->adr = offset; + offset += size; + if (fbase > base) { + base = fbase; + } + fld = fld->link; + } + off0 = offset; + if (offset == 0) { + offset = 1; + } + OPT_Align(&offset, base); + if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { + OPT_recno += 1; + base += __ASHL(OPT_recno, 16); + } + typ->size = offset; + typ->align = base; + typ->sysflag = __MASK(typ->sysflag, -256) + __SHORT(__ASHL(offset - off0, 8), 32768); + } else if (c == 2) { + OPT_TypSize(typ->BaseTyp); + typ->size = typ->n * typ->BaseTyp->size; + } else if (f == 11) { + typ->size = OPM_AddressSize; + if (typ->BaseTyp == OPT_undftyp) { + OPM_Mark(128, typ->n); + } else { + OPT_TypSize(typ->BaseTyp); + } + } else if (f == 12) { + typ->size = OPM_AddressSize; + } else if (c == 3) { + btyp = typ->BaseTyp; + OPT_TypSize(btyp); + if (btyp->comp == 3) { + typ->size = btyp->size + 4; + } else { + typ->size = 8; + } + } + } +} + +OPT_Const OPT_NewConst (void) +{ + OPT_Const const_ = NIL; + __NEW(const_, OPT_ConstDesc); + return const_; +} + +OPT_Object OPT_NewObj (void) +{ + OPT_Object obj = NIL; + __NEW(obj, OPT_ObjDesc); + obj->typ = NIL; + obj->conval = NIL; + obj->comment = NIL; + obj->name[0] = 0x00; + return obj; +} + +OPT_Struct OPT_NewStr (INT8 form, INT8 comp) +{ + OPT_Struct typ = NIL; + __NEW(typ, OPT_StrDesc); + typ->form = form; + typ->comp = comp; + typ->ref = 255; + if (form != 0) { + typ->txtpos = OPM_errpos; + } + typ->size = -1; + typ->BaseTyp = OPT_undftyp; + return typ; +} + +OPT_Node OPT_NewNode (INT8 class) +{ + OPT_Node node = NIL; + __NEW(node, OPT_NodeDesc); + node->class = class; + return node; +} + +OPT_ConstExt OPT_NewExt (void) +{ + OPT_ConstExt ext = NIL; + ext = __NEWARR(NIL, 1, 1, 1, 0, 256); + return ext; +} + +void OPT_OpenScope (INT8 level, OPT_Object owner) +{ + OPT_Object head = NIL; + head = OPT_NewObj(); + head->mode = 12; + head->mnolev = level; + head->link = owner; + if (owner != NIL) { + owner->scope = head; + } + head->left = OPT_topScope; + head->right = NIL; + head->scope = NIL; + OPT_topScope = head; +} + +void OPT_CloseScope (void) +{ + OPT_topScope = OPT_topScope->left; +} + +void OPT_Init (OPS_Name name, UINT32 opt) +{ + OPT_topScope = OPT_universe; + OPT_OpenScope(0, NIL); + OPT_SYSimported = 0; + __MOVE(name, OPT_SelfName, 256); + __MOVE(name, OPT_topScope->name, 256); + OPT_GlbMod[0] = OPT_topScope; + OPT_nofGmod = 1; + OPT_newsf = __IN(4, opt, 32); + OPT_findpc = __IN(8, opt, 32); + OPT_extsf = OPT_newsf || __IN(9, opt, 32); + OPT_sfpresent = 1; + __NEW(OPT_Links, OPT_LinkDesc); + __MOVE(name, OPT_Links->name, 256); +} + +void OPT_Close (void) +{ + INT16 i; + OPT_CloseScope(); + i = 0; + while (i < 64) { + OPT_GlbMod[__X(i, 64)] = NIL; + i += 1; + } + i = 14; + while (i < 255) { + OPT_impCtxt.ref[__X(i, 255)] = NIL; + OPT_impCtxt.old[__X(i, 255)] = NIL; + i += 1; + } +} + +void OPT_FindImport (OPT_Object mod, OPT_Object *res) +{ + OPT_Object obj = NIL; + obj = mod->scope; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + if ((obj->mode == 5 && obj->vis == 0)) { + obj = NIL; + } else { + obj->used = 1; + } + break; + } + } + *res = obj; +} + +void OPT_Find (OPT_Object *res) +{ + OPT_Object obj = NIL, head = NIL; + head = OPT_topScope; + for (;;) { + obj = head->right; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + break; + } + } + if (obj != NIL) { + break; + } + head = head->left; + if (head == NIL) { + break; + } + } + *res = obj; +} + +void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res) +{ + OPT_Object obj = NIL; + while (typ != NIL) { + obj = typ->link; + while (obj != NIL) { + if (__STRCMP(name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(name, obj->name) > 0) { + obj = obj->right; + } else { + *res = obj; + return; + } + } + typ = typ->BaseTyp; + } + *res = NIL; +} + +void OPT_Insert (OPS_Name name, OPT_Object *obj) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + INT8 mnolev; + CHAR commentText[256]; + INT16 j; + ob0 = OPT_topScope; + ob1 = ob0->right; + left = 0; + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob0->right; + left = 0; + } else { + OPT_err(1); + ob0 = ob1; + ob1 = ob0->right; + } + } else { + ob1 = OPT_NewObj(); + ob1->leaf = 1; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + __COPY(name, ob1->name, 256); + mnolev = OPT_topScope->mnolev; + ob1->mnolev = mnolev; + OPM_GetComment((void*)commentText, 256); + if (commentText[0] != 0x00) { + ob1->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((j < 255 && commentText[__X(j, 256)] != 0x00)) { + (*ob1->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*ob1->comment)[__X(j, 256)] = 0x00; + } + break; + } + } + *obj = ob1; +} + +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_FPrint(&*fp, (INT16)ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_DebugStruct (OPT_Struct btyp) +{ + OPM_LogWLn(); + if (btyp == NIL) { + OPM_LogWStr((CHAR*)"btyp is nil", 12); + OPM_LogWLn(); + } + OPM_LogWStr((CHAR*)"btyp^.strobji^.name = ", 23); + OPM_LogWStr(btyp->strobj->name, 256); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.form = ", 14); + OPM_LogWNum(btyp->form, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.comp = ", 14); + OPM_LogWNum(btyp->comp, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.mno = ", 13); + OPM_LogWNum(btyp->mno, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.extlev = ", 16); + OPM_LogWNum(btyp->extlev, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.size = ", 14); + OPM_LogWNum(btyp->size, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.align = ", 15); + OPM_LogWNum(btyp->align, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.txtpos = ", 16); + OPM_LogWNum(btyp->txtpos, 0); + OPM_LogWLn(); +} + +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par) +{ + OPT_IdFPrint(result); + OPM_FPrint(&*fp, result->idfp); + while (par != NIL) { + OPM_FPrint(&*fp, par->mode); + OPT_IdFPrint(par->typ); + OPM_FPrint(&*fp, par->typ->idfp); + par = par->link; + } +} + +void OPT_IdFPrint (OPT_Struct typ) +{ + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL; + INT32 idfp; + INT16 f, c; + if (!typ->idfpdone) { + typ->idfpdone = 1; + idfp = 0; + f = typ->form; + OPM_FPrint(&idfp, f); + if (__IN(f, 0x90, 32)) { + OPM_FPrint(&idfp, typ->size); + } + c = typ->comp; + OPM_FPrint(&idfp, c); + btyp = typ->BaseTyp; + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_FPrintName(&idfp, (void*)OPT_GlbMod[__X(typ->mno, 64)]->name, 256); + OPT_FPrintName(&idfp, (void*)strobj->name, 256); + } + if ((f == 11 || (c == 4 && btyp != NIL)) || c == 3) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + } else if (c == 2) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + OPM_FPrint(&idfp, typ->n); + } else if (f == 12) { + OPT_FPrintSign(&idfp, btyp, typ->link); + } + typ->idfp = idfp; + } +} + +static struct FPrintStr__15 { + INT32 *pbfp, *pvfp; + struct FPrintStr__15 *lnk; +} *FPrintStr__15_s; + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void FPrintTProcs__20 (OPT_Object obj); + +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + FPrintFlds__16(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + FPrintHdFld__18(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + FPrintHdFld__18(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_FPrint(&*FPrintStr__15_s->pvfp, 11); + OPM_FPrint(&*FPrintStr__15_s->pvfp, adr); + OPT_nofhdfld += 1; + } +} + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->vis); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)fld->name, 256); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->adr); + OPT_FPrintStr(fld->typ); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->typ->pbfp); + OPM_FPrint(&*FPrintStr__15_s->pvfp, fld->typ->pvfp); + } else { + FPrintHdFld__18(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void FPrintTProcs__20 (OPT_Object obj) +{ + if (obj != NIL) { + FPrintTProcs__20(obj->left); + if (obj->mode == 13) { + if (obj->vis != 0) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, 13); + OPM_FPrint(&*FPrintStr__15_s->pbfp, __ASHR(obj->adr, 16)); + OPT_FPrintSign(&*FPrintStr__15_s->pbfp, obj->typ, obj->link); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)obj->name, 256); + } + } + FPrintTProcs__20(obj->right); + } +} + +void OPT_FPrintStr (OPT_Struct typ) +{ + INT16 f, c; + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL, bstrobj = NIL; + INT32 pbfp, pvfp; + struct FPrintStr__15 _s; + _s.pbfp = &pbfp; + _s.pvfp = &pvfp; + _s.lnk = FPrintStr__15_s; + FPrintStr__15_s = &_s; + if (!typ->fpdone) { + OPT_IdFPrint(typ); + pbfp = typ->idfp; + if (typ->sysflag != 0) { + OPM_FPrint(&pbfp, typ->sysflag); + } + pvfp = pbfp; + typ->pbfp = pbfp; + typ->pvfp = pvfp; + typ->fpdone = 1; + f = typ->form; + c = typ->comp; + btyp = typ->BaseTyp; + if (f == 11) { + strobj = typ->strobj; + bstrobj = btyp->strobj; + if (((strobj == NIL || strobj->name[0] == 0x00) || bstrobj == NIL) || bstrobj->name[0] == 0x00) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + pvfp = pbfp; + } + } else if (f == 12) { + } else if (__IN(c, 0x0c, 32)) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pvfp); + pvfp = pbfp; + } else { + if (btyp != NIL) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + OPM_FPrint(&pvfp, btyp->pvfp); + } + OPM_FPrint(&pvfp, typ->size); + OPM_FPrint(&pvfp, typ->align); + OPM_FPrint(&pvfp, typ->n); + OPT_nofhdfld = 0; + FPrintFlds__16(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(225, typ->txtpos); + } + FPrintTProcs__20(typ->link); + OPM_FPrint(&pvfp, pbfp); + strobj = typ->strobj; + if (strobj == NIL || strobj->name[0] == 0x00) { + pbfp = pvfp; + } + } + typ->pbfp = pbfp; + typ->pvfp = pvfp; + } + FPrintStr__15_s = _s.lnk; +} + +void OPT_FPrintObj (OPT_Object obj) +{ + INT32 fprint; + INT16 f, m; + REAL rval; + OPT_ConstExt ext = NIL; + if (!obj->fpdone) { + fprint = 0; + obj->fpdone = 1; + OPM_FPrint(&fprint, obj->mode); + if (obj->mode == 3) { + f = obj->typ->form; + OPM_FPrint(&fprint, f); + switch (f) { + case 2: case 3: case 4: + OPM_FPrint(&fprint, obj->conval->intval); + break; + case 7: + OPM_FPrintSet(&fprint, obj->conval->setval); + break; + case 5: + rval = obj->conval->realval; + OPM_FPrintReal(&fprint, rval); + break; + case 6: + OPM_FPrintLReal(&fprint, obj->conval->realval); + break; + case 8: + OPT_FPrintName(&fprint, (void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } + } else if (obj->mode == 1) { + OPM_FPrint(&fprint, obj->vis); + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } else if (__IN(obj->mode, 0x0480, 32)) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + } else if (obj->mode == 9) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + ext = obj->conval->ext; + m = (INT16)(*ext)[0]; + f = 1; + OPM_FPrint(&fprint, m); + while (f <= m) { + OPM_FPrint(&fprint, (INT16)(*ext)[__X(f, 256)]); + f += 1; + } + } else if (obj->mode == 5) { + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } + obj->fprint = fprint; + } +} + +void OPT_FPrintErr (OPT_Object obj, INT16 errcode) +{ + INT16 i, j; + CHAR ch; + if (obj->mnolev != 0) { + __COPY(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, OPM_objname, 64); + i = 0; + while (OPM_objname[__X(i, 64)] != 0x00) { + i += 1; + } + OPM_objname[__X(i, 64)] = '.'; + j = 0; + i += 1; + do { + ch = obj->name[__X(j, 256)]; + OPM_objname[__X(i, 64)] = ch; + j += 1; + i += 1; + } while (!(ch == 0x00)); + } else { + __COPY(obj->name, OPM_objname, 64); + } + if (errcode == 249) { + if (OPM_noerr) { + OPT_err(errcode); + } + } else if (errcode == 253) { + if ((((!OPT_symNew && !OPT_symExtended)) && !OPT_extsf)) { + OPT_err(errcode); + } + OPT_symExtended = 1; + } else { + if ((!OPT_symNew && !OPT_newsf)) { + OPT_err(errcode); + } + OPT_symNew = 1; + } +} + +void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + if (*root == NIL) { + *root = obj; + *old = NIL; + } else { + ob0 = *root; + ob1 = ob0->right; + left = 0; + if (__STRCMP(obj->name, ob0->name) < 0) { + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(obj->name, ob0->name) > 0) { + ob1 = ob0->right; + left = 0; + } else { + *old = ob0; + return; + } + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(obj->name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob1->left; + left = 1; + } else if (__STRCMP(obj->name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob1->right; + left = 0; + } else { + *old = ob1; + break; + } + } else { + ob1 = obj; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + *old = NIL; + break; + } + } + } +} + +static void OPT_InName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + OPM_SymRCh(&ch); + name[__X(i, name__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_InMod (INT8 *mno) +{ + OPT_Object head = NIL; + OPS_Name name; + INT32 mn; + INT8 i; + mn = OPM_SymRInt(); + if (mn == 0) { + *mno = OPT_impCtxt.glbmno[0]; + } else { + if (mn == 16) { + OPT_InName((void*)name, 256); + if ((__STRCMP(name, OPT_SelfName) == 0 && !OPT_impCtxt.self)) { + OPT_err(154); + } + i = 0; + while ((i < OPT_nofGmod && __STRCMP(name, OPT_GlbMod[__X(i, 64)]->name) != 0)) { + i += 1; + } + if (i < OPT_nofGmod) { + *mno = i; + } else { + head = OPT_NewObj(); + head->mode = 12; + __COPY(name, head->name, 256); + *mno = OPT_nofGmod; + head->mnolev = -*mno; + if (OPT_nofGmod < 64) { + OPT_GlbMod[__X(*mno, 64)] = head; + OPT_nofGmod += 1; + } else { + OPT_err(227); + } + } + OPT_impCtxt.glbmno[__X(OPT_impCtxt.nofm, 64)] = *mno; + OPT_impCtxt.nofm += 1; + } else { + *mno = OPT_impCtxt.glbmno[__X(-mn, 64)]; + } + } +} + +static void OPT_InLinks (void) +{ + OPS_Name linkname; + OPT_Link l = NIL; + OPT_InName((void*)linkname, 256); + while (linkname[0] != 0x00) { + l = OPT_Links; + while ((l != NIL && __STRCMP(l->name, linkname) != 0)) { + l = l->next; + } + if (l == NIL) { + l = OPT_Links; + __NEW(OPT_Links, OPT_LinkDesc); + OPT_Links->next = l; + __MOVE(linkname, OPT_Links->name, 256); + } + OPT_InName((void*)linkname, 256); + } +} + +static void OPT_InConstant (INT32 f, OPT_Const conval) +{ + CHAR ch; + INT16 i; + OPT_ConstExt ext = NIL; + REAL rval; + switch (f) { + case 1: case 3: case 2: + OPM_SymRCh(&ch); + conval->intval = (INT16)ch; + break; + case 4: + conval->intval = OPM_SymRInt(); + break; + case 7: + OPM_SymRSet(&conval->setval); + break; + case 5: + OPM_SymRReal(&rval); + conval->realval = rval; + conval->intval = -1; + break; + case 6: + OPM_SymRLReal(&conval->realval); + conval->intval = -1; + break; + case 8: + ext = OPT_NewExt(); + conval->ext = ext; + i = 0; + do { + OPM_SymRCh(&ch); + (*ext)[__X(i, 256)] = ch; + i += 1; + } while (!(ch == 0x00)); + conval->intval2 = i; + conval->intval = -1; + break; + case 9: + conval->intval = 0; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", 37); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } +} + +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par) +{ + OPT_Object last = NIL, new = NIL; + INT32 tag; + OPT_InStruct(&*res); + tag = OPM_SymRInt(); + last = NIL; + while (tag != 18) { + if (tag < 0 || tag > 100) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag value in InSign: ", 37); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return; + } + new = OPT_NewObj(); + new->mnolev = -mno; + if (last == NIL) { + *par = new; + } else { + last->link = new; + } + if (tag == 23) { + new->mode = 1; + } else { + new->mode = 2; + } + OPT_InStruct(&new->typ); + new->adr = OPM_SymRInt(); + OPT_InName((void*)new->name, 256); + last = new; + tag = OPM_SymRInt(); + } +} + +static OPT_Object OPT_InFld (void) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + if (tag <= 26) { + obj->mode = 4; + if (tag == 26) { + obj->vis = 2; + } else { + obj->vis = 1; + } + OPT_InStruct(&obj->typ); + OPT_InName((void*)obj->name, 256); + obj->adr = OPM_SymRInt(); + } else { + obj->mode = 4; + if (tag == 27) { + __MOVE("@ptr", obj->name, 5); + } else { + __MOVE("@proc", obj->name, 6); + } + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = OPM_SymRInt(); + } + return obj; +} + +static OPT_Object OPT_InTProc (INT8 mno) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + obj->mnolev = -mno; + if (tag == 29) { + obj->mode = 13; + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + obj->vis = 1; + OPT_InName((void*)obj->name, 256); + obj->adr = __ASHL(OPM_SymRInt(), 16); + } else { + obj->mode = 13; + __MOVE("@tproc", obj->name, 7); + obj->link = OPT_NewObj(); + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = __ASHL(OPM_SymRInt(), 16); + } + return obj; +} + +static OPT_Struct OPT_InTyp (INT32 tag) +{ + if (tag == 4) { + return OPT_IntType(OPM_SymRInt()); + } else if (tag == 7) { + return OPT_SetType(OPM_SymRInt()); + } else { + return OPT_impCtxt.ref[__X(tag, 255)]; + } + __RETCHK; +} + +static void OPT_InStruct (OPT_Struct *typ) +{ + INT8 mno; + INT16 ref; + INT32 tag; + OPS_Name name; + OPT_Struct t = NIL; + OPT_Object obj = NIL, last = NIL, fld = NIL, old = NIL, dummy = NIL; + tag = OPM_SymRInt(); + if (tag != 34) { + *typ = OPT_InTyp(-tag); + } else { + ref = OPT_impCtxt.nofr; + OPT_impCtxt.nofr += 1; + if (ref < OPT_impCtxt.minr) { + OPT_impCtxt.minr = ref; + } + OPT_InMod(&mno); + OPT_InName((void*)name, 256); + obj = OPT_NewObj(); + if (name[0] == 0x00) { + if (OPT_impCtxt.self) { + old = NIL; + } else { + __MOVE("@", obj->name, 2); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + obj->name[0] = 0x00; + } + *typ = OPT_NewStr(0, 1); + } else { + __MOVE(name, obj->name, 256); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (old != NIL) { + OPT_FPrintObj(old); + OPT_impCtxt.pvfp[__X(ref, 255)] = old->typ->pvfp; + if (OPT_impCtxt.self) { + *typ = OPT_NewStr(0, 1); + } else { + *typ = old->typ; + (*typ)->link = NIL; + (*typ)->sysflag = 0; + (*typ)->fpdone = 0; + (*typ)->idfpdone = 0; + } + } else { + *typ = OPT_NewStr(0, 1); + } + } + OPT_impCtxt.ref[__X(ref, 255)] = *typ; + OPT_impCtxt.old[__X(ref, 255)] = old; + (*typ)->ref = ref + 255; + (*typ)->mno = mno; + (*typ)->allocated = 1; + (*typ)->strobj = obj; + obj->mode = 5; + obj->typ = *typ; + obj->mnolev = -mno; + obj->vis = 0; + tag = OPM_SymRInt(); + if (tag == 35) { + (*typ)->sysflag = __SHORTF(OPM_SymRInt(), 32768); + tag = OPM_SymRInt(); + } + switch (tag) { + case 36: + (*typ)->form = 11; + (*typ)->size = OPM_AddressSize; + (*typ)->n = 0; + OPT_InStruct(&(*typ)->BaseTyp); + break; + case 37: + (*typ)->form = 13; + (*typ)->comp = 2; + OPT_InStruct(&(*typ)->BaseTyp); + (*typ)->n = OPM_SymRInt(); + OPT_TypSize(*typ); + break; + case 38: + (*typ)->form = 13; + (*typ)->comp = 3; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + OPT_TypSize(*typ); + break; + case 39: + (*typ)->form = 13; + (*typ)->comp = 4; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp == OPT_notyp) { + (*typ)->BaseTyp = NIL; + } + (*typ)->extlev = 0; + t = (*typ)->BaseTyp; + while (t != NIL) { + (*typ)->extlev += 1; + t = t->BaseTyp; + } + (*typ)->size = OPM_SymRInt(); + (*typ)->align = OPM_SymRInt(); + (*typ)->n = OPM_SymRInt(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + last = NIL; + while ((OPT_impCtxt.nextTag >= 25 && OPT_impCtxt.nextTag <= 28)) { + fld = OPT_InFld(); + fld->mnolev = -mno; + if (last != NIL) { + last->link = fld; + } + last = fld; + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + while (OPT_impCtxt.nextTag != 18) { + fld = OPT_InTProc(mno); + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + break; + case 40: + (*typ)->form = 12; + (*typ)->size = OPM_AddressSize; + OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", 35); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + break; + } + if (ref == OPT_impCtxt.minr) { + while (ref < OPT_impCtxt.nofr) { + t = OPT_InTyp(ref); + OPT_FPrintStr(t); + obj = t->strobj; + if (obj->name[0] != 0x00) { + OPT_FPrintObj(obj); + } + old = OPT_impCtxt.old[__X(ref, 255)]; + if (old != NIL) { + t->strobj = old; + if (OPT_impCtxt.self) { + if (old->mnolev < 0) { + if (old->history != 5) { + if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } + } + } else if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } else if (old->vis == 0) { + old->history = 1; + } else { + old->history = 0; + } + } else { + if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 5; + } + if (old->fprint != obj->fprint) { + OPT_FPrintErr(old, 249); + } + } + } else if (OPT_impCtxt.self) { + obj->history = 4; + } else { + obj->history = 1; + } + ref += 1; + } + OPT_impCtxt.minr = 255; + } + } +} + +static OPT_Object OPT_InObj (INT8 mno) +{ + INT16 i, s; + CHAR ch; + OPT_Object obj = NIL, old = NIL; + OPT_Struct typ = NIL; + INT32 tag; + OPT_ConstExt ext = NIL; + OPS_Name commentText; + BOOLEAN hasComment; + INT16 j; + INT32 len; + tag = OPT_impCtxt.nextTag; + hasComment = 0; + while (tag == 41) { + len = OPM_SymRInt(); + if (len < 0) { + len = 0; + } + if (len > 255) { + len = 255; + } + i = 0; + while (i < len) { + OPM_SymRCh(&commentText[__X(i, 256)]); + i += 1; + } + commentText[__X(i, 256)] = 0x00; + hasComment = 1; + tag = OPM_SymRInt(); + } + OPT_impCtxt.nextTag = tag; + if (tag < 0 || tag > 50) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag in InObj: ", 30); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + if (tag == 19) { + OPT_InStruct(&typ); + obj = typ->strobj; + if (!OPT_impCtxt.self) { + obj->vis = 1; + } + } else { + obj = OPT_NewObj(); + obj->mnolev = -mno; + obj->vis = 1; + if (tag <= 11) { + obj->mode = 3; + obj->conval = OPT_NewConst(); + OPT_InConstant(tag, obj->conval); + obj->typ = OPT_InTyp(tag); + } else if ((tag >= 31 && tag <= 33)) { + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + switch (tag) { + case 31: + obj->mode = 7; + break; + case 32: + obj->mode = 10; + break; + case 33: + obj->mode = 9; + ext = OPT_NewExt(); + obj->conval->ext = ext; + s = __SHORTF(OPM_SymRInt(), 32768); + (*ext)[0] = __CHR(s); + i = 1; + while (i <= s) { + OPM_SymRCh(&(*ext)[__X(i, 256)]); + i += 1; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", 32); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + break; + } + } else if (tag == 20) { + obj->mode = 5; + OPT_InStruct(&obj->typ); + } else if (tag == 21 || tag == 22) { + obj->mode = 1; + if (tag == 22) { + obj->vis = 2; + } + OPT_InStruct(&obj->typ); + } else { + OPM_LogWStr((CHAR*)"ERROR: Unexpected tag in InObj: ", 33); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + OPT_InName((void*)obj->name, 256); + } + if ((hasComment && obj != NIL)) { + obj->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((((j < 255 && j < len)) && commentText[__X(j, 256)] != 0x00)) { + (*obj->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*obj->comment)[__X(j, 256)] = 0x00; + } + OPT_FPrintObj(obj); + if ((obj->mode == 1 && (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00))) { + OPM_FPrint(&OPT_impCtxt.reffp, obj->typ->ref - 255); + } + if (tag != 19) { + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (OPT_impCtxt.self) { + if (old != NIL) { + if (old->vis == 0) { + old->history = 4; + } else { + OPT_FPrintObj(old); + if (obj->fprint != old->fprint) { + old->history = 2; + } else if (obj->typ->pvfp != old->typ->pvfp) { + old->history = 3; + } else { + old->history = 1; + } + } + } else { + obj->history = 4; + } + } + } else { + if (OPT_impCtxt.self) { + if (obj->vis == 0) { + obj->history = 4; + } else if (obj->history == 0) { + obj->history = 1; + } + } + } + return obj; +} + +void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done) +{ + OPT_Object obj = NIL; + INT8 mno; + OPS_Name aliasName__copy; + __DUPARR(aliasName, OPS_Name); + if (__STRCMP(name, "SYSTEM") == 0) { + OPT_SYSimported = 1; + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->mnolev = 0; + obj->scope = OPT_syslink; + obj->typ = OPT_notyp; + } else { + OPT_impCtxt.nofr = 14; + OPT_impCtxt.minr = 255; + OPT_impCtxt.nofm = 0; + OPT_impCtxt.self = __STRCMP(aliasName, "@self") == 0; + OPT_impCtxt.reffp = 0; + if ((OPT_impCtxt.self && __IN(17, OPM_Options, 32))) { + OPM_DeleteSym((void*)name, 256); + *done = 0; + } else { + OPM_OldSym((void*)name, 256, &*done); + } + if (*done) { + OPT_InMod(&mno); + OPT_InLinks(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + while (!OPM_eofSF()) { + obj = OPT_InObj(mno); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->scope = OPT_GlbMod[__X(mno, 64)]->right; + OPT_GlbMod[__X(mno, 64)]->link = obj; + obj->mnolev = -mno; + obj->typ = OPT_notyp; + OPM_CloseOldSym(); + } else if (OPT_impCtxt.self) { + OPT_newsf = 1; + OPT_extsf = 1; + OPT_sfpresent = 0; + } else { + OPT_err(152); + } + } +} + +static void OPT_OutName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_SymWCh(ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_OutMod (INT16 mno) +{ + if (OPT_expCtxt.locmno[__X(mno, 64)] < 0) { + OPM_SymWInt(16); + OPT_expCtxt.locmno[__X(mno, 64)] = OPT_expCtxt.nofm; + OPT_expCtxt.nofm += 1; + OPT_OutName((void*)OPT_GlbMod[__X(mno, 64)]->name, 256); + } else { + OPM_SymWInt(-OPT_expCtxt.locmno[__X(mno, 64)]); + } +} + +static void OPT_OutLinks (void) +{ + OPT_Link l = NIL; + l = OPT_Links; + while (l != NIL) { + OPT_OutName((void*)l->name, 256); + l = l->next; + } + OPM_SymWCh(0x00); +} + +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + OPT_OutFlds(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + OPT_OutHdFld(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + OPT_OutHdFld(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_SymWInt(27); + OPM_SymWInt(adr); + OPT_nofhdfld += 1; + } +} + +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + if (fld->vis == 2) { + OPM_SymWInt(26); + } else { + OPM_SymWInt(25); + } + OPT_OutStr(fld->typ); + OPT_OutName((void*)fld->name, 256); + OPM_SymWInt(fld->adr); + } else { + OPT_OutHdFld(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void OPT_OutSign (OPT_Struct result, OPT_Object par) +{ + OPT_OutStr(result); + while (par != NIL) { + if (par->mode == 1) { + OPM_SymWInt(23); + } else { + OPM_SymWInt(24); + } + OPT_OutStr(par->typ); + OPM_SymWInt(par->adr); + OPT_OutName((void*)par->name, 256); + par = par->link; + } + OPM_SymWInt(18); +} + +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj) +{ + if (obj != NIL) { + OPT_OutTProcs(typ, obj->left); + if (obj->mode == 13) { + if ((((typ->BaseTyp != NIL && __ASHR(obj->adr, 16) < typ->BaseTyp->n)) && obj->vis == 0)) { + OPM_Mark(109, typ->txtpos); + } + if (obj->vis != 0) { + if (obj->vis != 0) { + OPM_SymWInt(29); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } else { + OPM_SymWInt(30); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } + } + } + OPT_OutTProcs(typ, obj->right); + } +} + +static void OPT_OutStr (OPT_Struct typ) +{ + OPT_Object strobj = NIL; + if (typ->ref < OPT_expCtxt.ref) { + OPM_SymWInt(-typ->ref); + if (__IN(typ->ref, 0x90, 32)) { + OPM_SymWInt(typ->size); + } + } else { + OPM_SymWInt(34); + typ->ref = OPT_expCtxt.ref; + OPT_expCtxt.ref += 1; + if (OPT_expCtxt.ref >= 255) { + OPT_err(228); + } + OPT_OutMod(typ->mno); + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_OutName((void*)strobj->name, 256); + switch (strobj->history) { + case 2: + OPT_FPrintErr(strobj, 252); + break; + case 3: + OPT_FPrintErr(strobj, 251); + break; + case 5: + OPT_FPrintErr(strobj, 249); + break; + default: + break; + } + } else { + OPM_SymWCh(0x00); + } + if (typ->sysflag != 0) { + OPM_SymWInt(35); + OPM_SymWInt(typ->sysflag); + } + switch (typ->form) { + case 11: + OPM_SymWInt(36); + OPT_OutStr(typ->BaseTyp); + break; + case 12: + OPM_SymWInt(40); + OPT_OutSign(typ->BaseTyp, typ->link); + break; + case 13: + switch (typ->comp) { + case 2: + OPM_SymWInt(37); + OPT_OutStr(typ->BaseTyp); + OPM_SymWInt(typ->n); + break; + case 3: + OPM_SymWInt(38); + OPT_OutStr(typ->BaseTyp); + break; + case 4: + OPM_SymWInt(39); + if (typ->BaseTyp == NIL) { + OPT_OutStr(OPT_notyp); + } else { + OPT_OutStr(typ->BaseTyp); + } + OPM_SymWInt(typ->size); + OPM_SymWInt(typ->align); + OPM_SymWInt(typ->n); + OPT_nofhdfld = 0; + OPT_OutFlds(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(223, typ->txtpos); + } + OPT_OutTProcs(typ, typ->link); + OPM_SymWInt(18); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", 39); + OPM_LogWNum(typ->comp, 0); + OPM_LogWLn(); + break; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", 39); + OPM_LogWNum(typ->form, 0); + OPM_LogWLn(); + break; + } + } +} + +static void OPT_OutConstant (OPT_Object obj) +{ + INT16 f; + REAL rval; + f = obj->typ->form; + OPM_SymWInt(f); + switch (f) { + case 2: case 3: + OPM_SymWCh(__CHR(obj->conval->intval)); + break; + case 4: + OPM_SymWInt(obj->conval->intval); + OPM_SymWInt(obj->typ->size); + break; + case 7: + OPM_SymWSet(obj->conval->setval); + OPM_SymWInt(obj->typ->size); + break; + case 5: + rval = obj->conval->realval; + OPM_SymWReal(rval); + break; + case 6: + OPM_SymWLReal(obj->conval->realval); + break; + case 8: + OPT_OutName((void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } +} + +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_SymWCh(text[__X(i, text__len)]); + i += 1; + } + OPM_SymWCh(0x00); + __DEL(text); +} + +static void OPT_OutObj (OPT_Object obj) +{ + INT16 i, j; + OPT_ConstExt ext = NIL; + INT16 k, l; + if (obj != NIL) { + OPT_OutObj(obj->left); + if (__IN(obj->mode, 0x06ea, 32)) { + if (obj->comment != NIL) { + OPM_SymWInt(41); + k = 0; + while ((k < 255 && (*obj->comment)[__X(k, 256)] != 0x00)) { + k += 1; + } + OPM_SymWInt(k); + l = 0; + while (l < k) { + OPM_SymWCh((*obj->comment)[__X(l, 256)]); + l += 1; + } + } + if (obj->history == 4) { + OPT_FPrintErr(obj, 250); + } else if (obj->vis != 0) { + switch (obj->history) { + case 0: + OPT_FPrintErr(obj, 253); + break; + case 1: + break; + case 2: + OPT_FPrintErr(obj, 252); + break; + case 3: + OPT_FPrintErr(obj, 251); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", 42); + OPM_LogWNum(obj->history, 0); + OPM_LogWLn(); + break; + } + switch (obj->mode) { + case 3: + OPT_OutConstant(obj); + OPT_OutName((void*)obj->name, 256); + break; + case 5: + if (obj->typ->strobj == obj) { + OPM_SymWInt(19); + OPT_OutStr(obj->typ); + } else { + OPM_SymWInt(20); + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + } + break; + case 1: + if (obj->vis == 2) { + OPM_SymWInt(22); + } else { + OPM_SymWInt(21); + } + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + if (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00) { + OPM_FPrint(&OPT_expCtxt.reffp, obj->typ->ref); + } + break; + case 7: + OPM_SymWInt(31); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 10: + OPM_SymWInt(32); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 9: + OPM_SymWInt(33); + OPT_OutSign(obj->typ, obj->link); + ext = obj->conval->ext; + j = (INT16)(*ext)[0]; + i = 1; + OPM_SymWInt(j); + while (i <= j) { + OPM_SymWCh((*ext)[__X(i, 256)]); + i += 1; + } + OPT_OutName((void*)obj->name, 256); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", 38); + OPM_LogWNum(obj->mode, 0); + OPM_LogWLn(); + break; + } + } + } + OPT_OutObj(obj->right); + } +} + +void OPT_Export (BOOLEAN *ext, BOOLEAN *new) +{ + INT16 i; + INT8 nofmod; + BOOLEAN done; + OPT_symExtended = 0; + OPT_symNew = 0; + nofmod = OPT_nofGmod; + OPT_Import((CHAR*)"@self", OPT_SelfName, &done); + OPT_nofGmod = nofmod; + if (OPM_noerr) { + OPM_NewSym((void*)OPT_SelfName, 256); + if (OPM_noerr) { + OPM_SymWInt(16); + OPT_OutName((void*)OPT_SelfName, 256); + OPT_OutLinks(); + OPT_expCtxt.reffp = 0; + OPT_expCtxt.ref = 14; + OPT_expCtxt.nofm = 1; + OPT_expCtxt.locmno[0] = 0; + i = 1; + while (i < 64) { + OPT_expCtxt.locmno[__X(i, 64)] = -1; + i += 1; + } + OPT_OutObj(OPT_topScope->right); + *ext = (OPT_sfpresent && OPT_symExtended); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); + if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { + *new = 1; + if (!OPT_extsf) { + OPT_err(155); + } + } + OPT_newsf = 0; + OPT_symNew = 0; + if (!OPM_noerr || OPT_findpc) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } +} + +static void OPT_InitStruct (OPT_Struct *typ, INT8 form) +{ + *typ = OPT_NewStr(form, 1); + (*typ)->ref = form; + (*typ)->size = 1; + (*typ)->allocated = 1; + (*typ)->strobj = OPT_NewObj(); + (*typ)->pbfp = form; + (*typ)->pvfp = form; + (*typ)->fpdone = 1; + (*typ)->idfp = form; + (*typ)->idfpdone = 1; +} + +static void OPT_EnterBoolConst (OPS_Name name, INT32 value) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->conval = OPT_NewConst(); + obj->mode = 3; + obj->typ = OPT_booltyp; + obj->conval->intval = value; +} + +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + typ = OPT_NewStr(form, 1); + obj->mode = 5; + obj->typ = typ; + obj->vis = 1; + typ->strobj = obj; + typ->size = size; + typ->ref = form; + typ->allocated = 1; + typ->pbfp = form; + typ->pvfp = form; + typ->fpdone = 1; + typ->idfp = form; + typ->idfpdone = 1; + if (__IN(form, 0x90, 32)) { + OPM_FPrint(&typ->idfp, typ->size); + } + *res = typ; +} + +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 5; + obj->typ = NIL; + obj->vis = 1; + *res = obj; +} + +static void OPT_EnterProc (OPS_Name name, INT16 num) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 8; + obj->typ = OPT_notyp; + obj->adr = num; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPT_topScope); + P(OPT_undftyp); + P(OPT_niltyp); + P(OPT_notyp); + P(OPT_bytetyp); + P(OPT_cpbytetyp); + P(OPT_booltyp); + P(OPT_chartyp); + P(OPT_sinttyp); + P(OPT_inttyp); + P(OPT_linttyp); + P(OPT_hinttyp); + P(OPT_int8typ); + P(OPT_int16typ); + P(OPT_int32typ); + P(OPT_int64typ); + P(OPT_settyp); + P(OPT_set32typ); + P(OPT_set64typ); + P(OPT_realtyp); + P(OPT_lrltyp); + P(OPT_stringtyp); + P(OPT_adrtyp); + P(OPT_sysptrtyp); + P(OPT_sintobj); + P(OPT_intobj); + P(OPT_lintobj); + P(OPT_setobj); + __ENUMP(OPT_GlbMod, 64, P); + P(OPT_universe); + P(OPT_syslink); + __ENUMR(&OPT_impCtxt, OPT_ImpCtxt__typ, 3140, 1, P); + P(OPT_Links); +} + +__TDESC(OPT_ConstDesc, 1, 1) = {__TDFLDS("ConstDesc", 32), {0, -8}}; +__TDESC(OPT_ObjDesc, 1, 7) = {__TDFLDS("ObjDesc", 308), {0, 4, 8, 12, 284, 288, 304, -32}}; +__TDESC(OPT_StrDesc, 1, 3) = {__TDFLDS("StrDesc", 56), {44, 48, 52, -16}}; +__TDESC(OPT_NodeDesc, 1, 6) = {__TDFLDS("NodeDesc", 28), {0, 4, 8, 16, 20, 24, -28}}; +__TDESC(OPT_ImpCtxt, 1, 510) = {__TDFLDS("ImpCtxt", 3140), {16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60, 64, 68, 72, 76, + 80, 84, 88, 92, 96, 100, 104, 108, 112, 116, 120, 124, 128, 132, 136, 140, + 144, 148, 152, 156, 160, 164, 168, 172, 176, 180, 184, 188, 192, 196, 200, 204, + 208, 212, 216, 220, 224, 228, 232, 236, 240, 244, 248, 252, 256, 260, 264, 268, + 272, 276, 280, 284, 288, 292, 296, 300, 304, 308, 312, 316, 320, 324, 328, 332, + 336, 340, 344, 348, 352, 356, 360, 364, 368, 372, 376, 380, 384, 388, 392, 396, + 400, 404, 408, 412, 416, 420, 424, 428, 432, 436, 440, 444, 448, 452, 456, 460, + 464, 468, 472, 476, 480, 484, 488, 492, 496, 500, 504, 508, 512, 516, 520, 524, + 528, 532, 536, 540, 544, 548, 552, 556, 560, 564, 568, 572, 576, 580, 584, 588, + 592, 596, 600, 604, 608, 612, 616, 620, 624, 628, 632, 636, 640, 644, 648, 652, + 656, 660, 664, 668, 672, 676, 680, 684, 688, 692, 696, 700, 704, 708, 712, 716, + 720, 724, 728, 732, 736, 740, 744, 748, 752, 756, 760, 764, 768, 772, 776, 780, + 784, 788, 792, 796, 800, 804, 808, 812, 816, 820, 824, 828, 832, 836, 840, 844, + 848, 852, 856, 860, 864, 868, 872, 876, 880, 884, 888, 892, 896, 900, 904, 908, + 912, 916, 920, 924, 928, 932, 936, 940, 944, 948, 952, 956, 960, 964, 968, 972, + 976, 980, 984, 988, 992, 996, 1000, 1004, 1008, 1012, 1016, 1020, 1024, 1028, 1032, 1036, + 1040, 1044, 1048, 1052, 1056, 1060, 1064, 1068, 1072, 1076, 1080, 1084, 1088, 1092, 1096, 1100, + 1104, 1108, 1112, 1116, 1120, 1124, 1128, 1132, 1136, 1140, 1144, 1148, 1152, 1156, 1160, 1164, + 1168, 1172, 1176, 1180, 1184, 1188, 1192, 1196, 1200, 1204, 1208, 1212, 1216, 1220, 1224, 1228, + 1232, 1236, 1240, 1244, 1248, 1252, 1256, 1260, 1264, 1268, 1272, 1276, 1280, 1284, 1288, 1292, + 1296, 1300, 1304, 1308, 1312, 1316, 1320, 1324, 1328, 1332, 1336, 1340, 1344, 1348, 1352, 1356, + 1360, 1364, 1368, 1372, 1376, 1380, 1384, 1388, 1392, 1396, 1400, 1404, 1408, 1412, 1416, 1420, + 1424, 1428, 1432, 1436, 1440, 1444, 1448, 1452, 1456, 1460, 1464, 1468, 1472, 1476, 1480, 1484, + 1488, 1492, 1496, 1500, 1504, 1508, 1512, 1516, 1520, 1524, 1528, 1532, 1536, 1540, 1544, 1548, + 1552, 1556, 1560, 1564, 1568, 1572, 1576, 1580, 1584, 1588, 1592, 1596, 1600, 1604, 1608, 1612, + 1616, 1620, 1624, 1628, 1632, 1636, 1640, 1644, 1648, 1652, 1656, 1660, 1664, 1668, 1672, 1676, + 1680, 1684, 1688, 1692, 1696, 1700, 1704, 1708, 1712, 1716, 1720, 1724, 1728, 1732, 1736, 1740, + 1744, 1748, 1752, 1756, 1760, 1764, 1768, 1772, 1776, 1780, 1784, 1788, 1792, 1796, 1800, 1804, + 1808, 1812, 1816, 1820, 1824, 1828, 1832, 1836, 1840, 1844, 1848, 1852, 1856, 1860, 1864, 1868, + 1872, 1876, 1880, 1884, 1888, 1892, 1896, 1900, 1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, + 1936, 1940, 1944, 1948, 1952, 1956, 1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, + 2000, 2004, 2008, 2012, 2016, 2020, 2024, 2028, 2032, 2036, 2040, 2044, 2048, 2052, -2044}}; +__TDESC(OPT_ExpCtxt, 1, 0) = {__TDFLDS("ExpCtxt", 72), {-4}}; +__TDESC(OPT_LinkDesc, 1, 1) = {__TDFLDS("LinkDesc", 260), {256, -8}}; + +export void *OPT__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __REGMOD("OPT", EnumPtrs); + __REGCMD("Close", OPT_Close); + __REGCMD("CloseScope", OPT_CloseScope); + __REGCMD("InitRecno", OPT_InitRecno); + __INITYP(OPT_ConstDesc, OPT_ConstDesc, 0); + __INITYP(OPT_ObjDesc, OPT_ObjDesc, 0); + __INITYP(OPT_StrDesc, OPT_StrDesc, 0); + __INITYP(OPT_NodeDesc, OPT_NodeDesc, 0); + __INITYP(OPT_ImpCtxt, OPT_ImpCtxt, 0); + __INITYP(OPT_ExpCtxt, OPT_ExpCtxt, 0); + __INITYP(OPT_LinkDesc, OPT_LinkDesc, 0); +/* BEGIN */ + OPT_topScope = NIL; + OPT_OpenScope(0, NIL); + OPM_errpos = 0; + OPT_InitStruct(&OPT_undftyp, 0); + OPT_undftyp->BaseTyp = OPT_undftyp; + OPT_InitStruct(&OPT_notyp, 10); + OPT_InitStruct(&OPT_stringtyp, 8); + OPT_InitStruct(&OPT_niltyp, 9); + OPT_EnterTyp((CHAR*)"BYTE", 1, 1, &OPT_bytetyp); + OPT_EnterTyp((CHAR*)"PTR", 11, -1, &OPT_sysptrtyp); + OPT_EnterTyp((CHAR*)"ADDRESS", 4, -1, &OPT_adrtyp); + OPT_EnterTyp((CHAR*)"INT8", 4, 1, &OPT_int8typ); + OPT_EnterTyp((CHAR*)"INT16", 4, 2, &OPT_int16typ); + OPT_EnterTyp((CHAR*)"INT32", 4, 4, &OPT_int32typ); + OPT_EnterTyp((CHAR*)"INT64", 4, 8, &OPT_int64typ); + OPT_EnterTyp((CHAR*)"SET32", 7, 4, &OPT_set32typ); + OPT_EnterTyp((CHAR*)"SET64", 7, 8, &OPT_set64typ); + OPT_EnterProc((CHAR*)"ADR", 20); + OPT_EnterProc((CHAR*)"CC", 21); + OPT_EnterProc((CHAR*)"LSH", 22); + OPT_EnterProc((CHAR*)"ROT", 23); + OPT_EnterProc((CHAR*)"GET", 24); + OPT_EnterProc((CHAR*)"PUT", 25); + OPT_EnterProc((CHAR*)"GETREG", 26); + OPT_EnterProc((CHAR*)"PUTREG", 27); + OPT_EnterProc((CHAR*)"BIT", 28); + OPT_EnterProc((CHAR*)"VAL", 29); + OPT_EnterProc((CHAR*)"NEW", 30); + OPT_EnterProc((CHAR*)"MOVE", 31); + OPT_syslink = OPT_topScope->right; + OPT_universe = OPT_topScope; + OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, 1, &OPT_booltyp); + OPT_EnterTyp((CHAR*)"CHAR", 3, 1, &OPT_chartyp); + OPT_EnterTyp((CHAR*)"REAL", 5, 4, &OPT_realtyp); + OPT_EnterTyp((CHAR*)"LONGREAL", 6, 8, &OPT_lrltyp); + OPT_EnterTyp((CHAR*)"HUGEINT", 4, 8, &OPT_hinttyp); + OPT_EnterTyp((CHAR*)"BYTE@", 4, 1, &OPT_cpbytetyp); + OPT_EnterTypeAlias((CHAR*)"SHORTINT", &OPT_sintobj); + OPT_EnterTypeAlias((CHAR*)"INTEGER", &OPT_intobj); + OPT_EnterTypeAlias((CHAR*)"LONGINT", &OPT_lintobj); + OPT_EnterTypeAlias((CHAR*)"SET", &OPT_setobj); + OPT_EnterBoolConst((CHAR*)"FALSE", 0); + OPT_EnterBoolConst((CHAR*)"TRUE", 1); + OPT_EnterProc((CHAR*)"HALT", 0); + OPT_EnterProc((CHAR*)"NEW", 1); + OPT_EnterProc((CHAR*)"ABS", 2); + OPT_EnterProc((CHAR*)"CAP", 3); + OPT_EnterProc((CHAR*)"ORD", 4); + OPT_EnterProc((CHAR*)"ENTIER", 5); + OPT_EnterProc((CHAR*)"ODD", 6); + OPT_EnterProc((CHAR*)"MIN", 7); + OPT_EnterProc((CHAR*)"MAX", 8); + OPT_EnterProc((CHAR*)"CHR", 9); + OPT_EnterProc((CHAR*)"SHORT", 10); + OPT_EnterProc((CHAR*)"LONG", 11); + OPT_EnterProc((CHAR*)"SIZE", 12); + OPT_EnterProc((CHAR*)"INC", 13); + OPT_EnterProc((CHAR*)"DEC", 14); + OPT_EnterProc((CHAR*)"INCL", 15); + OPT_EnterProc((CHAR*)"EXCL", 16); + OPT_EnterProc((CHAR*)"LEN", 17); + OPT_EnterProc((CHAR*)"COPY", 18); + OPT_EnterProc((CHAR*)"ASH", 19); + OPT_EnterProc((CHAR*)"ASSERT", 32); + OPT_impCtxt.ref[0] = OPT_undftyp; + OPT_impCtxt.ref[1] = OPT_bytetyp; + OPT_impCtxt.ref[2] = OPT_booltyp; + OPT_impCtxt.ref[3] = OPT_chartyp; + OPT_impCtxt.ref[4] = OPT_int32typ; + OPT_impCtxt.ref[5] = OPT_realtyp; + OPT_impCtxt.ref[6] = OPT_lrltyp; + OPT_impCtxt.ref[7] = OPT_settyp; + OPT_impCtxt.ref[8] = OPT_stringtyp; + OPT_impCtxt.ref[9] = OPT_niltyp; + OPT_impCtxt.ref[10] = OPT_notyp; + OPT_impCtxt.ref[11] = OPT_sysptrtyp; + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPT.h b/bootstrap/unix-44/OPT.h new file mode 100644 index 00000000..cf456af5 --- /dev/null +++ b/bootstrap/unix-44/OPT.h @@ -0,0 +1,128 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPT__h +#define OPT__h + +#include "SYSTEM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused; + char _prvt0[4]; + INT32 idfp; + char _prvt1[8]; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +import OPT_Object OPT_topScope; +import OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +import OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +import INT8 OPT_nofGmod; +import OPT_Object OPT_GlbMod[64]; +import OPS_Name OPT_SelfName; +import BOOLEAN OPT_SYSimported; +import OPT_Link OPT_Links; + +import ADDRESS *OPT_ConstDesc__typ; +import ADDRESS *OPT_ObjDesc__typ; +import ADDRESS *OPT_StrDesc__typ; +import ADDRESS *OPT_NodeDesc__typ; +import ADDRESS *OPT_LinkDesc__typ; + +import void OPT_Align (INT32 *adr, INT32 base); +import INT32 OPT_BaseAlignment (OPT_Struct typ); +import void OPT_Close (void); +import void OPT_CloseScope (void); +import void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +import void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +import void OPT_FPrintObj (OPT_Object obj); +import void OPT_FPrintStr (OPT_Struct typ); +import void OPT_Find (OPT_Object *res); +import void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +import void OPT_FindImport (OPT_Object mod, OPT_Object *res); +import void OPT_IdFPrint (OPT_Struct typ); +import void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +import void OPT_Init (OPS_Name name, UINT32 opt); +import void OPT_InitRecno (void); +import void OPT_Insert (OPS_Name name, OPT_Object *obj); +import void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +import INT16 OPT_IntSize (INT64 n); +import OPT_Struct OPT_IntType (INT32 size); +import OPT_Const OPT_NewConst (void); +import OPT_ConstExt OPT_NewExt (void); +import OPT_Node OPT_NewNode (INT8 class); +import OPT_Object OPT_NewObj (void); +import OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +import void OPT_OpenScope (INT8 level, OPT_Object owner); +import OPT_Struct OPT_SetType (INT32 size); +import OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +import INT32 OPT_SizeAlignment (INT32 size); +import void OPT_TypSize (OPT_Struct typ); +import void *OPT__init(void); + + +#endif // OPT diff --git a/bootstrap/unix-44/OPV.c b/bootstrap/unix-44/OPV.c new file mode 100644 index 00000000..0425b2e0 --- /dev/null +++ b/bootstrap/unix-44/OPV.c @@ -0,0 +1,1585 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPC.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +typedef + struct OPV_ExitInfo { + INT16 level, label; + } OPV_ExitInfo; + + +static INT16 OPV_stamp; +static OPV_ExitInfo OPV_exit; +static INT16 OPV_nofExitLabels; + +export ADDRESS *OPV_ExitInfo__typ; + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp); +export void OPV_AdrAndSize (OPT_Object topScope); +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec); +static void OPV_DefineTDescs (OPT_Node n); +static void OPV_Entier (OPT_Node n, INT16 prec); +static void OPV_GetTProcNum (OPT_Object obj); +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc); +static BOOLEAN OPV_ImplicitReturn (OPT_Node n); +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim); +export void OPV_Init (void); +static void OPV_InitTDescs (OPT_Node n); +static void OPV_Len (OPT_Node n, INT64 dim); +export void OPV_Module (OPT_Node prog); +static void OPV_NewArr (OPT_Node d, OPT_Node x); +static void OPV_ParIntLiteral (INT64 n, INT32 size); +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp); +static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (OPT_Node n, INT32 to); +static void OPV_Stamp (OPS_Name s); +static OPT_Object OPV_SuperProc (OPT_Node n); +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); +static void OPV_TraverseRecord (OPT_Struct typ); +static void OPV_TypeOf (OPT_Node n); +static void OPV_design (OPT_Node n, INT16 prec); +static void OPV_expr (OPT_Node n, INT16 prec); +static void OPV_stat (OPT_Node n, OPT_Object outerProc); + + +void OPV_Init (void) +{ + OPV_stamp = 0; + OPV_nofExitLabels = 0; +} + +static void OPV_GetTProcNum (OPT_Object obj) +{ + INT32 oldPos; + OPT_Struct typ = NIL; + OPT_Object redef = NIL; + oldPos = OPM_errpos; + OPM_errpos = obj->scope->adr; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(obj->name, typ->BaseTyp, &redef); + if (redef != NIL) { + obj->adr = __ASHL(__ASHR(redef->adr, 16), 16); + if (!__IN(2, obj->conval->setval, 64)) { + OPM_err(119); + } + } else { + obj->adr += __ASHL(typ->n, 16); + typ->n += 1; + } + OPM_errpos = oldPos; +} + +static void OPV_TraverseRecord (OPT_Struct typ) +{ + if (!typ->allocated) { + if (typ->BaseTyp != NIL) { + OPV_TraverseRecord(typ->BaseTyp); + typ->n = typ->BaseTyp->n; + } + typ->allocated = 1; + OPV_Traverse(typ->link, typ->strobj, 0); + } +} + +static void OPV_Stamp (OPS_Name s) +{ + INT16 i, j, k; + CHAR n[10]; + OPV_stamp += 1; + i = 0; + j = OPV_stamp; + while (s[__X(i, 256)] != 0x00) { + i += 1; + } + if (i > 25) { + i = 25; + } + s[__X(i, 256)] = '_'; + s[__X(i + 1, 256)] = '_'; + i += 2; + k = 0; + do { + n[__X(k, 10)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } while (!(j == 0)); + do { + k -= 1; + s[__X(i, 256)] = n[__X(k, 10)]; + i += 1; + } while (!(k == 0)); + s[__X(i, 256)] = 0x00; +} + +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported) +{ + INT16 mode; + OPT_Object scope = NIL; + OPT_Struct typ = NIL; + if (obj != NIL) { + OPV_Traverse(obj->left, outerScope, exported); + if (obj->name[0] == '@') { + obj->name[0] = '_'; + OPV_Stamp(obj->name); + } + obj->linkadr = 0; + mode = obj->mode; + if ((mode == 5 && (obj->vis != 0) == exported)) { + typ = obj->typ; + OPT_TypSize(obj->typ); + if (typ->form == 11) { + typ = typ->BaseTyp; + } + if (typ->comp == 4) { + OPV_TraverseRecord(typ); + } + } else if (mode == 13) { + OPV_GetTProcNum(obj); + } else if (mode == 1) { + OPT_TypSize(obj->typ); + } + if (!exported) { + if ((__IN(mode, 0x60, 32) && obj->mnolev > 0)) { + OPV_Stamp(obj->name); + } + if (__IN(mode, 0x26, 32)) { + obj->scope = outerScope; + } else if (__IN(mode, 0x26c0, 32)) { + if (obj->conval->setval == 0x0) { + OPM_err(129); + } + scope = obj->scope; + scope->leaf = 1; + __MOVE(obj->name, scope->name, 256); + OPV_Stamp(scope->name); + if (mode == 9) { + obj->adr = 1; + } + if (scope->mnolev > 1) { + outerScope->leaf = 0; + } + OPV_Traverse(obj->scope->right, obj->scope, 0); + } + } + OPV_Traverse(obj->right, outerScope, exported); + } +} + +void OPV_AdrAndSize (OPT_Object topScope) +{ + __ASSERT(OPT_sinttyp != NIL, 0); + __ASSERT(OPT_inttyp != NIL, 0); + __ASSERT(OPT_linttyp != NIL, 0); + OPM_errpos = topScope->adr; + topScope->leaf = 1; + OPV_Traverse(topScope->right, topScope, 1); + OPV_Traverse(topScope->right, topScope, 0); + OPT_chartyp->strobj->linkadr = 2; + OPT_cpbytetyp->strobj->linkadr = 2; + OPT_settyp->strobj->linkadr = 2; + OPT_realtyp->strobj->linkadr = 2; + OPT_adrtyp->strobj->linkadr = 2; + OPT_int8typ->strobj->linkadr = 2; + OPT_int16typ->strobj->linkadr = 2; + OPT_int32typ->strobj->linkadr = 2; + OPT_int64typ->strobj->linkadr = 2; + OPT_set32typ->strobj->linkadr = 2; + OPT_set64typ->strobj->linkadr = 2; + OPT_hinttyp->strobj->linkadr = 2; + OPT_lrltyp->strobj->linkadr = 2; + OPT_booltyp->strobj->linkadr = 2; + OPT_bytetyp->strobj->linkadr = 2; + OPT_sysptrtyp->strobj->linkadr = 2; +} + +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp) +{ + switch (class) { + case 7: case 0: case 2: case 4: case 9: + case 13: + return 10; + break; + case 5: + if (__IN(3, OPM_Options, 32)) { + return 10; + } else { + return 9; + } + break; + case 1: + if (__IN(comp, 0x0c, 32)) { + return 10; + } else { + return 9; + } + break; + case 3: + return 9; + break; + case 11: + switch (subclass) { + case 33: case 7: case 24: case 29: case 20: + return 9; + break; + case 16: case 21: case 22: case 23: case 25: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 12: + switch (subclass) { + case 1: + if (form == 7) { + return 4; + } else { + return 8; + } + break; + case 2: + if (form == 7) { + return 3; + } else { + return 8; + } + break; + case 3: case 4: + return 10; + break; + case 6: + if (form == 7) { + return 2; + } else { + return 7; + } + break; + case 7: + if (form == 7) { + return 4; + } else { + return 7; + } + break; + case 11: case 12: case 13: case 14: + return 6; + break; + case 9: case 10: + return 5; + break; + case 5: + return 1; + break; + case 8: + return 0; + break; + case 19: case 15: case 17: case 18: case 26: + case 27: case 28: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 10: + return 10; + break; + case 8: case 6: + return 12; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence, class = ", 43); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + __RETCHK; +} + +static void OPV_Len (OPT_Node n, INT64 dim) +{ + INT64 d; + OPT_Struct array = NIL; + while ((n->class == 4 && n->typ->comp == 3)) { + dim += 1; + n = n->left; + } + if ((n->class == 3 && n->typ->comp == 3)) { + d = dim; + array = n->typ; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->len[", 7); + OPM_WriteInt(dim); + OPM_Write(']'); + } else { + OPM_WriteInt(array->n); + } + } else { + OPC_Len(n->obj, n->typ, dim); + } +} + +static BOOLEAN OPV_SideEffects (OPT_Node n) +{ + if (n != NIL) { + return (n->class == 13 || OPV_SideEffects(n->left)) || OPV_SideEffects(n->right); + } else { + return 0; + } + __RETCHK; +} + +static void OPV_Entier (OPT_Node n, INT16 prec) +{ + if (__IN(n->typ->form, 0x60, 32)) { + OPM_WriteString((CHAR*)"__ENTIER(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else { + OPV_expr(n, prec); + } +} + +static void OPV_SizeCast (OPT_Node n, INT32 to) +{ + if ((to < n->typ->size && __IN(2, OPM_Options, 32))) { + OPM_WriteString((CHAR*)"__SHORT", 8); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPM_SignedMaximum(to) + 1); + OPM_Write(')'); + } else { + if ((n->typ->size != to && (n->typ->size > 4 || to != 4))) { + OPM_WriteString((CHAR*)"(INT", 5); + OPM_WriteInt(__ASHL(to, 3)); + OPM_WriteString((CHAR*)")", 2); + } + OPV_Entier(n, 9); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec) +{ + INT16 from, to; + from = n->typ->form; + to = newtype->form; + if (to == 7) { + if (from == 7) { + OPV_SizeCast(n, newtype->size); + } else { + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(newtype->size, 3)); + OPM_Write(')'); + } + } else if (to == 4) { + OPV_SizeCast(n, newtype->size); + } else if (to == 3) { + if (__IN(2, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__CHR", 6); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_Write(')'); + } else { + OPM_WriteString((CHAR*)"(CHAR)", 7); + OPV_Entier(n, 9); + } + } else { + OPV_expr(n, prec); + } +} + +static void OPV_TypeOf (OPT_Node n) +{ + if (n->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else if (__IN(n->class, 0x15, 32)) { + OPC_Andent(n->typ); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (n->class == 3) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n->left, -1); + OPM_Write(')'); + } else if (n->class == 5) { + OPV_TypeOf(n->left); + } else if ((n->class == 11 && n->subcl == 29)) { + OPC_TypeOf(n->left->obj); + } else { + OPC_TypeOf(n->obj); + } +} + +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim) +{ + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + OPV_expr(n->right, prec); + } else { + if (OPV_SideEffects(n->right)) { + OPM_WriteString((CHAR*)"__XF(", 6); + } else { + OPM_WriteString((CHAR*)"__X(", 5); + } + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(d, dim); + OPM_Write(')'); + } +} + +static void OPV_design (OPT_Node n, INT16 prec) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT16 class, designPrec, comp; + OPT_Node d = NIL, x = NIL; + INT16 dims, i, _for__26; + comp = n->typ->comp; + obj = n->obj; + class = n->class; + designPrec = OPV_Precedence(class, n->subcl, n->typ->form, comp); + if ((((((class == 0 && obj->mnolev > 0)) && (INT16)obj->mnolev != OPM_level)) && prec == 10)) { + designPrec = 9; + } + if (prec > designPrec) { + OPM_Write('('); + } + if (prec == 11) { + OPM_Write('*'); + } + switch (class) { + case 9: + OPC_Ident(n->obj); + break; + case 0: + OPC_CompleteIdent(n->obj); + break; + case 1: + if (!__IN(comp, 0x0c, 32)) { + OPM_Write('*'); + } + OPC_CompleteIdent(n->obj); + break; + case 2: + if (n->left->class == 3) { + OPV_design(n->left->left, designPrec); + OPM_WriteString((CHAR*)"->", 3); + } else { + OPV_design(n->left, designPrec); + OPM_Write('.'); + } + OPC_Ident(n->obj); + break; + case 3: + if (n->typ->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->data", 7); + } else { + OPM_Write('*'); + OPV_design(n->left, designPrec); + } + break; + case 4: + d = n->left; + if (d->typ->comp == 3) { + dims = 0; + while (d->class == 4) { + d = d->left; + dims += 1; + } + if (n->typ->comp == 3) { + OPM_Write('&'); + } + OPV_design(d, designPrec); + OPM_Write('['); + if (n->typ->comp == 3) { + OPM_Write('('); + } + i = dims; + x = n; + while (x != d) { + if (x->left != d) { + OPV_Index(x, d, 7, i); + OPM_WriteString((CHAR*)" + ", 4); + OPV_Len(d, i); + OPM_WriteString((CHAR*)" * (", 5); + i -= 1; + } else { + OPV_Index(x, d, -1, i); + } + x = x->left; + } + _for__26 = dims; + i = 1; + while (i <= _for__26) { + OPM_Write(')'); + i += 1; + } + if (n->typ->comp == 3) { + OPM_Write(')'); + while (i < __ASHR(d->typ->size - 4, 2)) { + OPM_WriteString((CHAR*)" * ", 4); + OPV_Len(d, i); + i += 1; + } + } + OPM_Write(']'); + } else { + OPV_design(n->left, designPrec); + OPM_Write('['); + OPV_Index(n, n->left, -1, 0); + OPM_Write(']'); + } + break; + case 5: + typ = n->typ; + obj = n->left->obj; + if (__IN(3, OPM_Options, 32)) { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__GUARDR(", 10); + if ((INT16)obj->mnolev != OPM_level) { + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"__curr->", 9); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } + } else { + if (typ->BaseTyp->strobj == NIL) { + OPM_WriteString((CHAR*)"__GUARDA(", 10); + } else { + OPM_WriteString((CHAR*)"__GUARDP(", 10); + } + OPV_expr(n->left, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + } else { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + OPC_CompleteIdent(obj); + } else { + OPM_Write('('); + OPC_Ident(typ->strobj); + OPM_Write(')'); + OPV_expr(n->left, designPrec); + } + } + break; + case 6: + if (__IN(3, OPM_Options, 32)) { + if (n->left->class == 1) { + OPM_WriteString((CHAR*)"__GUARDEQR(", 12); + OPC_CompleteIdent(n->left->obj); + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n->left); + } else { + OPM_WriteString((CHAR*)"__GUARDEQP(", 12); + OPV_expr(n->left->left, -1); + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + } else { + OPV_expr(n->left, -1); + } + break; + case 11: + if (n->subcl == 29) { + OPV_design(n->left, prec); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.design, class = ", 39); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + if (prec > designPrec) { + OPM_Write(')'); + } +} + +static void OPV_ParIntLiteral (INT64 n, INT32 size) +{ + OPM_WriteInt(n); +} + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp) +{ + OPT_Struct typ = NIL, aptyp = NIL; + INT16 comp, form, mode, prec, dim; + OPM_Write('('); + while (n != NIL) { + typ = fp->typ; + comp = typ->comp; + form = typ->form; + mode = fp->mode; + prec = -1; + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + prec = 10; + } + if (!__IN(n->typ->comp, 0x0c, 32)) { + if (mode == 2) { + if (typ != n->typ) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPM_Write('&'); + prec = 9; + } else { + if ((__IN(comp, 0x0c, 32) && n->class == 7)) { + OPM_WriteString((CHAR*)"(CHAR*)", 8); + } else if ((((form == 11 && typ != n->typ)) && n->typ != OPT_niltyp)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + } else { + if ((((mode == 2 && typ != n->typ)) && prec == -1)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPV_expr(n->left, prec); + } else if ((form == 4 && n->class == 7)) { + OPV_ParIntLiteral(n->conval->intval, n->typ->size); + } else { + OPV_expr(n, prec); + } + if ((comp == 4 && mode == 2)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n); + } else if (comp == 3) { + if (n->class == 7) { + OPM_WriteString((CHAR*)", ", 3); + OPV_ParIntLiteral(n->conval->intval2, OPM_AddressSize); + } else { + aptyp = n->typ; + dim = 0; + while ((typ->comp == 3 && typ->BaseTyp->form != 1)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n, dim); + typ = typ->BaseTyp; + aptyp = aptyp->BaseTyp; + dim += 1; + } + if ((typ->comp == 3 && typ->BaseTyp->form == 1)) { + OPM_WriteString((CHAR*)", ", 3); + while (aptyp->comp == 3) { + OPV_Len(n, dim); + OPM_WriteString((CHAR*)" * ", 4); + dim += 1; + aptyp = aptyp->BaseTyp; + } + OPV_ParIntLiteral(aptyp->size, OPM_AddressSize); + } + } + } + n = n->link; + fp = fp->link; + if (n != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static OPT_Object OPV_SuperProc (OPT_Node n) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + typ = n->right->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(n->left->obj->name, typ->BaseTyp, &obj); + return obj; +} + +static void OPV_expr (OPT_Node n, INT16 prec) +{ + INT16 class, subclass, form, exprPrec; + OPT_Struct typ = NIL; + OPT_Node l = NIL, r = NIL; + OPT_Object proc = NIL; + class = n->class; + subclass = n->subcl; + form = n->typ->form; + l = n->left; + r = n->right; + exprPrec = OPV_Precedence(class, subclass, form, n->typ->comp); + if ((exprPrec <= prec && __IN(class, 0x3ce0, 32))) { + OPM_Write('('); + } + switch (class) { + case 7: + OPC_Constant(n->conval, form); + break; + case 10: + OPM_WriteString((CHAR*)"__SETRNG(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(__ASHL(n->typ->size, 3)); + OPM_Write(')'); + break; + case 11: + switch (subclass) { + case 33: + OPM_Write('!'); + OPV_expr(l, exprPrec); + break; + case 7: + if (form == 7) { + OPM_Write('~'); + } else { + OPM_Write('-'); + } + OPV_expr(l, exprPrec); + break; + case 16: + typ = n->obj->typ; + if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"__IS(", 6); + OPC_TypeOf(l->obj); + } else { + OPM_WriteString((CHAR*)"__ISP(", 7); + OPV_expr(l, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + break; + case 20: + OPV_Convert(l, n->typ, exprPrec); + break; + case 21: + if (OPV_SideEffects(l)) { + if (l->typ->form < 5) { + if (l->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__ABSF(", 8); + } else { + OPM_WriteString((CHAR*)"__ABSFD(", 9); + } + } else { + OPM_WriteString((CHAR*)"__ABS(", 7); + } + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 22: + OPM_WriteString((CHAR*)"__CAP(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 23: + OPM_WriteString((CHAR*)"__ODD(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + if (l->class == 1) { + OPC_CompleteIdent(l->obj); + } else { + if ((l->typ->form != 8 && !__IN(l->typ->comp, 0x0c, 32))) { + OPM_Write('&'); + } + OPV_expr(l, exprPrec); + } + break; + case 29: + if (!__IN(l->class, 0x17, 32) || (((__IN(n->typ->form, 0x1890, 32) && __IN(l->typ->form, 0x1890, 32))) && n->typ->size == l->typ->size)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + if (__IN(n->typ->form, 0x1800, 32) || __IN(l->typ->form, 0x1800, 32)) { + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + } + OPV_expr(l, exprPrec); + } else { + OPM_WriteString((CHAR*)"__VAL(", 7); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_Write(')'); + } + break; + default: + OPM_err(200); + break; + } + break; + case 12: + switch (subclass) { + case 19: + OPV_Len(l, r->conval->intval); + break; + case 15: case 17: case 18: case 26: case 27: + case 28: case 3: case 4: + switch (subclass) { + case 15: + OPM_WriteString((CHAR*)"__IN(", 6); + break; + case 17: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ASHL(", 8); + } else { + OPM_WriteString((CHAR*)"__ASHR(", 8); + } + } else if (OPV_SideEffects(r)) { + OPM_WriteString((CHAR*)"__ASHF(", 8); + } else { + OPM_WriteString((CHAR*)"__ASH(", 7); + } + break; + case 18: + OPM_WriteString((CHAR*)"__MASK(", 8); + break; + case 26: + OPM_WriteString((CHAR*)"__BIT(", 7); + break; + case 27: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__LSHL(", 8); + } else { + OPM_WriteString((CHAR*)"__LSHR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__LSH(", 7); + } + break; + case 28: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ROTL(", 8); + } else { + OPM_WriteString((CHAR*)"__ROTR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__ROT(", 7); + } + break; + case 3: + if (OPV_SideEffects(n)) { + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__DIVF(", 8); + } else { + OPM_WriteString((CHAR*)"__DIV(", 7); + } + break; + case 4: + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + if (OPV_SideEffects(n)) { + OPM_WriteString((CHAR*)"__MODF(", 8); + } else { + OPM_WriteString((CHAR*)"__MOD(", 7); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if ((((__IN(subclass, 0x18020000, 32) && r->class == 7)) && r->conval->intval < 0)) { + OPM_WriteInt(-r->conval->intval); + } else { + OPV_expr(r, -1); + } + if (__IN(subclass, 0x18008000, 32)) { + OPM_WriteString((CHAR*)", ", 3); + if (subclass == 15) { + OPM_WriteInt(__ASHL(r->typ->size, 3)); + } else { + OPM_WriteInt(__ASHL(l->typ->size, 3)); + } + } + OPM_Write(')'); + break; + case 9: case 10: case 11: case 12: case 13: + case 14: + if (__IN(l->typ->form, 0x2100, 32)) { + OPM_WriteString((CHAR*)"__STRCMP(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_Write(')'); + OPC_Cmp(subclass); + OPM_Write('0'); + } else { + OPV_expr(l, exprPrec); + OPC_Cmp(subclass); + typ = l->typ; + if ((((((typ->form == 11 && r->typ->form != 9)) && r->typ != typ)) && r->typ != OPT_sysptrtyp)) { + OPM_WriteString((CHAR*)"(void *) ", 10); + } + OPV_expr(r, exprPrec); + } + break; + default: + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write('('); + } + OPV_expr(l, exprPrec); + switch (subclass) { + case 1: + if (form == 7) { + OPM_WriteString((CHAR*)" & ", 4); + } else { + OPM_WriteString((CHAR*)" * ", 4); + } + break; + case 2: + if (form == 7) { + OPM_WriteString((CHAR*)" ^ ", 4); + } else { + OPM_WriteString((CHAR*)" / ", 4); + if (r->obj == NIL || r->obj->typ->form == 4) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + } + } + break; + case 5: + OPM_WriteString((CHAR*)" && ", 5); + break; + case 6: + if (form == 7) { + OPM_WriteString((CHAR*)" | ", 4); + } else { + OPM_WriteString((CHAR*)" + ", 4); + } + break; + case 7: + if (form == 7) { + OPM_WriteString((CHAR*)" & ~", 5); + } else { + OPM_WriteString((CHAR*)" - ", 4); + } + break; + case 8: + OPM_WriteString((CHAR*)" || ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(r, exprPrec); + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write(')'); + } + break; + } + break; + case 13: + if ((l->obj != NIL && l->obj->mode == 13)) { + if (l->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(l->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (l->class == 9) { + OPV_design(l, 10); + } else { + OPV_design(l, 11); + } + OPV_ActualPar(r, n->obj); + break; + default: + OPV_design(n, prec); + break; + } + if ((exprPrec <= prec && __IN(class, 0x3ca0, 32))) { + OPM_Write(')'); + } +} + +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc) +{ + OPT_Node if_ = NIL; + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT32 adr; + if_ = n->left; + while (if_ != NIL) { + OPM_WriteString((CHAR*)"if ", 4); + OPV_expr(if_->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + if ((n->class == 27 && if_->left->left != NIL)) { + obj = if_->left->left->obj; + typ = obj->typ; + adr = obj->adr; + if (typ->comp == 4) { + OPC_BegStat(); + OPC_Ident(if_->left->obj); + OPM_WriteString((CHAR*)" *", 3); + OPM_WriteString(obj->name, 256); + OPM_WriteString((CHAR*)"__ = (void*)", 13); + obj->adr = 0; + OPC_CompleteIdent(obj); + OPC_EndStat(); + } + obj->adr = 1; + obj->typ = if_->left->obj->typ; + OPV_stat(if_->right, outerProc); + obj->typ = typ; + obj->adr = adr; + } else { + OPV_stat(if_->right, outerProc); + } + if_ = if_->link; + if ((if_ != NIL || n->right != NIL) || withtrap) { + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" else ", 7); + } else { + OPC_EndBlk(); + } + } + if (withtrap) { + OPM_WriteString((CHAR*)"__WITHCHK", 10); + OPC_EndStat(); + } else if (n->right != NIL) { + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + } +} + +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Node switchCase = NIL, label = NIL; + INT64 low, high; + INT16 form, i; + OPM_WriteString((CHAR*)"switch ", 8); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + form = n->left->typ->form; + switchCase = n->right->left; + while (switchCase != NIL) { + label = switchCase->left; + i = 0; + while (label != NIL) { + low = label->conval->intval; + high = label->conval->intval2; + while (low <= high) { + if (i == 0) { + OPC_BegStat(); + } + OPC_Case(low, form); + low += 1; + i += 1; + if (i == 5) { + OPM_WriteLn(); + i = 0; + } + } + label = label->link; + } + if (i > 0) { + OPM_WriteLn(); + } + OPC_Indent(1); + OPV_stat(switchCase->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_EndStat(); + OPC_Indent(-1); + switchCase = switchCase->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"default: ", 10); + if (n->right->conval->setval != 0x0) { + OPC_Indent(1); + OPM_WriteLn(); + OPV_stat(n->right->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_Indent(-1); + } else { + OPM_WriteString((CHAR*)"__CASECHK", 10); + } + OPC_EndStat(); + OPC_EndBlk(); +} + +static BOOLEAN OPV_ImplicitReturn (OPT_Node n) +{ + while ((n != NIL && n->class != 26)) { + n = n->link; + } + return n == NIL; +} + +static void OPV_NewArr (OPT_Node d, OPT_Node x) +{ + OPT_Struct typ = NIL, base = NIL; + INT16 nofdim, nofdyn; + typ = d->typ->BaseTyp; + base = typ; + nofdim = 0; + nofdyn = 0; + while (base->comp == 3) { + nofdim += 1; + nofdyn += 1; + base = base->BaseTyp; + } + OPV_design(d, -1); + OPM_WriteString((CHAR*)" = __NEWARR(", 13); + while (base->comp == 2) { + nofdim += 1; + base = base->BaseTyp; + } + if ((base->comp == 4 && OPC_NofPtrs(base) != 0)) { + OPC_Andent(base); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (base->form == 11) { + OPM_WriteString((CHAR*)"POINTER__typ", 13); + } else { + OPM_WriteString((CHAR*)"NIL", 4); + } + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(base->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPT_BaseAlignment(base)); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdim); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdyn); + while (typ != base) { + OPM_WriteString((CHAR*)", ", 3); + if (typ->comp == 3) { + if (x->class == 7) { + OPC_IntLiteral(x->conval->intval, OPM_AddressSize); + } else { + OPM_WriteString((CHAR*)"((ADDRESS)(", 12); + OPV_expr(x, 10); + OPM_WriteString((CHAR*)"))", 3); + } + x = x->link; + } else { + OPC_IntLiteral(typ->n, OPM_AddressSize); + } + typ = typ->BaseTyp; + } + OPM_Write(')'); +} + +static void OPV_DefineTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_TDescDecl(n->typ); + n = n->link; + } +} + +static void OPV_InitTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_InitTDesc(n->typ); + n = n->link; + } +} + +static void OPV_stat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Object proc = NIL; + OPV_ExitInfo saved; + OPT_Node l = NIL, r = NIL; + while ((n != NIL && OPM_noerr)) { + OPM_errpos = OPM_Longint(n->conval->intval); + if (n->class != 14) { + OPC_BegStat(); + } + switch (n->class) { + case 18: + if (n->obj == NIL) { + OPM_level += 1; + OPV_stat(n->left, outerProc); + OPM_level -= 1; + OPC_GenEnumPtrs(OPT_topScope->scope); + OPV_DefineTDescs(n->right); + OPC_EnterBody(); + OPV_InitTDescs(n->right); + OPM_WriteString((CHAR*)"/* BEGIN */", 12); + OPM_WriteLn(); + OPV_stat(n->right, outerProc); + OPC_ExitBody(); + } else { + proc = n->obj; + OPC_TypeDefs(proc->scope->right, 0); + if (!proc->scope->leaf) { + OPC_DefineInter(proc); + } + OPM_level += 1; + OPV_stat(n->left, proc); + OPM_level -= 1; + OPC_EnterProc(proc); + OPV_stat(n->right, proc); + OPC_ExitProc(proc, 1, OPV_ImplicitReturn(n->right)); + } + break; + case 14: + break; + case 19: + switch (n->subcl) { + case 0: + l = n->left; + r = n->right; + if (l->typ->comp == 2) { + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if (r->typ == OPT_stringtyp) { + OPM_WriteInt(r->conval->intval2); + } else if (r->typ->comp == 3) { + OPM_WriteString((CHAR*)"__X(", 5); + OPC_Len(r->obj, r->typ, 0); + OPM_WriteString((CHAR*)" * ", 4); + OPM_WriteInt(r->typ->BaseTyp->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(l->typ->size + 1); + OPM_Write(')'); + } else { + __ASSERT(r->typ->comp == 2, 0); + __ASSERT(r->typ->size <= l->typ->size, 0); + OPM_WriteInt(r->typ->size); + } + OPM_Write(')'); + } else { + if ((((((l->typ->form == 11 && l->obj != NIL)) && l->obj->adr == 1)) && l->obj->mode == 1)) { + l->obj->adr = 0; + OPV_design(l, -1); + l->obj->adr = 1; + if (r->typ->form != 9) { + OPM_WriteString((CHAR*)" = (void*)", 11); + } else { + OPM_WriteString((CHAR*)" = ", 4); + } + } else { + OPV_design(l, -1); + OPM_WriteString((CHAR*)" = ", 4); + } + if (l->typ == r->typ) { + OPV_expr(r, -1); + } else if ((((l->typ->form == 11 && r->typ->form != 9)) && l->typ->strobj != NIL)) { + OPM_Write('('); + OPC_Ident(l->typ->strobj); + OPM_Write(')'); + OPV_expr(r, -1); + } else if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Andent(l->typ); + OPM_WriteString((CHAR*)"*)&", 4); + OPV_expr(r, 9); + } else { + OPV_expr(r, -1); + } + } + break; + case 1: + if (n->left->typ->BaseTyp->comp == 4) { + OPM_WriteString((CHAR*)"__NEW(", 7); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(n->left->typ->BaseTyp); + OPM_WriteString((CHAR*)")", 2); + } else if (__IN(n->left->typ->BaseTyp->comp, 0x0c, 32)) { + OPV_NewArr(n->left, n->right); + } + break; + case 13: case 14: + OPV_expr(n->left, -1); + OPC_Increment(n->subcl == 14); + OPV_expr(n->right, -1); + break; + case 15: case 16: + OPV_expr(n->left, -1); + OPC_SetInclude(n->subcl == 16); + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(n->left->typ->size, 3)); + OPM_Write(')'); + break; + case 18: + OPM_WriteString((CHAR*)"__COPY(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n->left, 0); + OPM_Write(')'); + break; + case 31: + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right->link, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"__GET(", 7); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + break; + case 25: + OPM_WriteString((CHAR*)"__PUT(", 7); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->right->typ->strobj); + OPM_Write(')'); + break; + case 26: case 27: + OPM_err(200); + break; + case 30: + OPM_WriteString((CHAR*)"__SYSNEW(", 10); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_Write(')'); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.subcl = ", 40); + OPM_LogWNum(n->subcl, 0); + OPM_LogWLn(); + break; + } + break; + case 13: + if ((n->left->obj != NIL && n->left->obj->mode == 13)) { + if (n->left->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(n->left->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (n->left->class == 9) { + OPV_design(n->left, 10); + } else { + OPV_design(n->left, 11); + } + OPV_ActualPar(n->right, n->obj); + break; + case 20: + if (n->subcl != 32) { + OPV_IfStat(n, 0, outerProc); + } else if (__IN(7, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__ASSERT(", 10); + OPV_expr(n->left->left->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(n->left->right->right->conval->intval); + OPM_Write(')'); + OPC_EndStat(); + } + break; + case 21: + OPV_exit.level += 1; + OPV_CaseStat(n, outerProc); + OPV_exit.level -= 1; + break; + case 22: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"while ", 7); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + OPV_exit.level -= 1; + break; + case 23: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"do ", 4); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" while (!", 10); + OPV_expr(n->right, 9); + OPM_Write(')'); + OPV_exit.level -= 1; + break; + case 24: + saved = OPV_exit; + OPV_exit.level = 0; + OPV_exit.label = -1; + OPM_WriteString((CHAR*)"for (;;) ", 10); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk(); + if (OPV_exit.label != -1) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"exit__", 7); + OPM_WriteInt(OPV_exit.label); + OPM_Write(':'); + OPC_EndStat(); + } + OPV_exit = saved; + break; + case 25: + if (OPV_exit.level == 0) { + OPM_WriteString((CHAR*)"break", 6); + } else { + if (OPV_exit.label == -1) { + OPV_exit.label = OPV_nofExitLabels; + OPV_nofExitLabels += 1; + } + OPM_WriteString((CHAR*)"goto exit__", 12); + OPM_WriteInt(OPV_exit.label); + } + break; + case 26: + if (OPM_level == 0) { + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI", 7); + } else { + OPM_WriteString((CHAR*)"__ENDMOD", 9); + } + } else if (OPC_NeedsRetval(outerProc)) { + OPM_WriteString((CHAR*)"__retval = ", 12); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + OPC_EndStat(); + OPC_BegStat(); + OPC_ExitProc(outerProc, 0, 0); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"return __retval", 16); + } else { + OPC_ExitProc(outerProc, 0, 0); + OPM_WriteString((CHAR*)"return", 7); + if (n->left != NIL) { + OPM_Write(' '); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + } + } + break; + case 27: + OPV_IfStat(n, n->subcl == 0, outerProc); + break; + case 28: + OPC_Halt(OPM_Longint(n->right->conval->intval)); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.class = ", 40); + OPM_LogWNum(n->class, 0); + OPM_LogWLn(); + break; + } + if (!__IN(n->class, 0x09744000, 32)) { + OPC_EndStat(); + } + n = n->link; + } +} + +void OPV_Module (OPT_Node prog) +{ + if (!__IN(10, OPM_Options, 32)) { + OPC_GenHdr(prog->right); + OPC_GenHdrIncludes(); + } + OPC_GenBdy(prog->right); + OPV_stat(prog, NIL); +} + +__TDESC(OPV_ExitInfo, 1, 0) = {__TDFLDS("ExitInfo", 4), {-4}}; + +export void *OPV__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPV", 0); + __REGCMD("Init", OPV_Init); + __INITYP(OPV_ExitInfo, OPV_ExitInfo, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/OPV.h b/bootstrap/unix-44/OPV.h new file mode 100644 index 00000000..fbabd8f4 --- /dev/null +++ b/bootstrap/unix-44/OPV.h @@ -0,0 +1,18 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPV__h +#define OPV__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPV_AdrAndSize (OPT_Object topScope); +import void OPV_Init (void); +import void OPV_Module (OPT_Node prog); +import void *OPV__init(void); + + +#endif // OPV diff --git a/bootstrap/unix-44/Out.c b/bootstrap/unix-44/Out.c new file mode 100644 index 00000000..ce936589 --- /dev/null +++ b/bootstrap/unix-44/Out.c @@ -0,0 +1,345 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export BOOLEAN Out_IsConsole; +static CHAR Out_buf[128]; +static INT16 Out_in; + + +export void Out_Char (CHAR ch); +export void Out_Flush (void); +export void Out_Hex (INT64 x, INT64 n); +export void Out_Int (INT64 x, INT64 n); +static INT32 Out_Length (CHAR *s, ADDRESS s__len); +export void Out_Ln (void); +export void Out_LongReal (LONGREAL x, INT16 n); +export void Out_Open (void); +export void Out_Real (REAL x, INT16 n); +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_); +export void Out_String (CHAR *str, ADDRESS str__len); +export LONGREAL Out_Ten (INT16 e); +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i); +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i); + +#define Out_Entier64(x) (INT64)(x) + +void Out_Flush (void) +{ + INT16 error; + if (Out_in > 0) { + error = Platform_Write(1, (ADDRESS)Out_buf, Out_in); + } + Out_in = 0; +} + +void Out_Open (void) +{ +} + +void Out_Char (CHAR ch) +{ + if (Out_in >= 128) { + Out_Flush(); + } + Out_buf[__X(Out_in, 128)] = ch; + Out_in += 1; + if (ch == 0x0a) { + Out_Flush(); + } +} + +static INT32 Out_Length (CHAR *s, ADDRESS s__len) +{ + INT32 l; + l = 0; + while ((l < s__len && s[__X(l, s__len)] != 0x00)) { + l += 1; + } + return l; +} + +void Out_String (CHAR *str, ADDRESS str__len) +{ + INT32 l; + INT16 error; + __DUP(str, str__len, CHAR); + l = Out_Length((void*)str, str__len); + if (Out_in + l > 128) { + Out_Flush(); + } + if (l > 128) { + error = Platform_Write(1, (ADDRESS)str, l); + } else { + __MOVE((ADDRESS)str, (ADDRESS)&Out_buf[__X(Out_in, 128)], l); + Out_in += __SHORT(l, 32768); + } + __DEL(str); +} + +void Out_Int (INT64 x, INT64 n) +{ + CHAR s[22]; + INT16 i; + BOOLEAN negative; + negative = x < 0; + if (x == (-9223372036854775807LL-1)) { + __MOVE("8085774586302733229", s, 20); + i = 19; + } else { + if (x < 0) { + x = -x; + } + s[0] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i = 1; + while (x != 0) { + s[__X(i, 22)] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i += 1; + } + } + if (negative) { + s[__X(i, 22)] = '-'; + i += 1; + } + while (n > (INT64)i) { + Out_Char(' '); + n -= 1; + } + while (i > 0) { + i -= 1; + Out_Char(s[__X(i, 22)]); + } +} + +void Out_Hex (INT64 x, INT64 n) +{ + if (n < 1) { + n = 1; + } else if (n > 16) { + n = 16; + } + if (x >= 0) { + while ((n < 16 && __LSH(x, -__ASHL(n, 2), 64) != 0)) { + n += 1; + } + } + x = __ROT(x, __ASHL(16 - n, 2), 64); + while (n > 0) { + x = __ROTL(x, 4, 64); + n -= 1; + if (__MASK(x, -16) < 10) { + Out_Char(__CHR(__MASK(x, -16) + 48)); + } else { + Out_Char(__CHR((__MASK(x, -16) - 10) + 65)); + } + } +} + +void Out_Ln (void) +{ + Out_String(Platform_NL, 3); + Out_Flush(); +} + +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i) +{ + *i -= 1; + s[__X(*i, s__len)] = __CHR(__MOD(n, 10) + 48); +} + +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i) +{ + INT16 j; + INT32 l; + __DUP(t, t__len, CHAR); + l = Out_Length((void*)t, t__len); + if (l > *i) { + l = *i; + } + *i -= __SHORT(l, 32768); + j = 0; + while (j < l) { + s[__X(*i + j, s__len)] = t[__X(j, t__len)]; + j += 1; + } + __DEL(t); +} + +LONGREAL Out_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_) +{ + INT16 e; + INT64 f; + CHAR s[30]; + INT16 i, el; + LONGREAL x0; + BOOLEAN nn, en; + INT64 m; + INT16 d, dr; + e = (INT16)__MASK(__ASHR((__VAL(INT64, x)), 52), -2048); + f = __MASK((__VAL(INT64, x)), -4503599627370496LL); + nn = (__VAL(INT64, x) < 0 && !((e == 2047 && f != 0))); + if (nn) { + n -= 1; + } + i = 30; + if (e == 2047) { + if (f == 0) { + Out_prepend((CHAR*)"Infinity", 9, (void*)s, 30, &i); + } else { + Out_prepend((CHAR*)"NaN", 4, (void*)s, 30, &i); + } + } else { + if (long_) { + el = 3; + dr = n - 6; + if (dr > 17) { + dr = 17; + } + d = dr; + if (d < 15) { + d = 15; + } + } else { + el = 2; + dr = n - 5; + if (dr > 9) { + dr = 9; + } + d = dr; + if (d < 6) { + d = 6; + } + } + if (e == 0) { + while (el > 0) { + i -= 1; + s[__X(i, 30)] = '0'; + el -= 1; + } + i -= 1; + s[__X(i, 30)] = '+'; + m = 0; + } else { + if (nn) { + x = -x; + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Out_Ten(e); + } else { + x = Out_Ten(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + en = e < 0; + if (en) { + e = -e; + } + while (el > 0) { + Out_digit(e, (void*)s, 30, &i); + e = __DIV(e, 10); + el -= 1; + } + i -= 1; + if (en) { + s[__X(i, 30)] = '-'; + } else { + s[__X(i, 30)] = '+'; + } + x0 = Out_Ten(d - 1); + x = x0 * x; + x = x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + m = Out_Entier64(x); + } + i -= 1; + if (long_) { + s[__X(i, 30)] = 'D'; + } else { + s[__X(i, 30)] = 'E'; + } + if (dr < 2) { + dr = 2; + } + while ((d > dr && __MOD(m, 10) == 0)) { + m = __DIV(m, 10); + d -= 1; + } + while (d > 1) { + Out_digit(m, (void*)s, 30, &i); + m = __DIV(m, 10); + d -= 1; + } + i -= 1; + s[__X(i, 30)] = '.'; + Out_digit(m, (void*)s, 30, &i); + } + n -= 30 - i; + while (n > 0) { + Out_Char(' '); + n -= 1; + } + if (nn) { + Out_Char('-'); + } + while (i < 30) { + Out_Char(s[__X(i, 30)]); + i += 1; + } +} + +void Out_Real (REAL x, INT16 n) +{ + Out_RealP(x, n, 0); +} + +void Out_LongReal (LONGREAL x, INT16 n) +{ + Out_RealP(x, n, 1); +} + + +export void *Out__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Out", 0); + __REGCMD("Flush", Out_Flush); + __REGCMD("Ln", Out_Ln); + __REGCMD("Open", Out_Open); +/* BEGIN */ + Out_IsConsole = Platform_IsConsole(1); + Out_in = 0; + __ENDMOD; +} diff --git a/bootstrap/unix-44/Out.h b/bootstrap/unix-44/Out.h new file mode 100644 index 00000000..a72547f4 --- /dev/null +++ b/bootstrap/unix-44/Out.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Out__h +#define Out__h + +#include "SYSTEM.h" + + +import BOOLEAN Out_IsConsole; + + +import void Out_Char (CHAR ch); +import void Out_Flush (void); +import void Out_Hex (INT64 x, INT64 n); +import void Out_Int (INT64 x, INT64 n); +import void Out_Ln (void); +import void Out_LongReal (LONGREAL x, INT16 n); +import void Out_Open (void); +import void Out_Real (REAL x, INT16 n); +import void Out_String (CHAR *str, ADDRESS str__len); +import LONGREAL Out_Ten (INT16 e); +import void *Out__init(void); + + +#endif // Out diff --git a/bootstrap/unix-44/Platform.c b/bootstrap/unix-44/Platform.c new file mode 100644 index 00000000..befa6033 --- /dev/null +++ b/bootstrap/unix-44/Platform.c @@ -0,0 +1,535 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 volume, index, mtime; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +export BOOLEAN Platform_LittleEndian; +export INT16 Platform_PID; +export CHAR Platform_CWD[256]; +static INT32 Platform_TimeStart; +export INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +export CHAR Platform_NL[3]; + +export ADDRESS *Platform_FileIdentity__typ; + +export BOOLEAN Platform_Absent (INT16 e); +export INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +export INT16 Platform_Close (INT32 h); +export BOOLEAN Platform_ConnectionFailed (INT16 e); +export void Platform_Delay (INT32 ms); +export BOOLEAN Platform_DifferentFilesystems (INT16 e); +export INT16 Platform_Error (void); +export void Platform_Exit (INT32 code); +export void Platform_GetClock (INT32 *t, INT32 *d); +export void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +export void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +export INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export BOOLEAN Platform_Inaccessible (INT16 e); +export BOOLEAN Platform_Interrupted (INT16 e); +export BOOLEAN Platform_IsConsole (INT32 h); +export void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +export INT16 Platform_MaxNameLength (void); +export INT16 Platform_MaxPathLength (void); +export INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +export BOOLEAN Platform_NoSuchDirectory (INT16 e); +export INT32 Platform_OSAllocate (INT32 size); +export void Platform_OSFree (INT32 address); +export INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +export INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +export INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +export BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +export BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +export INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +export void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +export void Platform_SetInterruptHandler (Platform_SignalHandler handler); +export void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +export void Platform_SetQuitHandler (Platform_SignalHandler handler); +export INT16 Platform_Size (INT32 h, INT32 *l); +export INT16 Platform_Sync (INT32 h); +export INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +static void Platform_TestLittleEndian (void); +export INT32 Platform_Time (void); +export BOOLEAN Platform_TimedOut (INT16 e); +export BOOLEAN Platform_TooManyFiles (INT16 e); +export INT16 Platform_Truncate (INT32 h, INT32 l); +export INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +export INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d); +export BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#define Platform_EACCES() EACCES +#define Platform_EAGAIN() EAGAIN +#define Platform_ECONNABORTED() ECONNABORTED +#define Platform_ECONNREFUSED() ECONNREFUSED +#define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR +#define Platform_EMFILE() EMFILE +#define Platform_ENETUNREACH() ENETUNREACH +#define Platform_ENFILE() ENFILE +#define Platform_ENOENT() ENOENT +#define Platform_EROFS() EROFS +#define Platform_ETIMEDOUT() ETIMEDOUT +#define Platform_EXDEV() EXDEV +#define Platform_NAMEMAX() NAME_MAX +#define Platform_PATHMAX() PATH_MAX +#define Platform_allocate(size) (ADDRESS)((void*)malloc((size_t)size)) +#define Platform_chdir(n, n__len) chdir((char*)n) +#define Platform_closefile(fd) close(fd) +#define Platform_err() errno +#define Platform_exit(code) exit((int)code) +#define Platform_free(address) free((void*)address) +#define Platform_fstat(fd) fstat(fd, &s) +#define Platform_fsync(fd) fsync(fd) +#define Platform_ftruncate(fd, l) ftruncate(fd, l) +#define Platform_getcwd(cwd, cwd__len) getcwd((char*)cwd, cwd__len) +#define Platform_getenv(var, var__len) getenv((char*)var) +#define Platform_getpid() (INTEGER)getpid() +#define Platform_gettimeval() struct timeval tv; gettimeofday(&tv,0) +#define Platform_isatty(fd) isatty(fd) +#define Platform_lseek(fd, o, w) lseek(fd, o, w) +#define Platform_nanosleep(s, ns) struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem) +#define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) +#define Platform_openro(n, n__len) open((char*)n, O_RDONLY) +#define Platform_openrw(n, n__len) open((char*)n, O_RDWR) +#define Platform_readfile(fd, p, l) (LONGINT)read(fd, (void*)(ADDRESS)(p), l) +#define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) +#define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) +#define Platform_seekcur() SEEK_CUR +#define Platform_seekend() SEEK_END +#define Platform_seekset() SEEK_SET +#define Platform_sethandler(s, h) SystemSetHandler(s, (ADDRESS)h) +#define Platform_stat(n, n__len) stat((char*)n, &s) +#define Platform_statdev() (LONGINT)s.st_dev +#define Platform_statino() (LONGINT)s.st_ino +#define Platform_statmtime() (LONGINT)s.st_mtime +#define Platform_statsize() (ADDRESS)s.st_size +#define Platform_structstats() struct stat s +#define Platform_system(str, str__len) system((char*)str) +#define Platform_tmhour() (LONGINT)time->tm_hour +#define Platform_tmmday() (LONGINT)time->tm_mday +#define Platform_tmmin() (LONGINT)time->tm_min +#define Platform_tmmon() (LONGINT)time->tm_mon +#define Platform_tmsec() (LONGINT)time->tm_sec +#define Platform_tmyear() (LONGINT)time->tm_year +#define Platform_tvsec() tv.tv_sec +#define Platform_tvusec() tv.tv_usec +#define Platform_unlink(n, n__len) unlink((char*)n) +#define Platform_writefile(fd, p, l) write(fd, (void*)(ADDRESS)(p), l) + +BOOLEAN Platform_TooManyFiles (INT16 e) +{ + return e == Platform_EMFILE() || e == Platform_ENFILE(); +} + +BOOLEAN Platform_NoSuchDirectory (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_DifferentFilesystems (INT16 e) +{ + return e == Platform_EXDEV(); +} + +BOOLEAN Platform_Inaccessible (INT16 e) +{ + return (e == Platform_EACCES() || e == Platform_EROFS()) || e == Platform_EAGAIN(); +} + +BOOLEAN Platform_Absent (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_TimedOut (INT16 e) +{ + return e == Platform_ETIMEDOUT(); +} + +BOOLEAN Platform_ConnectionFailed (INT16 e) +{ + return ((e == Platform_ECONNREFUSED() || e == Platform_ECONNABORTED()) || e == Platform_ENETUNREACH()) || e == Platform_EHOSTUNREACH(); +} + +BOOLEAN Platform_Interrupted (INT16 e) +{ + return e == Platform_EINTR(); +} + +INT16 Platform_MaxNameLength (void) +{ + return Platform_NAMEMAX(); +} + +INT16 Platform_MaxPathLength (void) +{ + return Platform_PATHMAX(); +} + +INT32 Platform_OSAllocate (INT32 size) +{ + return Platform_allocate(size); +} + +void Platform_OSFree (INT32 address) +{ + Platform_free(address); +} + +typedef + CHAR (*EnvPtr__83)[1024]; + +BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + EnvPtr__83 p = NIL; + __DUP(var, var__len, CHAR); + p = (EnvPtr__83)(ADDRESS)Platform_getenv(var, var__len); + if (p != NIL) { + __COPY(*p, val, val__len); + } + __DEL(var); + return p != NIL; +} + +void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + __DUP(var, var__len, CHAR); + if (!Platform_getEnv(var, var__len, (void*)val, val__len)) { + val[0] = 0x00; + } + __DEL(var); +} + +void Platform_SetInterruptHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(2, handler); +} + +void Platform_SetQuitHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(3, handler); +} + +void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(4, handler); +} + +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d) +{ + *d = (__ASHL((int)__MOD(ye, 100), 9) + __ASHL(mo + 1, 5)) + da; + *t = (__ASHL(ho, 12) + __ASHL(mi, 6)) + se; +} + +void Platform_GetClock (INT32 *t, INT32 *d) +{ + Platform_gettimeval(); + Platform_sectotm(Platform_tvsec()); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec) +{ + Platform_gettimeval(); + *sec = Platform_tvsec(); + *usec = Platform_tvusec(); +} + +INT32 Platform_Time (void) +{ + INT32 ms; + Platform_gettimeval(); + ms = (int)__DIVF(Platform_tvusec(), 1000) + Platform_tvsec() * 1000; + return (int)__MOD(ms - Platform_TimeStart, 2147483647); +} + +void Platform_Delay (INT32 ms) +{ + INT32 s, ns; + s = __DIV(ms, 1000); + ns = (int)__MOD(ms, 1000) * 1000000; + Platform_nanosleep(s, ns); +} + +INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len) +{ + __DUP(cmd, cmd__len, CHAR); + __DEL(cmd); + return Platform_system(cmd, cmd__len); +} + +INT16 Platform_Error (void) +{ + return Platform_err(); +} + +INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openro(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openrw(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_opennew(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_Close (INT32 h) +{ + if (Platform_closefile(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +BOOLEAN Platform_IsConsole (INT32 h) +{ + return Platform_isatty(h) != 0; +} + +INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + return 0; +} + +INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + __DUP(n, n__len, CHAR); + Platform_structstats(); + if (Platform_stat(n, n__len) < 0) { + __DEL(n); + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + __DEL(n); + return 0; +} + +BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (i1.index == i2.index && i1.volume == i2.volume); +} + +BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return i1.mtime == i2.mtime; +} + +void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source) +{ + (*target).mtime = source.mtime; +} + +void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d) +{ + Platform_sectotm(i.mtime); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +INT16 Platform_Size (INT32 h, INT32 *l) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + *l = Platform_statsize(); + return 0; +} + +INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n) +{ + *n = Platform_readfile(h, p, l); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n) +{ + *n = Platform_readfile(h, (ADDRESS)b, b__len); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Write (INT32 h, INT32 p, INT32 l) +{ + INT32 written; + written = Platform_writefile(h, p, l); + if (written < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Sync (INT32 h) +{ + if (Platform_fsync(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence) +{ + if (Platform_lseek(h, offset, whence) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Truncate (INT32 h, INT32 l) +{ + if (Platform_ftruncate(h, l) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Unlink (CHAR *n, ADDRESS n__len) +{ + if (Platform_unlink(n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Chdir (CHAR *n, ADDRESS n__len) +{ + INT16 r; + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + return 0; + } else { + return Platform_err(); + } + __RETCHK; +} + +INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len) +{ + if (Platform_rename(o, o__len, n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +void Platform_Exit (INT32 code) +{ + Platform_exit(code); +} + +static void Platform_TestLittleEndian (void) +{ + INT16 i; + i = 1; + __GET((ADDRESS)&i, Platform_LittleEndian, BOOLEAN); +} + +__TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 12), {-4}}; + +export void *Platform__init(void) +{ + __DEFMOD; + __REGMOD("Platform", 0); + __INITYP(Platform_FileIdentity, Platform_FileIdentity, 0); +/* BEGIN */ + Platform_TestLittleEndian(); + Platform_TimeStart = 0; + Platform_TimeStart = Platform_Time(); + Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } + Platform_SeekSet = Platform_seekset(); + Platform_SeekCur = Platform_seekcur(); + Platform_SeekEnd = Platform_seekend(); + Platform_NL[0] = 0x0a; + Platform_NL[1] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-44/Platform.h b/bootstrap/unix-44/Platform.h new file mode 100644 index 00000000..fbeef8c7 --- /dev/null +++ b/bootstrap/unix-44/Platform.h @@ -0,0 +1,74 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Platform__h +#define Platform__h + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 _prvt0; + char _prvt1[8]; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +import BOOLEAN Platform_LittleEndian; +import INT16 Platform_PID; +import CHAR Platform_CWD[256]; +import INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +import CHAR Platform_NL[3]; + +import ADDRESS *Platform_FileIdentity__typ; + +import BOOLEAN Platform_Absent (INT16 e); +import INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +import INT16 Platform_Close (INT32 h); +import BOOLEAN Platform_ConnectionFailed (INT16 e); +import void Platform_Delay (INT32 ms); +import BOOLEAN Platform_DifferentFilesystems (INT16 e); +import INT16 Platform_Error (void); +import void Platform_Exit (INT32 code); +import void Platform_GetClock (INT32 *t, INT32 *d); +import void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +import INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import BOOLEAN Platform_Inaccessible (INT16 e); +import BOOLEAN Platform_Interrupted (INT16 e); +import BOOLEAN Platform_IsConsole (INT32 h); +import void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +import INT16 Platform_MaxNameLength (void); +import INT16 Platform_MaxPathLength (void); +import INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +import BOOLEAN Platform_NoSuchDirectory (INT16 e); +import INT32 Platform_OSAllocate (INT32 size); +import void Platform_OSFree (INT32 address); +import INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +import INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +import INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +import BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +import BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +import INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +import void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +import void Platform_SetInterruptHandler (Platform_SignalHandler handler); +import void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +import void Platform_SetQuitHandler (Platform_SignalHandler handler); +import INT16 Platform_Size (INT32 h, INT32 *l); +import INT16 Platform_Sync (INT32 h); +import INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +import INT32 Platform_Time (void); +import BOOLEAN Platform_TimedOut (INT16 e); +import BOOLEAN Platform_TooManyFiles (INT16 e); +import INT16 Platform_Truncate (INT32 h, INT32 l); +import INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +import INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +import BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void *Platform__init(void); + + +#endif // Platform diff --git a/bootstrap/unix-44/Reals.c b/bootstrap/unix-44/Reals.c new file mode 100644 index 00000000..512ec2c4 --- /dev/null +++ b/bootstrap/unix-44/Reals.c @@ -0,0 +1,157 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + + + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len); +export void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +export void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +export void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +export void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +export INT16 Reals_Expo (REAL x); +export INT16 Reals_ExpoL (LONGREAL x); +export void Reals_SetExpo (REAL *x, INT16 ex); +export REAL Reals_Ten (INT16 e); +export LONGREAL Reals_TenL (INT16 e); +static CHAR Reals_ToHex (INT16 i); + + +REAL Reals_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +LONGREAL Reals_TenL (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + for (;;) { + if (__ODD(e)) { + r = r * power; + } + e = __ASHR(e, 1); + if (e <= 0) { + return r; + } + power = power * power; + } + __RETCHK; +} + +INT16 Reals_Expo (REAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 2, i, INT16); + return __MASK(__ASHR(i, 7), -256); +} + +void Reals_SetExpo (REAL *x, INT16 ex) +{ + CHAR c; + __GET((ADDRESS)x + 3, c, CHAR); + __PUT((ADDRESS)x + 3, __CHR(__ASHL(__ASHR((INT16)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((ADDRESS)x + 2, c, CHAR); + __PUT((ADDRESS)x + 2, __CHR(__MASK((INT16)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); +} + +INT16 Reals_ExpoL (LONGREAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 6, i, INT16); + return __MASK(__ASHR(i, 4), -2048); +} + +void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + INT32 i, j, k; + if (x < (LONGREAL)0) { + x = -x; + } + k = 0; + if (n > 9) { + i = __SHORT(__ENTIER(x / (LONGREAL)(LONGREAL)1000000000), 2147483648LL); + j = __SHORT(__ENTIER(x - i * (LONGREAL)1000000000), 2147483648LL); + if (j < 0) { + j = 0; + } + while (k < 9) { + d[__X(k, d__len)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } + } else { + i = __SHORT(__ENTIER(x), 2147483648LL); + } + while (k < n) { + d[__X(k, d__len)] = __CHR((int)__MOD(i, 10) + 48); + i = __DIV(i, 10); + k += 1; + } +} + +void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + Reals_ConvertL(x, n, (void*)d, d__len); +} + +static CHAR Reals_ToHex (INT16 i) +{ + if (i < 10) { + return __CHR(i + 48); + } else { + return __CHR(i + 55); + } + __RETCHK; +} + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len) +{ + INT16 i; + INT32 l; + CHAR by; + i = 0; + l = b__len; + while (i < l) { + by = __VAL(CHAR, b[__X(i, b__len)]); + d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((INT16)by, 4)); + d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((INT16)by, -16)); + i += 1; + } +} + +void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&y, 4, (void*)d, d__len * 1); +} + +void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&x, 8, (void*)d, d__len * 1); +} + + +export void *Reals__init(void) +{ + __DEFMOD; + __REGMOD("Reals", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/Reals.h b/bootstrap/unix-44/Reals.h new file mode 100644 index 00000000..93e7fa75 --- /dev/null +++ b/bootstrap/unix-44/Reals.h @@ -0,0 +1,23 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Reals__h +#define Reals__h + +#include "SYSTEM.h" + + + + +import void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +import void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +import void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +import void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +import INT16 Reals_Expo (REAL x); +import INT16 Reals_ExpoL (LONGREAL x); +import void Reals_SetExpo (REAL *x, INT16 ex); +import REAL Reals_Ten (INT16 e); +import LONGREAL Reals_TenL (INT16 e); +import void *Reals__init(void); + + +#endif // Reals diff --git a/bootstrap/unix-44/Strings.c b/bootstrap/unix-44/Strings.c new file mode 100644 index 00000000..4b18812f --- /dev/null +++ b/bootstrap/unix-44/Strings.c @@ -0,0 +1,374 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Reals.h" + + + + +export void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +export void Strings_Cap (CHAR *s, ADDRESS s__len); +export void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +export void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +export void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export INT16 Strings_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +export INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +export void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +export void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); + + +INT16 Strings_Length (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + if (i <= 32767) { + __DEL(s); + return __SHORT(i, 32768); + } else { + __DEL(s); + return 32767; + } + __RETCHK; +} + +void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(extra, extra__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(extra, extra__len); + i = 0; + while ((i < n2 && (i + n1) < dest__len)) { + dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; + i += 1; + } + if ((i + n1) < dest__len) { + dest[__X(i + n1, dest__len)] = 0x00; + } + __DEL(extra); +} + +void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(source, source__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(source, source__len); + if (pos < 0) { + pos = 0; + } + if (pos > n1) { + Strings_Append(dest, dest__len, (void*)source, source__len); + __DEL(source); + return; + } + if ((pos + n2) < dest__len) { + i = n1; + while (i >= pos) { + if ((i + n2) < dest__len) { + dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; + } + i -= 1; + } + } + i = 0; + while (i < n2) { + dest[__X(pos + i, dest__len)] = source[__X(i, source__len)]; + i += 1; + } + __DEL(source); +} + +void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n) +{ + INT16 len, i; + len = Strings_Length(s, s__len); + if (pos < 0) { + pos = 0; + } else if (pos >= len) { + return; + } + if (pos + n < len) { + i = pos + n; + while (i < len) { + s[__X(i - n, s__len)] = s[__X(i, s__len)]; + i += 1; + } + if ((i - n) < s__len) { + s[__X(i - n, s__len)] = 0x00; + } + } else { + s[__X(pos, s__len)] = 0x00; + } +} + +void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + __DUP(source, source__len, CHAR); + Strings_Delete((void*)dest, dest__len, pos, pos + Strings_Length(source, source__len)); + Strings_Insert(source, source__len, pos, (void*)dest, dest__len); + __DEL(source); +} + +void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len) +{ + INT16 len, destLen, i; + __DUP(source, source__len, CHAR); + len = Strings_Length(source, source__len); + destLen = __SHORT(dest__len, 32768) - 1; + if (pos < 0) { + pos = 0; + } + if (pos >= len) { + dest[0] = 0x00; + __DEL(source); + return; + } + i = 0; + while (((((pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + if (i < destLen) { + dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; + } + i += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(source); +} + +INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos) +{ + INT16 n1, n2, i, j; + __DUP(pattern, pattern__len, CHAR); + __DUP(s, s__len, CHAR); + n1 = Strings_Length(s, s__len); + n2 = Strings_Length(pattern, pattern__len); + if (n2 == 0) { + __DEL(pattern); + __DEL(s); + return 0; + } + i = pos; + while (i <= n1 - n2) { + if (s[__X(i, s__len)] == pattern[0]) { + j = 1; + while ((j < n2 && s[__X(i + j, s__len)] == pattern[__X(j, pattern__len)])) { + j += 1; + } + if (j == n2) { + __DEL(pattern); + __DEL(s); + return i; + } + } + i += 1; + } + __DEL(pattern); + __DEL(s); + return -1; +} + +void Strings_Cap (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + if (('a' <= s[__X(i, s__len)] && s[__X(i, s__len)] <= 'z')) { + s[__X(i, s__len)] = __CAP(s[__X(i, s__len)]); + } + i += 1; + } +} + +static struct Match__7 { + struct Match__7 *lnk; +} *Match__7_s; + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m); + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m) +{ + while ((((n >= 0 && m >= 0)) && mask[__X(m, mask__len)] != '*')) { + if (name[__X(n, name__len)] != mask[__X(m, mask__len)]) { + return 0; + } + n -= 1; + m -= 1; + } + if (m < 0) { + return n < 0; + } + while ((m >= 0 && mask[__X(m, mask__len)] == '*')) { + m -= 1; + } + if (m < 0) { + return 1; + } + while (n >= 0) { + if (M__8(name, name__len, mask, mask__len, n, m)) { + return 1; + } + n -= 1; + } + return 0; +} + +BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len) +{ + struct Match__7 _s; + BOOLEAN __retval; + __DUP(string, string__len, CHAR); + __DUP(pattern, pattern__len, CHAR); + _s.lnk = Match__7_s; + Match__7_s = &_s; + __retval = M__8((void*)string, string__len, (void*)pattern, pattern__len, Strings_Length(string, string__len) - 1, Strings_Length(pattern, pattern__len) - 1); + Match__7_s = _s.lnk; + __DEL(string); + __DEL(pattern); + ; + return __retval; +} + +void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r) +{ + INT16 p, e; + REAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (REAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (REAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (REAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (REAL)(REAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (REAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + +void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r) +{ + INT16 p, e; + LONGREAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (LONGREAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (LONGREAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (LONGREAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (LONGREAL)(LONGREAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (LONGREAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + + +export void *Strings__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Reals); + __REGMOD("Strings", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/Strings.h b/bootstrap/unix-44/Strings.h new file mode 100644 index 00000000..f0e3ae34 --- /dev/null +++ b/bootstrap/unix-44/Strings.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Strings__h +#define Strings__h + +#include "SYSTEM.h" + + + + +import void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +import void Strings_Cap (CHAR *s, ADDRESS s__len); +import void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +import void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +import void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import INT16 Strings_Length (CHAR *s, ADDRESS s__len); +import BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +import INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +import void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +import void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); +import void *Strings__init(void); + + +#endif // Strings diff --git a/bootstrap/unix-44/Texts.c b/bootstrap/unix-44/Texts.c new file mode 100644 index 00000000..7e7522c2 --- /dev/null +++ b/bootstrap/unix-44/Texts.c @@ -0,0 +1,1833 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Files.h" +#include "Modules.h" +#include "Reals.h" + +typedef + struct Texts_RunDesc *Texts_Run; + +typedef + struct Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_RunDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + } Texts_RunDesc; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + struct Texts_ElemDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + } Texts_ElemDesc; + +struct Texts__1 { /* Texts_ElemDesc */ + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + Files_File file; + INT32 org, span; + CHAR mod[32], proc[32]; +}; + +typedef + struct Texts__1 *Texts_Alien; + +typedef + struct Texts_BufDesc { + INT32 len; + Texts_Run head; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + CHAR name[32]; + } Texts_FontDesc; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_PieceDesc *Texts_Piece; + +typedef + struct Texts_PieceDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + Files_File file; + INT32 org; + } Texts_PieceDesc; + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + Texts_Run head, cache; + INT32 corg; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + Files_Rider rider; + Files_File file; + } Texts_Writer; + + +export Texts_Elem Texts_new; +static Texts_Buffer Texts_del; +static Texts_FontsFont Texts_FontsDefault; + +export ADDRESS *Texts_FontDesc__typ; +export ADDRESS *Texts_RunDesc__typ; +export ADDRESS *Texts_PieceDesc__typ; +export ADDRESS *Texts_ElemMsg__typ; +export ADDRESS *Texts_ElemDesc__typ; +export ADDRESS *Texts_FileMsg__typ; +export ADDRESS *Texts_CopyMsg__typ; +export ADDRESS *Texts_IdentifyMsg__typ; +export ADDRESS *Texts_BufDesc__typ; +export ADDRESS *Texts_TextDesc__typ; +export ADDRESS *Texts_Reader__typ; +export ADDRESS *Texts_Scanner__typ; +export ADDRESS *Texts_Writer__typ; +export ADDRESS *Texts__1__typ; + +export void Texts_Append (Texts_Text T, Texts_Buffer B); +export void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +static Texts_Elem Texts_CloneElem (Texts_Elem e); +static Texts_Piece Texts_ClonePiece (Texts_Piece p); +export void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +export void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +export void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +export Texts_Text Texts_ElemBase (Texts_Elem E); +export INT32 Texts_ElemPos (Texts_Elem E); +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off); +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len); +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ); +export void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +export void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v); +export void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_OpenBuf (Texts_Buffer B); +export void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +export void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +export void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +export INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +export void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Recall (Texts_Buffer *B); +export void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +export void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +export void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +export void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +export void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base); +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un); +export void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +export void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +export void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +export void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +export void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +export void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +export void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +export void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +export void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +export void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +export void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +export void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +export void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); + + +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len) +{ + Texts_FontsFont F = NIL; + __NEW(F, Texts_FontDesc); + __COPY(name, F->name, 32); + return F; +} + +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off) +{ + Texts_Run v = NIL; + INT32 m; + if (*pos >= T->len) { + *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) { + while (m >= v->len) { + m -= v->len; + v = v->next; + } + } else { + while (m < 0) { + v = v->prev; + m += v->len; + } + } + *u = v; + *org = *pos - m; + *off = m; + T->cache = v->prev; + T->corg = *org; + } +} + +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un) +{ + Texts_Piece p = NIL, U = NIL; + if (off == 0) { + *un = *u; + *u = (*un)->prev; + } else if (off >= (*u)->len) { + *un = (*u)->next; + } else { + __NEW(p, Texts_PieceDesc); + *un = (Texts_Run)p; + U = __GUARDP(*u, Texts_PieceDesc, 1); + __GUARDEQP(p, Texts_PieceDesc) = *U; + p->org += off; + p->len -= off; + U->len -= p->len; + p->ascii = (*u)->ascii; + p->prev = (Texts_Run)U; + p->next = U->next; + p->next->prev = (Texts_Run)p; + U->next = (Texts_Run)p; + } +} + +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v) +{ + Texts_Piece p = NIL, q = NIL; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __ISP(*v, Texts_PieceDesc, 1))) && __STRCMP(u->fnt->name, (*v)->fnt->name) == 0)) && u->col == (*v)->col)) && u->voff == (*v)->voff)) && __GUARDP(u, Texts_PieceDesc, 1)->ascii == __GUARDP(*v, Texts_PieceDesc, 1)->ascii)) { + p = __GUARDP(u, Texts_PieceDesc, 1); + q = __GUARDP(*v, Texts_PieceDesc, 1); + if ((p->file == q->file && p->org + p->len == q->org)) { + if (T->cache == u) { + T->corg += q->len; + } else if (T->cache == *v) { + T->cache = T->head; + T->corg = 0; + } + p->len += q->len; + *v = (*v)->next; + } + } +} + +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base) +{ + Texts_Run u = NIL; + if (v != w->next) { + u = un->prev; + u->next = v; + v->prev = u; + un->prev = w; + w->next = un; + do { + if (__ISP(v, Texts_ElemDesc, 1)) { + __GUARDP(v, Texts_ElemDesc, 1)->base = base; + } + v = v->next; + } while (!(v == un)); + } +} + +static Texts_Piece Texts_ClonePiece (Texts_Piece p) +{ + Texts_Piece q = NIL; + __NEW(q, Texts_PieceDesc); + __GUARDEQP(q, Texts_PieceDesc) = *p; + return q; +} + +static Texts_Elem Texts_CloneElem (Texts_Elem e) +{ + Texts_CopyMsg msg; + msg.e = NIL; + (*e->handle)(e, (void*)&msg, Texts_CopyMsg__typ); + return msg.e; +} + +void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE) +{ + 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; +} + +Texts_Text Texts_ElemBase (Texts_Elem E) +{ + return E->base; +} + +INT32 Texts_ElemPos (Texts_Elem E) +{ + Texts_Run u = NIL; + INT32 pos; + u = E->base->head->next; + pos = 0; + while (u != (void *) E) { + pos = pos + u->len; + u = u->next; + } + return pos; +} + +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ) +{ + Texts_Alien e = NIL; + Files_Rider r; + INT32 i; + CHAR ch; + if (__ISP(E, Texts__1, 2)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + Texts_CopyMsg *msg__ = (void*)msg; + __NEW(e, Texts__1); + Texts_CopyElem((void*)(*(Texts_Alien*)&E), (void*)e); + e->file = (*(Texts_Alien*)&E)->file; + e->org = (*(Texts_Alien*)&E)->org; + e->span = (*(Texts_Alien*)&E)->span; + __MOVE((*(Texts_Alien*)&E)->mod, e->mod, 32); + __MOVE((*(Texts_Alien*)&E)->proc, e->proc, 32); + (*msg__).e = (Texts_Elem)e; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + Texts_IdentifyMsg *msg__ = (void*)msg; + __COPY((*(Texts_Alien*)&E)->mod, (*msg__).mod, 32); + __COPY((*(Texts_Alien*)&E)->proc, (*msg__).proc, 32); + (*msg__).mod[31] = 0x01; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_FileMsg, 1)) { + if (__IS(msg__typ, Texts_FileMsg, 1)) { + Texts_FileMsg *msg__ = (void*)msg; + if ((*msg__).id == 1) { + Files_Set(&r, Files_Rider__typ, (*(Texts_Alien*)&E)->file, (*(Texts_Alien*)&E)->org); + i = (*(Texts_Alien*)&E)->span; + while (i > 0) { + Files_Read(&r, Files_Rider__typ, (void*)&ch); + Files_Write(&(*msg__).r, Files_Rider__typ, ch); + i -= 1; + } + } + } else __WITHCHK; + } + } else __WITHCHK; +} + +void Texts_OpenBuf (Texts_Buffer B) +{ + Texts_Run u = NIL; + __NEW(u, Texts_RunDesc); + u->next = u; + u->prev = u; + B->head = u; + B->len = 0; +} + +void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB) +{ + Texts_Run u = NIL, v = NIL, vn = NIL; + u = SB->head->next; + v = DB->head->prev; + while (u != SB->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + vn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + } else { + vn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + v->next = vn; + vn->prev = v; + v = vn; + u = u->next; + } + v->next = DB->head; + DB->head->prev = v; + DB->len += SB->len; +} + +void Texts_Recall (Texts_Buffer *B) +{ + *B = Texts_del; + Texts_del = NIL; +} + +void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B) +{ + Texts_Run u = NIL, v = NIL, w = NIL, wn = NIL; + INT32 uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Find(T, &end, &v, &vo, &vd); + w = B->head->prev; + while (u != v) { + if (__ISP(u, Texts_PieceDesc, 1)) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + wn->len -= ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + } else { + wn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + w->next = wn; + wn->prev = w; + w = wn; + u = u->next; + ud = 0; + } + if (vd > 0) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(v, Texts_PieceDesc, 1)); + wn->len = vd - ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + w->next = wn; + wn->prev = w; + w = wn; + } + w->next = B->head; + B->head->prev = w; + B->len += end - beg; +} + +void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B) +{ + Texts_Run u = NIL, un = NIL, v = NIL; + Texts_Piece p = NIL, q = NIL; + INT32 uo, ud, len; + Texts_Find(T, &pos, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + len = B->len; + v = B->head->next; + Texts_Merge(T, u, &v); + Texts_Splice(un, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Append (Texts_Text T, Texts_Buffer B) +{ + Texts_Run v = NIL; + INT32 pos, len; + pos = T->len; + len = B->len; + v = B->head->next; + Texts_Merge(T, T->head->prev, &v); + Texts_Splice(T->head, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Delete (Texts_Text T, INT32 beg, INT32 end) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + __NEW(Texts_del, Texts_BufDesc); + Texts_OpenBuf(Texts_del); + Texts_del->len = end - beg; + Texts_Splice(Texts_del->head, un, v, NIL); + Texts_Merge(T, u, &vn); + u->next = vn; + vn->prev = u; + T->len -= end - beg; + if (T->notify != NIL) { + (*T->notify)(T, 2, beg, end); + } +} + +void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + while (un != vn) { + if ((__IN(0, sel, 32) && fnt != NIL)) { + un->fnt = fnt; + } + if (__IN(1, sel, 32)) { + un->col = col; + } + if (__IN(2, sel, 32)) { + un->voff = voff; + } + Texts_Merge(T, u, &un); + if (u->next == un) { + u = un; + un = un->next; + } else { + u->next = un; + un->prev = u; + } + } + Texts_Merge(T, u, &un); + u->next = un; + un->prev = u; + if (T->notify != NIL) { + (*T->notify)(T, 0, beg, end); + } +} + +void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos) +{ + Texts_Run u = NIL; + if (pos >= T->len) { + pos = T->len; + } + Texts_Find(T, &pos, &u, &(*R).org, &(*R).off); + (*R).run = u; + (*R).eot = 0; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, __GUARDP(u, Texts_PieceDesc, 1)->org + (*R).off); + } +} + +void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch) +{ + Texts_Run u = NIL; + INT32 pos; + CHAR nextch; + u = (*R).run; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).off += 1; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&*ch); + (*R).elem = NIL; + if ((*ch == 0x0a && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + *ch = 0x0d; + } else if ((*ch == 0x0d && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + pos = Files_Pos(&(*R).rider, Files_Rider__typ); + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&nextch); + if (nextch == 0x0a) { + (*R).off += 1; + } else { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, pos); + } + } + } else if (__ISP(u, Texts_ElemDesc, 1)) { + *ch = 0x1c; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + *ch = 0x00; + (*R).elem = NIL; + (*R).eot = 1; + } + if ((*R).off == u->len) { + (*R).org += u->len; + u = u->next; + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + } else __WITHCHK; + } + (*R).run = u; + (*R).off = 0; + } +} + +void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL, un = NIL; + u = (*R).run; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org += u->len; + u = u->next; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + un = u->next; + (*R).run = un; + (*R).org += 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + if (__ISP(un, Texts_PieceDesc, 1)) { + if (__ISP(un, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&un)->file, (*(Texts_Piece*)&un)->org); + } else __WITHCHK; + } + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL; + u = (*R).run->prev; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org -= u->len; + u = u->prev; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + (*R).run = u; + (*R).org -= 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ) +{ + return (*R).org + (*R).off; +} + +void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos) +{ + Texts_OpenReader((void*)&*S, S__typ, T, pos); + (*S).line = 0; + (*S).nextCh = ' '; +} + +static struct Scan__31 { + Texts_Scanner *S; + ADDRESS *S__typ; + CHAR *ch; + BOOLEAN *negE; + INT16 *e; + struct Scan__31 *lnk; +} *Scan__31_s; + +static void ReadScaleFactor__32 (void); + +static void ReadScaleFactor__32 (void) +{ + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + if (*Scan__31_s->ch == '-') { + *Scan__31_s->negE = 1; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } else { + *Scan__31_s->negE = 0; + if (*Scan__31_s->ch == '+') { + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } + } + while (('0' <= *Scan__31_s->ch && *Scan__31_s->ch <= '9')) { + *Scan__31_s->e = (*Scan__31_s->e * 10 + (INT16)*Scan__31_s->ch) - 48; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } +} + +void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ) +{ + CHAR ch, term; + BOOLEAN neg, negE, hex; + INT8 i, j, h; + INT16 e; + INT32 k; + REAL x, f; + LONGREAL y, g; + CHAR d[32]; + struct Scan__31 _s; + _s.S = S; _s.S__typ = S__typ; + _s.ch = &ch; + _s.negE = &negE; + _s.e = &e; + _s.lnk = Scan__31_s; + Scan__31_s = &_s; + ch = (*S).nextCh; + i = 0; + for (;;) { + if (ch == 0x0d) { + (*S).line += 1; + } else if ((ch != ' ' && ch != 0x09)) { + break; + } + Texts_Read((void*)&*S, S__typ, &ch); + } + if ((('A' <= __CAP(ch) && __CAP(ch) <= 'Z') || ch == '/') || ch == '.') { + do { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } while (!((((__CAP(ch) > 'Z' && ch != '_') || ('A' > __CAP(ch) && ch > '9')) || ((('0' > ch && ch != '.')) && ch != '/')) || i == 63)); + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i; + (*S).class = 1; + } else if (ch == '"') { + Texts_Read((void*)&*S, S__typ, &ch); + while ((((ch != '"' && ch >= ' ')) && i != 63)) { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i + 1; + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 2; + } else { + if (ch == '-') { + neg = 1; + Texts_Read((void*)&*S, S__typ, &ch); + } else { + neg = 0; + } + if (('0' <= ch && ch <= '9')) { + hex = 0; + j = 0; + for (;;) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + if (ch < '0') { + break; + } + if ('9' < ch) { + if (('A' <= ch && ch <= 'F')) { + hex = 1; + ch = __CHR((INT16)ch - 7); + } else if (('a' <= ch && ch <= 'f')) { + hex = 1; + ch = __CHR((INT16)ch - 39); + } else { + break; + } + } + } + if (ch == 'H') { + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 3; + if (i - j > 8) { + j = i - 8; + } + k = (INT16)d[__X(j, 32)] - 48; + j += 1; + if ((i - j == 7 && k >= 8)) { + k -= 16; + } + while (j < i) { + k = __ASHL(k, 4) + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + } else if (ch == '.') { + Texts_Read((void*)&*S, S__typ, &ch); + h = i; + while (('0' <= ch && ch <= '9')) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + if (ch == 'D') { + e = 0; + y = (LONGREAL)0; + g = (LONGREAL)1; + do { + y = y * (LONGREAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + g = g / (LONGREAL)(LONGREAL)10; + y = ((INT16)d[__X(j, 32)] - 48) * g + y; + j += 1; + } + ReadScaleFactor__32(); + if (negE) { + if (e <= 308) { + y = y / (LONGREAL)Reals_TenL(e); + } else { + y = (LONGREAL)0; + } + } else if (e > 0) { + if (e <= 308) { + y = Reals_TenL(e) * y; + } else { + __HALT(40); + } + } + if (neg) { + y = -y; + } + (*S).class = 5; + (*S).y = y; + } else { + e = 0; + x = (REAL)0; + f = (REAL)1; + do { + x = x * (REAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + f = f / (REAL)(REAL)10; + x = ((INT16)d[__X(j, 32)] - 48) * f + x; + j += 1; + } + if (ch == 'E') { + ReadScaleFactor__32(); + } + if (negE) { + if (e <= 38) { + x = x / (REAL)Reals_Ten(e); + } else { + x = (REAL)0; + } + } else if (e > 0) { + if (e <= 38) { + x = Reals_Ten(e) * x; + } else { + __HALT(40); + } + } + if (neg) { + x = -x; + } + (*S).class = 4; + (*S).x = x; + } + if (hex) { + (*S).class = 0; + } + } else { + (*S).class = 3; + k = 0; + do { + k = k * 10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == i)); + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + if (hex) { + (*S).class = 0; + } else { + (*S).class = 3; + } + } + } else { + (*S).class = 6; + if (neg) { + (*S).c = '-'; + } else { + (*S).c = ch; + Texts_Read((void*)&*S, S__typ, &ch); + } + } + } + (*S).nextCh = ch; + Scan__31_s = _s.lnk; +} + +void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ) +{ + __NEW((*W).buf, Texts_BufDesc); + Texts_OpenBuf((*W).buf); + (*W).fnt = Texts_FontsDefault; + (*W).col = 15; + (*W).voff = 0; + (*W).file = Files_New((CHAR*)"", 1); + Files_Set(&(*W).rider, Files_Rider__typ, (*W).file, 0); +} + +void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt) +{ + (*W).fnt = fnt; +} + +void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col) +{ + (*W).col = col; +} + +void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff) +{ + (*W).voff = voff; +} + +void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Files_Write(&(*W).rider, Files_Rider__typ, ch); + (*W).buf->len += 1; + un = (*W).buf->head; + u = un->prev; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __GUARDP(u, Texts_PieceDesc, 1)->file == (*W).file)) && __STRCMP(u->fnt->name, (*W).fnt->name) == 0)) && u->col == (*W).col)) && u->voff == (*W).voff)) && !__GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + u->len += 1; + } else { + __NEW(p, Texts_PieceDesc); + u->next = (Texts_Run)p; + p->prev = u; + p->next = un; + un->prev = (Texts_Run)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 = 0; + } +} + +void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e) +{ + Texts_Run u = NIL, un = NIL; + if (e->base != NIL) { + __HALT(99); + } + (*W).buf->len += 1; + e->len = 1; + e->fnt = (*W).fnt; + e->col = (*W).col; + e->voff = (*W).voff; + un = (*W).buf->head; + u = un->prev; + u->next = (Texts_Run)e; + e->prev = u; + e->next = un; + un->prev = (Texts_Run)e; +} + +void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ) +{ + Texts_Write(&*W, W__typ, 0x0d); +} + +void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while (s[__X(i, s__len)] >= ' ') { + Texts_Write(&*W, W__typ, s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n) +{ + INT16 i; + INT64 x0; + CHAR a[24]; + i = 0; + if (x < 0) { + if (x == (-9223372036854775807LL-1)) { + Texts_WriteString(&*W, W__typ, (CHAR*)" -9223372036854775808", 22); + return; + } else { + n -= 1; + x0 = -x; + } + } else { + x0 = x; + } + do { + a[__X(i, 24)] = __CHR(__MOD(x0, 10) + 48); + x0 = __DIV(x0, 10); + i += 1; + } while (!(x0 == 0)); + while (n > (INT64)i) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + if (x < 0) { + Texts_Write(&*W, W__typ, '-'); + } + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 24)]); + } while (!(i == 0)); +} + +void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x) +{ + INT16 i; + INT32 y; + CHAR a[20]; + i = 0; + Texts_Write(&*W, W__typ, ' '); + do { + y = __MASK(x, -16); + if (y < 10) { + a[__X(i, 20)] = __CHR(y + 48); + } else { + a[__X(i, 20)] = __CHR(y + 55); + } + x = __ASHR(x, 4); + i += 1; + } while (!(i == 8)); + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 20)]); + } while (!(i == 0)); +} + +void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n) +{ + INT16 e; + REAL x0; + CHAR d[9]; + e = Reals_Expo(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 9) { + n = 3; + } else { + n -= 6; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 8)); + if (x < (REAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __ASHR((e - 127) * 77, 8); + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + x0 = Reals_Ten(n - 1); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + x = x * 1.0000000e-001; + e += 1; + } + Reals_Convert(x, n, (void*)d, 9); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'E'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +static struct WriteRealFix__53 { + Texts_Writer *W; + ADDRESS *W__typ; + INT16 *i; + CHAR (*d)[9]; + struct WriteRealFix__53 *lnk; +} *WriteRealFix__53_s; + +static void dig__54 (INT16 n); +static void seq__56 (CHAR ch, INT16 n); + +static void seq__56 (CHAR ch, INT16 n) +{ + while (n > 0) { + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, ch); + n -= 1; + } +} + +static void dig__54 (INT16 n) +{ + while (n > 0) { + *WriteRealFix__53_s->i -= 1; + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, (*WriteRealFix__53_s->d)[__X(*WriteRealFix__53_s->i, 9)]); + n -= 1; + } +} + +void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k) +{ + INT16 e, i; + CHAR sign; + REAL x0; + CHAR d[9]; + struct WriteRealFix__53 _s; + _s.W = W; _s.W__typ = W__typ; + _s.i = &i; + _s.d = (void*)d; + _s.lnk = WriteRealFix__53_s; + WriteRealFix__53_s = &_s; + e = Reals_Expo(x); + if (k < 0) { + k = 0; + } + if (e == 0) { + seq__56(' ', (n - k) - 2); + Texts_Write(&*W, W__typ, '0'); + seq__56(' ', k + 1); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + seq__56(' ', n - 4); + } else { + e = __ASHR((e - 127) * 77, 8); + if (x < (REAL)0) { + sign = '-'; + x = -x; + } else { + sign = ' '; + } + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + if (k + e >= 8) { + k = 8 - e; + } else if (k + e < 0) { + k = -e; + x = (REAL)0; + } + x0 = Reals_Ten(k + e); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + e += 1; + } + e += 1; + i = k + e; + Reals_Convert(x, i, (void*)d, 9); + if (e > 0) { + seq__56(' ', ((n - e) - k) - 2); + Texts_Write(&*W, W__typ, sign); + dig__54(e); + Texts_Write(&*W, W__typ, '.'); + dig__54(k); + } else { + seq__56(' ', (n - k) - 3); + Texts_Write(&*W, W__typ, sign); + Texts_Write(&*W, W__typ, '0'); + Texts_Write(&*W, W__typ, '.'); + seq__56('0', -e); + dig__54(k + e); + } + } + WriteRealFix__53_s = _s.lnk; +} + +void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x) +{ + INT16 i; + CHAR d[8]; + Reals_ConvertH(x, (void*)d, 8); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 8)]); + i += 1; + } while (!(i == 8)); +} + +void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n) +{ + INT16 e; + LONGREAL x0; + CHAR d[16]; + e = Reals_ExpoL(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 2047) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 10) { + n = 3; + } else { + n -= 7; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 16)); + if (x < (LONGREAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Reals_TenL(e); + } else { + x = Reals_TenL(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + x0 = Reals_TenL(n - 1); + x = x0 * x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + Reals_ConvertL(x, n, (void*)d, 16); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'D'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 100) + 48)); + e = (int)__MOD(e, 100); + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x) +{ + INT16 i; + CHAR d[16]; + Reals_ConvertHL(x, (void*)d, 16); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 16)]); + i += 1; + } while (!(i == 16)); +} + +static struct WriteDate__43 { + Texts_Writer *W; + ADDRESS *W__typ; + struct WriteDate__43 *lnk; +} *WriteDate__43_s; + +static void WritePair__44 (CHAR ch, INT32 x); + +static void WritePair__44 (CHAR ch, INT32 x) +{ + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, ch); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR(__DIV(x, 10) + 48)); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR((int)__MOD(x, 10) + 48)); +} + +void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d) +{ + struct WriteDate__43 _s; + _s.W = W; _s.W__typ = W__typ; + _s.lnk = WriteDate__43_s; + WriteDate__43_s = &_s; + WritePair__44(' ', __MASK(d, -32)); + WritePair__44('.', __MASK(__ASHR(d, 5), -16)); + WritePair__44('.', __MASK(__ASHR(d, 9), -128)); + WritePair__44(' ', __MASK(__ASHR(t, 12), -32)); + WritePair__44(':', __MASK(__ASHR(t, 6), -64)); + WritePair__44(':', __MASK(t, -64)); + WriteDate__43_s = _s.lnk; +} + +static struct Load0__16 { + Texts_Text *T; + INT8 *ecnt; + Files_File *f; + Texts_FileMsg *msg; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Load0__16 *lnk; +} *Load0__16_s; + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e); + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e) +{ + Heap_Module M = NIL; + Heap_Command Cmd; + Texts_Alien a = NIL; + INT32 org, ew, eh; + INT8 eno; + Texts_new = NIL; + Files_ReadLInt(&*r, r__typ, &ew); + Files_ReadLInt(&*r, r__typ, &eh); + Files_Read(&*r, r__typ, (void*)&eno); + if (eno > *Load0__16_s->ecnt) { + *Load0__16_s->ecnt = eno; + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->mods)[__X(eno, 64)], 32); + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->procs)[__X(eno, 64)], 32); + } + org = Files_Pos(&*r, r__typ); + M = Modules_ThisMod((*Load0__16_s->mods)[__X(eno, 64)], 32); + if (M != NIL) { + Cmd = Modules_ThisCommand(M, (*Load0__16_s->procs)[__X(eno, 64)], 32); + if (Cmd != NIL) { + (*Cmd)(); + } + } + *e = Texts_new; + if (*e != NIL) { + (*e)->W = ew; + (*e)->H = eh; + (*e)->base = *Load0__16_s->T; + (*Load0__16_s->msg).pos = pos; + (*(*e)->handle)(*e, (void*)&*Load0__16_s->msg, Texts_FileMsg__typ); + if (Files_Pos(&*r, r__typ) != org + span) { + *e = NIL; + } + } + if (*e == NIL) { + Files_Set(&*r, r__typ, *Load0__16_s->f, org + span); + __NEW(a, Texts__1); + a->W = ew; + a->H = eh; + a->handle = Texts_HandleAlien; + a->base = *Load0__16_s->T; + a->file = *Load0__16_s->f; + a->org = org; + a->span = span; + __COPY((*Load0__16_s->mods)[__X(eno, 64)], a->mod, 32); + __COPY((*Load0__16_s->procs)[__X(eno, 64)], a->proc, 32); + *e = (Texts_Elem)a; + } +} + +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Texts_Elem e = NIL; + INT32 org, pos, hlen, plen; + INT8 ecnt, fcnt, fno, col, voff; + Files_File f = NIL; + Texts_FileMsg msg; + CHAR mods[64][32], procs[64][32]; + CHAR name[32]; + Texts_FontsFont fnts[32]; + struct Load0__16 _s; + _s.T = &T; + _s.ecnt = &ecnt; + _s.f = &f; + _s.msg = &msg; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Load0__16_s; + Load0__16_s = &_s; + pos = Files_Pos(&*r, r__typ); + f = Files_Base(&*r, r__typ); + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + T->head = u; + ecnt = 0; + fcnt = 0; + msg.id = 0; + msg.r = *r; + Files_ReadLInt(&msg.r, Files_Rider__typ, &hlen); + org = (pos - 2) + hlen; + pos = org; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + while (fno != 0) { + if (fno > fcnt) { + fcnt = fno; + Files_ReadString(&msg.r, Files_Rider__typ, (void*)name, 32); + fnts[__X(fno, 32)] = Texts_FontsThis((void*)name, 32); + } + Files_Read(&msg.r, Files_Rider__typ, (void*)&col); + Files_Read(&msg.r, Files_Rider__typ, (void*)&voff); + Files_ReadLInt(&msg.r, Files_Rider__typ, &plen); + if (plen > 0) { + __NEW(p, Texts_PieceDesc); + p->file = f; + p->org = pos; + p->ascii = 0; + un = (Texts_Run)p; + un->len = plen; + } else { + LoadElem__17(&msg.r, Files_Rider__typ, pos - org, -plen, &e); + un = (Texts_Run)e; + un->len = 1; + } + un->col = col; + un->voff = voff; + pos += un->len; + u->next = un; + un->prev = u; + u = un; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + } + u->next = T->head; + T->head->prev = u; + T->cache = T->head; + T->corg = 0; + Files_ReadLInt(&msg.r, Files_Rider__typ, &T->len); + Files_Set(&*r, r__typ, f, Files_Pos(&msg.r, Files_Rider__typ) + T->len); + Load0__16_s = _s.lnk; +} + +void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + INT16 tag; + Files_ReadInt(&*r, r__typ, &tag); + if (tag != -4095) { + Files_Set(&*r, r__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ) - 2); + } + Texts_Load0(&*r, r__typ, T); +} + +void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + Texts_Run u = NIL; + Texts_Piece p = NIL; + CHAR tag, version; + INT32 hlen; + __DUP(name, name__len, CHAR); + f = Files_Old(name, name__len); + if (f == NIL) { + f = Files_New((CHAR*)"", 1); + } + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Read(&r, Files_Rider__typ, (void*)&tag); + Files_Read(&r, Files_Rider__typ, (void*)&version); + if (tag == 0xf0 || (tag == 0x01 && version == 0xf0)) { + Texts_Load0(&r, Files_Rider__typ, T); + } else { + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + __NEW(p, Texts_PieceDesc); + if ((tag == 0xf7 && version == 0x07)) { + Files_Set(&r, Files_Rider__typ, f, 28); + Files_ReadLInt(&r, Files_Rider__typ, &hlen); + Files_Set(&r, Files_Rider__typ, f, 22 + hlen); + Files_ReadLInt(&r, Files_Rider__typ, &T->len); + p->org = 26 + hlen; + } else { + T->len = Files_Length(f); + p->org = 0; + } + if (T->len > 0) { + p->len = T->len; + p->fnt = Texts_FontsDefault; + p->col = 15; + p->voff = 0; + p->file = f; + p->ascii = 1; + u->next = (Texts_Run)p; + u->prev = (Texts_Run)p; + p->next = u; + p->prev = u; + } else { + u->next = u; + u->prev = u; + } + T->head = u; + T->cache = T->head; + T->corg = 0; + } + __DEL(name); +} + +static struct Store__39 { + INT8 *ecnt; + Texts_FileMsg *msg; + Texts_IdentifyMsg *iden; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Store__39 *lnk; +} *Store__39_s; + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e); + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e) +{ + Files_Rider r1; + INT32 org, span; + INT8 eno; + __COPY((*Store__39_s->iden).mod, (*Store__39_s->mods)[__X(*Store__39_s->ecnt, 64)], 32); + __COPY((*Store__39_s->iden).proc, (*Store__39_s->procs)[__X(*Store__39_s->ecnt, 64)], 32); + eno = 1; + while (__STRCMP((*Store__39_s->mods)[__X(eno, 64)], (*Store__39_s->iden).mod) != 0 || __STRCMP((*Store__39_s->procs)[__X(eno, 64)], (*Store__39_s->iden).proc) != 0) { + eno += 1; + } + Files_Set(&r1, Files_Rider__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ)); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_Write(&*r, r__typ, eno); + if (eno == *Store__39_s->ecnt) { + *Store__39_s->ecnt += 1; + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).mod, 32); + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).proc, 32); + } + (*Store__39_s->msg).pos = pos; + org = Files_Pos(&*r, r__typ); + (*e->handle)(e, (void*)&*Store__39_s->msg, Texts_FileMsg__typ); + span = Files_Pos(&*r, r__typ) - org; + Files_WriteLInt(&r1, Files_Rider__typ, -span); + Files_WriteLInt(&r1, Files_Rider__typ, e->W); + Files_WriteLInt(&r1, Files_Rider__typ, e->H); +} + +void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Files_Rider r1; + Texts_Run u = NIL, un = NIL; + Texts_Elem e = NIL; + INT32 org, pos, delta, hlen, rlen; + INT8 ecnt, fcnt; + CHAR ch; + INT8 fno; + Texts_FileMsg msg; + Texts_IdentifyMsg iden; + CHAR mods[64][32], procs[64][32]; + Texts_FontsFont fnts[32]; + CHAR block[1024]; + struct Store__39 _s; + _s.ecnt = &ecnt; + _s.msg = &msg; + _s.iden = &iden; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Store__39_s; + Store__39_s = &_s; + org = Files_Pos(&*r, r__typ); + msg.id = 1; + msg.r = *r; + Files_WriteLInt(&msg.r, Files_Rider__typ, 0); + u = T->head->next; + pos = 0; + delta = 0; + fcnt = 1; + ecnt = 1; + while (u != T->head) { + if (__ISP(u, Texts_ElemDesc, 1)) { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + } else { + iden.mod[0] = 0x01; + } + if (iden.mod[0] != 0x00) { + fnts[__X(fcnt, 32)] = u->fnt; + fno = 1; + while (__STRCMP(fnts[__X(fno, 32)]->name, u->fnt->name) != 0) { + fno += 1; + } + Files_Write(&msg.r, Files_Rider__typ, fno); + if (fno == fcnt) { + fcnt += 1; + Files_WriteString(&msg.r, Files_Rider__typ, u->fnt->name, 32); + } + Files_Write(&msg.r, Files_Rider__typ, u->col); + Files_Write(&msg.r, Files_Rider__typ, u->voff); + } + if (__ISP(u, Texts_PieceDesc, 1)) { + rlen = u->len; + un = u->next; + while ((((((__ISP(un, Texts_PieceDesc, 1) && un->fnt == u->fnt)) && un->col == u->col)) && un->voff == u->voff)) { + rlen += un->len; + un = un->next; + } + Files_WriteLInt(&msg.r, Files_Rider__typ, rlen); + pos += rlen; + u = un; + } else if (iden.mod[0] != 0x00) { + StoreElem__40(&msg.r, Files_Rider__typ, pos, __GUARDP(u, Texts_ElemDesc, 1)); + pos += 1; + u = u->next; + } else { + delta += 1; + u = u->next; + } + } + Files_Write(&msg.r, Files_Rider__typ, 0); + Files_WriteLInt(&msg.r, Files_Rider__typ, T->len - delta); + hlen = (Files_Pos(&msg.r, Files_Rider__typ) - org) + 2; + Files_Set(&r1, Files_Rider__typ, Files_Base(&msg.r, Files_Rider__typ), org); + Files_WriteLInt(&r1, Files_Rider__typ, hlen); + u = T->head->next; + while (u != T->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if ((*(Texts_Piece*)&u)->ascii) { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 0) { + Files_Read(&r1, Files_Rider__typ, (void*)&ch); + delta -= 1; + if (ch == 0x0a) { + Files_Write(&msg.r, Files_Rider__typ, 0x0d); + } else { + Files_Write(&msg.r, Files_Rider__typ, ch); + } + } + } else { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 1024) { + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, 1024); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, 1024); + delta -= 1024; + } + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, delta); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, delta); + } + } else __WITHCHK; + } else { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + if (iden.mod[0] != 0x00) { + Files_Write(&msg.r, Files_Rider__typ, 0x1c); + } + } + u = u->next; + } + __GUARDEQR(r, r__typ, Files_Rider) = msg.r; + if (T->notify != NIL) { + (*T->notify)(T, 3, 0, 0); + } + Store__39_s = _s.lnk; +} + +void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + INT16 i, res; + CHAR bak[64]; + __DUP(name, name__len, CHAR); + f = Files_New(name, name__len); + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Write(&r, Files_Rider__typ, 0xf0); + Files_Write(&r, Files_Rider__typ, 0x01); + Texts_Store(&r, Files_Rider__typ, T); + i = 0; + while (name[__X(i, name__len)] != 0x00) { + i += 1; + } + __COPY(name, bak, 64); + bak[__X(i, 64)] = '.'; + bak[__X(i + 1, 64)] = 'B'; + bak[__X(i + 2, 64)] = 'a'; + bak[__X(i + 3, 64)] = 'k'; + bak[__X(i + 4, 64)] = 0x00; + Files_Rename(name, name__len, bak, 64, &res); + Files_Register(f); + __DEL(name); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Texts_new); + P(Texts_del); + P(Texts_FontsDefault); +} + +__TDESC(Texts_FontDesc, 1, 0) = {__TDFLDS("FontDesc", 32), {-4}}; +__TDESC(Texts_RunDesc, 1, 3) = {__TDFLDS("RunDesc", 20), {0, 4, 12, -16}}; +__TDESC(Texts_PieceDesc, 1, 4) = {__TDFLDS("PieceDesc", 28), {0, 4, 12, 20, -20}}; +__TDESC(Texts_ElemMsg, 1, 0) = {__TDFLDS("ElemMsg", 1), {-4}}; +__TDESC(Texts_ElemDesc, 1, 4) = {__TDFLDS("ElemDesc", 36), {0, 4, 12, 32, -20}}; +__TDESC(Texts_FileMsg, 1, 1) = {__TDFLDS("FileMsg", 28), {16, -8}}; +__TDESC(Texts_CopyMsg, 1, 1) = {__TDFLDS("CopyMsg", 4), {0, -8}}; +__TDESC(Texts_IdentifyMsg, 1, 0) = {__TDFLDS("IdentifyMsg", 64), {-4}}; +__TDESC(Texts_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 8), {4, -8}}; +__TDESC(Texts_TextDesc, 1, 2) = {__TDFLDS("TextDesc", 20), {8, 12, -12}}; +__TDESC(Texts_Reader, 1, 4) = {__TDFLDS("Reader", 48), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Scanner, 1, 4) = {__TDFLDS("Scanner", 140), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Writer, 1, 4) = {__TDFLDS("Writer", 36), {0, 4, 20, 32, -20}}; +__TDESC(Texts__1, 1, 5) = {__TDFLDS("", 112), {0, 4, 12, 32, 36, -24}}; + +export void *Texts__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Reals); + __REGMOD("Texts", EnumPtrs); + __INITYP(Texts_FontDesc, Texts_FontDesc, 0); + __INITYP(Texts_RunDesc, Texts_RunDesc, 0); + __INITYP(Texts_PieceDesc, Texts_RunDesc, 1); + __INITYP(Texts_ElemMsg, Texts_ElemMsg, 0); + __INITYP(Texts_ElemDesc, Texts_RunDesc, 1); + __INITYP(Texts_FileMsg, Texts_ElemMsg, 1); + __INITYP(Texts_CopyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_IdentifyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_BufDesc, Texts_BufDesc, 0); + __INITYP(Texts_TextDesc, Texts_TextDesc, 0); + __INITYP(Texts_Reader, Texts_Reader, 0); + __INITYP(Texts_Scanner, Texts_Reader, 1); + __INITYP(Texts_Writer, Texts_Writer, 0); + __INITYP(Texts__1, Texts_ElemDesc, 2); +/* BEGIN */ + Texts_del = NIL; + __NEW(Texts_FontsDefault, Texts_FontDesc); + __MOVE("Syntax10.Scn.Fnt", Texts_FontsDefault->name, 17); + __ENDMOD; +} diff --git a/bootstrap/unix-44/Texts.h b/bootstrap/unix-44/Texts.h new file mode 100644 index 00000000..dc569fa9 --- /dev/null +++ b/bootstrap/unix-44/Texts.h @@ -0,0 +1,172 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Texts__h +#define Texts__h + +#include "SYSTEM.h" +#include "Files.h" + +typedef + struct Texts_BufDesc { + INT32 len; + char _prvt0[4]; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_RunDesc { + INT32 _prvt0; + char _prvt1[15]; + } Texts_RunDesc; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_ElemDesc { + char _prvt0[20]; + INT32 W, H; + Texts_Handler handle; + char _prvt1[4]; + } Texts_ElemDesc; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + char _prvt0[32]; + } Texts_FontDesc; + +typedef + Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[32]; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[32]; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + char _prvt0[12]; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + char _prvt0[26]; + } Texts_Writer; + + +import Texts_Elem Texts_new; + +import ADDRESS *Texts_FontDesc__typ; +import ADDRESS *Texts_RunDesc__typ; +import ADDRESS *Texts_ElemMsg__typ; +import ADDRESS *Texts_ElemDesc__typ; +import ADDRESS *Texts_FileMsg__typ; +import ADDRESS *Texts_CopyMsg__typ; +import ADDRESS *Texts_IdentifyMsg__typ; +import ADDRESS *Texts_BufDesc__typ; +import ADDRESS *Texts_TextDesc__typ; +import ADDRESS *Texts_Reader__typ; +import ADDRESS *Texts_Scanner__typ; +import ADDRESS *Texts_Writer__typ; + +import void Texts_Append (Texts_Text T, Texts_Buffer B); +import void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +import void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +import void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +import void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +import Texts_Text Texts_ElemBase (Texts_Elem E); +import INT32 Texts_ElemPos (Texts_Elem E); +import void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +import void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_OpenBuf (Texts_Buffer B); +import void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +import void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +import void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +import INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +import void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Recall (Texts_Buffer *B); +import void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +import void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +import void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +import void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +import void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +import void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +import void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +import void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +import void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +import void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +import void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +import void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +import void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +import void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +import void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +import void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +import void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); +import void *Texts__init(void); + + +#endif // Texts diff --git a/bootstrap/unix-44/VT100.c b/bootstrap/unix-44/VT100.c new file mode 100644 index 00000000..346fb37b --- /dev/null +++ b/bootstrap/unix-44/VT100.c @@ -0,0 +1,275 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Out.h" +#include "Strings.h" + + +export CHAR VT100_CSI[5]; +static CHAR VT100_tmpstr[32]; + + +export void VT100_CHA (INT16 n); +export void VT100_CNL (INT16 n); +export void VT100_CPL (INT16 n); +export void VT100_CUB (INT16 n); +export void VT100_CUD (INT16 n); +export void VT100_CUF (INT16 n); +export void VT100_CUP (INT16 n, INT16 m); +export void VT100_CUU (INT16 n); +export void VT100_DECTCEMh (void); +export void VT100_DECTCEMl (void); +export void VT100_DSR (INT16 n); +export void VT100_ED (INT16 n); +export void VT100_EL (INT16 n); +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len); +export void VT100_HVP (INT16 n, INT16 m); +export void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +export void VT100_RCP (void); +export void VT100_Reset (void); +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end); +export void VT100_SCP (void); +export void VT100_SD (INT16 n); +export void VT100_SGR (INT16 n); +export void VT100_SGR2 (INT16 n, INT16 m); +export void VT100_SU (INT16 n); +export void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); + + +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end) +{ + CHAR h; + while (start < end) { + h = str[__X(start, str__len)]; + str[__X(start, str__len)] = str[__X(end, str__len)]; + str[__X(end, str__len)] = h; + start += 1; + end -= 1; + } +} + +void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len) +{ + CHAR b[21]; + INT16 s, e; + INT8 maxLength; + maxLength = 11; + if (int_ == (-2147483647-1)) { + __MOVE("-2147483648", b, 12); + e = 11; + } else { + if (int_ < 0) { + b[0] = '-'; + int_ = -int_; + s = 1; + } else { + s = 0; + } + e = s; + do { + b[__X(e, 21)] = __CHR((int)__MOD(int_, 10) + 48); + int_ = __DIV(int_, 10); + e += 1; + } while (!(int_ == 0)); + b[__X(e, 21)] = 0x00; + VT100_Reverse0((void*)b, 21, s, e - 1); + } + __COPY(b, str, str__len); +} + +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len) +{ + CHAR cmd[9]; + __DUP(letter, letter__len, CHAR); + __COPY(VT100_CSI, cmd, 9); + Strings_Append(letter, letter__len, (void*)cmd, 9); + Out_String(cmd, 9); + __DEL(letter); +} + +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[5], mstr[5]; + CHAR cmd[12]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 5); + VT100_IntToStr(m, (void*)mstr, 5); + __COPY(VT100_CSI, cmd, 12); + Strings_Append(nstr, 5, (void*)cmd, 12); + Strings_Append((CHAR*)";", 2, (void*)cmd, 12); + Strings_Append(mstr, 5, (void*)cmd, 12); + Strings_Append(letter, letter__len, (void*)cmd, 12); + Out_String(cmd, 12); + __DEL(letter); +} + +void VT100_Reset (void) +{ + CHAR cmd[6]; + __COPY("\033", cmd, 6); + Strings_Append((CHAR*)"c", 2, (void*)cmd, 6); + Out_String(cmd, 6); + Out_Ln(); +} + +void VT100_CUU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"A", 2); +} + +void VT100_CUD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"B", 2); +} + +void VT100_CUF (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"C", 2); +} + +void VT100_CUB (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"D", 2); +} + +void VT100_CNL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"E", 2); +} + +void VT100_CPL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"F", 2); +} + +void VT100_CHA (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"G", 2); +} + +void VT100_CUP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"H", 2); +} + +void VT100_ED (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"J", 2); +} + +void VT100_EL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"K", 2); +} + +void VT100_SU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"S", 2); +} + +void VT100_SD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"T", 2); +} + +void VT100_HVP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"f", 2); +} + +void VT100_SGR (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"m", 2); +} + +void VT100_SGR2 (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"m", 2); +} + +void VT100_DSR (INT16 n) +{ + VT100_EscSeq(6, (CHAR*)"n", 2); +} + +void VT100_SCP (void) +{ + VT100_EscSeq0((CHAR*)"s", 2); +} + +void VT100_RCP (void) +{ + VT100_EscSeq0((CHAR*)"u", 2); +} + +void VT100_DECTCEMl (void) +{ + VT100_EscSeq0((CHAR*)"\?25l", 5); +} + +void VT100_DECTCEMh (void) +{ + VT100_EscSeq0((CHAR*)"\?25h", 5); +} + +void VT100_SetAttr (CHAR *attr, ADDRESS attr__len) +{ + CHAR tmpstr[16]; + __DUP(attr, attr__len, CHAR); + __COPY(VT100_CSI, tmpstr, 16); + Strings_Append(attr, attr__len, (void*)tmpstr, 16); + Out_String(tmpstr, 16); + __DEL(attr); +} + + +export void *VT100__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Strings); + __REGMOD("VT100", 0); + __REGCMD("DECTCEMh", VT100_DECTCEMh); + __REGCMD("DECTCEMl", VT100_DECTCEMl); + __REGCMD("RCP", VT100_RCP); + __REGCMD("Reset", VT100_Reset); + __REGCMD("SCP", VT100_SCP); +/* BEGIN */ + __COPY("\033", VT100_CSI, 5); + Strings_Append((CHAR*)"[", 2, (void*)VT100_CSI, 5); + __ENDMOD; +} diff --git a/bootstrap/unix-44/VT100.h b/bootstrap/unix-44/VT100.h new file mode 100644 index 00000000..4e708647 --- /dev/null +++ b/bootstrap/unix-44/VT100.h @@ -0,0 +1,38 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef VT100__h +#define VT100__h + +#include "SYSTEM.h" + + +import CHAR VT100_CSI[5]; + + +import void VT100_CHA (INT16 n); +import void VT100_CNL (INT16 n); +import void VT100_CPL (INT16 n); +import void VT100_CUB (INT16 n); +import void VT100_CUD (INT16 n); +import void VT100_CUF (INT16 n); +import void VT100_CUP (INT16 n, INT16 m); +import void VT100_CUU (INT16 n); +import void VT100_DECTCEMh (void); +import void VT100_DECTCEMl (void); +import void VT100_DSR (INT16 n); +import void VT100_ED (INT16 n); +import void VT100_EL (INT16 n); +import void VT100_HVP (INT16 n, INT16 m); +import void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +import void VT100_RCP (void); +import void VT100_Reset (void); +import void VT100_SCP (void); +import void VT100_SD (INT16 n); +import void VT100_SGR (INT16 n); +import void VT100_SGR2 (INT16 n, INT16 m); +import void VT100_SU (INT16 n); +import void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); +import void *VT100__init(void); + + +#endif // VT100 diff --git a/bootstrap/unix-44/extTools.c b/bootstrap/unix-44/extTools.c new file mode 100644 index 00000000..ce2fc413 --- /dev/null +++ b/bootstrap/unix-44/extTools.c @@ -0,0 +1,139 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "Modules.h" +#include "OPM.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + CHAR extTools_CommandString[4096]; + + +static extTools_CommandString extTools_CFLAGS; + + +export void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len); +export void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len); + + +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len) +{ + INT16 r, status, exitcode; + extTools_CommandString fullcmd; + __DUP(title, title__len, CHAR); + __DUP(cmd, cmd__len, CHAR); + if (__IN(18, OPM_Options, 32)) { + Out_String((CHAR*)" ", 3); + Out_String(cmd, cmd__len); + Out_Ln(); + } + __COPY(cmd, fullcmd, 4096); + Heap_GC(0); + r = Platform_System(fullcmd, 4096); + status = __MASK(r, -128); + exitcode = __ASHR(r, 8); + if (exitcode > 127) { + exitcode = exitcode - 256; + } + if (r != 0) { + Out_String(title, title__len); + Out_String(cmd, cmd__len); + Out_Ln(); + Out_String((CHAR*)"-- failed: status ", 19); + Out_Int(status, 1); + Out_String((CHAR*)", exitcode ", 12); + Out_Int(exitcode, 1); + Out_String((CHAR*)".", 2); + Out_Ln(); + if ((status == 0 && exitcode == 127)) { + Out_String((CHAR*)"Is the C compiler in the current command path\?", 47); + Out_Ln(); + } + if (status != 0) { + Modules_Halt(status); + } else { + Modules_Halt(exitcode); + } + } + __DEL(title); + __DEL(cmd); +} + +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + __DUP(additionalopts, additionalopts__len, CHAR); + __COPY("gcc -fPIC -g -Wno-stringop-overflow", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Strings_Append(additionalopts, additionalopts__len, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 4096); + Strings_Append(extTools_CFLAGS, 4096, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + __DEL(additionalopts); +} + +void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len) +{ + extTools_CommandString cmd; + __DUP(moduleName, moduleName__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, (CHAR*)"", 1); + Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c", 3, (void*)cmd, 4096); + extTools_execute((CHAR*)"C compile: ", 12, cmd, 4096); + __DEL(moduleName); +} + +void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + extTools_CommandString cmd; + __DUP(additionalopts, additionalopts__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, additionalopts, additionalopts__len); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c ", 4, (void*)cmd, 4096); + if (statically) { + Strings_Append((CHAR*)" -static", 9, (void*)cmd, 4096); + } + Strings_Append((CHAR*)" -o ", 5, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + if (!statically || 1) { + Strings_Append((CHAR*)" -L\"", 5, (void*)cmd, 4096); + Strings_Append(OPM_InstallDir, 1024, (void*)cmd, 4096); + Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 4096); + Strings_Append((CHAR*)" -lvoc", 7, (void*)cmd, 4096); + Strings_Append((CHAR*)"-O", 3, (void*)cmd, 4096); + Strings_Append(OPM_Model, 10, (void*)cmd, 4096); + Strings_Append((CHAR*)"", 1, (void*)cmd, 4096); + } + extTools_execute((CHAR*)"C compile and link: ", 21, cmd, 4096); + __DEL(additionalopts); +} + + +export void *extTools__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("extTools", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-44/extTools.h b/bootstrap/unix-44/extTools.h new file mode 100644 index 00000000..686f0b4e --- /dev/null +++ b/bootstrap/unix-44/extTools.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef extTools__h +#define extTools__h + +#include "SYSTEM.h" + + + + +import void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +import void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +import void *extTools__init(void); + + +#endif // extTools diff --git a/bootstrap/unix-48/Compiler.c b/bootstrap/unix-48/Compiler.c new file mode 100644 index 00000000..4460479d --- /dev/null +++ b/bootstrap/unix-48/Compiler.c @@ -0,0 +1,213 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspamS */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "OPB.h" +#include "OPC.h" +#include "OPM.h" +#include "OPP.h" +#include "OPT.h" +#include "OPV.h" +#include "Platform.h" +#include "Strings.h" +#include "VT100.h" +#include "extTools.h" + + + + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len); +export void Compiler_Module (BOOLEAN *done); +static void Compiler_PropagateElementaryTypeSizes (void); +export void Compiler_Translate (void); +static void Compiler_Trap (INT32 sig); + + +void Compiler_Module (BOOLEAN *done) +{ + BOOLEAN ext, new; + OPT_Node p = NIL; + OPP_Module(&p, OPM_Options); + if (OPM_noerr) { + OPV_Init(); + OPT_InitRecno(); + OPV_AdrAndSize(OPT_topScope); + OPT_Export(&ext, &new); + if (OPM_noerr) { + OPM_OpenFiles((void*)OPT_SelfName, 256); + OPM_DeleteObj((void*)OPT_SelfName, 256); + OPC_Init(); + OPV_Module(p); + if (OPM_noerr) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" Main program.", 16); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + if (new) { + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" New symbol file.", 19); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_RegisterNewSym(); + } else if (ext) { + OPM_LogWStr((CHAR*)" Extended symbol file.", 24); + OPM_RegisterNewSym(); + } + } + } else { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } + OPM_CloseFiles(); + OPT_Close(); + OPM_LogWLn(); + *done = OPM_noerr; +} + +static void Compiler_PropagateElementaryTypeSizes (void) +{ + OPT_Struct adrinttyp = NIL; + OPT_sysptrtyp->size = OPM_AddressSize; + OPT_sysptrtyp->idfp = OPT_sysptrtyp->form; + OPM_FPrint(&OPT_sysptrtyp->idfp, OPT_sysptrtyp->size); + OPT_adrtyp->size = OPM_AddressSize; + OPT_adrtyp->idfp = OPT_adrtyp->form; + OPM_FPrint(&OPT_adrtyp->idfp, OPT_adrtyp->size); + adrinttyp = OPT_IntType(OPM_AddressSize); + OPT_adrtyp->strobj = adrinttyp->strobj; + OPT_sinttyp = OPT_IntType(OPM_ShortintSize); + OPT_inttyp = OPT_IntType(OPM_IntegerSize); + OPT_linttyp = OPT_IntType(OPM_LongintSize); + OPT_sintobj->typ = OPT_sinttyp; + OPT_intobj->typ = OPT_inttyp; + OPT_lintobj->typ = OPT_linttyp; + switch (OPM_SetSize) { + case 4: + OPT_settyp = OPT_set32typ; + break; + default: + OPT_settyp = OPT_set64typ; + break; + } + OPT_setobj->typ = OPT_settyp; + if (__STRCMP(OPM_Model, "C") == 0) { + OPT_cpbytetyp->strobj->name[4] = 0x00; + } else { + OPT_cpbytetyp->strobj->name[4] = '@'; + } +} + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len) +{ + OPT_Link l = NIL; + CHAR fn[64]; + Platform_FileIdentity id; + objectnames[0] = 0x00; + l = OPT_Links; + while (l != NIL) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".sym", 5, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".o", 3, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + Strings_Append((CHAR*)" ", 2, (void*)objectnames, objectnames__len); + Strings_Append(fn, 64, (void*)objectnames, objectnames__len); + } else { + OPM_LogVT100((CHAR*)"91m", 4); + OPM_LogWStr((CHAR*)"Link warning: a local symbol file is present for module ", 57); + OPM_LogWStr(l->name, 256); + OPM_LogWStr((CHAR*)", but local object file '", 26); + OPM_LogWStr(fn, 64); + OPM_LogWStr((CHAR*)"' is missing.", 14); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_LogWLn(); + } + } + l = l->next; + } +} + +void Compiler_Translate (void) +{ + BOOLEAN done; + CHAR linkfiles[2048]; + if (OPM_OpenPar()) { + for (;;) { + OPM_Init(&done); + if (!done) { + return; + } + OPM_InitOptions(); + Compiler_PropagateElementaryTypeSizes(); + Heap_GC(0); + Compiler_Module(&done); + if (!done) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Module compilation failed.", 27); + OPM_LogWLn(); + Platform_Exit(1); + } + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + if (!__IN(10, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + Compiler_FindLocalObjectFiles((void*)linkfiles, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), linkfiles, 2048); + } + } + } + } + } +} + +static void Compiler_Trap (INT32 sig) +{ + Heap_FINALL(); + if (sig == 3) { + Platform_Exit(0); + } else { + if (sig == 4) { + OPM_LogWStr((CHAR*)" --- Oberon compiler internal error", 36); + OPM_LogWLn(); + } + Platform_Exit(2); + } +} + + +export int main(int argc, char **argv) +{ + __INIT(argc, argv); + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPP); + __MODULE_IMPORT(OPT); + __MODULE_IMPORT(OPV); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(VT100); + __MODULE_IMPORT(extTools); + __REGMAIN("Compiler", 0); + __REGCMD("Translate", Compiler_Translate); +/* BEGIN */ + Platform_SetInterruptHandler(Compiler_Trap); + Platform_SetQuitHandler(Compiler_Trap); + Platform_SetBadInstructionHandler(Compiler_Trap); + Compiler_Translate(); + __FINI; +} diff --git a/bootstrap/unix-48/Configuration.c b/bootstrap/unix-48/Configuration.c new file mode 100644 index 00000000..fa87c9de --- /dev/null +++ b/bootstrap/unix-48/Configuration.c @@ -0,0 +1,24 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + +export CHAR Configuration_versionLong[76]; + + + + + +export void *Configuration__init(void) +{ + __DEFMOD; + __REGMOD("Configuration", 0); +/* BEGIN */ + __MOVE("2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 76); + __ENDMOD; +} diff --git a/bootstrap/unix-48/Configuration.h b/bootstrap/unix-48/Configuration.h new file mode 100644 index 00000000..c3c54eed --- /dev/null +++ b/bootstrap/unix-48/Configuration.h @@ -0,0 +1,15 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Configuration__h +#define Configuration__h + +#include "SYSTEM.h" + + +import CHAR Configuration_versionLong[76]; + + +import void *Configuration__init(void); + + +#endif // Configuration diff --git a/bootstrap/unix-48/Files.c b/bootstrap/unix-48/Files.c new file mode 100644 index 00000000..54341368 --- /dev/null +++ b/bootstrap/unix-48/Files.c @@ -0,0 +1,1097 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_BufDesc { + Files_File f; + BOOLEAN chg; + INT32 org, size; + SYSTEM_BYTE data[4096]; + } Files_BufDesc; + +typedef + Files_BufDesc *Files_Buffer; + +typedef + CHAR Files_FileName[256]; + +typedef + struct Files_FileDesc { + Files_FileName workName, registerName; + BOOLEAN tempFile; + Platform_FileIdentity identity; + INT32 fd, len, pos; + Files_Buffer bufs[4]; + INT16 swapper, state; + struct Files_FileDesc *next; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + Files_Buffer buf; + INT32 org, offset; + } Files_Rider; + + +export INT16 Files_MaxPathLength, Files_MaxNameLength; +static Files_FileDesc *Files_files; +static INT16 Files_tempno; +static CHAR Files_HOME[1024]; +static struct { + ADDRESS len[1]; + CHAR data[1]; +} *Files_SearchPath; + +export ADDRESS *Files_FileDesc__typ; +export ADDRESS *Files_BufDesc__typ; +export ADDRESS *Files_Rider__typ; + +static void Files_Assert (BOOLEAN truth); +export Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +static Files_File Files_CacheEntry (Platform_FileIdentity identity); +export void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +export void Files_Close (Files_File f); +static void Files_CloseOSFile (Files_File f); +static void Files_Create (Files_File f); +export void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +static void Files_Deregister (CHAR *name, ADDRESS name__len); +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode); +static void Files_Finalize (SYSTEM_PTR o); +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len); +static void Files_Flush (Files_Buffer buf); +export void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +export void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len); +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len); +export INT32 Files_Length (Files_File f); +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len); +export Files_File Files_New (CHAR *name, ADDRESS name__len); +export Files_File Files_Old (CHAR *name, ADDRESS name__len); +export INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +export void Files_Purge (Files_File f); +export void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +export void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +export void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +export void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +export void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +export void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +export void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +export void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_Register (Files_File f); +export void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len); +export void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +export void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +export void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +export void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +export void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +export void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +export void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +export void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +export void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +export void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +export void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); + +#define Files_IdxTrap() __HALT(-1) + +static void Files_Assert (BOOLEAN truth) +{ + if (!truth) { + Out_Ln(); + __ASSERT(truth, 0); + } +} + +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode) +{ + __DUP(s, s__len, CHAR); + Out_Ln(); + Out_String((CHAR*)"-- ", 4); + Out_String(s, s__len); + Out_String((CHAR*)": ", 3); + if (f != NIL) { + if (f->registerName[0] != 0x00) { + Out_String(f->registerName, 256); + } else { + Out_String(f->workName, 256); + } + if (f->fd != 0) { + Out_String((CHAR*)", f.fd = ", 10); + Out_Int(f->fd, 1); + } + } + if (errcode != 0) { + Out_String((CHAR*)", errcode = ", 13); + Out_Int(errcode, 1); + } + Out_Ln(); + __HALT(99); + __DEL(s); +} + +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 i, j, ld, ln; + __DUP(dir, dir__len, CHAR); + __DUP(name, name__len, CHAR); + ld = Strings_Length(dir, dir__len); + ln = Strings_Length(name, name__len); + while ((ld > 0 && dir[__X(ld - 1, dir__len)] == '/')) { + ld -= 1; + } + if (((ld + ln) + 2) > dest__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + i = 0; + while (i < ld) { + dest[__X(i, dest__len)] = dir[__X(i, dir__len)]; + i += 1; + } + if (i > 0) { + dest[__X(i, dest__len)] = '/'; + i += 1; + } + j = 0; + while (j < ln) { + dest[__X(i, dest__len)] = name[__X(j, name__len)]; + i += 1; + j += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(dir); + __DEL(name); +} + +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len) +{ + INT16 i, n; + __DUP(finalName, finalName__len, CHAR); + if (finalName[0] == '/') { + __COPY(finalName, name, name__len); + } else { + Files_MakeFileName(Platform_CWD, 256, finalName, finalName__len, (void*)name, name__len); + } + i = Strings_Length(name, name__len) - 1; + while ((i > 0 && name[__X(i, name__len)] != '/')) { + i -= 1; + } + if ((i + 16) >= name__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + Files_tempno += 1; + n = Files_tempno; + name[__X(i + 1, name__len)] = '.'; + name[__X(i + 2, name__len)] = 't'; + name[__X(i + 3, name__len)] = 'm'; + name[__X(i + 4, name__len)] = 'p'; + name[__X(i + 5, name__len)] = '.'; + i += 6; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = '.'; + i += 1; + n = Platform_PID; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = 0x00; + __DEL(finalName); +} + +static void Files_Deregister (CHAR *name, ADDRESS name__len) +{ + Platform_FileIdentity identity; + Files_File osfile = NIL; + INT16 error; + __DUP(name, name__len, CHAR); + if (Platform_IdentifyByName(name, name__len, &identity, Platform_FileIdentity__typ) == 0) { + osfile = (Files_File)Files_files; + while ((osfile != NIL && !Platform_SameFile(osfile->identity, identity))) { + osfile = (Files_File)osfile->next; + } + if (osfile != NIL) { + __ASSERT(!osfile->tempFile, 0); + __ASSERT(osfile->fd >= 0, 0); + __MOVE(osfile->workName, osfile->registerName, 256); + Files_GetTempName(osfile->registerName, 256, (void*)osfile->workName, 256); + osfile->tempFile = 1; + osfile->state = 0; + error = Platform_Rename((void*)osfile->registerName, 256, (void*)osfile->workName, 256); + if (error != 0) { + Files_Err((CHAR*)"Couldn't rename previous version of file being registered", 58, osfile, error); + } + } + } + __DEL(name); +} + +static void Files_Create (Files_File f) +{ + BOOLEAN done; + INT16 error; + CHAR err[32]; + if (f->fd == -1) { + if (f->state == 1) { + Files_GetTempName(f->registerName, 256, (void*)f->workName, 256); + f->tempFile = 1; + } else { + __ASSERT(f->state == 2, 0); + Files_Deregister(f->registerName, 256); + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } + error = Platform_Unlink((void*)f->workName, 256); + error = Platform_New((void*)f->workName, 256, &f->fd); + done = error == 0; + if (done) { + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->state = 0; + f->pos = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + } else { + if (Platform_NoSuchDirectory(error)) { + __MOVE("no such directory", err, 18); + } else if (Platform_TooManyFiles(error)) { + __MOVE("too many files open", err, 20); + } else { + __MOVE("file not created", err, 17); + } + Files_Err(err, 32, f, error); + } + } +} + +static void Files_Flush (Files_Buffer buf) +{ + INT16 error; + Files_File f = NIL; + if (buf->chg) { + f = buf->f; + Files_Create(f); + if (buf->org != f->pos) { + error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); + } + error = Platform_Write(f->fd, (ADDRESS)buf->data, buf->size); + if (error != 0) { + Files_Err((CHAR*)"error writing file", 19, f, error); + } + f->pos = buf->org + buf->size; + buf->chg = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + if (error != 0) { + Files_Err((CHAR*)"error identifying file", 23, f, error); + } + } +} + +void Files_Close (Files_File f) +{ + INT32 i; + INT16 error; + if (f->state != 1 || f->registerName[0] != 0x00) { + Files_Create(f); + i = 0; + while ((i < 4 && f->bufs[__X(i, 4)] != NIL)) { + Files_Flush(f->bufs[__X(i, 4)]); + i += 1; + } + } +} + +INT32 Files_Length (Files_File f) +{ + return f->len; +} + +Files_File Files_New (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + __DUP(name, name__len, CHAR); + __NEW(f, Files_FileDesc); + f->workName[0] = 0x00; + __COPY(name, f->registerName, 256); + f->fd = -1; + f->state = 1; + f->len = 0; + f->pos = 0; + f->swapper = -1; + __DEL(name); + return f; +} + +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len) +{ + INT16 i; + CHAR ch; + i = 0; + if (Files_SearchPath == NIL) { + if (*pos == 0) { + dir[0] = '.'; + i = 1; + *pos += 1; + } + } else { + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (ch == ' ' || ch == ';') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + if (ch == '~') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (Files_HOME[__X(i, 1024)] != 0x00) { + dir[__X(i, dir__len)] = Files_HOME[__X(i, 1024)]; + i += 1; + } + if ((((((ch != '/' && ch != 0x00)) && ch != ';')) && ch != ' ')) { + while ((i > 0 && dir[__X(i - 1, dir__len)] != '/')) { + i -= 1; + } + } + } + while ((ch != 0x00 && ch != ';')) { + dir[__X(i, dir__len)] = ch; + i += 1; + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + while ((i > 0 && dir[__X(i - 1, dir__len)] == ' ')) { + i -= 1; + } + } + dir[__X(i, dir__len)] = 0x00; +} + +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + ch = name[0]; + while ((ch != 0x00 && ch != '/')) { + i += 1; + ch = name[__X(i, name__len)]; + } + return ch == '/'; +} + +static Files_File Files_CacheEntry (Platform_FileIdentity identity) +{ + Files_File f = NIL; + INT16 i, error; + f = (Files_File)Files_files; + while (f != NIL) { + if (Platform_SameFile(identity, f->identity)) { + if (!Platform_SameFileTime(identity, f->identity)) { + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + f->swapper = -1; + f->identity = identity; + error = Platform_Size(f->fd, &f->len); + } + return f; + } + f = (Files_File)f->next; + } + return NIL; +} + +Files_File Files_Old (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + INT32 fd; + INT16 pos; + BOOLEAN done; + CHAR dir[256], path[256]; + INT16 error; + Platform_FileIdentity identity; + __DUP(name, name__len, CHAR); + if (name[0] != 0x00) { + if (Files_HasDir((void*)name, name__len)) { + dir[0] = 0x00; + __COPY(name, path, 256); + } else { + pos = 0; + Files_ScanPath(&pos, (void*)dir, 256); + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + for (;;) { + error = Platform_OldRW((void*)path, 256, &fd); + done = error == 0; + if ((!done && Platform_TooManyFiles(error))) { + Files_Err((CHAR*)"too many files open", 20, f, error); + } + if ((!done && Platform_Inaccessible(error))) { + error = Platform_OldRO((void*)path, 256, &fd); + done = error == 0; + } + if ((!done && !Platform_Absent(error))) { + Out_String((CHAR*)"Warning: Files.Old ", 20); + Out_String(name, name__len); + Out_String((CHAR*)" error = ", 10); + Out_Int(error, 0); + Out_Ln(); + } + if (done) { + error = Platform_Identify(fd, &identity, Platform_FileIdentity__typ); + f = Files_CacheEntry(identity); + if (f != NIL) { + error = Platform_Close(fd); + __DEL(name); + return f; + } else { + __NEW(f, Files_FileDesc); + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->fd = fd; + f->state = 0; + f->pos = 0; + f->swapper = -1; + error = Platform_Size(fd, &f->len); + __COPY(name, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + f->identity = identity; + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + __DEL(name); + return f; + } + } else if (dir[0] == 0x00) { + __DEL(name); + return NIL; + } else { + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + } + } else { + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Files_Purge (Files_File f) +{ + INT16 i; + Platform_FileIdentity identity; + INT16 error; + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + if (f->fd != -1) { + error = Platform_Truncate(f->fd, 0); + error = Platform_Seek(f->fd, 0, Platform_SeekSet); + } + f->pos = 0; + f->len = 0; + f->swapper = -1; + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_SetMTime(&f->identity, Platform_FileIdentity__typ, identity); +} + +void Files_GetDate (Files_File f, INT32 *t, INT32 *d) +{ + Platform_FileIdentity identity; + INT16 error; + Files_Create(f); + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_MTimeAsClock(identity, &*t, &*d); +} + +INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ) +{ + Files_Assert((*r).offset <= 4096); + return (*r).org + (*r).offset; +} + +void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos) +{ + INT32 org, offset, i, n; + Files_Buffer buf = NIL; + INT16 error; + if (f != NIL) { + if (pos > f->len) { + pos = f->len; + } else if (pos < 0) { + pos = 0; + } + offset = __MASK(pos, -4096); + org = pos - offset; + i = 0; + while ((((i < 4 && f->bufs[__X(i, 4)] != NIL)) && org != f->bufs[__X(i, 4)]->org)) { + i += 1; + } + if (i < 4) { + if (f->bufs[__X(i, 4)] == NIL) { + __NEW(buf, Files_BufDesc); + buf->chg = 0; + buf->org = -1; + buf->f = f; + f->bufs[__X(i, 4)] = buf; + } else { + buf = f->bufs[__X(i, 4)]; + } + } else { + f->swapper = __MASK(f->swapper + 1, -4); + buf = f->bufs[__X(f->swapper, 4)]; + Files_Flush(buf); + } + if (buf->org != org) { + if (org == f->len) { + buf->size = 0; + } else { + Files_Create(f); + if (f->pos != org) { + error = Platform_Seek(f->fd, org, Platform_SeekSet); + } + error = Platform_ReadBuf(f->fd, (void*)buf->data, 4096, &n); + if (error != 0) { + Files_Err((CHAR*)"read from file not done", 24, f, error); + } + f->pos = org + n; + buf->size = n; + } + buf->org = org; + buf->chg = 0; + } + } else { + buf = NIL; + org = 0; + offset = 0; + } + Files_Assert(offset <= 4096); + (*r).buf = buf; + (*r).org = org; + (*r).offset = offset; + (*r).eof = 0; + (*r).res = 0; +} + +void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + INT32 offset; + Files_Buffer buf = NIL; + buf = (*r).buf; + offset = (*r).offset; + if ((*r).org != buf->org) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= buf->size); + if (offset < buf->size) { + *x = buf->data[__X(offset, 4096)]; + (*r).offset = offset + 1; + } else if ((*r).org + offset < buf->f->len) { + Files_Set(&*r, r__typ, (*r).buf->f, (*r).org + offset); + *x = (*r).buf->data[0]; + (*r).offset = 1; + } else { + *x = 0x00; + (*r).eof = 1; + } +} + +void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + Files_Read(&*r, r__typ, &*x); +} + +void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + restInBuf = buf->size - offset; + if (restInBuf == 0) { + (*r).res = n; + (*r).eof = 1; + return; + } else if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&buf->data[__X(offset, 4096)], (ADDRESS)&x[__X(xpos, x__len)], min); + offset += min; + (*r).offset = offset; + xpos += min; + n -= min; + Files_Assert(offset <= 4096); + } + (*r).res = 0; + (*r).eof = 0; +} + +Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ) +{ + return (*r).buf->f; +} + +void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x) +{ + Files_Buffer buf = NIL; + INT32 offset; + buf = (*r).buf; + offset = (*r).offset; + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset < 4096); + buf->data[__X(offset, 4096)] = x; + buf->chg = 1; + if (offset == buf->size) { + buf->size += 1; + buf->f->len += 1; + } + (*r).offset = offset + 1; + (*r).res = 0; +} + +void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= 4096); + restInBuf = 4096 - offset; + if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&x[__X(xpos, x__len)], (ADDRESS)&buf->data[__X(offset, 4096)], min); + offset += min; + (*r).offset = offset; + Files_Assert(offset <= 4096); + if (offset > buf->size) { + buf->f->len += offset - buf->size; + buf->size = offset; + } + xpos += min; + n -= min; + buf->chg = 1; + } + (*r).res = 0; +} + +void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res) +{ + __DUP(name, name__len, CHAR); + Files_Deregister(name, name__len); + *res = Platform_Unlink((void*)name, name__len); + __DEL(name); +} + +void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res) +{ + INT32 fdold, fdnew, n; + INT16 error, ignore; + Platform_FileIdentity oldidentity, newidentity; + CHAR buf[4096]; + __DUP(old, old__len, CHAR); + __DUP(new, new__len, CHAR); + error = Platform_IdentifyByName(old, old__len, &oldidentity, Platform_FileIdentity__typ); + if (error == 0) { + error = Platform_IdentifyByName(new, new__len, &newidentity, Platform_FileIdentity__typ); + if ((error != 0 && !Platform_SameFile(oldidentity, newidentity))) { + Files_Delete(new, new__len, &error); + } + error = Platform_Rename((void*)old, old__len, (void*)new, new__len); + if (!Platform_DifferentFilesystems(error)) { + *res = error; + __DEL(old); + __DEL(new); + return; + } else { + error = Platform_OldRO((void*)old, old__len, &fdold); + if (error != 0) { + *res = 2; + __DEL(old); + __DEL(new); + return; + } + error = Platform_New((void*)new, new__len, &fdnew); + if (error != 0) { + error = Platform_Close(fdold); + *res = 3; + __DEL(old); + __DEL(new); + return; + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + while (n > 0) { + error = Platform_Write(fdnew, (ADDRESS)buf, n); + if (error != 0) { + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + } + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + if (n == 0) { + error = Platform_Unlink((void*)old, old__len); + *res = 0; + } else { + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + } + } else { + *res = 2; + } + __DEL(old); + __DEL(new); +} + +void Files_Register (Files_File f) +{ + INT16 idx, errcode; + Files_File f1 = NIL; + if ((f->state == 1 && f->registerName[0] != 0x00)) { + f->state = 2; + } + Files_Close(f); + if (f->registerName[0] != 0x00) { + Files_Deregister(f->registerName, 256); + Files_Rename(f->workName, 256, f->registerName, 256, &errcode); + if (errcode != 0) { + Files_Err((CHAR*)"Couldn't rename temp name as register name", 43, f, errcode); + } + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } +} + +void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res) +{ + __DUP(path, path__len, CHAR); + *res = Platform_Chdir((void*)path, path__len); + __DEL(path); +} + +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len) +{ + INT32 i, j; + if (!Platform_LittleEndian) { + i = src__len; + j = 0; + while (i > 0) { + i -= 1; + dest[__X(j, dest__len)] = src[__X(i, src__len)]; + j += 1; + } + } else { + __MOVE((ADDRESS)src, (ADDRESS)dest, src__len); + } +} + +void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x) +{ + Files_Read(&*R, R__typ, (CHAR*)(void*)&*x); +} + +void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x) +{ + CHAR b[2]; + Files_ReadBytes(&*R, R__typ, (void*)b, 2, 2); + *x = (INT16)b[0] + __ASHL((INT16)b[1], 8); +} + +void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + *x = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); +} + +void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x) +{ + CHAR b[4]; + INT32 l; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + l = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); + *x = (UINT32)l; +} + +void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + Files_FlipBytes((void*)b, 4, (void*)&*x, 4); +} + +void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x) +{ + CHAR b[8]; + Files_ReadBytes(&*R, R__typ, (void*)b, 8, 8); + Files_FlipBytes((void*)b, 8, (void*)&*x, 8); +} + +void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&ch); + x[__X(i, x__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&x[__X(i, x__len)]); + i += 1; + } while (!(x[__X(i - 1, x__len)] == 0x00 || x[__X(i - 1, x__len)] == 0x0a)); + if (x[__X(i - 1, x__len)] == 0x0a) { + i -= 1; + } + if ((i > 0 && x[__X(i - 1, x__len)] == 0x0d)) { + i -= 1; + } + x[__X(i, x__len)] = 0x00; +} + +void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len) +{ + INT8 s, b; + INT64 q; + s = 0; + q = 0; + Files_Read(&*R, R__typ, (void*)&b); + while (b < 0) { + q += (INT64)__ASH(((INT16)b + 128), s); + s += 7; + Files_Read(&*R, R__typ, (void*)&b); + } + q += (INT64)__ASH((__MASK(b, -64) - __ASHL(__ASHR(b, 6), 6)), s); + Files_Assert(x__len <= 8); + __MOVE((ADDRESS)&q, (ADDRESS)x, x__len); +} + +void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x) +{ + Files_Write(&*R, R__typ, __VAL(CHAR, x)); +} + +void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x) +{ + CHAR b[2]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + Files_WriteBytes(&*R, R__typ, (void*)b, 2, 2); +} + +void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x) +{ + CHAR b[4]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + b[2] = __CHR(__ASHR(x, 16)); + b[3] = __CHR(__ASHR(x, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x) +{ + CHAR b[4]; + INT32 i; + UINT64 y; + y = x; + i = __VAL(INT32, y); + b[0] = __CHR(i); + b[1] = __CHR(__ASHR(i, 8)); + b[2] = __CHR(__ASHR(i, 16)); + b[3] = __CHR(__ASHR(i, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x) +{ + CHAR b[4]; + Files_FlipBytes((void*)&x, 4, (void*)b, 4); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x) +{ + CHAR b[8]; + Files_FlipBytes((void*)&x, 8, (void*)b, 8); + Files_WriteBytes(&*R, R__typ, (void*)b, 8, 8); +} + +void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + while (x[__X(i, x__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&*R, R__typ, (void*)x, x__len * 1, i + 1); +} + +void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x) +{ + while (x < -64 || x > 63) { + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128) + 128)); + x = __ASHR(x, 7); + } + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128))); +} + +void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len) +{ + __COPY(f->workName, name, name__len); +} + +static void Files_CloseOSFile (Files_File f) +{ + Files_File prev = NIL; + INT16 error; + if (Files_files == (void *) f) { + Files_files = f->next; + } else { + prev = (Files_File)Files_files; + while ((prev != NIL && prev->next != (void *) f)) { + prev = (Files_File)prev->next; + } + if (prev->next != NIL) { + prev->next = f->next; + } + } + error = Platform_Close(f->fd); + f->fd = -1; + f->state = 1; + Heap_FileCount -= 1; +} + +static void Files_Finalize (SYSTEM_PTR o) +{ + Files_File f = NIL; + INT32 res; + f = (Files_File)(ADDRESS)o; + if (f->fd >= 0) { + Files_CloseOSFile(f); + if (f->tempFile) { + res = Platform_Unlink((void*)f->workName, 256); + } + } +} + +void Files_SetSearchPath (CHAR *path, ADDRESS path__len) +{ + __DUP(path, path__len, CHAR); + if (Strings_Length(path, path__len) != 0) { + Files_SearchPath = __NEWARR(NIL, 1, 1, 1, 1, ((ADDRESS)((Strings_Length(path, path__len) + 1)))); + __COPY(path, Files_SearchPath->data, Files_SearchPath->len[0]); + } else { + Files_SearchPath = NIL; + } + __DEL(path); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Files_SearchPath); +} + +__TDESC(Files_FileDesc, 1, 4) = {__TDFLDS("FileDesc", 564), {540, 544, 548, 552, -20}}; +__TDESC(Files_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 4112), {0, -8}}; +__TDESC(Files_Rider, 1, 1) = {__TDFLDS("Rider", 20), {8, -8}}; + +export void *Files__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("Files", EnumPtrs); + __INITYP(Files_FileDesc, Files_FileDesc, 0); + __INITYP(Files_BufDesc, Files_BufDesc, 0); + __INITYP(Files_Rider, Files_Rider, 0); +/* BEGIN */ + Files_tempno = -1; + Heap_FileCount = 0; + Files_HOME[0] = 0x00; + Platform_GetEnv((CHAR*)"HOME", 5, (void*)Files_HOME, 1024); + Files_MaxPathLength = Platform_MaxPathLength(); + Files_MaxNameLength = Platform_MaxNameLength(); + __ENDMOD; +} diff --git a/bootstrap/unix-48/Files.h b/bootstrap/unix-48/Files.h new file mode 100644 index 00000000..ccdabcc2 --- /dev/null +++ b/bootstrap/unix-48/Files.h @@ -0,0 +1,70 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Files__h +#define Files__h + +#include "SYSTEM.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_FileDesc { + INT32 _prvt0; + char _prvt1[560]; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + char _prvt0[15]; + } Files_Rider; + + +import INT16 Files_MaxPathLength, Files_MaxNameLength; + +import ADDRESS *Files_FileDesc__typ; +import ADDRESS *Files_Rider__typ; + +import Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +import void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +import void Files_Close (Files_File f); +import void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +import void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +import void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +import INT32 Files_Length (Files_File f); +import Files_File Files_New (CHAR *name, ADDRESS name__len); +import Files_File Files_Old (CHAR *name, ADDRESS name__len); +import INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +import void Files_Purge (Files_File f); +import void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +import void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +import void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +import void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +import void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +import void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +import void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +import void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_Register (Files_File f); +import void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +import void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +import void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +import void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +import void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +import void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +import void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +import void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +import void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +import void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +import void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +import void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void *Files__init(void); + + +#endif // Files diff --git a/bootstrap/unix-48/Heap.c b/bootstrap/unix-48/Heap.c new file mode 100644 index 00000000..42552415 --- /dev/null +++ b/bootstrap/unix-48/Heap.c @@ -0,0 +1,799 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +struct Heap__1 { + CHAR ch; + SYSTEM_PTR p; +}; + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + struct Heap_FinDesc *Heap_FinNode; + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_FinDesc { + Heap_FinNode next; + INT32 obj; + BOOLEAN marked; + Heap_Finalizer finalize; + } Heap_FinDesc; + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + INT32 reserved1, reserved2; + } Heap_ModuleDesc; + + +export SYSTEM_PTR Heap_modules; +static INT32 Heap_freeList[10]; +static INT32 Heap_bigBlocks; +export INT32 Heap_allocated; +static BOOLEAN Heap_firstTry; +static INT16 Heap_ldUnit; +export INT32 Heap_heap; +static INT32 Heap_heapMin, Heap_heapMax; +export INT32 Heap_heapsize, Heap_heapMinExpand; +static Heap_FinNode Heap_fin; +static INT16 Heap_lockdepth; +static BOOLEAN Heap_interrupted; +export INT16 Heap_FileCount; + +export ADDRESS *Heap_ModuleDesc__typ; +export ADDRESS *Heap_CmdDesc__typ; +export ADDRESS *Heap_FinDesc__typ; +export ADDRESS *Heap__1__typ; + +static void Heap_CheckFin (void); +static void Heap_ExtendHeap (INT32 blksz); +export void Heap_FINALL (void); +static void Heap_Finalize (void); +export INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +export void Heap_GC (BOOLEAN markStack); +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len); +export void Heap_INCREF (Heap_Module m); +export void Heap_InitHeap (void); +export void Heap_Lock (void); +static void Heap_Mark (INT32 q); +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len); +static void Heap_MarkP (SYSTEM_PTR p); +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len); +export SYSTEM_PTR Heap_NEWBLK (INT32 size); +export SYSTEM_PTR Heap_NEWREC (INT32 tag); +static INT32 Heap_NewChunk (INT32 blksz); +export void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +export SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +export void Heap_REGTYP (Heap_Module m, INT32 typ); +export void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +static void Heap_Scan (void); +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len); +export void Heap_Unlock (void); + +extern void *Heap__init(); +extern ADDRESS Modules_MainStackFrame; +extern ADDRESS Platform_OSAllocate(ADDRESS size); +#define Heap_HeapModuleInit() Heap__init() +#define Heap_ModulesHalt(code) Modules_Halt(code) +#define Heap_ModulesMainStackFrame() Modules_MainStackFrame +#define Heap_OSAllocate(size) Platform_OSAllocate(size) +#define Heap_uLE(x, y) ((size_t)x <= (size_t)y) +#define Heap_uLT(x, y) ((size_t)x < (size_t)y) + +void Heap_Lock (void) +{ + Heap_lockdepth += 1; +} + +void Heap_Unlock (void) +{ + Heap_lockdepth -= 1; + if ((Heap_interrupted && Heap_lockdepth == 0)) { + Heap_ModulesHalt(-9); + } +} + +SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) +{ + Heap_Module m; + if (__STRCMP(name, "Heap") == 0) { + __SYSNEW(m, 48); + } else { + __NEW(m, Heap_ModuleDesc); + } + m->types = 0; + m->cmds = NIL; + __COPY(name, m->name, 20); + m->refcnt = 0; + m->enumPtrs = enumPtrs; + m->next = (Heap_Module)(ADDRESS)Heap_modules; + Heap_modules = (SYSTEM_PTR)m; + return (void*)m; +} + +INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len) +{ + Heap_Module m, p; + __DUP(name, name__len, CHAR); + m = (Heap_Module)(ADDRESS)Heap_modules; + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + p = m; + m = m->next; + } + if ((m != NIL && m->refcnt == 0)) { + if (m == (Heap_Module)(ADDRESS)Heap_modules) { + Heap_modules = (SYSTEM_PTR)m->next; + } else { + p->next = m->next; + } + __DEL(name); + return 0; + } else { + if (m == NIL) { + __DEL(name); + return -1; + } else { + __DEL(name); + return m->refcnt; + } + } + __RETCHK; +} + +void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd) +{ + Heap_Cmd c; + if (__STRCMP(m->name, "Heap") == 0) { + __SYSNEW(c, 32); + } else { + __NEW(c, Heap_CmdDesc); + } + __COPY(name, c->name, 24); + c->cmd = cmd; + c->next = m->cmds; + m->cmds = c; +} + +void Heap_REGTYP (Heap_Module m, INT32 typ) +{ + __PUT(typ, m->types, INT32); + m->types = typ; +} + +void Heap_INCREF (Heap_Module m) +{ + m->refcnt += 1; +} + +static INT32 Heap_NewChunk (INT32 blksz) +{ + INT32 chnk, blk, end; + chnk = Heap_OSAllocate(blksz + 12); + if (chnk != 0) { + blk = chnk + 12; + end = blk + blksz; + __PUT(chnk + 4, end, INT32); + __PUT(blk, blk + 4, INT32); + __PUT(blk + 4, blksz, INT32); + __PUT(blk + 8, -4, INT32); + __PUT(blk + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = blk; + Heap_heapsize += blksz; + if (Heap_uLT(blk + 4, Heap_heapMin)) { + Heap_heapMin = blk + 4; + } + if (Heap_uLT(Heap_heapMax, end)) { + Heap_heapMax = end; + } + } + return chnk; +} + +static void Heap_ExtendHeap (INT32 blksz) +{ + INT32 size, chnk, j, next; + if (Heap_uLT(Heap_heapMinExpand, blksz)) { + size = blksz; + } else { + size = Heap_heapMinExpand; + } + chnk = Heap_NewChunk(size); + if (chnk != 0) { + if (Heap_uLT(chnk, Heap_heap)) { + __PUT(chnk, Heap_heap, INT32); + Heap_heap = chnk; + } else { + j = Heap_heap; + __GET(j, next, INT32); + while ((next != 0 && Heap_uLT(next, chnk))) { + j = next; + __GET(j, next, INT32); + } + __PUT(chnk, next, INT32); + __PUT(j, chnk, INT32); + } + } else if (!Heap_firstTry) { + Heap_heapMinExpand = 16; + } +} + +SYSTEM_PTR Heap_NEWREC (INT32 tag) +{ + INT32 i, i0, di, blksz, restsize, t, adr, end, next, prev; + SYSTEM_PTR new; + Heap_Lock(); + __GET(tag, blksz, INT32); + i0 = __LSH(blksz, -Heap_ldUnit, 32); + i = i0; + if (i < 9) { + adr = Heap_freeList[i]; + while (adr == 0) { + i += 1; + adr = Heap_freeList[i]; + } + } + if (i < 9) { + __GET(adr + 12, next, INT32); + Heap_freeList[i] = next; + if (i != i0) { + di = i - i0; + restsize = __ASHL(di, 4); + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + adr += restsize; + } + } else { + adr = Heap_bigBlocks; + prev = 0; + for (;;) { + if (adr == 0) { + if (Heap_firstTry) { + Heap_GC(1); + blksz += 16; + t = __LSH(Heap_allocated + blksz, -(2 + Heap_ldUnit), 32) * 80; + if (Heap_uLT(Heap_heapsize, t)) { + Heap_ExtendHeap(t - Heap_heapsize); + } + Heap_firstTry = 0; + new = Heap_NEWREC(tag); + if (new == NIL) { + Heap_ExtendHeap(blksz); + new = Heap_NEWREC(tag); + } + Heap_firstTry = 1; + Heap_Unlock(); + return new; + } else { + Heap_Unlock(); + return NIL; + } + } + __GET(adr + 4, t, INT32); + if (Heap_uLE(blksz, t)) { + break; + } + prev = adr; + __GET(adr + 12, adr, INT32); + } + restsize = t - blksz; + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + if (Heap_uLT(144, restsize)) { + __PUT(adr + 4, restsize, INT32); + } else { + __GET(adr + 12, next, INT32); + if (prev == 0) { + Heap_bigBlocks = next; + } else { + __PUT(prev + 12, next, INT32); + } + if (restsize != 0) { + di = __ASHR(restsize, 4); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + } + } + adr += restsize; + } + i = adr + 16; + end = adr + blksz; + while (Heap_uLT(i, end)) { + __PUT(i, 0, INT32); + __PUT(i + 4, 0, INT32); + __PUT(i + 8, 0, INT32); + __PUT(i + 12, 0, INT32); + i += 16; + } + __PUT(adr + 12, 0, INT32); + __PUT(adr, tag, INT32); + __PUT(adr + 4, 0, INT32); + __PUT(adr + 8, 0, INT32); + Heap_allocated += blksz; + Heap_Unlock(); + return (SYSTEM_PTR)(ADDRESS)(adr + 4); +} + +SYSTEM_PTR Heap_NEWBLK (INT32 size) +{ + INT32 blksz, tag; + SYSTEM_PTR new; + Heap_Lock(); + blksz = __ASHL(__ASHR(size + 31, 4), 4); + new = Heap_NEWREC((ADDRESS)&blksz); + tag = ((INT32)(ADDRESS)new + blksz) - 12; + __PUT(tag - 4, 0, INT32); + __PUT(tag, blksz, INT32); + __PUT(tag + 4, -4, INT32); + __PUT((INT32)(ADDRESS)new - 4, tag, INT32); + Heap_Unlock(); + return new; +} + +static void Heap_Mark (INT32 q) +{ + INT32 p, tag, offset, fld, n, tagbits; + if (q != 0) { + __GET(q - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(q - 4, tagbits + 1, INT32); + p = 0; + tag = tagbits + 4; + for (;;) { + __GET(tag, offset, INT32); + if (offset < 0) { + __PUT(q - 4, (tag + offset) + 1, INT32); + if (p == 0) { + break; + } + n = q; + q = p; + __GET(q - 4, tag, INT32); + tag -= 1; + __GET(tag, offset, INT32); + fld = q + offset; + __GET(fld, p, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)n, SYSTEM_PTR); + } else { + fld = q + offset; + __GET(fld, n, INT32); + if (n != 0) { + __GET(n - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(n - 4, tagbits + 1, INT32); + __PUT(q - 4, tag + 1, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)p, SYSTEM_PTR); + p = q; + q = n; + tag = tagbits; + } + } + } + tag += 4; + } + } + } +} + +static void Heap_MarkP (SYSTEM_PTR p) +{ + Heap_Mark((INT32)(ADDRESS)p); +} + +static void Heap_Scan (void) +{ + INT32 chnk, adr, end, start, tag, i, size, freesize; + Heap_bigBlocks = 0; + i = 1; + while (i < 9) { + Heap_freeList[i] = 0; + i += 1; + } + freesize = 0; + Heap_allocated = 0; + chnk = Heap_heap; + while (chnk != 0) { + adr = chnk + 12; + __GET(chnk + 4, end, INT32); + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + tag -= 1; + __PUT(adr, tag, INT32); + __GET(tag, size, INT32); + Heap_allocated += size; + adr += size; + } else { + __GET(tag, size, INT32); + freesize += size; + adr += size; + } + } + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len) +{ + INT32 i, j; + INT32 x; + j = l; + x = a[j]; + for (;;) { + i = j; + j = __ASHL(j, 1) + 1; + if ((j < r && Heap_uLT(a[j], a[j + 1]))) { + j += 1; + } + if (j > r || Heap_uLE(a[j], x)) { + break; + } + a[i] = a[j]; + } + a[i] = x; +} + +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len) +{ + INT32 l, r; + INT32 x; + l = __ASHR(n, 1); + r = n - 1; + while (l > 0) { + l -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } + while (r > 0) { + x = a[0]; + a[0] = a[r]; + a[r] = x; + r -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } +} + +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + INT32 chnk, end, adr, tag, next, i, ptr, size; + chnk = Heap_heap; + i = 0; + while (chnk != 0) { + __GET(chnk + 4, end, INT32); + adr = chnk + 12; + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + __GET(tag - 1, size, INT32); + adr += size; + ptr = adr + 4; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + } else { + __GET(tag, size, INT32); + ptr = adr + 4; + adr += size; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + if (Heap_uLT(cand[i], adr)) { + Heap_Mark(ptr); + } + } + if (Heap_uLE(end, cand[i])) { + adr = end; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_CheckFin (void) +{ + Heap_FinNode n; + INT32 tag; + n = Heap_fin; + while (n != NIL) { + __GET(n->obj - 4, tag, INT32); + if (!__ODD(tag)) { + n->marked = 0; + Heap_Mark(n->obj); + } else { + n->marked = 1; + } + n = n->next; + } +} + +static void Heap_Finalize (void) +{ + Heap_FinNode n, prev; + n = Heap_fin; + prev = NIL; + while (n != NIL) { + if (!n->marked) { + if (n == Heap_fin) { + Heap_fin = Heap_fin->next; + } else { + prev->next = n->next; + } + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + if (prev == NIL) { + n = Heap_fin; + } else { + n = n->next; + } + } else { + prev = n; + n = n->next; + } + } +} + +void Heap_FINALL (void) +{ + Heap_FinNode n; + while (Heap_fin != NIL) { + n = Heap_fin; + Heap_fin = Heap_fin->next; + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + } +} + +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + SYSTEM_PTR frame; + INT32 nofcand; + INT32 inc, sp, p, stack0; + struct Heap__1 align; + if (n > 0) { + Heap_MarkStack(n - 1, cand, cand__len); + if (n > 100) { + return; + } + } + if (n == 0) { + nofcand = 0; + sp = (ADDRESS)&frame; + stack0 = Heap_ModulesMainStackFrame(); + inc = (ADDRESS)&align.p - (ADDRESS)&align; + if (Heap_uLT(stack0, sp)) { + inc = -inc; + } + while (sp != stack0) { + __GET(sp, p, INT32); + if ((Heap_uLE(Heap_heapMin, p) && Heap_uLT(p, Heap_heapMax))) { + if (nofcand == cand__len) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + nofcand = 0; + } + cand[nofcand] = p; + nofcand += 1; + } + sp += inc; + } + if (nofcand > 0) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + } + } +} + +void Heap_GC (BOOLEAN markStack) +{ + Heap_Module m; + INT32 i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23; + INT32 cand[10000]; + Heap_Lock(); + m = (Heap_Module)(ADDRESS)Heap_modules; + while (m != NIL) { + if (m->enumPtrs != NIL) { + (*m->enumPtrs)(Heap_MarkP); + } + m = m->next; + } + if (markStack) { + 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; + for (;;) { + i0 += 1; + i1 += 2; + i2 += 3; + i3 += 4; + i4 += 5; + i5 += 6; + i6 += 7; + i7 += 8; + i8 += 9; + i9 += 10; + i10 += 11; + i11 += 12; + i12 += 13; + i13 += 14; + i14 += 15; + i15 += 16; + i16 += 17; + i17 += 18; + i18 += 19; + i19 += 20; + i20 += 21; + i21 += 22; + i22 += 23; + i23 += 24; + if ((i0 == -99 && i15 == 24)) { + Heap_MarkStack(32, (void*)cand, 10000); + break; + } + } + 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) { + return; + } + } + Heap_CheckFin(); + Heap_Scan(); + Heap_Finalize(); + Heap_Unlock(); +} + +void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) +{ + Heap_FinNode f; + __NEW(f, Heap_FinDesc); + f->obj = (INT32)(ADDRESS)obj; + f->finalize = finalize; + f->marked = 1; + f->next = Heap_fin; + Heap_fin = f; +} + +void Heap_InitHeap (void) +{ + Heap_heap = 0; + Heap_heapsize = 0; + Heap_allocated = 0; + Heap_lockdepth = 0; + Heap_heapMin = -1; + Heap_heapMax = 0; + Heap_bigBlocks = 0; + Heap_heapMinExpand = 128000; + Heap_ldUnit = 4; + Heap_heap = Heap_NewChunk(128000); + __PUT(Heap_heap, 0, INT32); + Heap_firstTry = 1; + Heap_freeList[9] = 1; + Heap_FileCount = 0; + Heap_modules = NIL; + Heap_fin = NIL; + Heap_interrupted = 0; + Heap_HeapModuleInit(); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Heap_modules); + P(Heap_fin); +} + +__TDESC(Heap_ModuleDesc, 1, 2) = {__TDFLDS("ModuleDesc", 48), {0, 28, -12}}; +__TDESC(Heap_CmdDesc, 1, 1) = {__TDFLDS("CmdDesc", 32), {0, -8}}; +__TDESC(Heap_FinDesc, 1, 1) = {__TDFLDS("FinDesc", 16), {0, -8}}; +__TDESC(Heap__1, 1, 1) = {__TDFLDS("", 8), {4, -8}}; + +export void *Heap__init(void) +{ + __DEFMOD; + __REGMOD("Heap", EnumPtrs); + __REGCMD("FINALL", Heap_FINALL); + __REGCMD("InitHeap", Heap_InitHeap); + __REGCMD("Lock", Heap_Lock); + __REGCMD("Unlock", Heap_Unlock); + __INITYP(Heap_ModuleDesc, Heap_ModuleDesc, 0); + __INITYP(Heap_CmdDesc, Heap_CmdDesc, 0); + __INITYP(Heap_FinDesc, Heap_FinDesc, 0); + __INITYP(Heap__1, Heap__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/Heap.h b/bootstrap/unix-48/Heap.h new file mode 100644 index 00000000..3cde1c3b --- /dev/null +++ b/bootstrap/unix-48/Heap.h @@ -0,0 +1,73 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#ifndef Heap__h +#define Heap__h + +#include "SYSTEM.h" + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + char _prvt0[8]; + } Heap_ModuleDesc; + + +import SYSTEM_PTR Heap_modules; +import INT32 Heap_allocated; +import INT32 Heap_heap; +import INT32 Heap_heapsize, Heap_heapMinExpand; +import INT16 Heap_FileCount; + +import ADDRESS *Heap_ModuleDesc__typ; +import ADDRESS *Heap_CmdDesc__typ; + +import void Heap_FINALL (void); +import INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +import void Heap_GC (BOOLEAN markStack); +import void Heap_INCREF (Heap_Module m); +import void Heap_InitHeap (void); +import void Heap_Lock (void); +import SYSTEM_PTR Heap_NEWBLK (INT32 size); +import SYSTEM_PTR Heap_NEWREC (INT32 tag); +import void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +import SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +import void Heap_REGTYP (Heap_Module m, INT32 typ); +import void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +import void Heap_Unlock (void); +import void *Heap__init(void); + + +#endif // Heap diff --git a/bootstrap/unix-48/Modules.c b/bootstrap/unix-48/Modules.c new file mode 100644 index 00000000..535721e8 --- /dev/null +++ b/bootstrap/unix-48/Modules.c @@ -0,0 +1,506 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export INT16 Modules_res; +export CHAR Modules_resMsg[256]; +export Heap_ModuleName Modules_imported, Modules_importing; +export INT32 Modules_MainStackFrame; +export INT16 Modules_ArgCount; +export INT32 Modules_ArgVector; +export CHAR Modules_BinaryDir[1024]; + + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +export void Modules_AssertFail (INT32 code); +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len); +static void Modules_DisplayHaltCode (INT32 code); +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len); +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len); +export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +export void Modules_GetIntArg (INT16 n, INT32 *val); +export void Modules_Halt (INT32 code); +export void Modules_Init (INT32 argc, INT32 argvadr); +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len); +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len); +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len); +export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_errch (CHAR c); +static void Modules_errint (INT32 l); +static void Modules_errstring (CHAR *s, ADDRESS s__len); + +extern void Heap_InitHeap(); +extern void *Modules__init(void); +#define Modules_InitHeap() Heap_InitHeap() +#define Modules_ModulesInit() Modules__init() +#define Modules_modules() (Heap_Module)Heap_modules + +void Modules_Init (INT32 argc, INT32 argvadr) +{ + Modules_MainStackFrame = argvadr; + Modules_ArgCount = __VAL(INT16, argc); + __GET(argvadr, Modules_ArgVector, INT32); + Modules_InitHeap(); + Modules_ModulesInit(); +} + +typedef + CHAR (*argptr__15)[1024]; + +void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len) +{ + argptr__15 arg = NIL; + if (n < Modules_ArgCount) { + __GET(Modules_ArgVector + __ASHL(n, 2), arg, argptr__15); + __COPY(*arg, val, val__len); + } +} + +void Modules_GetIntArg (INT16 n, INT32 *val) +{ + CHAR s[64]; + INT32 k, d, i; + s[0] = 0x00; + Modules_GetArg(n, (void*)s, 64); + i = 0; + if (s[0] == '-') { + i = 1; + } + k = 0; + d = (INT16)s[__X(i, 64)] - 48; + while ((d >= 0 && d <= 9)) { + k = k * 10 + d; + i += 1; + d = (INT16)s[__X(i, 64)] - 48; + } + if (s[0] == '-') { + k = -k; + i -= 1; + } + if (i > 0) { + *val = k; + } +} + +INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len) +{ + INT16 i; + CHAR arg[256]; + __DUP(s, s__len, CHAR); + i = 0; + Modules_GetArg(i, (void*)arg, 256); + while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) { + i += 1; + Modules_GetArg(i, (void*)arg, 256); + } + __DEL(s); + return i; +} + +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return i; +} + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + if ((j > 0 && d[__X(j - 1, d__len)] != c)) { + d[__X(j, d__len)] = c; + j += 1; + } + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + if (c == 0x00) { + __DEL(s); + return 0; + } + i = 0; + while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return s[__X(i, s__len)] == c; +} + +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len) +{ + __DUP(d, d__len, CHAR); + if (d[0] == 0x00) { + __DEL(d); + return 0; + } + if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) { + __DEL(d); + return 1; + } + if (d[__X(1, d__len)] == ':') { + __DEL(d); + return 1; + } + __DEL(d); + return 0; +} + +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + __DUP(s, s__len, CHAR); + if (Modules_IsAbsolute(s, s__len)) { + __COPY(s, d, d__len); + } else { + __COPY(Platform_CWD, d, d__len); + Modules_AppendPart('/', s, s__len, (void*)d, d__len); + } + __DEL(s); +} + +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len) +{ + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __DEL(s); + return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0; +} + +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len) +{ + INT16 j; + __DUP(s, s__len, CHAR); + __DUP(p, p__len, CHAR); + j = 0; + while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) { + d[__X(j, d__len)] = s[__X(*i, s__len)]; + *i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) { + *i += 1; + } + __DEL(s); + __DEL(p); +} + +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + CHAR part[1024]; + __DUP(s, s__len, CHAR); + i = 0; + j = 0; + while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) { + i += 1; + d[__X(j, d__len)] = '/'; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (s[__X(i, s__len)] != 0x00) { + Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024); + if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) { + Modules_AppendPart('/', part, 1024, (void*)d, d__len); + } + } + __DEL(s); +} + +typedef + CHAR pathstring__12[4096]; + +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len) +{ + pathstring__12 arg0, pathlist, pathdir, tempstr; + INT16 i, j, k; + BOOLEAN present; + if (Modules_ArgCount < 1) { + binarydir[0] = 0x00; + return; + } + Modules_GetArg(0, (void*)arg0, 4096); + i = 0; + while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) { + i += 1; + } + if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') { + Modules_Trim(arg0, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } else { + Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096); + i = 0; + present = 0; + while ((!present && pathlist[__X(i, 4096)] != 0x00)) { + Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096); + Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096); + Modules_Trim(pathdir, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } + } + if (present) { + k = Modules_CharCount(binarydir, binarydir__len); + while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) { + k -= 1; + } + if (k == 0) { + binarydir[__X(k, binarydir__len)] = 0x00; + } else { + binarydir[__X(k - 1, binarydir__len)] = 0x00; + } + } else { + binarydir[0] = 0x00; + } +} + +Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len) +{ + Heap_Module m = NIL; + CHAR bodyname[64]; + Heap_Command body; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + m = m->next; + } + if (m != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + } else { + Modules_res = 1; + __COPY(name, Modules_importing, 20); + __MOVE(" module \"", Modules_resMsg, 10); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + } + __DEL(name); + return m; +} + +Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len) +{ + Heap_Cmd c = NIL; + __DUP(name, name__len, CHAR); + c = mod->cmds; + while ((c != NIL && __STRCMP(c->name, name) != 0)) { + c = c->next; + } + if (c != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + __DEL(name); + return c->cmd; + } else { + Modules_res = 2; + __MOVE(" command \"", Modules_resMsg, 11); + __COPY(name, Modules_importing, 20); + Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all) +{ + Heap_Module m = NIL, p = NIL; + INT32 refcount; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + if (all) { + Modules_res = 1; + __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34); + } else { + refcount = Heap_FreeModule(name, name__len); + if (refcount == 0) { + Modules_res = 0; + } else { + if (refcount < 0) { + __MOVE("module not found", Modules_resMsg, 17); + } else { + __MOVE("clients of this module exist", Modules_resMsg, 29); + } + Modules_res = 1; + } + } + __DEL(name); +} + +static void Modules_errch (CHAR c) +{ + INT16 e; + e = Platform_Write(1, (ADDRESS)&c, 1); +} + +static void Modules_errstring (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + Modules_errch(s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +static void Modules_errint (INT32 l) +{ + if (l < 0) { + Modules_errch('-'); + l = -l; + } + if (l >= 10) { + Modules_errint(__DIV(l, 10)); + } + Modules_errch(__CHR((int)__MOD(l, 10) + 48)); +} + +static void Modules_DisplayHaltCode (INT32 code) +{ + switch (code) { + case -1: + Modules_errstring((CHAR*)"Assertion failure.", 19); + break; + case -2: + Modules_errstring((CHAR*)"Index out of range.", 20); + break; + case -3: + Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49); + break; + case -4: + Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47); + break; + case -5: + Modules_errstring((CHAR*)"Type guard failed.", 19); + break; + case -6: + Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49); + break; + case -7: + Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32); + break; + case -8: + Modules_errstring((CHAR*)"Value out of range.", 20); + break; + case -9: + Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60); + break; + case -10: + Modules_errstring((CHAR*)"NIL access.", 12); + break; + case -11: + Modules_errstring((CHAR*)"Alignment error.", 17); + break; + case -12: + Modules_errstring((CHAR*)"Divide by zero.", 16); + break; + case -13: + Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31); + break; + case -14: + Modules_errstring((CHAR*)"Invalid function argument.", 27); + break; + case -15: + Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52); + break; + case -20: + Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60); + break; + default: + break; + } +} + +void Modules_Halt (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Terminated by Halt(", 20); + Modules_errint(code); + Modules_errstring((CHAR*)"). ", 4); + if (code < 0) { + Modules_DisplayHaltCode(code); + } + Modules_errstring(Platform_NL, 3); + Platform_Exit(code); +} + +void Modules_AssertFail (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Assertion failure.", 19); + if (code != 0) { + Modules_errstring((CHAR*)" ASSERT code ", 14); + Modules_errint(code); + Modules_errstring((CHAR*)".", 2); + } + Modules_errstring(Platform_NL, 3); + if (code > 0) { + Platform_Exit(code); + } else { + Platform_Exit(-1); + } +} + + +export void *Modules__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Modules", 0); +/* BEGIN */ + Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024); + __ENDMOD; +} diff --git a/bootstrap/unix-48/Modules.h b/bootstrap/unix-48/Modules.h new file mode 100644 index 00000000..26d86b38 --- /dev/null +++ b/bootstrap/unix-48/Modules.h @@ -0,0 +1,31 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Modules__h +#define Modules__h + +#include "SYSTEM.h" +#include "Heap.h" + + +import INT16 Modules_res; +import CHAR Modules_resMsg[256]; +import Heap_ModuleName Modules_imported, Modules_importing; +import INT32 Modules_MainStackFrame; +import INT16 Modules_ArgCount; +import INT32 Modules_ArgVector; +import CHAR Modules_BinaryDir[1024]; + + +import INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +import void Modules_AssertFail (INT32 code); +import void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +import void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +import void Modules_GetIntArg (INT16 n, INT32 *val); +import void Modules_Halt (INT32 code); +import void Modules_Init (INT32 argc, INT32 argvadr); +import Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +import Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +import void *Modules__init(void); + + +#endif // Modules diff --git a/bootstrap/unix-48/OPB.c b/bootstrap/unix-48/OPB.c new file mode 100644 index 00000000..913fbf2d --- /dev/null +++ b/bootstrap/unix-48/OPB.c @@ -0,0 +1,2592 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + + +static INT16 OPB_exp; +static INT64 OPB_maxExp; + + +export void OPB_Assign (OPT_Node *x, OPT_Node y); +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static INT16 OPB_BoolToInt (BOOLEAN b); +export void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +static void OPB_CharToString (OPT_Node n); +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode); +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo); +export void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +static void OPB_CheckProc (OPT_Struct x, OPT_Object y); +static void OPB_CheckPtr (OPT_Node x, OPT_Node y); +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x); +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp); +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y); +export void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +static void OPB_Convert (OPT_Node *x, OPT_Struct typ); +export void OPB_DeRef (OPT_Node *x); +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar); +export OPT_Node OPB_EmptySet (void); +export void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +export void OPB_Field (OPT_Node *x, OPT_Object y); +export void OPB_In (OPT_Node *x, OPT_Node y); +export void OPB_Index (OPT_Node *x, OPT_Node y); +export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +static BOOLEAN OPB_IntToBool (INT64 i); +export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +export void OPB_MOp (INT8 op, OPT_Node *x); +export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +export OPT_Node OPB_NewIntConst (INT64 intval); +export OPT_Node OPB_NewLeaf (OPT_Object obj); +export OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +export OPT_Node OPB_NewString (OPS_String str, INT64 len); +export OPT_Node OPB_Nil (void); +static BOOLEAN OPB_NotVar (OPT_Node x); +export void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +export void OPB_OptIf (OPT_Node *x); +export void OPB_Param (OPT_Node ap, OPT_Object fp); +export void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +export void OPB_Return (OPT_Node *x, OPT_Object proc); +export void OPB_SetElem (OPT_Node *x); +static void OPB_SetIntType (OPT_Node node); +export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static void OPB_SetSetType (OPT_Node node); +export void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +export void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +export void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +export void OPB_StaticLink (INT8 dlev); +export void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +static void OPB_err (INT16 n); +static INT64 OPB_log (INT64 x); + + +static void OPB_err (INT16 n) +{ + OPM_err(n); +} + +OPT_Node OPB_NewLeaf (OPT_Object obj) +{ + OPT_Node node = NIL; + switch (obj->mode) { + case 1: + node = OPT_NewNode(0); + node->readonly = (obj->vis == 2 && obj->mnolev < 0); + break; + case 2: + node = OPT_NewNode(1); + break; + case 3: + node = OPT_NewNode(7); + node->conval = OPT_NewConst(); + __GUARDEQP(node->conval, OPT_ConstDesc) = *obj->conval; + break; + case 5: + node = OPT_NewNode(8); + break; + case 6: case 7: case 8: case 9: case 10: + node = OPT_NewNode(9); + break; + default: + node = OPT_NewNode(0); + OPB_err(127); + break; + } + node->obj = obj; + node->typ = obj->typ; + return node; +} + +void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = OPT_notyp; + node->left = *x; + node->right = y; + *x = node; +} + +void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y) +{ + if (*x == NIL) { + *x = y; + } else { + (*last)->link = y; + } + while (y->link != NIL) { + y = y->link; + } + *last = y; +} + +static INT16 OPB_BoolToInt (BOOLEAN b) +{ + if (b) { + return 1; + } else { + return 0; + } + __RETCHK; +} + +static BOOLEAN OPB_IntToBool (INT64 i) +{ + return i != 0; +} + +OPT_Node OPB_NewBoolConst (BOOLEAN boolval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_booltyp; + x->conval = OPT_NewConst(); + x->conval->intval = OPB_BoolToInt(boolval); + return x; +} + +void OPB_OptIf (OPT_Node *x) +{ + OPT_Node if_ = NIL, pred = NIL; + if_ = (*x)->left; + while (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + *x = if_->right; + return; + } else if (if_->link == NIL) { + *x = (*x)->right; + return; + } else { + if_ = if_->link; + (*x)->left = if_; + } + } + pred = if_; + if_ = if_->link; + while (if_ != NIL) { + if (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + pred->link = NIL; + (*x)->right = if_->right; + return; + } else { + if_ = if_->link; + pred->link = if_; + } + } else { + pred = if_; + if_ = if_->link; + } + } +} + +OPT_Node OPB_Nil (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_niltyp; + x->conval = OPT_NewConst(); + x->conval->intval = 0; + return x; +} + +OPT_Node OPB_EmptySet (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_settyp; + x->conval = OPT_NewConst(); + x->conval->setval = 0x0; + return x; +} + +static void OPB_SetIntType (OPT_Node node) +{ + node->typ = OPT_IntType(OPT_IntSize(node->conval->intval)); +} + +static void OPB_SetSetType (OPT_Node node) +{ + INT32 i32; + __GET((ADDRESS)&node->conval->setval + 4, i32, INT32); + if (i32 == 0) { + node->typ = OPT_set32typ; + } else { + node->typ = OPT_set64typ; + } +} + +OPT_Node OPB_NewIntConst (INT64 intval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->intval = intval; + OPB_SetIntType(x); + return x; +} + +OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->realval = realval; + x->typ = typ; + x->conval->intval = -1; + return x; +} + +OPT_Node OPB_NewString (OPS_String str, INT64 len) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->typ = OPT_stringtyp; + x->conval->intval = -1; + x->conval->intval2 = OPM_Longint(len); + x->conval->ext = OPT_NewExt(); + __MOVE(str, *x->conval->ext, 256); + return x; +} + +static void OPB_CharToString (OPT_Node n) +{ + CHAR ch; + n->typ = OPT_stringtyp; + ch = __CHR(n->conval->intval); + n->conval->ext = OPT_NewExt(); + if (ch == 0x00) { + n->conval->intval2 = 1; + } else { + n->conval->intval2 = 2; + (*n->conval->ext)[1] = 0x00; + } + (*n->conval->ext)[0] = ch; + n->conval->intval = -1; + n->obj = NIL; +} + +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN OPB_NotVar (OPT_Node x) +{ + return (x->class >= 7 && ((x->class != 11 || x->subcl != 29) || x->left->class >= 7)); +} + +void OPB_DeRef (OPT_Node *x) +{ + OPT_Object strobj = NIL, bstrobj = NIL; + OPT_Struct typ = NIL, btyp = NIL; + typ = (*x)->typ; + if ((*x)->class >= 7) { + OPB_err(78); + } else if (typ->form == 11) { + if (typ == OPT_sysptrtyp) { + OPB_err(57); + } + btyp = typ->BaseTyp; + strobj = typ->strobj; + bstrobj = btyp->strobj; + if ((((((strobj != NIL && strobj->name[0] != 0x00)) && bstrobj != NIL)) && bstrobj->name[0] != 0x00)) { + btyp->pbused = 1; + } + OPB_BindNodes(3, btyp, &*x, NIL); + } else { + OPB_err(84); + } +} + +void OPB_Index (OPT_Node *x, OPT_Node y) +{ + INT16 f; + OPT_Struct typ = NIL; + f = y->typ->form; + if ((*x)->class >= 7) { + OPB_err(79); + } else if (f != 4 || __IN(y->class, 0x0300, 32)) { + OPB_err(80); + y->typ = OPT_inttyp; + } + if ((*x)->typ->comp == 2) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && (y->conval->intval < 0 || y->conval->intval >= (INT64)(*x)->typ->n))) { + OPB_err(81); + } + } else if ((*x)->typ->comp == 3) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && y->conval->intval < 0)) { + OPB_err(81); + } + } else { + OPB_err(82); + typ = OPT_undftyp; + } + OPB_BindNodes(4, typ, &*x, y); + (*x)->readonly = (*x)->left->readonly; +} + +void OPB_Field (OPT_Node *x, OPT_Object y) +{ + if ((*x)->class >= 7) { + OPB_err(77); + } + if ((y != NIL && __IN(y->mode, 0x2010, 32))) { + OPB_BindNodes(2, y->typ, &*x, NIL); + (*x)->obj = y; + (*x)->readonly = (*x)->left->readonly || (y->vis == 2 && y->mnolev < 0); + } else { + OPB_err(83); + (*x)->typ = OPT_undftyp; + } +} + +static struct TypTest__58 { + OPT_Node *x; + OPT_Object *obj; + BOOLEAN *guard; + struct TypTest__58 *lnk; +} *TypTest__58_s; + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1); + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1) +{ + OPT_Node node = NIL; + OPT_Struct t = NIL; + t = t0; + while ((((t != NIL && t != t1)) && t != OPT_undftyp)) { + t = t->BaseTyp; + } + if (t != t1) { + while ((((t1 != NIL && t1 != t0)) && t1 != OPT_undftyp)) { + t1 = t1->BaseTyp; + } + if (t1 == t0 || t0->form == 0) { + if (*TypTest__58_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__58_s->x, NIL); + (*TypTest__58_s->x)->readonly = (*TypTest__58_s->x)->left->readonly; + } else { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } + } else { + OPB_err(85); + } + } else if (t0 != t1) { + OPB_err(85); + } else if (!*TypTest__58_s->guard) { + if ((*TypTest__58_s->x)->class == 5) { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } else { + *TypTest__58_s->x = OPB_NewBoolConst(1); + } + } +} + +void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) +{ + struct TypTest__58 _s; + _s.x = x; + _s.obj = &obj; + _s.guard = &guard; + _s.lnk = TypTest__58_s; + TypTest__58_s = &_s; + if (OPB_NotVar(*x)) { + OPB_err(112); + } else if ((*x)->typ->form == 11) { + if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { + OPB_err(85); + } else if (obj->typ->form == 11) { + GTT__59((*x)->typ->BaseTyp, obj->typ->BaseTyp); + } else { + OPB_err(86); + } + } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { + GTT__59((*x)->typ, obj->typ); + } else { + OPB_err(87); + } + if (guard) { + (*x)->typ = obj->typ; + } else { + (*x)->typ = OPT_booltyp; + } + TypTest__58_s = _s.lnk; +} + +void OPB_In (OPT_Node *x, OPT_Node y) +{ + INT16 f; + INT64 k; + f = (*x)->typ->form; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((f == 4 && y->typ->form == 7)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (k < 0 || k >= (INT64)__ASHL(y->typ->size, 3)) { + OPB_err(202); + } else if (y->class == 7) { + (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval, 64)); + (*x)->obj = NIL; + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_err(92); + } + (*x)->typ = OPT_booltyp; +} + +static INT64 OPB_log (INT64 x) +{ + OPB_exp = 0; + if (x > 0) { + while (!__ODD(x)) { + x = __ASHR(x, 1); + OPB_exp += 1; + } + } + return x; +} + +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x) +{ + LONGREAL min, max, r; + if (f == 5) { + min = OPM_MinReal; + max = OPM_MaxReal; + } else { + min = OPM_MinLReal; + max = OPM_MaxLReal; + } + r = __ABS(x->realval); + if (r > max || r < min) { + OPB_err(nr); + x->realval = (LONGREAL)1; + } else if (f == 5) { + x->realval = x->realval; + } + x->intval = -1; +} + +static struct MOp__28 { + struct MOp__28 *lnk; +} *MOp__28_s; + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z); + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z) +{ + OPT_Node node = NIL; + node = OPT_NewNode(11); + node->subcl = op; + node->typ = typ; + node->left = z; + return node; +} + +void OPB_MOp (INT8 op, OPT_Node *x) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node z = NIL; + struct MOp__28 _s; + _s.lnk = MOp__28_s; + MOp__28_s = &_s; + z = *x; + if (z->class == 8 || z->class == 9) { + OPB_err(126); + } else { + typ = z->typ; + f = typ->form; + switch (op) { + case 33: + if (f == 2) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(98); + } + break; + case 6: + if (!__IN(f, 0x70, 32)) { + OPB_err(96); + } + break; + case 7: + if (__IN(f, 0xf0, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = -z->conval->intval; + OPB_SetIntType(z); + } + } else if (__IN(f, 0x60, 32)) { + z->conval->realval = -z->conval->realval; + } else { + if (z->typ->size == 8) { + z->conval->setval = ~z->conval->setval; + } else { + z->conval->setval = z->conval->setval ^ 0xffffffff; + } + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(97); + } + break; + case 21: + if (__IN(f, 0x70, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = __ABS(z->conval->intval); + OPB_SetIntType(z); + } + } else { + z->conval->realval = __ABS(z->conval->realval); + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + break; + case 22: + if (f == 3) { + if (z->class == 7) { + z->conval->intval = (INT16)__CAP(__CHR(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + z->typ = OPT_chartyp; + } + break; + case 23: + if (f == 4) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + z->typ = OPT_booltyp; + break; + case 24: + if ((((z->class == 7 && f == 3)) && z->conval->intval >= 32)) { + OPB_CharToString(z); + f = 8; + } + if (z->class < 7 || f == 8) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(127); + } + z->typ = OPT_adrtyp; + break; + case 25: + if ((f == 4 && z->class == 7)) { + if ((0 <= z->conval->intval && z->conval->intval <= -1)) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(219); + } + } else { + OPB_err(69); + } + z->typ = OPT_booltyp; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.MOp, op = ", 33); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + MOp__28_s = _s.lnk; +} + +static void OPB_CheckPtr (OPT_Node x, OPT_Node y) +{ + INT16 g; + OPT_Struct p = NIL, q = NIL, t = NIL; + g = y->typ->form; + if (g == 11) { + p = x->typ->BaseTyp; + q = y->typ->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + if (p->extlev < q->extlev) { + t = p; + p = q; + q = t; + } + while ((((p != q && p != NIL)) && p != OPT_undftyp)) { + p = p->BaseTyp; + } + if (p == NIL) { + OPB_err(100); + } + } else { + OPB_err(100); + } + } else if (g != 9) { + OPB_err(100); + } +} + +void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames) +{ + OPT_Struct ft = NIL, at = NIL; + while (fp != NIL) { + if (ap != NIL) { + ft = fp->typ; + at = ap->typ; + while ((ft->comp == 3 && at->comp == 3)) { + ft = ft->BaseTyp; + at = at->BaseTyp; + } + if (ft != at) { + if ((ft->form == 12 && at->form == 12)) { + if (ft->BaseTyp == at->BaseTyp) { + OPB_CheckParameters(ft->link, at->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(115); + } + } + if (fp->mode != ap->mode || (checkNames && __STRCMP(fp->name, ap->name) != 0)) { + OPB_err(115); + } + ap = ap->link; + } else { + OPB_err(116); + } + fp = fp->link; + } + if (ap != NIL) { + OPB_err(116); + } +} + +static void OPB_CheckProc (OPT_Struct x, OPT_Object y) +{ + if (__IN(y->mode, 0x04c0, 32)) { + if (y->mode == 6) { + if (y->mnolev == 0) { + y->mode = 7; + } else { + OPB_err(73); + } + } + if (x->BaseTyp == y->typ) { + OPB_CheckParameters(x->link, y->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(113); + } +} + +static struct ConstOp__13 { + OPT_Node *x; + INT16 *f; + OPT_Const *xval, *yval; + struct ConstOp__13 *lnk; +} *ConstOp__13_s; + +static INT16 ConstCmp__14 (void); + +static INT16 ConstCmp__14 (void) +{ + INT16 res; + switch (*ConstOp__13_s->f) { + case 0: + res = 9; + break; + case 1: case 3: case 4: + if ((*ConstOp__13_s->xval)->intval < (*ConstOp__13_s->yval)->intval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->intval > (*ConstOp__13_s->yval)->intval) { + res = 13; + } else { + res = 9; + } + break; + case 5: case 6: + if ((*ConstOp__13_s->xval)->realval < (*ConstOp__13_s->yval)->realval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->realval > (*ConstOp__13_s->yval)->realval) { + res = 13; + } else { + res = 9; + } + break; + case 2: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + case 7: + if ((*ConstOp__13_s->xval)->setval != (*ConstOp__13_s->yval)->setval) { + res = 10; + } else { + res = 9; + } + break; + case 8: + if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) < 0) { + res = 11; + } else if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) > 0) { + res = 13; + } else { + res = 9; + } + break; + case 9: case 11: case 12: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstCmp, f = ", 37); + OPM_LogWNum(*ConstOp__13_s->f, 0); + OPM_LogWLn(); + break; + } + (*ConstOp__13_s->x)->typ = OPT_booltyp; + return res; +} + +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y) +{ + INT16 f, g; + OPT_Const xval = NIL, yval = NIL; + INT64 xv, yv; + BOOLEAN temp; + struct ConstOp__13 _s; + _s.x = &x; + _s.f = &f; + _s.xval = &xval; + _s.yval = &yval; + _s.lnk = ConstOp__13_s; + ConstOp__13_s = &_s; + f = x->typ->form; + g = y->typ->form; + xval = x->conval; + yval = y->conval; + if (f != g) { + switch (f) { + case 3: + if (g == 8) { + OPB_CharToString(x); + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 4: + if (g == 4) { + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPT_IntType(x->typ->size); + } + } else if (g == 5) { + x->typ = OPT_realtyp; + xval->realval = xval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + xval->realval = xval->intval; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 5: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 6: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 5) { + y->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 8: + if (g == 3) { + OPB_CharToString(y); + g = 8; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(x, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + default: + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + break; + } + f = x->typ->form; + } + switch (op) { + case 1: + if (f == 4) { + xv = xval->intval; + yv = yval->intval; + if (((((xv == 0 || yv == 0) || (((xv > 0 && yv > 0)) && yv <= __DIV(9223372036854775807LL, xv))) || (((xv > 0 && yv < 0)) && yv >= __DIV((-9223372036854775807LL-1), xv))) || (((xv < 0 && yv > 0)) && xv >= __DIV((-9223372036854775807LL-1), yv))) || (((((((xv < 0 && yv < 0)) && xv != (-9223372036854775807LL-1))) && yv != (-9223372036854775807LL-1))) && -xv <= __DIV(9223372036854775807LL, -yv))) { + xval->intval = xv * yv; + OPB_SetIntType(x); + } else { + OPB_err(204); + } + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) <= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 / (LONGREAL)__ABS(yval->realval)) { + xval->realval = xval->realval * yval->realval; + OPB_CheckRealType(f, 204, xval); + } else { + OPB_err(204); + } + } else if (f == 7) { + xval->setval = (xval->setval & yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(101); + } + break; + case 2: + if (f == 4) { + if (yval->intval != 0) { + xval->realval = xval->intval / (REAL)yval->intval; + OPB_CheckRealType(5, 205, xval); + } else { + OPB_err(205); + xval->realval = (LONGREAL)1; + } + x->typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) >= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 * __ABS(yval->realval)) { + xval->realval = xval->realval / yval->realval; + OPB_CheckRealType(f, 205, xval); + } else { + OPB_err(205); + } + } else if (f == 7) { + xval->setval = xval->setval ^ yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(102); + } + break; + case 3: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __DIV(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(103); + } + break; + case 4: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __MOD(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(104); + } + break; + case 5: + if (f == 2) { + xval->intval = OPB_BoolToInt((OPB_IntToBool(xval->intval) && OPB_IntToBool(yval->intval))); + } else { + OPB_err(94); + } + break; + case 6: + if (f == 4) { + temp = (yval->intval >= 0 && xval->intval <= 9223372036854775807LL - yval->intval); + if (temp || (yval->intval < 0 && xval->intval >= (-9223372036854775807LL-1) - yval->intval)) { + xval->intval += yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(206); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 - yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 - yval->realval)) { + xval->realval = xval->realval + yval->realval; + OPB_CheckRealType(f, 206, xval); + } else { + OPB_err(206); + } + } else if (f == 7) { + xval->setval = xval->setval | yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(105); + } + break; + case 7: + if (f == 4) { + if ((yval->intval >= 0 && xval->intval >= (-9223372036854775807LL-1) + yval->intval) || (yval->intval < 0 && xval->intval <= 9223372036854775807LL + yval->intval)) { + xval->intval -= yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(207); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 + yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 + yval->realval)) { + xval->realval = xval->realval - yval->realval; + OPB_CheckRealType(f, 207, xval); + } else { + OPB_err(207); + } + } else if (f == 7) { + xval->setval = (xval->setval & ~yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(106); + } + break; + case 8: + if (f == 2) { + xval->intval = OPB_BoolToInt(OPB_IntToBool(xval->intval) || OPB_IntToBool(yval->intval)); + } else { + OPB_err(95); + } + break; + case 9: + xval->intval = OPB_BoolToInt(ConstCmp__14() == 9); + break; + case 10: + xval->intval = OPB_BoolToInt(ConstCmp__14() != 9); + break; + case 11: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 11); + } + break; + case 12: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 13); + } + break; + case 13: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 13); + } + break; + case 14: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 11); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstOp, op = ", 37); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + ConstOp__13_s = _s.lnk; +} + +static void OPB_Convert (OPT_Node *x, OPT_Struct typ) +{ + OPT_Node node = NIL; + INT16 f, g; + INT64 k; + LONGREAL r; + f = (*x)->typ->form; + g = typ->form; + if ((*x)->class == 7) { + if ((((f == 7 && g == 7)) && (*x)->typ->size > typ->size)) { + OPB_SetSetType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->setval = 0x0; + } + } else if (f == 4) { + if (g == 4) { + if ((*x)->typ->size > typ->size) { + OPB_SetIntType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->intval = 1; + } + } + } else if (__IN(g, 0x60, 32)) { + (*x)->conval->realval = (*x)->conval->intval; + (*x)->conval->intval = -1; + } else { + k = (*x)->conval->intval; + if (0 > k || k > 255) { + OPB_err(220); + } + } + } else if (__IN(f, 0x60, 32)) { + if (__IN(g, 0x60, 32)) { + OPB_CheckRealType(g, 203, (*x)->conval); + } else { + r = (*x)->conval->realval; + if (r < -9.22337203685478e+018 || r > 9.22337203685478e+018) { + OPB_err(203); + r = (LONGREAL)1; + } + (*x)->conval->intval = __SHORT(__ENTIER(r), 2147483648LL); + OPB_SetIntType(*x); + } + } + (*x)->obj = NIL; + } else if (((((*x)->class == 11 && (*x)->subcl == 20)) && ((INT16)(*x)->left->typ->form < f || f > g))) { + if ((*x)->left->typ == typ) { + *x = (*x)->left; + } + } else { + node = OPT_NewNode(11); + node->subcl = 20; + node->left = *x; + *x = node; + } + (*x)->typ = typ; +} + +static struct Op__38 { + INT16 *f, *g; + struct Op__38 *lnk; +} *Op__38_s; + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(12); + node->subcl = op; + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +{ + BOOLEAN ok, xCharArr, yCharArr; + xCharArr = (__IN((*x)->typ->comp, 0x0c, 32) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 8; + yCharArr = (__IN((*y)->typ->comp, 0x0c, 32) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 8; + if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + OPB_CharToString(*y); + *Op__38_s->g = 8; + yCharArr = 1; + } + if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + OPB_CharToString(*x); + *Op__38_s->f = 8; + xCharArr = 1; + } + ok = (xCharArr && yCharArr); + if (ok) { + if ((*Op__38_s->f == 8 && (*x)->conval->intval2 == 1)) { + (*x)->typ = OPT_chartyp; + (*x)->conval->intval = 0; + OPB_Index(&*y, OPB_NewIntConst(0)); + } else if ((*Op__38_s->g == 8 && (*y)->conval->intval2 == 1)) { + (*y)->typ = OPT_chartyp; + (*y)->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + } + return ok; +} + +void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y) +{ + INT16 f, g; + OPT_Node t = NIL, z = NIL; + OPT_Struct typ = NIL; + BOOLEAN do_; + INT64 val; + struct Op__38 _s; + _s.f = &f; + _s.g = &g; + _s.lnk = Op__38_s; + Op__38_s = &_s; + z = *x; + if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((z->class == 7 && y->class == 7)) { + OPB_ConstOp(op, z, y); + z->obj = NIL; + } else { + if (z->typ != y->typ) { + g = y->typ->form; + switch (z->typ->form) { + case 3: + if (z->class == 7) { + OPB_CharToString(z); + } else { + OPB_err(100); + } + break; + case 4: + if ((g == 4 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x70, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 7: + if ((g == 7 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (g == 7) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 5: + if (g == 4) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 6: + if (__IN(g, 0x70, 32)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&y, z->typ); + } else { + OPB_err(100); + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(z, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + case 8: + break; + case 13: + if (z->typ->comp == 4) { + OPB_err(100); + } + break; + default: + OPB_err(100); + break; + } + } + typ = z->typ; + f = typ->form; + g = y->typ->form; + switch (op) { + case 1: + do_ = 1; + if (f == 4) { + if (z->class == 7) { + val = z->conval->intval; + if (val == 1) { + do_ = 0; + z = y; + } else if (val == 0) { + do_ = 0; + } else if (OPB_log(val) == 1) { + t = y; + y = z; + z = t; + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } else if (y->class == 7) { + val = y->conval->intval; + if (val == 1) { + do_ = 0; + } else if (val == 0) { + do_ = 0; + z = y; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } + } else if (!__IN(f, 0xe1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 2: + if (f == 4) { + if ((y->class == 7 && y->conval->intval == 0)) { + OPB_err(205); + } + OPB_Convert(&z, OPT_realtyp); + OPB_Convert(&y, OPT_realtyp); + typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + if ((y->class == 7 && y->conval->realval == (LONGREAL)0)) { + OPB_err(205); + } + } else if ((f != 7 && f != 0)) { + OPB_err(102); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 3: + do_ = 1; + if (f == 4) { + if (y->class == 7) { + val = y->conval->intval; + if (val == 0) { + OPB_err(205); + } else if (val == 1) { + do_ = 0; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = -OPB_exp; + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(103); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 4: + if (f == 4) { + if (y->class == 7) { + if (y->conval->intval == 0) { + OPB_err(205); + } else if (OPB_log(y->conval->intval) == 1) { + op = 18; + y->conval->intval = __ASH(-1, OPB_exp); + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(104); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 5: + if (f == 2) { + if (z->class == 7) { + if (OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(94); + z->typ = OPT_undftyp; + } + break; + case 6: + if (!__IN(f, 0xf1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + do_ = 1; + if (f == 4) { + if ((z->class == 7 && z->conval->intval == 0)) { + do_ = 0; + z = y; + } + if ((y->class == 7 && y->conval->intval == 0)) { + do_ = 0; + } + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 7: + if (!__IN(f, 0xf1, 32)) { + OPB_err(106); + typ = OPT_undftyp; + } + if ((f != 4 || y->class != 7) || y->conval->intval != 0) { + NewOp__39(op, typ, &z, y); + } + break; + case 8: + if (f == 2) { + if (z->class == 7) { + if (!OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(95); + z->typ = OPT_undftyp; + } + break; + case 9: case 10: + if (__IN(f, 0x1aff, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPB_err(107); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 11: case 12: case 13: case 14: + if (__IN(f, 0x79, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ELSE in Op()", 13); + OPM_LogWLn(); + OPB_err(108); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", 32); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + Op__38_s = _s.lnk; +} + +void OPB_SetRange (OPT_Node *x, OPT_Node y) +{ + INT64 k, l; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if (((*x)->typ->form == 4 && y->typ->form == 4)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (0 > k || k > 63) { + OPB_err(202); + } + } + if (y->class == 7) { + l = y->conval->intval; + if (0 > l || l > 63) { + OPB_err(202); + } + } + if (((*x)->class == 7 && y->class == 7)) { + if (k <= l) { + (*x)->conval->setval = __SETRNG(k, l, 32); + OPB_SetSetType(*x); + } else { + OPB_err(201); + (*x)->conval->setval = __SETRNG(l, k, 32); + } + (*x)->obj = NIL; + } else { + OPB_BindNodes(10, OPT_settyp, &*x, y); + } + } else { + OPB_err(93); + } + (*x)->typ = OPT_settyp; +} + +void OPB_SetElem (OPT_Node *x) +{ + INT64 k; + if ((*x)->class == 8 || (*x)->class == 9) { + OPB_err(126); + } else if ((*x)->typ->form != 4) { + OPB_err(93); + } else if ((*x)->class == 7) { + k = (*x)->conval->intval; + if ((0 <= k && k <= 63)) { + (*x)->conval->setval = 0x0; + (*x)->conval->setval |= __SETOF(k,64); + } else { + OPB_err(202); + } + OPB_SetSetType(*x); + (*x)->obj = NIL; + } else { + OPB_Convert(&*x, OPT_settyp); + (*x)->typ = OPT_settyp; + } +} + +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) +{ + OPT_Struct y = NIL; + INT16 f, g; + OPT_Struct p = NIL, q = NIL; + y = ynode->typ; + f = x->form; + g = y->form; + if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { + OPB_err(126); + } + switch (f) { + case 0: case 8: + break; + case 1: + if (!((__IN(g, 0x1a, 32) && y->size == 1))) { + OPB_err(113); + } + break; + case 2: case 3: + if (g != f) { + OPB_err(113); + } + break; + case 4: case 7: + if (g != f || x->size < y->size) { + OPB_err(113); + } + break; + case 5: + if (!__IN(g, 0x30, 32)) { + OPB_err(113); + } + break; + case 6: + if (!__IN(g, 0x70, 32)) { + OPB_err(113); + } + break; + case 11: + if ((x == y || g == 9) || (x == OPT_sysptrtyp && g == 11)) { + } else if (g == 11) { + p = x->BaseTyp; + q = y->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + while ((((q != p && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + case 12: + if (ynode->class == 9) { + OPB_CheckProc(x, ynode->obj); + } else if (x == y || g == 9) { + } else { + OPB_err(113); + } + break; + case 10: case 9: + OPB_err(113); + break; + case 13: + x->pvused = 1; + if (x->comp == 2) { + if ((ynode->class == 7 && g == 3)) { + OPB_CharToString(ynode); + y = ynode->typ; + g = 8; + } + if (x == y) { + } else if ((((y->comp == 2 && y->BaseTyp == x->BaseTyp)) && y->n <= x->n)) { + } else if ((y->comp == 3 && y->BaseTyp == x->BaseTyp)) { + OPB_err(113); + } else if (x->BaseTyp == OPT_chartyp) { + if (g == 8) { + if (ynode->conval->intval2 > x->n) { + OPB_err(114); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else if (x->comp == 4) { + if (x == y) { + } else if (y->comp == 4) { + q = y->BaseTyp; + while ((((q != NIL && q != x)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.CheckAssign, f = ", 40); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } + if ((((((ynode->class == 7 && g < f)) && __IN(g, 0x30, 32))) && __IN(f, 0x70, 32))) { + OPB_Convert(&ynode, x); + } +} + +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo) +{ +} + +void OPB_StPar0 (OPT_Node *par0, INT16 fctno) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node x = NIL; + x = *par0; + f = x->typ->form; + switch (fctno) { + case 0: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + x->typ = OPT_notyp; + break; + case 1: + typ = OPT_notyp; + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + if (x->readonly) { + OPB_err(76); + } + f = x->typ->BaseTyp->comp; + if (__IN(f, 0x1c, 32)) { + if (f == 3) { + typ = x->typ->BaseTyp; + } + OPB_BindNodes(19, OPT_notyp, &x, NIL); + x->subcl = 1; + } else { + OPB_err(111); + } + } else { + OPB_err(111); + } + x->typ = typ; + break; + case 2: + OPB_MOp(21, &x); + break; + case 3: + OPB_MOp(22, &x); + break; + case 4: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 3) { + OPB_Convert(&x, OPT_inttyp); + } else { + OPB_err(111); + } + x->typ = OPT_inttyp; + break; + case 5: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x60, 32)) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + x->typ = OPT_linttyp; + break; + case 6: + OPB_MOp(23, &x); + break; + case 7: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(0); + break; + case 3: + x = OPB_NewIntConst(0); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(0); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MinReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MinLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 8: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(1); + break; + case 3: + x = OPB_NewIntConst(255); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(__ASHL(x->typ->size, 3) - 1); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MaxReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MaxLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 9: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x11, 32)) { + OPB_Convert(&x, OPT_chartyp); + } else { + OPB_err(111); + x->typ = OPT_chartyp; + } + break; + case 10: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, -1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 6) { + OPB_Convert(&x, OPT_realtyp); + } else { + OPB_err(111); + } + break; + case 11: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, 1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 5) { + OPB_Convert(&x, OPT_lrltyp); + } else if (f == 3) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + break; + case 13: case 14: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f != 4) { + OPB_err(111); + } else if (x->readonly) { + OPB_err(76); + } + break; + case 15: case 16: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (x->typ->form != 7) { + OPB_err(111); + x->typ = OPT_settyp; + } else if (x->readonly) { + OPB_err(76); + } + break; + case 17: + if (!__IN(x->typ->comp, 0x0c, 32)) { + OPB_err(131); + } + break; + case 18: + if ((x->class == 7 && f == 3)) { + OPB_CharToString(x); + f = 8; + } + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (((!__IN(x->typ->comp, 0x0c, 32) || x->typ->BaseTyp->form != 3) && f != 8)) { + OPB_err(111); + } + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if (x->typ->size < OPT_linttyp->size) { + OPB_Convert(&x, OPT_linttyp); + } + } else { + OPB_err(111); + x->typ = OPT_linttyp; + } + break; + case 20: + OPB_CheckLeaf(x, 0); + OPB_MOp(24, &x); + break; + case 12: + if (x->class != 8) { + OPB_err(110); + x = OPB_NewIntConst(1); + } else if (__IN(f, 0x18fe, 32) || __IN(x->typ->comp, 0x14, 32)) { + OPT_TypSize(x->typ); + x->typ->pvused = 1; + x = OPB_NewIntConst(x->typ->size); + } else { + OPB_err(111); + x = OPB_NewIntConst(1); + } + break; + case 21: + OPB_MOp(25, &x); + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (!__IN(f, 0x9a, 32)) { + OPB_err(111); + } + break; + case 24: case 25: case 28: case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + break; + case 26: case 27: + if ((f == 4 && x->class == 7)) { + if (x->conval->intval < 0 || x->conval->intval > -1) { + OPB_err(220); + } + } else { + OPB_err(69); + } + break; + case 29: + if (x->class != 8) { + OPB_err(110); + } else if (__IN(f, 0x0501, 32) || x->typ->comp == 3) { + OPB_err(111); + } + break; + case 30: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + } else { + OPB_err(111); + } + break; + case 32: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + x = OPB_NewBoolConst(0); + } else if (f != 2) { + OPB_err(120); + x = OPB_NewBoolConst(0); + } else { + OPB_MOp(33, &x); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.StPar0, fctno = ", 39); + OPM_LogWNum(fctno, 0); + OPM_LogWLn(); + break; + } + *par0 = x; +} + +static struct StPar1__53 { + struct StPar1__53 *lnk; +} *StPar1__53_s; + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right); + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->subcl = subcl; + node->left = left; + node->right = right; + return node; +} + +void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno) +{ + INT16 f, L; + OPT_Struct typ = NIL; + OPT_Node p = NIL, t = NIL; + struct StPar1__53 _s; + _s.lnk = StPar1__53_s; + StPar1__53_s = &_s; + p = *par0; + f = x->typ->form; + switch (fctno) { + case 13: case 14: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + p->typ = OPT_notyp; + } else { + if (x->typ != p->typ) { + if ((f == 4 && (x->class == 7 || (p->typ->form == 4 && x->typ->size <= p->typ->size)))) { + OPB_Convert(&x, p->typ); + } else { + OPB_err(111); + } + } + p = NewOp__54(19, fctno, p, x); + p->typ = OPT_notyp; + } + break; + case 15: case 16: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval >= (INT64)__ASHL(p->typ->size, 3)))) { + OPB_err(202); + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 17: + if (!(f == 4) || x->class != 7) { + OPB_err(69); + } else if (x->typ->size == 1) { + L = OPM_Integer(x->conval->intval); + typ = p->typ; + while ((L > 0 && __IN(typ->comp, 0x0c, 32))) { + typ = typ->BaseTyp; + L -= 1; + } + if (L != 0 || !__IN(typ->comp, 0x0c, 32)) { + OPB_err(132); + } else { + x->obj = NIL; + if (typ->comp == 3) { + while (p->class == 4) { + p = p->left; + x->conval->intval += 1; + } + p = NewOp__54(12, 19, p, x); + p->typ = OPT_linttyp; + } else { + p = x; + p->conval->intval = typ->n; + OPB_SetIntType(p); + } + } + } else { + OPB_err(132); + } + break; + case 18: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if ((__IN(x->typ->comp, 0x0c, 32) && x->typ->BaseTyp->form == 3)) { + if (x->readonly) { + OPB_err(76); + } + t = x; + x = p; + p = t; + p = NewOp__54(19, 18, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((p->class == 7 && x->class == 7)) { + if (-OPB_maxExp > x->conval->intval || x->conval->intval > OPB_maxExp) { + OPB_err(208); + p->conval->intval = 1; + } else if (x->conval->intval >= 0) { + if (__ABS(p->conval->intval) <= __DIV(9223372036854775807LL, (INT64)__ASH(1, x->conval->intval))) { + p->conval->intval = p->conval->intval * (INT64)__ASH(1, x->conval->intval); + } else { + OPB_err(208); + p->conval->intval = 1; + } + } else { + p->conval->intval = __ASH(p->conval->intval, x->conval->intval); + } + p->obj = NIL; + } else { + p = NewOp__54(12, 17, p, x); + p->typ = p->left->typ; + } + } else { + OPB_err(111); + } + break; + case 1: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp == 3) { + if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + } else { + OPB_err(111); + } + p->right = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(64); + } + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f != 4) { + OPB_err(111); + } else { + if (fctno == 22) { + p = NewOp__54(12, 27, p, x); + } else { + p = NewOp__54(12, 28, p, x); + } + p->typ = p->left->typ; + } + break; + case 24: case 25: case 26: case 27: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x18ff, 32)) { + if (fctno == 24 || fctno == 26) { + if (OPB_NotVar(x)) { + OPB_err(112); + } + t = x; + x = p; + p = t; + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 28: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(12, 26, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_booltyp; + break; + case 29: + if (((x->class == 8 || x->class == 9) || __IN(f, 0x0501, 32)) || x->typ->comp == 3) { + OPB_err(126); + } + OPT_TypSize(x->typ); + OPT_TypSize(p->typ); + if ((x->class != 7 && x->typ->size < p->typ->size)) { + OPB_err(-308); + } + if ((((x->class == 7 && x->typ->form == 4)) && p->typ->form == 4)) { + OPB_Convert(&x, p->typ); + } else { + t = OPT_NewNode(11); + t->subcl = 29; + t->left = x; + x = t; + x->typ = p->typ; + } + p = x; + break; + case 30: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(19, 30, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + p->link = x; + break; + case 32: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + break; + default: + OPB_err(64); + break; + } + *par0 = p; + StPar1__53_s = _s.lnk; +} + +void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n) +{ + OPT_Node node = NIL; + INT16 f; + OPT_Node p = NIL; + p = *par0; + f = x->typ->form; + if (fctno == 1) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp != 3) { + OPB_err(64); + } else if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + node = p->right; + while (node->link != NIL) { + node = node->link; + } + node->link = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(111); + } + } else if ((fctno == 31 && n == 2)) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + node = OPT_NewNode(19); + node->subcl = 31; + node->right = p; + node->left = p->link; + p->link = x; + p = node; + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + } else { + OPB_err(64); + } + *par0 = p; +} + +void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno) +{ + INT16 dim; + OPT_Node x = NIL, p = NIL; + p = *par0; + if (fctno <= 19) { + if ((fctno == 1 && p->typ != OPT_notyp)) { + if (p->typ->comp == 3) { + OPB_err(65); + } + p->typ = OPT_notyp; + } else if (fctno <= 12) { + if (parno < 1) { + OPB_err(65); + } + } else { + if (((fctno == 13 || fctno == 14) && parno == 1)) { + OPB_BindNodes(19, OPT_notyp, &p, OPB_NewIntConst(1)); + p->subcl = fctno; + p->right->typ = p->left->typ; + } else if ((fctno == 17 && parno == 1)) { + if (p->typ->comp == 3) { + dim = 0; + while (p->class == 4) { + p = p->left; + dim += 1; + } + OPB_BindNodes(12, OPT_linttyp, &p, OPB_NewIntConst(dim)); + p->subcl = 19; + } else { + p = OPB_NewIntConst(p->typ->n); + } + } else if (parno < 2) { + OPB_err(65); + } + } + } else if (fctno == 32) { + if (parno == 1) { + x = NIL; + OPB_BindNodes(28, OPT_notyp, &x, OPB_NewIntConst(0)); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else if (parno < 1) { + OPB_err(65); + } + } else { + if ((parno < 1 || (fctno > 21 && parno < 2)) || (fctno == 31 && parno < 3)) { + OPB_err(65); + } + } + *par0 = p; +} + +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar) +{ + INT16 f; + f = atyp->comp; + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((fvarpar && ftyp == OPT_bytetyp)) { + if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { + if (__IN(18, OPM_Options, 32)) { + OPB_err(-301); + } + } + } else if (__IN(f, 0x0c, 32)) { + if (ftyp->comp == 3) { + OPB_DynArrParCheck(ftyp, atyp, fvarpar); + } else if (ftyp != atyp) { + if ((((!fvarpar && ftyp->form == 11)) && atyp->form == 11)) { + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((ftyp->comp == 4 && atyp->comp == 4)) { + while ((((ftyp != atyp && atyp != NIL)) && atyp != OPT_undftyp)) { + atyp = atyp->BaseTyp; + } + if (atyp == NIL) { + OPB_err(113); + } + } else { + OPB_err(66); + } + } else { + OPB_err(66); + } + } + } else { + OPB_err(67); + } +} + +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp) +{ + if (fp->typ->form == 11) { + if ((*x)->class == 3) { + *x = (*x)->left; + } else { + OPB_err(71); + } + } +} + +void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar) +{ + if (((*x)->obj != NIL && __IN((*x)->obj->mode, 0x22c0, 32))) { + *fpar = (*x)->obj->link; + if ((*x)->obj->mode == 13) { + OPB_CheckReceiver(&(*x)->left, *fpar); + *fpar = (*fpar)->link; + } + } else if (((((*x)->class != 8 && (*x)->typ != NIL)) && (*x)->typ->form == 12)) { + *fpar = (*x)->typ->link; + } else { + OPB_err(121); + *fpar = NIL; + (*x)->typ = OPT_undftyp; + } +} + +void OPB_Param (OPT_Node ap, OPT_Object fp) +{ + OPT_Struct q = NIL; + if (fp->typ->form != 0) { + if (fp->mode == 2) { + if (OPB_NotVar(ap)) { + OPB_err(122); + } else { + OPB_CheckLeaf(ap, 0); + } + if (ap->readonly) { + OPB_err(76); + } + if (fp->typ->comp == 3) { + OPB_DynArrParCheck(fp->typ, ap->typ, 1); + } else if ((fp->typ->comp == 4 && ap->typ->comp == 4)) { + q = ap->typ; + while ((((q != fp->typ && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(111); + } + } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 11)) { + } else if ((ap->typ != fp->typ && !((((fp->typ->form == 1 && __IN(ap->typ->form, 0x1e, 32))) && ap->typ->size == 1)))) { + OPB_err(123); + } else if ((fp->typ->form == 11 && ap->class == 5)) { + OPB_err(123); + } + } else if (fp->typ->comp == 3) { + if ((ap->class == 7 && ap->typ->form == 3)) { + OPB_CharToString(ap); + } + if ((ap->typ->form == 8 && fp->typ->BaseTyp->form == 3)) { + } else if (ap->class >= 7) { + OPB_err(59); + } else { + OPB_DynArrParCheck(fp->typ, ap->typ, 0); + } + } else { + OPB_CheckAssign(fp->typ, ap); + } + } +} + +void OPB_StaticLink (INT8 dlev) +{ + OPT_Object scope = NIL; + scope = OPT_topScope; + while (dlev > 0) { + dlev -= 1; + scope->link->conval->setval |= __SETOF(3,64); + scope = scope->left; + } +} + +void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp) +{ + OPT_Struct typ = NIL; + OPT_Node p = NIL; + INT8 lev; + if ((*x)->class == 9) { + typ = (*x)->typ; + lev = (*x)->obj->mnolev; + if (lev > 0) { + OPB_StaticLink(OPT_topScope->mnolev - lev); + } + if ((*x)->obj->mode == 10) { + OPB_err(121); + } + } else if (((*x)->class == 2 && (*x)->obj->mode == 13)) { + typ = (*x)->typ; + (*x)->class = 9; + p = (*x)->left; + (*x)->left = NIL; + p->link = apar; + apar = p; + fp = (*x)->obj->link; + } else { + typ = (*x)->typ->BaseTyp; + } + OPB_BindNodes(13, typ, &*x, apar); + (*x)->obj = fp; +} + +void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc) +{ + OPT_Node x = NIL; + x = OPT_NewNode(18); + x->typ = OPT_notyp; + x->obj = proc; + x->left = *procdec; + x->right = stat; + *procdec = x; +} + +void OPB_Return (OPT_Node *x, OPT_Object proc) +{ + OPT_Node node = NIL; + if (proc == NIL) { + if (*x != NIL) { + OPB_err(124); + } + } else { + if (*x != NIL) { + OPB_CheckAssign(proc->typ, *x); + } else if (proc->typ != OPT_notyp) { + OPB_err(124); + } + } + node = OPT_NewNode(26); + node->typ = OPT_notyp; + node->obj = proc; + node->left = *x; + *x = node; +} + +void OPB_Assign (OPT_Node *x, OPT_Node y) +{ + OPT_Node z = NIL; + if ((*x)->class >= 7) { + OPB_err(56); + } + OPB_CheckAssign((*x)->typ, y); + if ((*x)->readonly) { + OPB_err(76); + } + if ((*x)->typ->comp == 4) { + if ((*x)->class == 5) { + z = (*x)->left; + } else { + z = *x; + } + if ((z->class == 3 && z->left->class == 5)) { + z->left = z->left->left; + } + if (((*x)->typ->strobj != NIL && (z->class == 3 || z->class == 1))) { + OPB_BindNodes(6, (*x)->typ, &z, NIL); + *x = z; + } + } else if (((((((*x)->typ->comp == 2 && (*x)->typ->BaseTyp == OPT_chartyp)) && y->typ->form == 8)) && y->conval->intval2 == 1)) { + y->typ = OPT_chartyp; + y->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + OPB_BindNodes(19, OPT_notyp, &*x, y); + (*x)->subcl = 0; +} + +void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ) +{ + OPT_Node node = NIL; + node = OPT_NewNode(14); + node->typ = typ; + node->conval = OPT_NewConst(); + node->conval->intval = typ->txtpos; + if (*inittd == NIL) { + *inittd = node; + } else { + (*last)->link = node; + } + *last = node; +} + + +export void *OPB__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPB", 0); +/* BEGIN */ + OPB_maxExp = OPB_log(4611686018427387904LL); + OPB_maxExp = OPB_exp; + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPB.h b/bootstrap/unix-48/OPB.h new file mode 100644 index 00000000..f66fcd66 --- /dev/null +++ b/bootstrap/unix-48/OPB.h @@ -0,0 +1,48 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPB__h +#define OPB__h + +#include "SYSTEM.h" +#include "OPS.h" +#include "OPT.h" + + + + +import void OPB_Assign (OPT_Node *x, OPT_Node y); +import void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +import void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +import void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +import void OPB_DeRef (OPT_Node *x); +import OPT_Node OPB_EmptySet (void); +import void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +import void OPB_Field (OPT_Node *x, OPT_Object y); +import void OPB_In (OPT_Node *x, OPT_Node y); +import void OPB_Index (OPT_Node *x, OPT_Node y); +import void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +import void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +import void OPB_MOp (INT8 op, OPT_Node *x); +import OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +import OPT_Node OPB_NewIntConst (INT64 intval); +import OPT_Node OPB_NewLeaf (OPT_Object obj); +import OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +import OPT_Node OPB_NewString (OPS_String str, INT64 len); +import OPT_Node OPB_Nil (void); +import void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +import void OPB_OptIf (OPT_Node *x); +import void OPB_Param (OPT_Node ap, OPT_Object fp); +import void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +import void OPB_Return (OPT_Node *x, OPT_Object proc); +import void OPB_SetElem (OPT_Node *x); +import void OPB_SetRange (OPT_Node *x, OPT_Node y); +import void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +import void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +import void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +import void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +import void OPB_StaticLink (INT8 dlev); +import void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +import void *OPB__init(void); + + +#endif // OPB diff --git a/bootstrap/unix-48/OPC.c b/bootstrap/unix-48/OPC.c new file mode 100644 index 00000000..7b92ccc1 --- /dev/null +++ b/bootstrap/unix-48/OPC.c @@ -0,0 +1,2025 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "OPM.h" +#include "OPT.h" + + +static INT16 OPC_indentLevel; +static INT8 OPC_hashtab[105]; +static CHAR OPC_keytab[50][9]; +static BOOLEAN OPC_GlbPtrs; +static CHAR OPC_BodyNameExt[13]; + + +export void OPC_Andent (OPT_Struct typ); +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); +export OPT_Object OPC_BaseTProc (OPT_Object obj); +export void OPC_BegBlk (void); +export void OPC_BegStat (void); +static void OPC_CProcDefs (OPT_Object obj, INT16 vis); +export void OPC_Case (INT64 caseVal, INT16 form); +static void OPC_CharacterLiteral (INT64 c); +export void OPC_Cmp (INT16 rel); +export void OPC_CompleteIdent (OPT_Object obj); +export void OPC_Constant (OPT_Const con, INT16 form); +static void OPC_DeclareBase (OPT_Object dcl); +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef); +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro); +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefAnonRecs (OPT_Node n); +export void OPC_DefineInter (OPT_Object proc); +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefineTProcTypes (OPT_Object obj); +static void OPC_DefineType (OPT_Struct str); +export void OPC_EndBlk (void); +export void OPC_EndBlk0 (void); +export void OPC_EndStat (void); +export void OPC_EnterBody (void); +export void OPC_EnterProc (OPT_Object proc); +export void OPC_ExitBody (void); +export void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign); +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign); +export void OPC_GenBdy (OPT_Node n); +static void OPC_GenDynTypes (OPT_Node n, INT16 vis); +export void OPC_GenEnumPtrs (OPT_Object var); +export void OPC_GenHdr (OPT_Node n); +export void OPC_GenHdrIncludes (void); +static void OPC_GenHeaderMsg (void); +export void OPC_Halt (INT32 n); +export void OPC_Ident (OPT_Object obj); +static void OPC_IdentList (OPT_Object obj, INT16 vis); +static void OPC_Include (CHAR *name, ADDRESS name__len); +static void OPC_IncludeImports (OPT_Object obj, INT16 vis); +export void OPC_Increment (BOOLEAN decrement); +export void OPC_Indent (INT16 count); +export void OPC_Init (void); +static void OPC_InitImports (OPT_Object obj); +static void OPC_InitKeywords (void); +export void OPC_InitTDesc (OPT_Struct typ); +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj); +export void OPC_IntLiteral (INT64 n, INT32 size); +export void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName); +static INT16 OPC_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN OPC_NeedsRetval (OPT_Object proc); +export INT32 OPC_NofPtrs (OPT_Struct typ); +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len); +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len); +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define); +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis); +static void OPC_PutBase (OPT_Struct typ); +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt); +static void OPC_RegCmds (OPT_Object obj); +export void OPC_SetInclude (BOOLEAN exclude); +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x); +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l); +export void OPC_TDescDecl (OPT_Struct typ); +export void OPC_TypeDefs (OPT_Object obj, INT16 vis); +export void OPC_TypeOf (OPT_Object ap); +static BOOLEAN OPC_Undefined (OPT_Object obj); + + +void OPC_Init (void) +{ + OPC_indentLevel = 0; + __MOVE("__init(void)", OPC_BodyNameExt, 13); +} + +void OPC_Indent (INT16 count) +{ + OPC_indentLevel += count; +} + +void OPC_BegStat (void) +{ + INT16 i; + i = OPC_indentLevel; + while (i > 0) { + OPM_Write(0x09); + i -= 1; + } +} + +void OPC_EndStat (void) +{ + OPM_Write(';'); + OPM_WriteLn(); +} + +void OPC_BegBlk (void) +{ + OPM_Write('{'); + OPM_WriteLn(); + OPC_indentLevel += 1; +} + +void OPC_EndBlk (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); + OPM_WriteLn(); +} + +void OPC_EndBlk0 (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); +} + +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x) +{ + CHAR ch; + INT16 i; + __DUP(s, s__len, CHAR); + ch = s[0]; + i = 0; + while (ch != 0x00) { + if (ch == '#') { + OPM_WriteInt(x); + } else { + OPM_Write(ch); + } + i += 1; + ch = s[__X(i, s__len)]; + } + __DEL(s); +} + +static INT16 OPC_Length (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + return i; +} + +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len) +{ + INT16 i, h; + i = 0; + h = 0; + while ((s[__X(i, s__len)] != 0x00 && i < 5)) { + h = 3 * h + (INT16)s[__X(i, s__len)]; + i += 1; + } + return (int)__MOD(h, 105); +} + +void OPC_Ident (OPT_Object obj) +{ + INT16 mode, level, h; + mode = obj->mode; + level = obj->mnolev; + if ((__IN(mode, 0x62, 32) && level > 0) || __IN(mode, 0x14, 32)) { + OPM_WriteStringVar((void*)obj->name, 256); + h = OPC_PerfectHash((void*)obj->name, 256); + if (OPC_hashtab[__X(h, 105)] >= 0) { + if (__STRCMP(OPC_keytab[__X(OPC_hashtab[__X(h, 105)], 50)], obj->name) == 0) { + OPM_Write('_'); + } + } + } else if ((mode == 5 && __IN(obj->typ->form, 0x90, 32))) { + if (obj->typ == OPT_adrtyp) { + OPM_WriteString((CHAR*)"ADDRESS", 8); + } else { + if (obj->typ->form == 4) { + OPM_WriteString((CHAR*)"INT", 4); + } else { + OPM_WriteString((CHAR*)"UINT", 5); + } + OPM_WriteInt(__ASHL(obj->typ->size, 3)); + } + } else { + if (mode != 5 || obj->linkadr != 2) { + if (mode == 13) { + OPC_Ident(obj->link->typ->strobj); + } else if (level < 0) { + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-level, 64)]->name, 256); + if (OPM_currFile == 0) { + OPT_GlbMod[__X(-level, 64)]->vis = 1; + } + } else { + OPM_WriteStringVar((void*)OPM_modName, 32); + } + OPM_Write('_'); + } else if (obj == OPT_sysptrtyp->strobj || obj == OPT_bytetyp->strobj) { + OPM_WriteString((CHAR*)"SYSTEM_", 8); + } + OPM_WriteStringVar((void*)obj->name, 256); + } +} + +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause) +{ + INT16 pointers; + *openClause = 0; + if (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->comp != 4)) { + if (__IN(typ->comp, 0x0c, 32)) { + OPC_Stars(typ->BaseTyp, &*openClause); + *openClause = typ->comp == 2; + } else if (typ->form == 12) { + OPM_Write('('); + OPM_Write('*'); + } else { + pointers = 0; + while (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->form == 11)) { + pointers += 1; + typ = typ->BaseTyp; + } + if (pointers > 0) { + if (typ->comp != 3) { + OPC_Stars(typ, &*openClause); + } + if (*openClause) { + OPM_Write('('); + *openClause = 0; + } + while (pointers > 0) { + OPM_Write('*'); + pointers -= 1; + } + } + } + } +} + +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef) +{ + OPT_Struct typ = NIL; + BOOLEAN varPar, openClause; + INT16 form, comp; + typ = dcl->typ; + varPar = ((dcl->mode == 2 && typ->comp != 2) || typ->comp == 3) || scopeDef; + OPC_Stars(typ, &openClause); + if (varPar) { + if (openClause) { + OPM_Write('('); + } + OPM_Write('*'); + } + if (dcl->name[0] != 0x00) { + OPC_Ident(dcl); + } + if ((varPar && openClause)) { + OPM_Write(')'); + } + openClause = 0; + for (;;) { + form = typ->form; + comp = typ->comp; + if (((typ->strobj != NIL && typ->strobj->name[0] != 0x00) || form == 10) || comp == 4) { + break; + } else if ((form == 11 && typ->BaseTyp->comp != 3)) { + openClause = 1; + } else if (form == 12 || __IN(comp, 0x0c, 32)) { + if (openClause) { + OPM_Write(')'); + openClause = 0; + } + if (form == 12) { + OPM_Write(')'); + OPC_AnsiParamList(typ->link, 0); + break; + } else if (comp == 2) { + OPM_Write('['); + OPM_WriteInt(typ->n); + OPM_Write(']'); + } + } else { + break; + } + typ = typ->BaseTyp; + } +} + +void OPC_Andent (OPT_Struct typ) +{ + if (typ->strobj == NIL || typ->align >= 65536) { + OPM_WriteStringVar((void*)OPM_modName, 32); + OPC_Str1((CHAR*)"__#", 4, __ASHR(typ->align, 16)); + } else { + OPC_Ident(typ->strobj); + } +} + +static BOOLEAN OPC_Undefined (OPT_Object obj) +{ + return obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (3 + OPM_currFile))) && obj->linkadr != 2); +} + +static void OPC_DeclareBase (OPT_Object dcl) +{ + OPT_Struct typ = NIL, prev = NIL; + OPT_Object obj = NIL; + INT16 nofdims; + INT32 off, n, dummy; + typ = dcl->typ; + prev = typ; + while ((((((((typ->strobj == NIL || typ->comp == 3) || OPC_Undefined(typ->strobj)) && typ->comp != 4)) && typ->form != 10)) && !((typ->form == 11 && typ->BaseTyp->comp == 3)))) { + prev = typ; + typ = typ->BaseTyp; + } + obj = typ->strobj; + if (typ->form == 10) { + OPM_WriteString((CHAR*)"void", 5); + } else if ((obj != NIL && !OPC_Undefined(obj))) { + OPC_Ident(obj); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"struct ", 8); + OPC_Andent(typ); + if ((prev->form != 11 && (obj != NIL || dcl->name[0] == 0x00))) { + if ((typ->BaseTyp != NIL && typ->BaseTyp->strobj->vis != 0)) { + OPM_WriteString((CHAR*)" { /* ", 7); + OPC_Ident(typ->BaseTyp->strobj); + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); + OPC_Indent(1); + } else { + OPM_Write(' '); + OPC_BegBlk(); + } + OPC_FieldList(typ, 1, &off, &n, &dummy); + OPC_EndBlk0(); + } + } else if ((typ->form == 11 && typ->BaseTyp->comp == 3)) { + typ = typ->BaseTyp->BaseTyp; + nofdims = 1; + while (typ->comp == 3) { + nofdims += 1; + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)"struct ", 8); + OPC_BegBlk(); + OPC_BegStat(); + OPC_Str1((CHAR*)"ADDRESS len[#]", 15, nofdims); + OPC_EndStat(); + OPC_BegStat(); + __NEW(obj, OPT_ObjDesc); + __NEW(obj->typ, OPT_StrDesc); + obj->typ->form = 13; + obj->typ->comp = 2; + obj->typ->n = 1; + obj->typ->BaseTyp = typ; + obj->mode = 4; + __MOVE("data", obj->name, 5); + obj->linkadr = 0; + OPC_DeclareBase(obj); + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + OPC_EndStat(); + OPC_EndBlk0(); + } +} + +INT32 OPC_NofPtrs (OPT_Struct typ) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n; + if ((typ->form == 11 && typ->sysflag == 0)) { + return 1; + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + n = OPC_NofPtrs(btyp); + } else { + n = 0; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + n = n + OPC_NofPtrs(fld->typ); + } else { + n += 1; + } + fld = fld->link; + } + return n; + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + return OPC_NofPtrs(btyp) * n; + } else { + return 0; + } + __RETCHK; +} + +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n, i; + if ((typ->form == 11 && typ->sysflag == 0)) { + OPM_WriteInt(adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + OPC_PutPtrOffsets(btyp, adr, &*cnt); + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + OPC_PutPtrOffsets(fld->typ, adr + fld->adr, &*cnt); + } else { + OPM_WriteInt(adr + fld->adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } + fld = fld->link; + } + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (OPC_NofPtrs(btyp) > 0) { + i = 0; + while (i < n) { + OPC_PutPtrOffsets(btyp, adr + i * btyp->size, &*cnt); + i += 1; + } + } + } +} + +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitTProcs(typ, obj->left); + if (obj->mode == 13) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITBP(", 10); + OPC_Ident(typ); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(obj); + OPC_Str1((CHAR*)", #)", 5, __ASHR(obj->adr, 16)); + OPC_EndStat(); + } + OPC_InitTProcs(typ, obj->right); + } +} + +static void OPC_PutBase (OPT_Struct typ) +{ + if (typ != NIL) { + OPC_PutBase(typ->BaseTyp); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)", ", 3); + } +} + +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName) +{ + OPT_Struct typ = NIL; + INT16 dim; + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + } + dim = 1; + typ = par->typ->BaseTyp; + while (typ->comp == 3) { + if (ansiDefine) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + } else { + OPM_WriteString((CHAR*)", ", 3); + } + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + dim += 1; + } +} + +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro) +{ + OPM_Write('('); + while (par != NIL) { + if (macro) { + OPM_WriteStringVar((void*)par->name, 256); + } else { + if ((par->mode == 1 && par->typ->form == 5)) { + OPM_Write('_'); + } + OPC_Ident(par); + } + if (par->typ->comp == 3) { + OPM_WriteString((CHAR*)", ", 3); + OPC_LenList(par, 0, 1); + } else if ((par->mode == 2 && par->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteStringVar((void*)par->name, 256); + OPM_WriteString((CHAR*)"__typ", 6); + } + par = par->link; + if (par != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static void OPC_DefineTProcTypes (OPT_Object obj) +{ + OPT_Object par = NIL; + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + par = obj->link; + while (par != NIL) { + OPC_DefineType(par->typ); + par = par->link; + } +} + +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DeclareTProcs(obj->left, &*empty); + if (obj->mode == 13) { + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + if (OPM_currFile == 0) { + if (obj->vis == 1) { + OPC_DefineTProcTypes(obj); + OPM_WriteString((CHAR*)"import ", 8); + *empty = 0; + OPC_ProcHeader(obj, 0); + } + } else { + *empty = 0; + OPC_DefineTProcTypes(obj); + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + } + OPC_DeclareTProcs(obj->right, &*empty); + } +} + +OPT_Object OPC_BaseTProc (OPT_Object obj) +{ + OPT_Struct typ = NIL, base = NIL; + INT32 mno; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + base = typ->BaseTyp; + mno = __ASHR(obj->adr, 16); + while ((base != NIL && mno < base->n)) { + typ = base; + base = typ->BaseTyp; + } + OPT_FindField(obj->name, typ, &obj); + return obj; +} + +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DefineTProcMacros(obj->left, &*empty); + if ((obj->mode == 13 && obj == OPC_BaseTProc(obj))) { + if (OPM_currFile == 1 || (OPM_currFile == 0 && obj->vis == 1)) { + OPM_WriteString((CHAR*)"#define __", 11); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_WriteString((CHAR*)" __SEND(", 9); + if (obj->link->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPC_Ident(obj->link); + OPM_Write(')'); + } else { + OPC_Ident(obj->link); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_Str1((CHAR*)", #, ", 6, __ASHR(obj->adr, 16)); + if (obj->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(obj->typ->strobj); + } + OPM_WriteString((CHAR*)"(*)", 4); + OPC_AnsiParamList(obj->link, 0); + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareParams(obj->link, 1); + OPM_Write(')'); + OPM_WriteLn(); + } + } + OPC_DefineTProcMacros(obj->right, &*empty); + } +} + +static void OPC_DefineType (OPT_Struct str) +{ + OPT_Object obj = NIL, field = NIL, par = NIL; + BOOLEAN empty; + if ((OPM_currFile == 1 || str->ref < 255) || (((OPM_currFile == 0 && str->strobj != NIL)) && str->strobj->vis == 1)) { + obj = str->strobj; + if (obj == NIL || OPC_Undefined(obj)) { + if (obj != NIL) { + if (obj->linkadr == 1) { + if (str->form != 11) { + OPM_Mark(244, str->txtpos); + obj->linkadr = 2; + } + } else { + obj->linkadr = 1; + } + } + if (str->comp == 4) { + if (str->BaseTyp != NIL) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while ((field != NIL && field->mode == 4)) { + if (field->vis != 0 || OPM_currFile == 1) { + OPC_DefineType(field->typ); + } + field = field->link; + } + } else if (str->form == 11) { + if (str->BaseTyp->comp != 4) { + OPC_DefineType(str->BaseTyp); + } + } else if (__IN(str->comp, 0x0c, 32)) { + if ((str->BaseTyp->strobj != NIL && str->BaseTyp->strobj->linkadr == 1)) { + OPM_Mark(244, str->txtpos); + str->BaseTyp->strobj->linkadr = 2; + } + OPC_DefineType(str->BaseTyp); + } else if (str->form == 12) { + if (str->BaseTyp != OPT_notyp) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while (field != NIL) { + OPC_DefineType(field->typ); + field = field->link; + } + } + } + if ((obj != NIL && OPC_Undefined(obj))) { + OPM_WriteString((CHAR*)"typedef", 8); + OPM_WriteLn(); + OPM_Write(0x09); + OPC_Indent(1); + obj->linkadr = 1; + OPC_DeclareBase(obj); + OPM_Write(' '); + obj->typ->strobj = NIL; + OPC_DeclareObj(obj, 0); + obj->typ->strobj = obj; + obj->linkadr = 3 + OPM_currFile; + OPC_EndStat(); + OPC_Indent(-1); + OPM_WriteLn(); + if (obj->typ->comp == 4) { + empty = 1; + OPC_DeclareTProcs(str->link, &empty); + OPC_DefineTProcMacros(str->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } else if ((obj->typ->form == 11 && obj->typ->BaseTyp->comp == 4)) { + empty = 1; + OPC_DeclareTProcs(obj->typ->BaseTyp->link, &empty); + OPC_DefineTProcMacros(obj->typ->BaseTyp->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } + } + } +} + +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len) +{ + INT16 i; + __DUP(y, y__len, CHAR); + i = 0; + while ((*x)[__X(i + 1, 256)] == y[__X(i, y__len)]) { + i += 1; + } + __DEL(y); + return y[__X(i, y__len)] == 0x00; +} + +static void OPC_CProcDefs (OPT_Object obj, INT16 vis) +{ + INT16 i; + OPT_ConstExt ext = NIL; + INT16 _for__7; + if (obj != NIL) { + OPC_CProcDefs(obj->left, vis); + if ((((obj->mode == 9 && (INT16)obj->vis >= vis)) && obj->adr == 1)) { + ext = obj->conval->ext; + i = 1; + if (((*ext)[1] != '#' && !(OPC_Prefixed(ext, (CHAR*)"extern ", 8) || OPC_Prefixed(ext, (CHAR*)"import ", 8)))) { + OPM_WriteString((CHAR*)"#define ", 9); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_Write(0x09); + } + _for__7 = (INT16)(*obj->conval->ext)[0]; + i = i; + while (i <= _for__7) { + OPM_Write((*obj->conval->ext)[__X(i, 256)]); + i += 1; + } + OPM_WriteLn(); + } + OPC_CProcDefs(obj->right, vis); + } +} + +void OPC_TypeDefs (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_TypeDefs(obj->left, vis); + if ((obj->mode == 5 && obj->typ->txtpos > 0)) { + OPC_DefineType(obj->typ); + } + OPC_TypeDefs(obj->right, vis); + } +} + +static void OPC_DefAnonRecs (OPT_Node n) +{ + OPT_Object o = NIL; + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if ((typ->strobj == NIL && (OPM_currFile == 1 || typ->ref < 255))) { + OPC_DefineType(typ); + __NEW(o, OPT_ObjDesc); + o->typ = typ; + o->name[0] = 0x00; + OPC_DeclareBase(o); + OPC_EndStat(); + OPM_WriteLn(); + } + n = n->link; + } +} + +void OPC_TDescDecl (OPT_Struct typ) +{ + INT32 nofptrs; + OPT_Object o = NIL; + OPC_BegStat(); + OPM_WriteString((CHAR*)"__TDESC(", 9); + OPC_Andent(typ); + OPC_Str1((CHAR*)", #", 4, typ->n + 1); + OPC_Str1((CHAR*)", #) = {__TDFLDS(", 18, OPC_NofPtrs(typ)); + OPM_Write('"'); + if (typ->strobj != NIL) { + OPM_WriteStringVar((void*)typ->strobj->name, 256); + } + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", 8, typ->size); + nofptrs = 0; + OPC_PutPtrOffsets(typ, 0, &nofptrs); + OPC_Str1((CHAR*)"#}}", 4, -((nofptrs + 1) * OPM_AddressSize)); + OPC_EndStat(); +} + +void OPC_InitTDesc (OPT_Struct typ) +{ + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITYP(", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + if (typ->BaseTyp != NIL) { + OPC_Andent(typ->BaseTyp); + } else { + OPC_Andent(typ); + } + OPC_Str1((CHAR*)", #)", 5, typ->extlev); + OPC_EndStat(); + if (typ->strobj != NIL) { + OPC_InitTProcs(typ->strobj, typ->link); + } +} + +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign) +{ + INT32 adr; + adr = off; + OPT_Align(&adr, align); + if ((*curAlign < align && gap - (adr - off) >= align)) { + gap -= (adr - off) + align; + OPC_BegStat(); + switch (align) { + case 2: + OPM_WriteString((CHAR*)"INT16", 6); + break; + case 4: + OPM_WriteString((CHAR*)"INT32", 6); + break; + case 8: + OPM_WriteString((CHAR*)"INT64", 6); + break; + default: + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected enclosing alignment in FillGap.", 43); + break; + } + OPC_Str1((CHAR*)" _prvt#", 8, *n); + *n += 1; + OPC_EndStat(); + *curAlign = align; + } + if (gap > 0) { + OPC_BegStat(); + OPC_Str1((CHAR*)"char _prvt#", 12, *n); + *n += 1; + OPC_Str1((CHAR*)"[#]", 4, gap); + OPC_EndStat(); + } +} + +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign) +{ + OPT_Object fld = NIL; + OPT_Struct base = NIL; + INT32 gap, adr, align, fldAlign; + fld = typ->link; + align = __MASK(typ->align, -65536); + if (typ->BaseTyp != NIL) { + OPC_FieldList(typ->BaseTyp, 0, &*off, &*n, &*curAlign); + } else { + *off = 0; + *n = 0; + *curAlign = 1; + } + while ((fld != NIL && fld->mode == 4)) { + if ((OPM_currFile == 0 && fld->vis == 0) || (((OPM_currFile == 1 && fld->vis == 0)) && typ->mno != 0)) { + fld = fld->link; + while ((((fld != NIL && fld->mode == 4)) && fld->vis == 0)) { + fld = fld->link; + } + } else { + adr = *off; + fldAlign = OPT_BaseAlignment(fld->typ); + OPT_Align(&adr, fldAlign); + gap = fld->adr - adr; + if (fldAlign > *curAlign) { + *curAlign = fldAlign; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + OPC_BegStat(); + OPC_DeclareBase(fld); + OPM_Write(' '); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + base = fld->typ; + fld = fld->link; + while ((((((((fld != NIL && fld->mode == 4)) && fld->typ == base)) && fld->adr == *off)) && ((OPM_currFile == 1 || fld->vis != 0) || fld->typ->strobj == NIL))) { + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + fld = fld->link; + } + OPC_EndStat(); + } + } + if (last) { + adr = typ->size - __ASHR(typ->sysflag, 8); + if (adr == 0) { + gap = 1; + } else { + gap = adr - *off; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + } +} + +static void OPC_IdentList (OPT_Object obj, INT16 vis) +{ + OPT_Struct base = NIL; + BOOLEAN first; + INT16 lastvis; + base = NIL; + first = 1; + while ((obj != NIL && obj->mode != 13)) { + if ((__IN(vis, 0x05, 32) || (vis == 1 && obj->vis != 0)) || (vis == 3 && !obj->leaf)) { + if (obj->typ != base || (INT16)obj->vis != lastvis) { + if (!first) { + OPC_EndStat(); + } + first = 0; + base = obj->typ; + lastvis = obj->vis; + OPC_BegStat(); + if ((vis == 1 && obj->vis != 0)) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((obj->mnolev == 0 && vis == 0)) { + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + } + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_WriteString((CHAR*)"double", 7); + } else { + OPC_DeclareBase(obj); + } + } else { + OPM_Write(','); + } + OPM_Write(' '); + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_Write('_'); + } + OPC_DeclareObj(obj, vis == 3); + if (obj->typ->comp == 3) { + OPC_EndStat(); + OPC_BegStat(); + base = OPT_adrtyp; + OPM_WriteString((CHAR*)"ADDRESS ", 9); + OPC_LenList(obj, 0, 1); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + base = NIL; + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + OPM_WriteString((CHAR*)" = NIL", 7); + } + } + obj = obj->link; + } + if (!first) { + OPC_EndStat(); + } +} + +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames) +{ + CHAR name[32]; + OPM_Write('('); + if (obj == NIL || obj->mode == 13) { + OPM_WriteString((CHAR*)"void", 5); + } else { + for (;;) { + OPC_DeclareBase(obj); + if (showParamNames) { + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + } else { + __COPY(obj->name, name, 32); + obj->name[0] = 0x00; + OPC_DeclareObj(obj, 0); + __COPY(name, obj->name, 256); + } + if (obj->typ->comp == 3) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + OPC_LenList(obj, 1, showParamNames); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ADDRESS *", 12); + if (showParamNames) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + } + } + if (obj->link == NIL || obj->link->mode == 13) { + break; + } + OPM_WriteString((CHAR*)", ", 3); + obj = obj->link; + } + } + OPM_Write(')'); +} + +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define) +{ + if (proc->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(proc->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(proc); + OPM_Write(' '); + OPC_AnsiParamList(proc->link, 1); + if (!define) { + OPM_Write(';'); + } + OPM_WriteLn(); +} + +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis) +{ + if (obj != NIL) { + OPC_ProcPredefs(obj->left, vis); + if ((((__IN(obj->mode, 0xc0, 32) && obj->vis >= vis)) && (obj->history != 4 || obj->mode == 6))) { + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + OPC_ProcPredefs(obj->right, vis); + } +} + +static void OPC_Include (CHAR *name, ADDRESS name__len) +{ + __DUP(name, name__len, CHAR); + OPM_WriteString((CHAR*)"#include ", 10); + OPM_Write('"'); + OPM_WriteStringVar((void*)name, name__len); + OPM_WriteString((CHAR*)".h", 3); + OPM_Write('"'); + OPM_WriteLn(); + __DEL(name); +} + +static void OPC_IncludeImports (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_IncludeImports(obj->left, vis); + if ((((obj->mode == 11 && obj->mnolev != 0)) && (INT16)OPT_GlbMod[__X(-obj->mnolev, 64)]->vis >= vis)) { + OPC_Include(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + } + OPC_IncludeImports(obj->right, vis); + } +} + +static void OPC_GenDynTypes (OPT_Node n, INT16 vis) +{ + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if (vis == 0 || typ->ref < 255) { + OPC_BegStat(); + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((typ->strobj != NIL && typ->strobj->mnolev > 0)) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_EndStat(); + } + n = n->link; + } +} + +void OPC_GenHdr (OPT_Node n) +{ + OPM_currFile = 0; + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 1); + OPM_WriteLn(); + OPC_GenDynTypes(n, 1); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 1); + OPM_WriteString((CHAR*)"import ", 8); + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPC_EndStat(); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#endif // ", 11); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteLn(); +} + +static void OPC_GenHeaderMsg (void) +{ + INT16 i; + OPM_WriteString((CHAR*)"/* ", 4); + OPM_WriteString((CHAR*)"voc", 4); + OPM_Write(' '); + OPM_WriteString(Configuration_versionLong, 76); + OPM_Write(' '); + i = 0; + while (i <= 31) { + if (__IN(i, OPM_Options, 32)) { + switch (i) { + case 0: + OPM_Write('x'); + break; + case 2: + OPM_Write('r'); + break; + case 3: + OPM_Write('t'); + break; + case 4: + OPM_Write('s'); + break; + case 5: + OPM_Write('p'); + break; + case 7: + OPM_Write('a'); + break; + case 9: + OPM_Write('e'); + break; + case 10: + OPM_Write('m'); + break; + case 13: + OPM_Write('S'); + break; + case 14: + OPM_Write('c'); + break; + case 15: + OPM_Write('M'); + break; + case 16: + OPM_Write('f'); + break; + case 17: + OPM_Write('F'); + break; + case 18: + OPM_Write('v'); + break; + default: + OPM_LogWStr((CHAR*)"( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg", 126); + OPM_LogWLn(); + break; + } + } + i += 1; + } + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); +} + +void OPC_GenHdrIncludes (void) +{ + OPM_currFile = 2; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#ifndef ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 1); + OPM_WriteLn(); +} + +void OPC_GenBdy (OPT_Node n) +{ + OPM_currFile = 1; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SHORTINT INT", 21); + OPM_WriteInt(__ASHL(OPT_sinttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define INTEGER INT", 21); + OPM_WriteInt(__ASHL(OPT_inttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define LONGINT INT", 21); + OPM_WriteInt(__ASHL(OPT_linttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SET UINT", 22); + OPM_WriteInt(__ASHL(OPT_settyp->size, 3)); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 0); + OPM_WriteLn(); + OPC_GenDynTypes(n, 0); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 0); + OPM_WriteLn(); +} + +static void OPC_RegCmds (OPT_Object obj) +{ + if (obj != NIL) { + OPC_RegCmds(obj->left); + if ((obj->mode == 7 && obj->history != 4)) { + if ((((obj->vis != 0 && obj->link == NIL)) && obj->typ == OPT_notyp)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__REGCMD(\"", 11); + OPM_WriteStringVar((void*)obj->name, 256); + OPM_WriteString((CHAR*)"\", ", 4); + OPC_Ident(obj); + OPM_Write(')'); + OPC_EndStat(); + } + } + OPC_RegCmds(obj->right); + } +} + +static void OPC_InitImports (OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitImports(obj->left); + if ((obj->mode == 11 && obj->mnolev != 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__MODULE_IMPORT(", 17); + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + OPM_Write(')'); + OPC_EndStat(); + } + OPC_InitImports(obj->right); + } +} + +void OPC_GenEnumPtrs (OPT_Object var) +{ + OPT_Struct typ = NIL; + INT32 n; + OPC_GlbPtrs = 0; + while (var != NIL) { + typ = var->typ; + if (OPC_NofPtrs(typ) > 0) { + if (!OPC_GlbPtrs) { + OPC_GlbPtrs = 1; + OPM_WriteString((CHAR*)"static void EnumPtrs(void (*P)(void*))", 39); + OPM_WriteLn(); + OPC_BegBlk(); + } + OPC_BegStat(); + if (typ->form == 11) { + OPM_WriteString((CHAR*)"P(", 3); + OPC_Ident(var); + OPM_Write(')'); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(&", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPM_WriteString((CHAR*)", 1, P)", 8); + } else if (typ->comp == 2) { + n = typ->n; + typ = typ->BaseTyp; + while (typ->comp == 2) { + n = n * typ->n; + typ = typ->BaseTyp; + } + if (typ->form == 11) { + OPM_WriteString((CHAR*)"__ENUMP(", 9); + OPC_Ident(var); + OPC_Str1((CHAR*)", #, P)", 8, n); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(", 9); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPC_Str1((CHAR*)", #, P)", 8, n); + } + } + OPC_EndStat(); + } + var = var->link; + } + if (OPC_GlbPtrs) { + OPC_EndBlk(); + OPM_WriteLn(); + } +} + +void OPC_EnterBody (void) +{ + OPM_WriteLn(); + OPM_WriteString((CHAR*)"export ", 8); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); + OPM_WriteLn(); + } else { + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteString(OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPM_WriteLn(); + } + OPC_BegBlk(); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); + } else { + OPM_WriteString((CHAR*)"__DEFMOD", 9); + } + OPC_EndStat(); + if ((__IN(10, OPM_Options, 32) && 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); + OPC_EndStat(); + } + OPC_InitImports(OPT_topScope->right); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); + } else { + OPM_WriteString((CHAR*)"__REGMOD(\"", 11); + } + OPM_WriteString(OPM_modName, 32); + if (OPC_GlbPtrs) { + OPM_WriteString((CHAR*)"\", EnumPtrs)", 13); + } else { + OPM_WriteString((CHAR*)"\", 0)", 6); + } + OPC_EndStat(); + if (__STRCMP(OPM_modName, "SYSTEM") != 0) { + OPC_RegCmds(OPT_topScope); + } +} + +void OPC_ExitBody (void) +{ + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI;", 8); + } else { + OPM_WriteString((CHAR*)"__ENDMOD;", 10); + } + OPM_WriteLn(); + OPC_EndBlk(); +} + +void OPC_DefineInter (OPT_Object proc) +{ + OPT_Object scope = NIL; + scope = proc->scope; + OPM_WriteString((CHAR*)"static ", 8); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPC_BegBlk(); + OPC_IdentList(proc->link, 3); + OPC_IdentList(scope->scope, 3); + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + OPC_EndBlk0(); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPM_WriteLn(); + OPC_ProcPredefs(scope->right, 0); + OPM_WriteLn(); +} + +BOOLEAN OPC_NeedsRetval (OPT_Object proc) +{ + return (proc->typ != OPT_notyp && !proc->scope->leaf); +} + +void OPC_EnterProc (OPT_Object proc) +{ + OPT_Object var = NIL, scope = NIL; + OPT_Struct typ = NIL; + INT16 dim; + if (proc->vis != 1) { + OPM_WriteString((CHAR*)"static ", 8); + } + OPC_ProcHeader(proc, 1); + OPC_BegBlk(); + scope = proc->scope; + OPC_IdentList(scope->scope, 0); + if (!scope->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } + if (OPC_NeedsRetval(proc)) { + OPC_BegStat(); + OPC_Ident(proc->typ->strobj); + OPM_WriteString((CHAR*)" __retval", 10); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((var->typ->comp == 2 && var->mode == 1)) { + OPC_BegStat(); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__copy", 7); + OPC_EndStat(); + } + var = var->link; + } + var = proc->link; + while (var != NIL) { + if ((((__IN(var->typ->comp, 0x0c, 32) && var->mode == 1)) && var->typ->sysflag == 0)) { + OPC_BegStat(); + if (var->typ->comp == 2) { + OPM_WriteString((CHAR*)"__DUPARR(", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + } else { + OPM_WriteString((CHAR*)"__DUP(", 7); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + typ = var->typ->BaseTyp; + dim = 1; + while (typ->comp == 3) { + OPM_WriteString((CHAR*)" * ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + typ = typ->BaseTyp; + dim += 1; + } + OPM_WriteString((CHAR*)", ", 3); + if (typ->strobj == NIL) { + OPM_Mark(200, typ->txtpos); + } else { + OPC_Ident(typ->strobj); + } + } + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + if (!scope->leaf) { + var = proc->link; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (__IN(var->typ->comp, 0x0c, 32)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } else if (var->mode != 2) { + OPM_Write('&'); + } + OPC_Ident(var); + if (var->typ->comp == 3) { + typ = var->typ; + dim = 0; + do { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + } while (!(typ->comp != 3)); + } else if ((var->mode == 2 && var->typ->comp == 4)) { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_EndStat(); + } + var = var->link; + } + var = scope->scope; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (var->typ->comp != 2) { + OPM_Write('&'); + } else { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPC_Ident(var); + OPC_EndStat(); + } + var = var->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_Write('&'); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } +} + +void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet) +{ + OPT_Object var = NIL; + BOOLEAN indent; + indent = eoBlock; + if ((implicitRet && proc->typ != OPT_notyp)) { + OPM_Write(0x09); + OPM_WriteString((CHAR*)"__RETCHK;", 10); + OPM_WriteLn(); + } else if (!eoBlock || implicitRet) { + if (!proc->scope->leaf) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteStringVar((void*)proc->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((((var->typ->comp == 3 && var->mode == 1)) && var->typ->sysflag == 0)) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteString((CHAR*)"__DEL(", 7); + OPC_Ident(var); + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + } + if (eoBlock) { + OPC_EndBlk(); + OPM_WriteLn(); + } else if (indent) { + OPC_BegStat(); + } +} + +void OPC_CompleteIdent (OPT_Object obj) +{ + INT16 comp, level; + level = obj->mnolev; + if (obj->adr == 1) { + if (obj->typ->comp == 4) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__", 3); + } else { + OPM_WriteString((CHAR*)"(*(", 4); + OPC_Ident(obj->typ->strobj); + OPM_WriteString((CHAR*)"*)&", 4); + OPC_Ident(obj); + OPM_Write(')'); + } + } else if ((level != OPM_level && level > 0)) { + comp = obj->typ->comp; + if ((obj->mode != 2 && comp != 3)) { + OPM_Write('*'); + } + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)"->", 3); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } +} + +void OPC_TypeOf (OPT_Object ap) +{ + INT16 i; + __ASSERT(ap->typ->comp == 4, 0); + if (ap->mode == 2) { + if ((INT16)ap->mnolev != OPM_level) { + OPM_WriteStringVar((void*)ap->scope->name, 256); + OPM_WriteString((CHAR*)"_s->", 5); + OPC_Ident(ap); + } else { + OPC_Ident(ap); + } + OPM_WriteString((CHAR*)"__typ", 6); + } else if (ap->typ->strobj != NIL) { + OPC_Ident(ap->typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + } else { + OPC_Andent(ap->typ); + } +} + +void OPC_Cmp (INT16 rel) +{ + switch (rel) { + case 9: + OPM_WriteString((CHAR*)" == ", 5); + break; + case 10: + OPM_WriteString((CHAR*)" != ", 5); + break; + case 11: + OPM_WriteString((CHAR*)" < ", 4); + break; + case 12: + OPM_WriteString((CHAR*)" <= ", 5); + break; + case 13: + OPM_WriteString((CHAR*)" > ", 4); + break; + case 14: + OPM_WriteString((CHAR*)" >= ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Cmp, rel = ", 34); + OPM_LogWNum(rel, 0); + OPM_LogWLn(); + break; + } +} + +static void OPC_CharacterLiteral (INT64 c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", 3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l) +{ + INT32 i; + INT16 c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (INT16)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write(__CHR(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write(__CHR(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write(__CHR(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + +void OPC_Case (INT64 caseVal, INT16 form) +{ + CHAR ch; + OPM_WriteString((CHAR*)"case ", 6); + switch (form) { + case 3: + OPC_CharacterLiteral(caseVal); + break; + case 4: + OPM_WriteInt(caseVal); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Case, form = ", 36); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } + OPM_WriteString((CHAR*)": ", 3); +} + +void OPC_SetInclude (BOOLEAN exclude) +{ + if (exclude) { + OPM_WriteString((CHAR*)" &= ~", 6); + } else { + OPM_WriteString((CHAR*)" |= ", 5); + } +} + +void OPC_Increment (BOOLEAN decrement) +{ + if (decrement) { + OPM_WriteString((CHAR*)" -= ", 5); + } else { + OPM_WriteString((CHAR*)" += ", 5); + } +} + +void OPC_Halt (INT32 n) +{ + OPC_Str1((CHAR*)"__HALT(#)", 10, n); +} + +void OPC_IntLiteral (INT64 n, INT32 size) +{ + if ((((size > 4 && n <= 2147483647)) && n > (-2147483647-1))) { + OPM_WriteString((CHAR*)"((INT", 6); + OPM_WriteInt(__ASHL(size, 3)); + OPM_WriteString((CHAR*)")(", 3); + OPM_WriteInt(n); + OPM_WriteString((CHAR*)"))", 3); + } else { + OPM_WriteInt(n); + } +} + +void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim) +{ + INT64 d; + d = dim; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPC_CompleteIdent(obj); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + } else { + OPM_WriteInt(array->n); + } +} + +void OPC_Constant (OPT_Const con, INT16 form) +{ + INT16 i; + UINT64 s; + INT64 hex; + BOOLEAN skipLeading; + switch (form) { + case 1: + OPM_WriteInt(con->intval); + break; + case 2: + OPM_WriteInt(con->intval); + break; + case 3: + OPC_CharacterLiteral(con->intval); + break; + case 4: + OPM_WriteInt(con->intval); + break; + case 5: + OPM_WriteReal(con->realval, 'f'); + break; + case 6: + OPM_WriteReal(con->realval, 0x00); + break; + case 7: + OPM_WriteString((CHAR*)"0x", 3); + skipLeading = 1; + s = con->setval; + i = 64; + do { + hex = 0; + do { + i -= 1; + hex = __ASHL(hex, 1); + if (__IN(i, s, 64)) { + hex += 1; + } + } while (!(__MASK(i, -8) == 0)); + if (hex != 0 || !skipLeading) { + OPM_WriteHex(hex); + skipLeading = 0; + } + } while (!(i == 0)); + if (skipLeading) { + OPM_Write('0'); + } + break; + case 8: + OPC_StringLiteral(*con->ext, 256, con->intval2 - 1); + break; + case 9: + OPM_WriteString((CHAR*)"NIL", 4); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Constant, form = ", 40); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } +} + +static struct InitKeywords__46 { + INT8 *n; + struct InitKeywords__46 *lnk; +} *InitKeywords__46_s; + +static void Enter__47 (CHAR *s, ADDRESS s__len); + +static void Enter__47 (CHAR *s, ADDRESS s__len) +{ + INT16 h; + __DUP(s, s__len, CHAR); + h = OPC_PerfectHash((void*)s, s__len); + OPC_hashtab[__X(h, 105)] = *InitKeywords__46_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__46_s->n, 50)], 9); + *InitKeywords__46_s->n += 1; + __DEL(s); +} + +static void OPC_InitKeywords (void) +{ + INT8 n, i; + struct InitKeywords__46 _s; + _s.n = &n; + _s.lnk = InitKeywords__46_s; + InitKeywords__46_s = &_s; + n = 0; + i = 0; + while (i <= 104) { + OPC_hashtab[__X(i, 105)] = -1; + i += 1; + } + Enter__47((CHAR*)"ADDRESS", 8); + Enter__47((CHAR*)"INT16", 6); + Enter__47((CHAR*)"INT32", 6); + Enter__47((CHAR*)"INT64", 6); + Enter__47((CHAR*)"INT8", 5); + Enter__47((CHAR*)"UINT16", 7); + Enter__47((CHAR*)"UINT32", 7); + Enter__47((CHAR*)"UINT64", 7); + Enter__47((CHAR*)"UINT8", 6); + Enter__47((CHAR*)"asm", 4); + Enter__47((CHAR*)"auto", 5); + Enter__47((CHAR*)"break", 6); + Enter__47((CHAR*)"case", 5); + Enter__47((CHAR*)"char", 5); + Enter__47((CHAR*)"const", 6); + Enter__47((CHAR*)"continue", 9); + Enter__47((CHAR*)"default", 8); + Enter__47((CHAR*)"do", 3); + Enter__47((CHAR*)"double", 7); + Enter__47((CHAR*)"else", 5); + Enter__47((CHAR*)"enum", 5); + Enter__47((CHAR*)"extern", 7); + Enter__47((CHAR*)"export", 7); + Enter__47((CHAR*)"float", 6); + Enter__47((CHAR*)"for", 4); + Enter__47((CHAR*)"fortran", 8); + Enter__47((CHAR*)"goto", 5); + Enter__47((CHAR*)"if", 3); + Enter__47((CHAR*)"import", 7); + Enter__47((CHAR*)"int", 4); + Enter__47((CHAR*)"long", 5); + Enter__47((CHAR*)"register", 9); + Enter__47((CHAR*)"return", 7); + Enter__47((CHAR*)"short", 6); + Enter__47((CHAR*)"signed", 7); + Enter__47((CHAR*)"sizeof", 7); + Enter__47((CHAR*)"size_t", 7); + Enter__47((CHAR*)"static", 7); + Enter__47((CHAR*)"struct", 7); + Enter__47((CHAR*)"switch", 7); + Enter__47((CHAR*)"typedef", 8); + Enter__47((CHAR*)"union", 6); + Enter__47((CHAR*)"unsigned", 9); + Enter__47((CHAR*)"void", 5); + Enter__47((CHAR*)"volatile", 9); + Enter__47((CHAR*)"while", 6); + InitKeywords__46_s = _s.lnk; +} + + +export void *OPC__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPT); + __REGMOD("OPC", 0); + __REGCMD("BegBlk", OPC_BegBlk); + __REGCMD("BegStat", OPC_BegStat); + __REGCMD("EndBlk", OPC_EndBlk); + __REGCMD("EndBlk0", OPC_EndBlk0); + __REGCMD("EndStat", OPC_EndStat); + __REGCMD("EnterBody", OPC_EnterBody); + __REGCMD("ExitBody", OPC_ExitBody); + __REGCMD("GenHdrIncludes", OPC_GenHdrIncludes); + __REGCMD("Init", OPC_Init); +/* BEGIN */ + OPC_InitKeywords(); + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPC.h b/bootstrap/unix-48/OPC.h new file mode 100644 index 00000000..3bfd88b8 --- /dev/null +++ b/bootstrap/unix-48/OPC.h @@ -0,0 +1,49 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPC__h +#define OPC__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPC_Andent (OPT_Struct typ); +import OPT_Object OPC_BaseTProc (OPT_Object obj); +import void OPC_BegBlk (void); +import void OPC_BegStat (void); +import void OPC_Case (INT64 caseVal, INT16 form); +import void OPC_Cmp (INT16 rel); +import void OPC_CompleteIdent (OPT_Object obj); +import void OPC_Constant (OPT_Const con, INT16 form); +import void OPC_DefineInter (OPT_Object proc); +import void OPC_EndBlk (void); +import void OPC_EndBlk0 (void); +import void OPC_EndStat (void); +import void OPC_EnterBody (void); +import void OPC_EnterProc (OPT_Object proc); +import void OPC_ExitBody (void); +import void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +import void OPC_GenBdy (OPT_Node n); +import void OPC_GenEnumPtrs (OPT_Object var); +import void OPC_GenHdr (OPT_Node n); +import void OPC_GenHdrIncludes (void); +import void OPC_Halt (INT32 n); +import void OPC_Ident (OPT_Object obj); +import void OPC_Increment (BOOLEAN decrement); +import void OPC_Indent (INT16 count); +import void OPC_Init (void); +import void OPC_InitTDesc (OPT_Struct typ); +import void OPC_IntLiteral (INT64 n, INT32 size); +import void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +import BOOLEAN OPC_NeedsRetval (OPT_Object proc); +import INT32 OPC_NofPtrs (OPT_Struct typ); +import void OPC_SetInclude (BOOLEAN exclude); +import void OPC_TDescDecl (OPT_Struct typ); +import void OPC_TypeDefs (OPT_Object obj, INT16 vis); +import void OPC_TypeOf (OPT_Object ap); +import void *OPC__init(void); + + +#endif // OPC diff --git a/bootstrap/unix-48/OPM.c b/bootstrap/unix-48/OPM.c new file mode 100644 index 00000000..bcb39247 --- /dev/null +++ b/bootstrap/unix-48/OPM.c @@ -0,0 +1,1183 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Files.h" +#include "Modules.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" +#include "Texts.h" +#include "VT100.h" + +typedef + CHAR OPM_FileName[32]; + + +static CHAR OPM_currentComment[256]; +static BOOLEAN OPM_hasComment; +static CHAR OPM_SourceFileName[256]; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static INT16 OPM_GlobalAddressSize; +export INT16 OPM_AddressSize; +static INT16 OPM_GlobalAlignment; +export INT16 OPM_Alignment; +export UINT32 OPM_GlobalOptions, OPM_Options; +export INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +export INT64 OPM_MaxIndex; +export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +export BOOLEAN OPM_noerr; +export INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +export INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +export CHAR OPM_modName[32]; +export CHAR OPM_objname[64]; +static INT32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; +static Texts_Reader OPM_inR; +static Texts_Text OPM_Log, OPM_Errors; +static Files_Rider OPM_oldSF, OPM_newSF; +static Files_Rider OPM_R[3]; +static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; +static INT16 OPM_S; +export CHAR OPM_InstallDir[1024]; +export CHAR OPM_ResourceDir[1024]; + + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F); +export void OPM_CloseFiles (void); +export void OPM_CloseOldSym (void); +export void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +export void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +export void OPM_FPrint (INT32 *fp, INT64 val); +export void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +export void OPM_FPrintReal (INT32 *fp, REAL val); +export void OPM_FPrintSet (INT32 *fp, UINT64 val); +static void OPM_FindInstallDir (void); +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos); +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len); +export void OPM_Get (CHAR *ch); +export void OPM_GetComment (CHAR *text, ADDRESS text__len); +export void OPM_Init (BOOLEAN *done); +export void OPM_InitOptions (void); +export INT16 OPM_Integer (INT64 n); +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len); +export void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +static void OPM_LogErrMsg (INT16 n); +export void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +export void OPM_LogW (CHAR ch); +export void OPM_LogWLn (void); +export void OPM_LogWNum (INT64 i, INT64 len); +export void OPM_LogWStr (CHAR *s, ADDRESS s__len); +export INT32 OPM_Longint (INT64 n); +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len); +export void OPM_Mark (INT16 n, INT32 pos); +export void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +export void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +export void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +export BOOLEAN OPM_OpenPar (void); +export void OPM_RegisterNewSym (void); +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len); +static void OPM_ShowLine (INT64 pos); +export INT64 OPM_SignedMaximum (INT32 bytecount); +export INT64 OPM_SignedMinimum (INT32 bytecount); +export void OPM_StoreComment (CHAR *text, ADDRESS text__len); +export void OPM_SymRCh (CHAR *ch); +export INT32 OPM_SymRInt (void); +export INT64 OPM_SymRInt64 (void); +export void OPM_SymRLReal (LONGREAL *lr); +export void OPM_SymRReal (REAL *r); +export void OPM_SymRSet (UINT64 *s); +export void OPM_SymWCh (CHAR ch); +export void OPM_SymWInt (INT64 i); +export void OPM_SymWLReal (LONGREAL lr); +export void OPM_SymWReal (REAL r); +export void OPM_SymWSet (UINT64 s); +export void OPM_Write (CHAR ch); +export void OPM_WriteHex (INT64 i); +export void OPM_WriteInt (INT64 i); +export void OPM_WriteLn (void); +export void OPM_WriteReal (LONGREAL r, CHAR suffx); +export void OPM_WriteString (CHAR *s, ADDRESS s__len); +export void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +export BOOLEAN OPM_eofSF (void); +export void OPM_err (INT16 n); + +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s + +void OPM_LogW (CHAR ch) +{ + Out_Char(ch); +} + +void OPM_LogWStr (CHAR *s, ADDRESS s__len) +{ + __DUP(s, s__len, CHAR); + Out_String(s, s__len); + __DEL(s); +} + +void OPM_LogWNum (INT64 i, INT64 len) +{ + Out_Int(i, len); +} + +void OPM_LogWLn (void) +{ + Out_Ln(); +} + +void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len) +{ + __DUP(vt100code, vt100code__len, CHAR); + if ((Out_IsConsole && !__IN(16, OPM_Options, 32))) { + VT100_SetAttr(vt100code, vt100code__len); + } + __DEL(vt100code); +} + +void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len) +{ + __DUP(modname, modname__len, CHAR); + OPM_LogWStr((CHAR*)"Compiling ", 11); + OPM_LogWStr(modname, modname__len); + if (__IN(18, OPM_Options, 32)) { + OPM_LogWStr((CHAR*)", s:", 5); + OPM_LogWNum(__ASHL(OPM_ShortintSize, 3), 1); + OPM_LogWStr((CHAR*)" i:", 4); + OPM_LogWNum(__ASHL(OPM_IntegerSize, 3), 1); + OPM_LogWStr((CHAR*)" l:", 4); + OPM_LogWNum(__ASHL(OPM_LongintSize, 3), 1); + OPM_LogWStr((CHAR*)" adr:", 6); + OPM_LogWNum(__ASHL(OPM_AddressSize, 3), 1); + OPM_LogWStr((CHAR*)" algn:", 7); + OPM_LogWNum(__ASHL(OPM_Alignment, 3), 1); + } + OPM_LogW('.'); + __DEL(modname); +} + +void OPM_StoreComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_currentComment[__X(i, 256)] = text[__X(i, text__len)]; + i += 1; + } + OPM_currentComment[__X(i, 256)] = 0x00; + OPM_hasComment = 1; + __DEL(text); +} + +void OPM_GetComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + if (OPM_hasComment) { + i = 0; + while ((((i < text__len && i < 256)) && OPM_currentComment[__X(i, 256)] != 0x00)) { + text[__X(i, text__len)] = OPM_currentComment[__X(i, 256)]; + i += 1; + } + text[__X(i, text__len)] = 0x00; + OPM_hasComment = 0; + } else { + text[0] = 0x00; + } +} + +INT64 OPM_SignedMaximum (INT32 bytecount) +{ + INT64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + return result - 1; +} + +INT64 OPM_SignedMinimum (INT32 bytecount) +{ + return -OPM_SignedMaximum(bytecount) - 1; +} + +INT32 OPM_Longint (INT64 n) +{ + return __VAL(INT32, n); +} + +INT16 OPM_Integer (INT64 n) +{ + return __VAL(INT16, n); +} + +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 1; + while (s[__X(i, s__len)] != 0x00) { + switch (s[__X(i, s__len)]) { + case 'p': + OPM_Options = OPM_Options ^ 0x20; + break; + case 'a': + OPM_Options = OPM_Options ^ 0x80; + break; + case 'r': + OPM_Options = OPM_Options ^ 0x04; + break; + case 't': + OPM_Options = OPM_Options ^ 0x08; + break; + case 'x': + OPM_Options = OPM_Options ^ 0x01; + break; + case 'e': + OPM_Options = OPM_Options ^ 0x0200; + break; + case 's': + OPM_Options = OPM_Options ^ 0x10; + break; + case 'F': + OPM_Options = OPM_Options ^ 0x020000; + break; + case 'm': + OPM_Options = OPM_Options ^ 0x0400; + break; + case 'M': + OPM_Options = OPM_Options ^ 0x8000; + break; + case 'S': + OPM_Options = OPM_Options ^ 0x2000; + break; + case 'c': + OPM_Options = OPM_Options ^ 0x4000; + break; + case 'f': + OPM_Options = OPM_Options ^ 0x010000; + break; + case 'V': + OPM_Options = OPM_Options ^ 0x040000; + break; + case 'O': + if (i + 1 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); + OPM_LogWLn(); + } else { + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); + } + i += 1; + } + break; + case 'A': + if (i + 2 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-M option requires two following digits.", 41); + OPM_LogWLn(); + } else { + OPM_AddressSize = (INT16)s[__X(i + 1, s__len)] - 48; + OPM_Alignment = (INT16)s[__X(i + 2, s__len)] - 48; + i += 2; + } + break; + default: + OPM_LogWStr((CHAR*)" warning: option ", 19); + OPM_LogW('-'); + OPM_LogW(s[__X(i, s__len)]); + OPM_LogWStr((CHAR*)" ignored", 9); + OPM_LogWLn(); + break; + } + i += 1; + } + __DEL(s); +} + +BOOLEAN OPM_OpenPar (void) +{ + CHAR s[256]; + if (Modules_ArgCount == 1) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Oberon-2 compiler v", 20); + OPM_LogWStr(Configuration_versionLong, 76); + OPM_LogW('.'); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Based on Ofront by J. Templ and Software Templ OEG.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Further development by Norayr Chilingarian, David Brown and others.", 68); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Loaded from ", 13); + OPM_LogWStr(Modules_BinaryDir, 1024); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Usage:", 7); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWStr((CHAR*)"voc", 4); + OPM_LogWStr((CHAR*)" options {files {options}}.", 28); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options:", 9); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Run time safety", 18); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -p Initialise pointers to NIL. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -a Halt on assertion failures. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -r Halt on range check failures.", 39); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -t Halt on type guard failure. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -x Halt on index out of range. On by default.", 52); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Symbol file management", 25); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -e Allow extension of old symbol file.", 45); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -s Allow generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -F Force generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" C compiler and linker control", 32); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -m This module is main. Link dynamically.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -M This module is main. Link statically.", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -S Don't call C compiler", 31); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -c Don't link.", 21); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Miscellaneous", 16); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -f Disable VT100 control characters in status output.", 60); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -V Display compiler debugging messages.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Size model for elementary types (default O2)", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Target machine address size and alignment (default is that of the running compiler binary)", 93); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86).", 79); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm).", 97); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms).", 71); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"All options are off by default, except where noted above.", 58); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Initial options specify defaults for all files.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options following a filename are specific to that file.", 56); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Repeating an option toggles its value.", 39); + OPM_LogWLn(); + return 0; + } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; + OPM_S = 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __MOVE(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; + return 1; + } + __RETCHK; +} + +void OPM_InitOptions (void) +{ + CHAR s[256]; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __MOVE(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); + } + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 4; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + __MOVE(OPM_InstallDir, OPM_ResourceDir, 1024); + if (OPM_ResourceDir[0] != 0x00) { + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + } + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); +} + +void OPM_Init (BOOLEAN *done) +{ + Texts_Text T = NIL; + INT32 beg, end, time; + CHAR s[256]; + *done = 0; + OPM_curpos = 0; + if (OPM_S >= Modules_ArgCount) { + return; + } + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + __NEW(T, Texts_TextDesc); + Texts_Open(T, s, 256); + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" ", 3); + __COPY(s, OPM_SourceFileName, 256); + if (T->len == 0) { + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" not found.", 12); + OPM_LogWLn(); + } else { + Texts_OpenReader(&OPM_inR, Texts_Reader__typ, T, 0); + *done = 1; + } + OPM_S += 1; + OPM_level = 0; + OPM_noerr = 1; + OPM_errpos = OPM_curpos; + OPM_lasterrpos = OPM_curpos - 10; + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; +} + +void OPM_Get (CHAR *ch) +{ + OPM_curpos = Texts_Pos(&OPM_inR, Texts_Reader__typ); + Texts_Read(&OPM_inR, Texts_Reader__typ, &*ch); + if ((*ch < 0x09 && !OPM_inR.eot)) { + *ch = ' '; + } +} + +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len) +{ + INT16 i, j; + CHAR ch; + __DUP(ext, ext__len, CHAR); + i = 0; + for (;;) { + ch = name[__X(i, name__len)]; + if (ch == 0x00) { + break; + } + FName[__X(i, FName__len)] = ch; + i += 1; + } + j = 0; + do { + ch = ext[__X(j, ext__len)]; + FName[__X(i, FName__len)] = ch; + i += 1; + j += 1; + } while (!(ch == 0x00)); + __DEL(ext); +} + +static void OPM_LogErrMsg (INT16 n) +{ + INT16 l; + Texts_Scanner S; + CHAR c; + if (n >= 0) { + OPM_LogVT100((CHAR*)"31m", 4); + OPM_LogWStr((CHAR*)" err ", 7); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + OPM_LogVT100((CHAR*)"35m", 4); + OPM_LogWStr((CHAR*)" warning ", 11); + n = -n; + OPM_LogVT100((CHAR*)"0m", 3); + } + OPM_LogWNum(n, 1); + OPM_LogWStr((CHAR*)" ", 3); + if (OPM_Errors == NIL) { + __NEW(OPM_Errors, Texts_TextDesc); + Texts_Open(OPM_Errors, (CHAR*)"Errors.Txt", 11); + } + Texts_OpenScanner(&S, Texts_Scanner__typ, OPM_Errors, 0); + do { + l = S.line; + Texts_Scan(&S, Texts_Scanner__typ); + } while (!((((l != S.line && S.class == 3)) && S.i == n) || S.eot)); + if (!S.eot) { + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + while ((!S.eot && c >= ' ')) { + Out_Char(c); + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + } + } +} + +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos) +{ + CHAR ch, cheol; + if (pos < (INT64)OPM_ErrorLineStartPos) { + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; + } + if (pos < (INT64)OPM_ErrorLineLimitPos) { + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); + return; + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineLimitPos); + Files_Read(&*r, r__typ, (void*)&ch); + while (((INT64)OPM_ErrorLineLimitPos < pos && !(*r).eof)) { + OPM_ErrorLineStartPos = OPM_ErrorLineLimitPos; + OPM_ErrorLineNumber += 1; + while ((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) { + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + } + cheol = ch; + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + if ((cheol == 0x0d && ch == 0x0a)) { + OPM_ErrorLineLimitPos += 1; + Files_Read(&*r, r__typ, (void*)&ch); + } + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); +} + +static void OPM_ShowLine (INT64 pos) +{ + Files_File f = NIL; + Files_Rider r; + CHAR line[1023]; + INT16 i; + CHAR ch; + f = Files_Old(OPM_SourceFileName, 256); + OPM_FindLine(f, &r, Files_Rider__typ, pos); + i = 0; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + while ((((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) && i < 1022)) { + line[__X(i, 1023)] = ch; + i += 1; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + } + line[__X(i, 1023)] = 0x00; + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWNum(OPM_ErrorLineNumber, 4); + OPM_LogWStr((CHAR*)": ", 3); + OPM_LogWStr(line, 1023); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 7); + if (pos >= (INT64)OPM_ErrorLineLimitPos) { + pos = OPM_ErrorLineLimitPos - 1; + } + i = __SHORTF(OPM_Longint(pos - (INT64)OPM_ErrorLineStartPos), 32768); + while (i > 0) { + OPM_LogW(' '); + i -= 1; + } + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogW('^'); + OPM_LogVT100((CHAR*)"0m", 3); +} + +void OPM_Mark (INT16 n, INT32 pos) +{ + if (pos == -1) { + pos = 0; + } + if (n >= 0) { + OPM_noerr = 0; + if (pos < OPM_lasterrpos || OPM_lasterrpos + 9 < pos) { + OPM_lasterrpos = pos; + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + if (n < 249) { + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + OPM_LogErrMsg(n); + } else if (n == 255) { + OPM_LogWStr((CHAR*)"pos", 4); + OPM_LogWNum(pos, 6); + OPM_LogWStr((CHAR*)" pc ", 6); + OPM_LogWNum(OPM_breakpc, 1); + } else if (n == 254) { + OPM_LogWStr((CHAR*)"pc not found", 13); + } else { + OPM_LogWStr(OPM_objname, 64); + if (n == 253) { + OPM_LogWStr((CHAR*)" is new, compile with option e", 31); + } else if (n == 252) { + OPM_LogWStr((CHAR*)" is redefined, compile with option s", 37); + } else if (n == 251) { + OPM_LogWStr((CHAR*)" is redefined (private part only), compile with option s", 57); + } else if (n == 250) { + OPM_LogWStr((CHAR*)" is no longer visible, compile with option s", 45); + } else if (n == 249) { + OPM_LogWStr((CHAR*)" is not consistently imported, recompile imports", 49); + } + } + } + } else { + if (pos >= 0) { + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + } + OPM_LogErrMsg(n); + if (pos < 0) { + OPM_LogWLn(); + } + } +} + +void OPM_err (INT16 n) +{ + OPM_Mark(n, OPM_errpos); +} + +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len) +{ + INT16 i; + INT32 l; + __ASSERT(__MASK(bytes__len, -4) == 0, 0); + i = 0; + while (i < bytes__len) { + __GET((ADDRESS)&bytes[__X(i, bytes__len)], l, INT32); + *fp = __ROTL((INT32)((UINT32)*fp ^ (UINT32)l), 1, 32); + i += 4; + } +} + +void OPM_FPrint (INT32 *fp, INT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintSet (INT32 *fp, UINT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintReal (INT32 *fp, REAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 4); +} + +void OPM_FPrintLReal (INT32 *fp, LONGREAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_SymRCh (CHAR *ch) +{ + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); +} + +INT32 OPM_SymRInt (void) +{ + INT32 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 4); + return k; +} + +INT64 OPM_SymRInt64 (void) +{ + INT64 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 8); + return k; +} + +void OPM_SymRSet (UINT64 *s) +{ + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&*s, 8); +} + +void OPM_SymRReal (REAL *r) +{ + Files_ReadReal(&OPM_oldSF, Files_Rider__typ, &*r); +} + +void OPM_SymRLReal (LONGREAL *lr) +{ + Files_ReadLReal(&OPM_oldSF, Files_Rider__typ, &*lr); +} + +void OPM_CloseOldSym (void) +{ + Files_Close(Files_Base(&OPM_oldSF, Files_Rider__typ)); +} + +void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done) +{ + CHAR tag, ver; + OPM_FileName fileName; + INT16 res; + OPM_oldSFile = NIL; + *done = 0; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_oldSFile = Files_Old(fileName, 32); + *done = OPM_oldSFile != NIL; + if (*done) { + Files_Set(&OPM_oldSF, Files_Rider__typ, OPM_oldSFile, 0); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&tag); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&ver); + if (tag != 0xf7 || ver != 0x84) { + if (!__IN(4, OPM_Options, 32)) { + OPM_err(-306); + } + OPM_CloseOldSym(); + *done = 0; + } + } +} + +BOOLEAN OPM_eofSF (void) +{ + return OPM_oldSF.eof; +} + +void OPM_SymWCh (CHAR ch) +{ + Files_Write(&OPM_newSF, Files_Rider__typ, ch); +} + +void OPM_SymWInt (INT64 i) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, i); +} + +void OPM_SymWSet (UINT64 s) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, (INT64)s); +} + +void OPM_SymWReal (REAL r) +{ + Files_WriteReal(&OPM_newSF, Files_Rider__typ, r); +} + +void OPM_SymWLReal (LONGREAL lr) +{ + Files_WriteLReal(&OPM_newSF, Files_Rider__typ, lr); +} + +void OPM_RegisterNewSym (void) +{ + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { + Files_Register(OPM_newSFile); + } +} + +void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".sym", 5); + Files_Delete(fn, 32, &res); +} + +void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".o", 3); + Files_Delete(fn, 32, &res); +} + +void OPM_NewSym (CHAR *modName, ADDRESS modName__len) +{ + OPM_FileName fileName; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_newSFile = Files_New(fileName, 32); + if (OPM_newSFile != NIL) { + Files_Set(&OPM_newSF, Files_Rider__typ, OPM_newSFile, 0); + Files_Write(&OPM_newSF, Files_Rider__typ, 0xf7); + Files_Write(&OPM_newSF, Files_Rider__typ, 0x84); + } else { + OPM_err(153); + } +} + +void OPM_Write (CHAR ch) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, ch); +} + +void OPM_WriteString (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteStringVar (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteHex (INT64 i) +{ + CHAR s[3]; + INT32 digit; + digit = __ASHR(__SHORT(i, 2147483648LL), 4); + if (digit < 10) { + s[0] = __CHR(48 + digit); + } else { + s[0] = __CHR(87 + digit); + } + digit = __MASK(__SHORT(i, 2147483648LL), -16); + if (digit < 10) { + s[1] = __CHR(48 + digit); + } else { + s[1] = __CHR(87 + digit); + } + s[2] = 0x00; + OPM_WriteString(s, 3); +} + +void OPM_WriteInt (INT64 i) +{ + CHAR s[26]; + INT64 i1, k; + if ((i == OPM_SignedMinimum(2) || i == OPM_SignedMinimum(4)) || i == OPM_SignedMinimum(8)) { + OPM_Write('('); + OPM_WriteInt(i + 1); + OPM_WriteString((CHAR*)"-1)", 4); + } else { + i1 = __ABS(i); + if (i1 <= 2147483647) { + k = 0; + } else { + __MOVE("LL", s, 3); + k = 2; + } + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + while (i1 > 0) { + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + } + if (i < 0) { + s[__X(k, 26)] = '-'; + k += 1; + } + while (k > 0) { + k -= 1; + OPM_Write(s[__X(k, 26)]); + } + } +} + +void OPM_WriteReal (LONGREAL r, CHAR suffx) +{ + Texts_Writer W; + Texts_Text T = NIL; + Texts_Reader R; + CHAR s[32]; + CHAR ch; + INT16 i; + if ((((r < OPM_SignedMaximum(OPM_LongintSize) && r > OPM_SignedMinimum(OPM_LongintSize))) && r == (__SHORT(__ENTIER(r), 2147483648LL)))) { + if (suffx == 'f') { + OPM_WriteString((CHAR*)"(REAL)", 7); + } else { + OPM_WriteString((CHAR*)"(LONGREAL)", 11); + } + OPM_WriteInt(__SHORT(__ENTIER(r), 2147483648LL)); + } else { + Texts_OpenWriter(&W, Texts_Writer__typ); + if (suffx == 'f') { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 16); + } else { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 23); + } + __NEW(T, Texts_TextDesc); + Texts_Open(T, (CHAR*)"", 1); + Texts_Append(T, W.buf); + Texts_OpenReader(&R, Texts_Reader__typ, T, 0); + i = 0; + Texts_Read(&R, Texts_Reader__typ, &ch); + while (ch != 0x00) { + s[__X(i, 32)] = ch; + i += 1; + Texts_Read(&R, Texts_Reader__typ, &ch); + } + s[__X(i, 32)] = 0x00; + i = 0; + ch = s[0]; + while ((ch != 'D' && ch != 0x00)) { + i += 1; + ch = s[__X(i, 32)]; + } + if (ch == 'D') { + s[__X(i, 32)] = 'e'; + } + OPM_WriteString(s, 32); + } +} + +void OPM_WriteLn (void) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, 0x0a); +} + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F) +{ + Files_Rider R1; + CHAR buffer[4096]; + if (F != NIL) { + Files_Set(&R1, Files_Rider__typ, F, 0); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + while (4096 - R1.res > 0) { + Files_WriteBytes(&*R, R__typ, (void*)buffer, 4096, 4096 - R1.res); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + } + } +} + +void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len) +{ + OPM_FileName FName; + __COPY(moduleName, OPM_modName, 32); + OPM_HFile = Files_New((CHAR*)"", 1); + if (OPM_HFile != NIL) { + Files_Set(&OPM_R[0], Files_Rider__typ, OPM_HFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".c", 3); + OPM_BFile = Files_New(FName, 32); + if (OPM_BFile != NIL) { + Files_Set(&OPM_R[1], Files_Rider__typ, OPM_BFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".h", 3); + OPM_HIFile = Files_New(FName, 32); + if (OPM_HIFile != NIL) { + Files_Set(&OPM_R[2], Files_Rider__typ, OPM_HIFile, 0); + } else { + OPM_err(153); + } +} + +void OPM_CloseFiles (void) +{ + OPM_FileName FName; + INT16 res; + if (OPM_noerr) { + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWNum(Files_Pos(&OPM_R[1], Files_Rider__typ), 0); + OPM_LogWStr((CHAR*)" chars.", 8); + } + if (OPM_noerr) { + if (__STRCMP(OPM_modName, "SYSTEM") == 0) { + if (!__IN(10, OPM_Options, 32)) { + Files_Register(OPM_BFile); + } + } else if (!__IN(10, OPM_Options, 32)) { + OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); + Files_Register(OPM_HIFile); + Files_Register(OPM_BFile); + } else { + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".h", 3); + Files_Delete(FName, 32, &res); + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".sym", 5); + Files_Delete(FName, 32, &res); + Files_Register(OPM_BFile); + } + } + OPM_HFile = NIL; + OPM_BFile = NIL; + OPM_HIFile = NIL; + OPM_newSFile = NIL; + OPM_oldSFile = NIL; + Files_Set(&OPM_R[0], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[1], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[2], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_newSF, Files_Rider__typ, NIL, 0); + Files_Set(&OPM_oldSF, Files_Rider__typ, NIL, 0); +} + +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len) +{ + CHAR testpath[4096]; + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/lib/lib", 9, (void*)testpath, 4096); + Strings_Append((CHAR*)"voc", 4, (void*)testpath, 4096); + Strings_Append((CHAR*)"-O2.a", 6, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/include/Oberon.h", 20, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/sym/Files.sym", 17, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __DEL(s); + return 1; +} + +static void OPM_FindInstallDir (void) +{ + INT16 i; + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + Strings_Append((CHAR*)"/", 2, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)"voc", 4, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)".d", 3, (void*)OPM_InstallDir, 1024); + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + i = Strings_Length(OPM_InstallDir, 1024); + while ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] != '/')) { + i -= 1; + } + if ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] == '/')) { + OPM_InstallDir[__X(i - 1, 1024)] = 0x00; + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + } + __COPY("", OPM_InstallDir, 1024); +} + +static void EnumPtrs(void (*P)(void*)) +{ + __ENUMR(&OPM_inR, Texts_Reader__typ, 48, 1, P); + P(OPM_Log); + P(OPM_Errors); + __ENUMR(&OPM_oldSF, Files_Rider__typ, 20, 1, P); + __ENUMR(&OPM_newSF, Files_Rider__typ, 20, 1, P); + __ENUMR(OPM_R, Files_Rider__typ, 20, 3, P); + P(OPM_oldSFile); + P(OPM_newSFile); + P(OPM_HFile); + P(OPM_BFile); + P(OPM_HIFile); +} + + +export void *OPM__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(Texts); + __MODULE_IMPORT(VT100); + __REGMOD("OPM", EnumPtrs); + __REGCMD("CloseFiles", OPM_CloseFiles); + __REGCMD("CloseOldSym", OPM_CloseOldSym); + __REGCMD("InitOptions", OPM_InitOptions); + __REGCMD("LogWLn", OPM_LogWLn); + __REGCMD("RegisterNewSym", OPM_RegisterNewSym); + __REGCMD("WriteLn", OPM_WriteLn); +/* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; + OPM_FindInstallDir(); + OPM_hasComment = 0; + OPM_currentComment[0] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPM.h b/bootstrap/unix-48/OPM.h new file mode 100644 index 00000000..64c15a28 --- /dev/null +++ b/bootstrap/unix-48/OPM.h @@ -0,0 +1,76 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPM__h +#define OPM__h + +#include "SYSTEM.h" + + +import CHAR OPM_Model[10]; +import INT16 OPM_AddressSize, OPM_Alignment; +import UINT32 OPM_GlobalOptions, OPM_Options; +import INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +import INT64 OPM_MaxIndex; +import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +import BOOLEAN OPM_noerr; +import INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +import INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +import CHAR OPM_modName[32]; +import CHAR OPM_objname[64]; +import CHAR OPM_InstallDir[1024]; +import CHAR OPM_ResourceDir[1024]; + + +import void OPM_CloseFiles (void); +import void OPM_CloseOldSym (void); +import void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +import void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +import void OPM_FPrint (INT32 *fp, INT64 val); +import void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +import void OPM_FPrintReal (INT32 *fp, REAL val); +import void OPM_FPrintSet (INT32 *fp, UINT64 val); +import void OPM_Get (CHAR *ch); +import void OPM_GetComment (CHAR *text, ADDRESS text__len); +import void OPM_Init (BOOLEAN *done); +import void OPM_InitOptions (void); +import INT16 OPM_Integer (INT64 n); +import void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +import void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +import void OPM_LogW (CHAR ch); +import void OPM_LogWLn (void); +import void OPM_LogWNum (INT64 i, INT64 len); +import void OPM_LogWStr (CHAR *s, ADDRESS s__len); +import INT32 OPM_Longint (INT64 n); +import void OPM_Mark (INT16 n, INT32 pos); +import void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +import void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +import void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +import BOOLEAN OPM_OpenPar (void); +import void OPM_RegisterNewSym (void); +import INT64 OPM_SignedMaximum (INT32 bytecount); +import INT64 OPM_SignedMinimum (INT32 bytecount); +import void OPM_StoreComment (CHAR *text, ADDRESS text__len); +import void OPM_SymRCh (CHAR *ch); +import INT32 OPM_SymRInt (void); +import INT64 OPM_SymRInt64 (void); +import void OPM_SymRLReal (LONGREAL *lr); +import void OPM_SymRReal (REAL *r); +import void OPM_SymRSet (UINT64 *s); +import void OPM_SymWCh (CHAR ch); +import void OPM_SymWInt (INT64 i); +import void OPM_SymWLReal (LONGREAL lr); +import void OPM_SymWReal (REAL r); +import void OPM_SymWSet (UINT64 s); +import void OPM_Write (CHAR ch); +import void OPM_WriteHex (INT64 i); +import void OPM_WriteInt (INT64 i); +import void OPM_WriteLn (void); +import void OPM_WriteReal (LONGREAL r, CHAR suffx); +import void OPM_WriteString (CHAR *s, ADDRESS s__len); +import void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +import BOOLEAN OPM_eofSF (void); +import void OPM_err (INT16 n); +import void *OPM__init(void); + + +#endif // OPM diff --git a/bootstrap/unix-48/OPP.c b/bootstrap/unix-48/OPP.c new file mode 100644 index 00000000..ad4a370a --- /dev/null +++ b/bootstrap/unix-48/OPP.c @@ -0,0 +1,1881 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPB.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +struct OPP__1 { + INT32 low, high; +}; + +typedef + struct OPP__1 OPP_CaseTable[128]; + + +static INT8 OPP_sym, OPP_level; +static INT16 OPP_LoopLevel; +static OPT_Node OPP_TDinit, OPP_lastTDinit; +static INT16 OPP_nofFwdPtr; +static OPT_Struct OPP_FwdPtr[64]; + +export ADDRESS *OPP__1__typ; + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar); +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq); +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab); +static void OPP_CheckMark (INT8 *vis); +static void OPP_CheckSym (INT16 s); +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_); +static void OPP_ConstExpression (OPT_Node *x); +static void OPP_Element (OPT_Node *x); +static void OPP_Expression (OPT_Node *x); +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b); +static void OPP_Factor (OPT_Node *x); +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp); +export void OPP_Module (OPT_Node *prog, UINT32 opt); +static void OPP_PointerType (OPT_Struct *typ); +static void OPP_ProcedureDeclaration (OPT_Node *x); +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec); +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Sets (OPT_Node *x); +static void OPP_SimpleExpression (OPT_Node *x); +static void OPP_StandProcCall (OPT_Node *x); +static void OPP_StatSeq (OPT_Node *stat); +static void OPP_Term (OPT_Node *x); +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_err (INT16 n); +static void OPP_qualident (OPT_Object *id); +static void OPP_selector (OPT_Node *x); + + +static void OPP_err (INT16 n) +{ + OPM_err(n); +} + +static void OPP_CheckSym (INT16 s) +{ + if ((INT16)OPP_sym == s) { + OPS_Get(&OPP_sym); + } else { + OPM_err(s); + } +} + +static void OPP_qualident (OPT_Object *id) +{ + OPT_Object obj = NIL; + INT8 lev; + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if ((((OPP_sym == 18 && obj != NIL)) && obj->mode == 11)) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPT_FindImport(obj, &obj); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + obj = NIL; + } + } + if (obj == NIL) { + OPP_err(0); + obj = OPT_NewObj(); + obj->mode = 1; + obj->typ = OPT_undftyp; + obj->adr = 0; + } else { + lev = obj->mnolev; + if ((__IN(obj->mode, 0x06, 32) && lev != OPP_level)) { + obj->leaf = 0; + if (lev > 0) { + OPB_StaticLink(OPP_level - lev); + } + } + } + *id = obj; +} + +static void OPP_ConstExpression (OPT_Node *x) +{ + OPP_Expression(&*x); + if ((*x)->class != 7) { + OPP_err(50); + *x = OPB_NewIntConst(1); + } +} + +static void OPP_CheckMark (INT8 *vis) +{ + OPS_Get(&OPP_sym); + if (OPP_sym == 1 || OPP_sym == 7) { + if (OPP_level > 0) { + OPP_err(47); + } + if (OPP_sym == 1) { + *vis = 1; + } else { + *vis = 2; + } + OPS_Get(&OPP_sym); + } else { + *vis = 0; + } +} + +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_) +{ + OPT_Node x = NIL; + INT64 sf; + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + if (!OPT_SYSimported) { + OPP_err(135); + } + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + sf = x->conval->intval; + if (sf < 0 || sf > 1) { + OPP_err(220); + sf = 0; + } + } else { + OPP_err(51); + sf = 0; + } + *sysflag = OPM_Integer(sf); + OPP_CheckSym(23); + } else { + *sysflag = default_; + } +} + +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object fld = NIL, first = NIL, last = NIL, base = NIL; + OPT_Struct ftyp = NIL; + INT16 sysflag; + *typ = OPT_NewStr(13, 4); + (*typ)->BaseTyp = NIL; + OPP_CheckSysFlag(&sysflag, -1); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&base); + if ((base->mode == 5 && base->typ->comp == 4)) { + if (base->typ == *banned) { + OPP_err(58); + } else { + base->typ->pvused = 1; + (*typ)->BaseTyp = base->typ; + (*typ)->extlev = base->typ->extlev + 1; + (*typ)->sysflag = base->typ->sysflag; + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } + if (sysflag >= 0) { + (*typ)->sysflag = sysflag; + } + OPT_OpenScope(0, NIL); + first = NIL; + last = NIL; + for (;;) { + if (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + if ((*typ)->BaseTyp != NIL) { + OPT_FindField(OPS_name, (*typ)->BaseTyp, &fld); + if (fld != NIL) { + OPP_err(1); + } + } + OPT_Insert(OPS_name, &fld); + OPP_CheckMark(&fld->vis); + fld->mode = 4; + fld->link = NIL; + fld->typ = OPT_undftyp; + if (first == NIL) { + first = fld; + } + if (last == NIL) { + (*typ)->link = fld; + } else { + last->link = fld; + } + last = fld; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&ftyp, &*banned); + ftyp->pvused = 1; + if (ftyp->comp == 3) { + ftyp = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = ftyp; + first = first->link; + } + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + OPT_CloseScope(); +} + +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Node x = NIL; + INT64 n; + INT16 sysflag; + OPP_CheckSysFlag(&sysflag, 0); + if (OPP_sym == 25) { + *typ = OPT_NewStr(13, 3); + (*typ)->mno = 0; + (*typ)->sysflag = sysflag; + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + } else { + *typ = OPT_NewStr(13, 2); + (*typ)->sysflag = sysflag; + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + n = x->conval->intval; + if (n <= 0 || n > OPM_MaxIndex) { + OPP_err(63); + n = 1; + } + } else { + OPP_err(51); + n = 1; + } + (*typ)->n = OPM_Longint(n); + if (OPP_sym == 25) { + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + } else if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + if (OPP_sym != 25) { + OPP_ArrayType(&(*typ)->BaseTyp, &*banned); + } + } else { + OPP_err(35); + } + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(88); + } + } +} + +static void OPP_PointerType (OPT_Struct *typ) +{ + OPT_Object id = NIL; + *typ = OPT_NewStr(11, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + OPP_CheckSym(28); + if (OPP_sym == 38) { + OPT_Find(&id); + if (id == NIL) { + if (OPP_nofFwdPtr < 64) { + OPP_FwdPtr[__X(OPP_nofFwdPtr, 64)] = *typ; + OPP_nofFwdPtr += 1; + } else { + OPP_err(224); + } + (*typ)->link = OPT_NewObj(); + __COPY(OPS_name, (*typ)->link->name, 256); + (*typ)->BaseTyp = OPT_undftyp; + OPS_Get(&OPP_sym); + } else { + OPP_qualident(&id); + if (id->mode == 5) { + if (__IN(id->typ->comp, 0x1c, 32)) { + (*typ)->BaseTyp = id->typ; + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(52); + } + } + } else { + OPP_Type(&(*typ)->BaseTyp, &OPT_notyp); + if (!__IN((*typ)->BaseTyp->comp, 0x1c, 32)) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } +} + +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp) +{ + INT8 mode; + OPT_Object par = NIL, first = NIL, last = NIL, res = NIL; + OPT_Struct typ = NIL; + first = NIL; + last = *firstPar; + if (OPP_sym == 38 || OPP_sym == 60) { + for (;;) { + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + mode = 2; + } else { + mode = 1; + } + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &par); + OPS_Get(&OPP_sym); + par->mode = mode; + par->link = NIL; + if (first == NIL) { + first = par; + } + if (*firstPar == NIL) { + *firstPar = par; + } else { + last->link = par; + } + last = par; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else if (OPP_sym == 60) { + OPP_err(19); + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + if (((typ->comp == 2 || typ->comp == 4) && typ->strobj == NIL)) { + OPP_err(-309); + } + if (mode == 1) { + typ->pvused = 1; + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + } + OPP_CheckSym(22); + if (OPP_sym == 20) { + OPS_Get(&OPP_sym); + *resTyp = OPT_undftyp; + if (OPP_sym == 38) { + OPP_qualident(&res); + if (res->mode == 5) { + if (res->typ->form < 13) { + *resTyp = res->typ; + } else { + OPP_err(54); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + *resTyp = OPT_notyp; + } +} + +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object id = NIL; + *typ = OPT_undftyp; + if (OPP_sym < 30) { + OPP_err(12); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + if (id->mode == 5) { + if (id->typ == *banned) { + OPP_err(58); + } else { + *typ = id->typ; + } + } else { + OPP_err(52); + } + } else if (OPP_sym == 54) { + OPS_Get(&OPP_sym); + OPP_ArrayType(&*typ, &*banned); + } else if (OPP_sym == 55) { + OPS_Get(&OPP_sym); + OPP_RecordType(&*typ, &*banned); + OPB_Inittd(&OPP_TDinit, &OPP_lastTDinit, *typ); + OPP_CheckSym(41); + } else if (OPP_sym == 56) { + OPS_Get(&OPP_sym); + OPP_PointerType(&*typ); + } else if (OPP_sym == 61) { + OPS_Get(&OPP_sym); + *typ = OPT_NewStr(12, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPT_OpenScope(OPP_level, NIL); + OPP_FormalParameters(&(*typ)->link, &(*typ)->BaseTyp); + OPT_CloseScope(); + } else { + (*typ)->BaseTyp = OPT_notyp; + (*typ)->link = NIL; + } + } else { + OPP_err(12); + } + for (;;) { + if (((OPP_sym >= 39 && OPP_sym <= 42) || OPP_sym == 22) || OPP_sym == 64) { + break; + } + OPP_err(15); + if (OPP_sym == 38) { + break; + } + OPS_Get(&OPP_sym); + } +} + +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned) +{ + OPP_TypeDecl(&*typ, &*banned); + if (((((*typ)->form == 11 && (*typ)->BaseTyp == OPT_undftyp)) && (*typ)->strobj == NIL)) { + OPP_err(0); + } +} + +static void OPP_selector (OPT_Node *x) +{ + OPT_Object obj = NIL, proc = NIL; + OPT_Node y = NIL; + OPT_Struct typ = NIL; + OPS_Name name; + for (;;) { + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + for (;;) { + if (((*x)->typ != NIL && (*x)->typ->form == 11)) { + OPB_DeRef(&*x); + } + OPP_Expression(&y); + OPB_Index(&*x, y); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(23); + } else if (OPP_sym == 18) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __MOVE(OPS_name, name, 256); + OPS_Get(&OPP_sym); + if ((*x)->typ != NIL) { + if ((*x)->typ->form == 11) { + OPB_DeRef(&*x); + } + if ((*x)->typ->comp == 4) { + OPT_FindField(name, (*x)->typ, &obj); + OPB_Field(&*x, obj); + if ((obj != NIL && obj->mode == 13)) { + if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + y = (*x)->left; + if (y->class == 3) { + y = y->left; + } + if (y->obj != NIL) { + proc = OPT_topScope; + while ((proc->link != NIL && proc->link->mode != 13)) { + proc = proc->left; + } + if (proc->link == NIL || proc->link->link != y->obj) { + OPP_err(75); + } + typ = y->obj->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField((*x)->obj->name, typ->BaseTyp, &proc); + if (proc != NIL) { + (*x)->subcl = 1; + } else { + OPP_err(74); + } + } else { + OPP_err(75); + } + } + if ((obj->typ != OPT_notyp && OPP_sym != 30)) { + OPP_err(30); + } + } + } else { + OPP_err(53); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + OPB_DeRef(&*x); + } else if ((((((OPP_sym == 30 && (*x)->class < 7)) && (*x)->typ->form != 12)) && ((*x)->obj == NIL || (*x)->obj->mode != 13))) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 1); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } else { + break; + } + } +} + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar) +{ + OPT_Node apar = NIL, last = NIL; + *aparlist = NIL; + last = NIL; + if (OPP_sym != 22) { + for (;;) { + OPP_Expression(&apar); + if (fpar != NIL) { + OPB_Param(apar, fpar); + OPB_Link(&*aparlist, &last, apar); + fpar = fpar->link; + } else { + OPP_err(64); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + } + if (fpar != NIL) { + OPP_err(65); + } +} + +static void OPP_StandProcCall (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 m; + INT16 n; + m = __SHORT(__SHORT((*x)->obj->adr, 32768), 128); + n = 0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym != 22) { + for (;;) { + if (n == 0) { + OPP_Expression(&*x); + OPB_StPar0(&*x, m); + n = 1; + } else if (n == 1) { + OPP_Expression(&y); + OPB_StPar1(&*x, y, m); + n = 2; + } else { + OPP_Expression(&y); + OPB_StParN(&*x, y, m, n); + n += 1; + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(22); + } else { + OPS_Get(&OPP_sym); + } + OPB_StFct(&*x, m, n); + } else { + OPP_err(30); + } + if ((OPP_level > 0 && (m == 1 || m == 30))) { + OPT_topScope->link->leaf = 0; + } +} + +static void OPP_Element (OPT_Node *x) +{ + OPT_Node y = NIL; + OPP_Expression(&*x); + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_SetRange(&*x, y); + } else { + OPB_SetElem(&*x); + } +} + +static void OPP_Sets (OPT_Node *x) +{ + OPT_Node y = NIL; + if (OPP_sym != 24) { + OPP_Element(&*x); + for (;;) { + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + OPP_Element(&y); + OPB_Op(6, &*x, y); + } + } else { + *x = OPB_EmptySet(); + } + OPP_CheckSym(24); +} + +static void OPP_Factor (OPT_Node *x) +{ + OPT_Object fpar = NIL, id = NIL; + OPT_Node apar = NIL; + if (OPP_sym < 30) { + OPP_err(13); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + *x = OPB_NewLeaf(id); + OPP_selector(&*x); + if (((*x)->class == 9 && (*x)->obj->mode == 8)) { + OPP_StandProcCall(&*x); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPB_PrepCall(&*x, &fpar); + OPP_ActualParameters(&apar, fpar); + OPB_Call(&*x, apar, fpar); + OPP_CheckSym(22); + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + } else if (OPP_sym == 35) { + switch (OPS_numtyp) { + case 1: + *x = OPB_NewIntConst(OPS_intval); + (*x)->typ = OPT_chartyp; + break; + case 2: + *x = OPB_NewIntConst(OPS_intval); + break; + case 3: + *x = OPB_NewRealConst(OPS_realval, OPT_realtyp); + break; + case 4: + *x = OPB_NewRealConst(OPS_lrlval, OPT_lrltyp); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPP.Factor, OPS.numtyp = ", 44); + OPM_LogWNum(OPS_numtyp, 0); + OPM_LogWLn(); + break; + } + OPS_Get(&OPP_sym); + } else if (OPP_sym == 37) { + *x = OPB_NewString(OPS_str, OPS_intval); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 36) { + *x = OPB_Nil(); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + OPP_err(30); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 32) { + OPS_Get(&OPP_sym); + OPP_Sets(&*x); + } else if (OPP_sym == 33) { + OPS_Get(&OPP_sym); + OPP_Factor(&*x); + OPB_MOp(33, &*x); + } else { + OPP_err(13); + OPS_Get(&OPP_sym); + *x = NIL; + } + if (*x == NIL) { + *x = OPB_NewIntConst(1); + (*x)->typ = OPT_undftyp; + } +} + +static void OPP_Term (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 mulop; + OPP_Factor(&*x); + while ((1 <= OPP_sym && OPP_sym <= 5)) { + mulop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Factor(&y); + OPB_Op(mulop, &*x, y); + } +} + +static void OPP_SimpleExpression (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 addop; + if (OPP_sym == 7) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(7, &*x); + } else if (OPP_sym == 6) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(6, &*x); + } else { + OPP_Term(&*x); + } + while ((6 <= OPP_sym && OPP_sym <= 8)) { + addop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Term(&y); + OPB_Op(addop, &*x, y); + } +} + +static void OPP_Expression (OPT_Node *x) +{ + OPT_Node y = NIL; + OPT_Object obj = NIL; + INT8 relation; + OPP_SimpleExpression(&*x); + if ((9 <= OPP_sym && OPP_sym <= 14)) { + relation = OPP_sym; + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_Op(relation, &*x, y); + } else if (OPP_sym == 15) { + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_In(&*x, y); + } else if (OPP_sym == 16) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 0); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } +} + +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec) +{ + OPT_Object obj = NIL; + *typ = OPT_undftyp; + *rec = NIL; + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + *mode = 2; + } else { + *mode = 1; + } + __MOVE(OPS_name, name, 256); + OPP_CheckSym(38); + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if (obj == NIL) { + OPP_err(0); + } else if (obj->mode != 5) { + OPP_err(72); + } else { + *typ = obj->typ; + *rec = *typ; + if ((*rec)->form == 11) { + *rec = (*rec)->BaseTyp; + } + if (!((((*mode == 1 && (*typ)->form == 11)) && (*rec)->comp == 4) || (*mode == 2 && (*typ)->comp == 4))) { + OPP_err(70); + *rec = NIL; + } + if ((*rec != NIL && (*rec)->mno != OPP_level)) { + OPP_err(72); + *rec = NIL; + } + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + if (*rec == NIL) { + *rec = OPT_NewStr(13, 4); + (*rec)->BaseTyp = NIL; + } +} + +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b) +{ + if ((b->form == 11 && x->form == 11)) { + b = b->BaseTyp; + x = x->BaseTyp; + } + if ((b->comp == 4 && x->comp == 4)) { + do { + x = x->BaseTyp; + } while (!(x == NIL || x == b)); + } + return x == b; +} + +static struct ProcedureDeclaration__16 { + OPT_Node *x; + OPT_Object *proc, *fwd; + OPS_Name *name; + INT8 *mode, *vis; + BOOLEAN *forward; + struct ProcedureDeclaration__16 *lnk; +} *ProcedureDeclaration__16_s; + +static void Body__17 (void); +static void GetCode__19 (void); +static void GetParams__21 (void); +static void TProcDecl__23 (void); + +static void GetCode__19 (void) +{ + OPT_ConstExt ext = NIL; + INT16 n; + INT64 c; + ext = OPT_NewExt(); + (*ProcedureDeclaration__16_s->proc)->conval->ext = ext; + n = 0; + if (OPP_sym == 37) { + while (OPS_str[__X(n, 256)] != 0x00) { + (*ext)[__X(n + 1, 256)] = OPS_str[__X(n, 256)]; + n += 1; + } + (*ext)[0] = __CHR(n); + OPS_Get(&OPP_sym); + } else { + for (;;) { + if (OPP_sym == 35) { + c = OPS_intval; + n += 1; + if ((c < 0 || c > 255) || n == 256) { + OPP_err(64); + c = 1; + n = 1; + } + OPS_Get(&OPP_sym); + (*ext)[__X(n, 256)] = __CHR(c); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35) { + OPP_err(19); + } else { + (*ext)[0] = __CHR(n); + break; + } + } + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); +} + +static void GetParams__21 (void) +{ + (*ProcedureDeclaration__16_s->proc)->vis = *ProcedureDeclaration__16_s->vis; + (*ProcedureDeclaration__16_s->proc)->mode = *ProcedureDeclaration__16_s->mode; + (*ProcedureDeclaration__16_s->proc)->typ = OPT_notyp; + (*ProcedureDeclaration__16_s->proc)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->proc)->conval->setval = 0x0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_FormalParameters(&(*ProcedureDeclaration__16_s->proc)->link, &(*ProcedureDeclaration__16_s->proc)->typ); + } + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link, (*ProcedureDeclaration__16_s->fwd)->link, 1); + if ((*ProcedureDeclaration__16_s->proc)->typ != (*ProcedureDeclaration__16_s->fwd)->typ) { + OPP_err(117); + } + *ProcedureDeclaration__16_s->proc = *ProcedureDeclaration__16_s->fwd; + OPT_topScope = (*ProcedureDeclaration__16_s->proc)->scope; + if (*ProcedureDeclaration__16_s->mode == 10) { + (*ProcedureDeclaration__16_s->proc)->mode = 10; + } + } +} + +static void Body__17 (void) +{ + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + c = OPM_errpos; + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); + OPP_CheckSym(39); + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, *ProcedureDeclaration__16_s->proc); + *ProcedureDeclaration__16_s->x = procdec; + (*ProcedureDeclaration__16_s->x)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->x)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, (*ProcedureDeclaration__16_s->proc)->name) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } +} + +static void TProcDecl__23 (void) +{ + OPT_Object baseProc = NIL; + OPT_Struct objTyp = NIL, recTyp = NIL; + INT8 objMode; + OPS_Name objName; + OPS_Get(&OPP_sym); + *ProcedureDeclaration__16_s->mode = 13; + if (OPP_level > 0) { + OPP_err(73); + } + OPP_Receiver(&objMode, objName, &objTyp, &recTyp); + if (OPP_sym == 38) { + __MOVE(OPS_name, *ProcedureDeclaration__16_s->name, 256); + OPP_CheckMark(&*ProcedureDeclaration__16_s->vis); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp, &*ProcedureDeclaration__16_s->fwd); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp->BaseTyp, &baseProc); + if ((baseProc != NIL && baseProc->mode != 13)) { + baseProc = NIL; + } + if (*ProcedureDeclaration__16_s->fwd == baseProc) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mnolev != OPP_level)) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mode == 13)) && !__IN(1, (*ProcedureDeclaration__16_s->fwd)->conval->setval, 64))) { + *ProcedureDeclaration__16_s->proc = OPT_NewObj(); + (*ProcedureDeclaration__16_s->proc)->leaf = 1; + if ((*ProcedureDeclaration__16_s->fwd)->vis != *ProcedureDeclaration__16_s->vis) { + OPP_err(118); + } + } else { + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPP_err(1); + *ProcedureDeclaration__16_s->fwd = NIL; + } + OPT_OpenScope(0, NIL); + OPT_topScope->right = recTyp->link; + OPT_Insert(*ProcedureDeclaration__16_s->name, &*ProcedureDeclaration__16_s->proc); + recTyp->link = OPT_topScope->right; + OPT_CloseScope(); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, *ProcedureDeclaration__16_s->proc); + OPT_Insert(objName, &(*ProcedureDeclaration__16_s->proc)->link); + (*ProcedureDeclaration__16_s->proc)->link->mode = objMode; + (*ProcedureDeclaration__16_s->proc)->link->typ = objTyp; + GetParams__21(); + if (baseProc != NIL) { + if (objMode != baseProc->link->mode || !OPP_Extends(objTyp, baseProc->link->typ)) { + OPP_err(115); + } + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link->link, baseProc->link->link, 0); + if ((*ProcedureDeclaration__16_s->proc)->typ != baseProc->typ) { + OPP_err(117); + } + if ((((((baseProc->vis == 1 && (*ProcedureDeclaration__16_s->proc)->vis == 0)) && recTyp->strobj != NIL)) && recTyp->strobj->vis == 1)) { + OPP_err(109); + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(2,64); + } + if (!*ProcedureDeclaration__16_s->forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } +} + +static void OPP_ProcedureDeclaration (OPT_Node *x) +{ + OPT_Object proc = NIL, fwd = NIL; + OPS_Name name; + INT8 mode, vis; + BOOLEAN forward; + struct ProcedureDeclaration__16 _s; + _s.x = x; + _s.proc = &proc; + _s.fwd = &fwd; + _s.name = (void*)name; + _s.mode = &mode; + _s.vis = &vis; + _s.forward = &forward; + _s.lnk = ProcedureDeclaration__16_s; + ProcedureDeclaration__16_s = &_s; + proc = NIL; + forward = 0; + *x = NIL; + mode = 6; + if ((OPP_sym != 38 && OPP_sym != 30)) { + if (OPP_sym == 1) { + } else if (OPP_sym == 17) { + forward = 1; + } else if (OPP_sym == 6) { + mode = 10; + } else if (OPP_sym == 7) { + mode = 9; + } else { + OPP_err(38); + } + if ((__IN(mode, 0x0600, 32) && !OPT_SYSimported)) { + OPP_err(135); + } + OPS_Get(&OPP_sym); + } + if (OPP_sym == 30) { + TProcDecl__23(); + } else if (OPP_sym == 38) { + OPT_Find(&fwd); + __MOVE(OPS_name, name, 256); + OPP_CheckMark(&vis); + if ((vis != 0 && mode == 6)) { + mode = 7; + } + if ((fwd != NIL && (fwd->mnolev != OPP_level || fwd->mode == 8))) { + fwd = NIL; + } + if ((((fwd != NIL && __IN(fwd->mode, 0xc0, 32))) && !__IN(1, fwd->conval->setval, 64))) { + proc = OPT_NewObj(); + proc->leaf = 1; + if (fwd->vis != vis) { + OPP_err(118); + } + } else { + if (fwd != NIL) { + OPP_err(1); + fwd = NIL; + } + OPT_Insert(name, &proc); + } + if ((mode != 6 && OPP_level > 0)) { + OPP_err(73); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, proc); + proc->link = NIL; + GetParams__21(); + if (mode == 9) { + GetCode__19(); + } else if (!forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } + ProcedureDeclaration__16_s = _s.lnk; +} + +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab) +{ + OPT_Node x = NIL, y = NIL, lastlab = NIL; + INT16 i, f; + INT32 xval, yval; + *lab = NIL; + lastlab = NIL; + for (;;) { + OPP_ConstExpression(&x); + f = x->typ->form; + if (__IN(f, 0x18, 32)) { + xval = OPM_Longint(x->conval->intval); + } else { + OPP_err(61); + xval = 1; + } + if (f == 4) { + if (!(LabelTyp->form == 4) || LabelTyp->size < x->typ->size) { + OPP_err(60); + } + } else if ((INT16)LabelTyp->form != f) { + OPP_err(60); + } + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&y); + yval = OPM_Longint(y->conval->intval); + if (((INT16)y->typ->form != f && !((f == 4 && y->typ->form == 4)))) { + OPP_err(60); + } + if (yval < xval) { + OPP_err(63); + yval = xval; + } + } else { + yval = xval; + } + x->conval->intval2 = yval; + i = *n; + if (i < 128) { + for (;;) { + if (i == 0) { + break; + } + if (tab[__X(i - 1, 128)].low <= yval) { + if (tab[__X(i - 1, 128)].high >= xval) { + OPP_err(62); + } + break; + } + tab[__X(i, 128)] = tab[__X(i - 1, 128)]; + i -= 1; + } + tab[__X(i, 128)].low = xval; + tab[__X(i, 128)].high = yval; + *n += 1; + } else { + OPP_err(213); + } + OPB_Link(&*lab, &lastlab, x); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35 || OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } +} + +static struct StatSeq__30 { + INT32 *pos; + struct StatSeq__30 *lnk; +} *StatSeq__30_s; + +static void CasePart__31 (OPT_Node *x); +static void CheckBool__33 (OPT_Node *x); +static void SetPos__35 (OPT_Node x); + +static void CasePart__31 (OPT_Node *x) +{ + INT16 n; + INT32 low, high; + BOOLEAN e; + OPP_CaseTable tab; + OPT_Node cases = NIL, lab = NIL, y = NIL, lastcase = NIL; + OPP_Expression(&*x); + *StatSeq__30_s->pos = OPM_errpos; + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + } else if (!__IN((*x)->typ->form, 0x18, 32)) { + OPP_err(125); + } + OPP_CheckSym(25); + cases = NIL; + lastcase = NIL; + n = 0; + for (;;) { + if (OPP_sym < 40) { + OPP_CaseLabelList(&lab, (*x)->typ, &n, tab); + OPP_CheckSym(20); + OPP_StatSeq(&y); + OPB_Construct(17, &lab, y); + OPB_Link(&cases, &lastcase, lab); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + if (n > 0) { + low = tab[0].low; + high = tab[__X(n - 1, 128)].high; + if (high - low > 512) { + OPP_err(209); + } + } else { + low = 1; + high = 0; + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + OPM_Mark(-307, OPM_curpos); + } + OPB_Construct(16, &cases, y); + OPB_Construct(21, &*x, cases); + cases->conval = OPT_NewConst(); + cases->conval->intval = low; + cases->conval->intval2 = high; + if (e) { + cases->conval->setval = 0x02; + } else { + cases->conval->setval = 0x0; + } +} + +static void SetPos__35 (OPT_Node x) +{ + x->conval = OPT_NewConst(); + x->conval->intval = *StatSeq__30_s->pos; +} + +static void CheckBool__33 (OPT_Node *x) +{ + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + *x = OPB_NewBoolConst(0); + } else if ((*x)->typ->form != 2) { + OPP_err(120); + *x = OPB_NewBoolConst(0); + } + *StatSeq__30_s->pos = OPM_errpos; +} + +static void OPP_StatSeq (OPT_Node *stat) +{ + OPT_Object fpar = NIL, id = NIL, t = NIL, obj = NIL; + OPT_Struct idtyp = NIL; + BOOLEAN e; + OPT_Node s = NIL, x = NIL, y = NIL, z = NIL, apar = NIL, last = NIL, lastif = NIL; + INT32 pos; + OPS_Name name; + struct StatSeq__30 _s; + _s.pos = &pos; + _s.lnk = StatSeq__30_s; + StatSeq__30_s = &_s; + *stat = NIL; + last = NIL; + for (;;) { + x = NIL; + if (OPP_sym < 38) { + OPP_err(14); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 38)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + x = OPB_NewLeaf(id); + OPP_selector(&x); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if (OPP_sym == 9) { + OPP_err(34); + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if ((x->class == 9 && x->obj->mode == 8)) { + OPP_StandProcCall(&x); + if ((x != NIL && x->typ != OPT_notyp)) { + OPP_err(55); + } + } else { + OPB_PrepCall(&x, &fpar); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_ActualParameters(&apar, fpar); + OPP_CheckSym(22); + } else { + apar = NIL; + if (fpar != NIL) { + OPP_err(65); + } + } + OPB_Call(&x, apar, fpar); + if (x->typ != OPT_notyp) { + OPP_err(55); + } + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + pos = OPM_errpos; + } else if (OPP_sym == 45) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(26); + OPP_StatSeq(&y); + OPB_Construct(15, &x, y); + SetPos__35(x); + lastif = x; + while (OPP_sym == 43) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + OPP_CheckSym(26); + OPP_StatSeq(&z); + OPB_Construct(15, &y, z); + SetPos__35(y); + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 42) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + } + OPB_Construct(20, &x, y); + OPP_CheckSym(41); + OPB_OptIf(&x); + pos = OPM_errpos; + } else if (OPP_sym == 46) { + OPS_Get(&OPP_sym); + CasePart__31(&x); + OPP_CheckSym(41); + } else if (OPP_sym == 47) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(27); + OPP_StatSeq(&y); + OPB_Construct(22, &x, y); + OPP_CheckSym(41); + } else if (OPP_sym == 48) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&x); + if (OPP_sym == 44) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + } else { + OPP_err(44); + } + OPB_Construct(23, &x, y); + } else if (OPP_sym == 49) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&id); + if (!(id->typ->form == 4)) { + OPP_err(68); + } + OPP_CheckSym(34); + OPP_Expression(&y); + pos = OPM_errpos; + x = OPB_NewLeaf(id); + OPB_Assign(&x, y); + SetPos__35(x); + OPP_CheckSym(28); + OPP_Expression(&y); + pos = OPM_errpos; + if (y->class != 7) { + __MOVE("@@", name, 3); + OPT_Insert(name, &t); + __MOVE("@for", t->name, 5); + t->mode = 1; + t->typ = x->left->typ; + obj = OPT_topScope->scope; + if (obj == NIL) { + OPT_topScope->scope = t; + } else { + while (obj->link != NIL) { + obj = obj->link; + } + obj->link = t; + } + z = OPB_NewLeaf(t); + OPB_Assign(&z, y); + SetPos__35(z); + OPB_Link(&*stat, &last, z); + y = OPB_NewLeaf(t); + } else if (!(y->typ->form == 4) || y->typ->size > x->left->typ->size) { + OPP_err(113); + } + OPB_Link(&*stat, &last, x); + if (OPP_sym == 29) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&z); + } else { + z = OPB_NewIntConst(1); + } + pos = OPM_errpos; + x = OPB_NewLeaf(id); + if (z->conval->intval > 0) { + OPB_Op(12, &x, y); + } else if (z->conval->intval < 0) { + OPB_Op(14, &x, y); + } else { + OPP_err(63); + OPB_Op(14, &x, y); + } + OPP_CheckSym(27); + OPP_StatSeq(&s); + y = OPB_NewLeaf(id); + OPB_StPar1(&y, z, 13); + SetPos__35(y); + if (s == NIL) { + s = y; + } else { + z = s; + while (z->link != NIL) { + z = z->link; + } + z->link = y; + } + OPP_CheckSym(41); + OPB_Construct(22, &x, s); + } else { + OPP_err(38); + } + } else if (OPP_sym == 50) { + OPS_Get(&OPP_sym); + OPP_LoopLevel += 1; + OPP_StatSeq(&x); + OPP_LoopLevel -= 1; + OPB_Construct(24, &x, NIL); + OPP_CheckSym(41); + pos = OPM_errpos; + } else if (OPP_sym == 51) { + OPS_Get(&OPP_sym); + idtyp = NIL; + x = NIL; + for (;;) { + if (OPP_sym == 38) { + OPP_qualident(&id); + y = OPB_NewLeaf(id); + if ((((id != NIL && id->typ->form == 11)) && (id->mode == 2 || !id->leaf))) { + OPP_err(245); + } + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPP_qualident(&t); + if (t->mode == 5) { + if (id != NIL) { + idtyp = id->typ; + OPB_TypTest(&y, t, 0); + id->typ = t->typ; + } else { + OPP_err(130); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + OPP_err(38); + } + pos = OPM_errpos; + OPP_CheckSym(27); + OPP_StatSeq(&s); + OPB_Construct(15, &y, s); + SetPos__35(y); + if (idtyp != NIL) { + id->typ = idtyp; + idtyp = NIL; + } + if (x == NIL) { + x = y; + lastif = x; + } else { + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&s); + } else { + s = NIL; + } + OPB_Construct(27, &x, s); + OPP_CheckSym(41); + if (e) { + x->subcl = 1; + } + } else if (OPP_sym == 52) { + OPS_Get(&OPP_sym); + if (OPP_LoopLevel == 0) { + OPP_err(46); + } + OPB_Construct(25, &x, NIL); + pos = OPM_errpos; + } else if (OPP_sym == 53) { + OPS_Get(&OPP_sym); + if (OPP_sym < 39) { + OPP_Expression(&x); + } + if (OPP_level > 0) { + OPB_Return(&x, OPT_topScope->link); + } else { + OPB_Return(&x, NIL); + } + pos = OPM_errpos; + } + if (x != NIL) { + SetPos__35(x); + OPB_Link(&*stat, &last, x); + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym <= 38 || (45 <= OPP_sym && OPP_sym <= 53)) { + OPP_err(39); + } else { + break; + } + } + StatSeq__30_s = _s.lnk; +} + +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq) +{ + OPT_Struct typ = NIL; + OPT_Object obj = NIL, first = NIL, last = NIL; + OPT_Node x = NIL, lastdec = NIL; + INT16 i; + first = NIL; + last = NIL; + OPP_nofFwdPtr = 0; + for (;;) { + if (OPP_sym == 58) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->typ = OPT_sinttyp; + obj->mode = 1; + if (OPP_sym == 9) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else if (OPP_sym == 34) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else { + OPP_err(9); + x = OPB_NewIntConst(1); + } + obj->mode = 3; + obj->typ = x->typ; + obj->conval = x->conval; + OPP_CheckSym(39); + } + } + if (OPP_sym == 59) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + obj->mode = 5; + obj->typ = OPT_undftyp; + OPP_CheckMark(&obj->vis); + if (OPP_sym == 9) { + if (((((((((__STRCMP(obj->name, "SHORTINT") == 0 || __STRCMP(obj->name, "INTEGER") == 0) || __STRCMP(obj->name, "LONGINT") == 0) || __STRCMP(obj->name, "HUGEINT") == 0) || __STRCMP(obj->name, "REAL") == 0) || __STRCMP(obj->name, "LONGREAL") == 0) || __STRCMP(obj->name, "SET") == 0) || __STRCMP(obj->name, "CHAR") == 0) || __STRCMP(obj->name, "TRUE") == 0) || __STRCMP(obj->name, "FALSE") == 0) { + OPM_Mark(-310, OPM_curpos); + } + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else if (OPP_sym == 34 || OPP_sym == 20) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else { + OPP_err(9); + } + if (obj->typ->strobj == NIL) { + obj->typ->strobj = obj; + } + if (__IN(obj->typ->comp, 0x1c, 32)) { + i = 0; + while (i < OPP_nofFwdPtr) { + typ = OPP_FwdPtr[__X(i, 64)]; + i += 1; + if (__STRCMP(typ->link->name, obj->name) == 0) { + typ->BaseTyp = obj->typ; + typ->link->name[0] = 0x00; + } + } + } + OPP_CheckSym(39); + } + } + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->mode = 1; + obj->link = NIL; + obj->leaf = obj->vis == 0; + obj->typ = OPT_undftyp; + if (first == NIL) { + first = obj; + } + if (last == NIL) { + OPT_topScope->scope = obj; + } else { + last->link = obj; + } + last = obj; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + typ->pvused = 1; + if (typ->comp == 3) { + typ = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + OPP_CheckSym(39); + } + } + if (OPP_sym < 58 || OPP_sym > 60) { + break; + } + } + i = 0; + while (i < OPP_nofFwdPtr) { + if (OPP_FwdPtr[__X(i, 64)]->link->name[0] != 0x00) { + OPP_err(128); + } + OPP_FwdPtr[__X(i, 64)] = NIL; + i += 1; + } + OPT_topScope->adr = OPM_errpos; + *procdec = NIL; + lastdec = NIL; + while (OPP_sym == 61) { + OPS_Get(&OPP_sym); + OPP_ProcedureDeclaration(&x); + if (x != NIL) { + if (lastdec == NIL) { + *procdec = x; + } else { + lastdec->link = x; + } + lastdec = x; + } + OPP_CheckSym(39); + } + if (OPP_sym == 57) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&*statseq); + } else { + *statseq = NIL; + } + if ((OPP_level == 0 && OPP_TDinit != NIL)) { + OPP_lastTDinit->link = *statseq; + *statseq = OPP_TDinit; + } + OPP_CheckSym(41); +} + +void OPP_Module (OPT_Node *prog, UINT32 opt) +{ + OPS_Name impName, aliasName; + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + BOOLEAN done; + OPS_Init(); + OPP_LoopLevel = 0; + OPP_level = 0; + OPS_Get(&OPP_sym); + if (OPP_sym == 63) { + OPS_Get(&OPP_sym); + } else { + OPP_err(16); + } + if (OPP_sym == 38) { + OPM_LogCompiling(OPS_name, 256); + OPT_Init(OPS_name, opt); + OPS_Get(&OPP_sym); + OPP_CheckSym(39); + if (OPP_sym == 62) { + OPS_Get(&OPP_sym); + for (;;) { + if (OPP_sym == 38) { + __COPY(OPS_name, aliasName, 256); + __COPY(aliasName, impName, 256); + OPS_Get(&OPP_sym); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __COPY(OPS_name, impName, 256); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + } + OPT_Import(aliasName, impName, &done); + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(39); + } + if (OPM_noerr) { + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; + c = OPM_errpos; + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, NIL); + *prog = procdec; + (*prog)->conval = OPT_NewConst(); + (*prog)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, OPT_SelfName) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + if (OPP_sym != 18) { + OPP_err(18); + } + } + } else { + OPP_err(38); + } + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPP_TDinit); + P(OPP_lastTDinit); + __ENUMP(OPP_FwdPtr, 64, P); +} + +__TDESC(OPP__1, 1, 0) = {__TDFLDS("", 8), {-4}}; + +export void *OPP__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPP", EnumPtrs); + __INITYP(OPP__1, OPP__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPP.h b/bootstrap/unix-48/OPP.h new file mode 100644 index 00000000..3d8cefe8 --- /dev/null +++ b/bootstrap/unix-48/OPP.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPP__h +#define OPP__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPP_Module (OPT_Node *prog, UINT32 opt); +import void *OPP__init(void); + + +#endif // OPP diff --git a/bootstrap/unix-48/OPS.c b/bootstrap/unix-48/OPS.c new file mode 100644 index 00000000..a25a2c12 --- /dev/null +++ b/bootstrap/unix-48/OPS.c @@ -0,0 +1,666 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +export OPS_Name OPS_name; +export OPS_String OPS_str; +export INT16 OPS_numtyp; +export INT64 OPS_intval; +export REAL OPS_realval; +export LONGREAL OPS_lrlval; +static CHAR OPS_ch; + + +export void OPS_Get (INT8 *sym); +static void OPS_Identifier (INT8 *sym); +export void OPS_Init (void); +static void OPS_Number (void); +static void OPS_Str (INT8 *sym); +static void OPS_err (INT16 n); + + +static void OPS_err (INT16 n) +{ + OPM_err(n); +} + +static void OPS_Str (INT8 *sym) +{ + INT16 i; + CHAR och; + i = 0; + och = OPS_ch; + for (;;) { + OPM_Get(&OPS_ch); + if (OPS_ch == och) { + break; + } + if (OPS_ch < ' ') { + OPS_err(3); + break; + } + if (i == 255) { + OPS_err(241); + break; + } + OPS_str[__X(i, 256)] = OPS_ch; + i += 1; + } + OPM_Get(&OPS_ch); + OPS_str[__X(i, 256)] = 0x00; + OPS_intval = i + 1; + if (OPS_intval == 2) { + *sym = 35; + OPS_numtyp = 1; + OPS_intval = (INT16)OPS_str[0]; + } else { + *sym = 37; + } +} + +static void OPS_Identifier (INT8 *sym) +{ + INT16 i; + i = 0; + do { + OPS_name[__X(i, 256)] = OPS_ch; + i += 1; + OPM_Get(&OPS_ch); + } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256)); + if (i == 256) { + OPS_err(240); + i -= 1; + } + OPS_name[__X(i, 256)] = 0x00; + *sym = 38; +} + +static struct Number__6 { + struct Number__6 *lnk; +} *Number__6_s; + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex); +static LONGREAL Ten__9 (INT16 e); + +static LONGREAL Ten__9 (INT16 e) +{ + LONGREAL x, p; + x = (LONGREAL)1; + p = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + x = x * p; + } + e = __ASHR(e, 1); + if (e > 0) { + p = p * p; + } + } + return x; +} + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex) +{ + if (ch <= '9') { + return (INT16)ch - 48; + } else if (hex) { + return ((INT16)ch - 65) + 10; + } else { + OPS_err(2); + return 0; + } + __RETCHK; +} + +static void OPS_Number (void) +{ + INT16 i, m, n, d, e; + CHAR dig[24]; + LONGREAL f; + CHAR expCh; + BOOLEAN neg; + struct Number__6 _s; + _s.lnk = Number__6_s; + Number__6_s = &_s; + i = 0; + m = 0; + n = 0; + d = 0; + for (;;) { + if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) { + if (m > 0 || OPS_ch != '0') { + if (n < 24) { + dig[__X(n, 24)] = OPS_ch; + n += 1; + } + m += 1; + } + OPM_Get(&OPS_ch); + i += 1; + } else if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPS_ch = 0x7f; + break; + } else if (d == 0) { + d = i; + } else { + OPS_err(2); + } + } else { + break; + } + } + if (d == 0) { + if (n == m) { + OPS_intval = 0; + i = 0; + if (OPS_ch == 'X') { + OPM_Get(&OPS_ch); + OPS_numtyp = 1; + if (n <= 2) { + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else if (OPS_ch == 'H') { + OPM_Get(&OPS_ch); + OPS_numtyp = 2; + if (n <= 16) { + if ((n == 16 && dig[0] > '7')) { + OPS_intval = -1; + } + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 2; + while (i < n) { + d = Ord__7(dig[__X(i, 24)], 0); + i += 1; + if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (INT64)d; + } else { + OPS_err(203); + } + } + } + } else { + OPS_err(203); + } + } else { + f = (LONGREAL)0; + e = 0; + expCh = 'E'; + while (n > 0) { + n -= 1; + f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10; + } + if (OPS_ch == 'E' || OPS_ch == 'D') { + expCh = OPS_ch; + OPM_Get(&OPS_ch); + neg = 0; + if (OPS_ch == '-') { + neg = 1; + OPM_Get(&OPS_ch); + } else if (OPS_ch == '+') { + OPM_Get(&OPS_ch); + } + if (('0' <= OPS_ch && OPS_ch <= '9')) { + do { + n = Ord__7(OPS_ch, 0); + OPM_Get(&OPS_ch); + if (e <= __DIV(32767 - n, 10)) { + e = e * 10 + n; + } else { + OPS_err(203); + } + } while (!(OPS_ch < '0' || '9' < OPS_ch)); + if (neg) { + e = -e; + } + } else { + OPS_err(2); + } + } + e -= (i - d) - m; + if (expCh == 'E') { + OPS_numtyp = 3; + if ((-37 < e && e <= 38)) { + if (e < 0) { + OPS_realval = (f / (LONGREAL)Ten__9(-e)); + } else { + OPS_realval = (f * Ten__9(e)); + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 4; + if ((-307 < e && e <= 308)) { + if (e < 0) { + OPS_lrlval = f / (LONGREAL)Ten__9(-e); + } else { + OPS_lrlval = f * Ten__9(e); + } + } else { + OPS_err(203); + } + } + } + Number__6_s = _s.lnk; +} + +static struct Get__1 { + struct Get__1 *lnk; +} *Get__1_s; + +static void Comment__2 (void); + +static void Comment__2 (void) +{ + BOOLEAN isExported; + CHAR commentText[256]; + INT16 i, nestLevel; + CHAR prevCh, nextCh; + i = 0; + while (i <= 255) { + commentText[__X(i, 256)] = 0x00; + i += 1; + } + isExported = 0; + i = 0; + nestLevel = 1; + prevCh = 0x00; + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + isExported = 1; + OPM_Get(&OPS_ch); + if (OPS_ch == ')') { + commentText[0] = 0x00; + OPM_StoreComment(commentText, 256); + OPM_Get(&OPS_ch); + return; + } + } + while ((nestLevel > 0 && OPS_ch != 0x00)) { + if ((prevCh == '(' && OPS_ch == '*')) { + nestLevel += 1; + prevCh = 0x00; + } else if ((prevCh == '*' && OPS_ch == ')')) { + nestLevel -= 1; + if (nestLevel == 0) { + OPM_Get(&OPS_ch); + } else { + prevCh = 0x00; + } + } else { + if ((((isExported && nestLevel == 1)) && prevCh != 0x00)) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } + } + prevCh = OPS_ch; + } + if (nestLevel > 0) { + OPM_Get(&OPS_ch); + } + } + if (OPS_ch == 0x00) { + OPS_err(5); + } + if ((((((isExported && nestLevel == 0)) && prevCh != 0x00)) && prevCh != '*')) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } else { + OPM_LogWStr((CHAR*)"Truncating final comment character", 35); + OPM_LogWLn(); + } + } + if (isExported) { + if (i >= 256) { + OPM_LogWStr((CHAR*)"Warning: commentText overflow", 30); + OPM_LogWLn(); + i = 255; + } + commentText[__X(i, 256)] = 0x00; + OPM_StoreComment(commentText, 256); + } +} + +void OPS_Get (INT8 *sym) +{ + INT8 s; + struct Get__1 _s; + _s.lnk = Get__1_s; + Get__1_s = &_s; + OPM_errpos = OPM_curpos - 1; + while (OPS_ch <= ' ') { + if (OPS_ch == 0x00) { + *sym = 64; + Get__1_s = _s.lnk; + return; + } else { + OPM_Get(&OPS_ch); + } + } + switch (OPS_ch) { + case '"': case '\'': + OPS_Str(&s); + break; + case '#': + s = 10; + OPM_Get(&OPS_ch); + break; + case '&': + s = 5; + OPM_Get(&OPS_ch); + break; + case '(': + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + Comment__2(); + OPS_Get(&s); + } else { + s = 30; + } + break; + case ')': + s = 22; + OPM_Get(&OPS_ch); + break; + case '*': + s = 1; + OPM_Get(&OPS_ch); + break; + case '+': + s = 6; + OPM_Get(&OPS_ch); + break; + case ',': + s = 19; + OPM_Get(&OPS_ch); + break; + case '-': + s = 7; + OPM_Get(&OPS_ch); + break; + case '.': + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + s = 21; + } else { + s = 18; + } + break; + case '/': + s = 2; + OPM_Get(&OPS_ch); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + OPS_Number(); + s = 35; + break; + case ':': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 34; + } else { + s = 20; + } + break; + case ';': + s = 39; + OPM_Get(&OPS_ch); + break; + case '<': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 12; + } else { + s = 11; + } + break; + case '=': + s = 9; + OPM_Get(&OPS_ch); + break; + case '>': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 14; + } else { + s = 13; + } + break; + case 'A': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "ARRAY") == 0) { + s = 54; + } + break; + case 'B': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "BEGIN") == 0) { + s = 57; + } else if (__STRCMP(OPS_name, "BY") == 0) { + s = 29; + } + break; + case 'C': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "CASE") == 0) { + s = 46; + } else if (__STRCMP(OPS_name, "CONST") == 0) { + s = 58; + } + break; + case 'D': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "DO") == 0) { + s = 27; + } else if (__STRCMP(OPS_name, "DIV") == 0) { + s = 3; + } + break; + case 'E': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "END") == 0) { + s = 41; + } else if (__STRCMP(OPS_name, "ELSE") == 0) { + s = 42; + } else if (__STRCMP(OPS_name, "ELSIF") == 0) { + s = 43; + } else if (__STRCMP(OPS_name, "EXIT") == 0) { + s = 52; + } + break; + case 'F': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "FOR") == 0) { + s = 49; + } + break; + case 'I': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "IF") == 0) { + s = 45; + } else if (__STRCMP(OPS_name, "IN") == 0) { + s = 15; + } else if (__STRCMP(OPS_name, "IS") == 0) { + s = 16; + } else if (__STRCMP(OPS_name, "IMPORT") == 0) { + s = 62; + } + break; + case 'L': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "LOOP") == 0) { + s = 50; + } + break; + case 'M': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "MOD") == 0) { + s = 4; + } else if (__STRCMP(OPS_name, "MODULE") == 0) { + s = 63; + } + break; + case 'N': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "NIL") == 0) { + s = 36; + } + break; + case 'O': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "OR") == 0) { + s = 8; + } else if (__STRCMP(OPS_name, "OF") == 0) { + s = 25; + } + break; + case 'P': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "PROCEDURE") == 0) { + s = 61; + } else if (__STRCMP(OPS_name, "POINTER") == 0) { + s = 56; + } + break; + case 'R': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "RECORD") == 0) { + s = 55; + } else if (__STRCMP(OPS_name, "REPEAT") == 0) { + s = 48; + } else if (__STRCMP(OPS_name, "RETURN") == 0) { + s = 53; + } + break; + case 'T': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "THEN") == 0) { + s = 26; + } else if (__STRCMP(OPS_name, "TO") == 0) { + s = 28; + } else if (__STRCMP(OPS_name, "TYPE") == 0) { + s = 59; + } + break; + case 'U': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "UNTIL") == 0) { + s = 44; + } + break; + case 'V': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "VAR") == 0) { + s = 60; + } + break; + case 'W': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "WHILE") == 0) { + s = 47; + } else if (__STRCMP(OPS_name, "WITH") == 0) { + s = 51; + } + break; + case 'G': case 'H': case 'J': case 'K': case 'Q': + case 'S': case 'X': case 'Y': case 'Z': + OPS_Identifier(&s); + break; + case '[': + s = 31; + OPM_Get(&OPS_ch); + break; + case ']': + s = 23; + OPM_Get(&OPS_ch); + break; + case '^': + s = 17; + OPM_Get(&OPS_ch); + break; + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + OPS_Identifier(&s); + break; + case '{': + s = 32; + OPM_Get(&OPS_ch); + break; + case '|': + s = 40; + OPM_Get(&OPS_ch); + break; + case '}': + s = 24; + OPM_Get(&OPS_ch); + break; + case '~': + s = 33; + OPM_Get(&OPS_ch); + break; + case 0x7f: + s = 21; + OPM_Get(&OPS_ch); + break; + default: + s = 0; + OPM_Get(&OPS_ch); + break; + } + *sym = s; + Get__1_s = _s.lnk; +} + +void OPS_Init (void) +{ + OPS_ch = ' '; +} + + +export void *OPS__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __REGMOD("OPS", 0); + __REGCMD("Init", OPS_Init); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPS.h b/bootstrap/unix-48/OPS.h new file mode 100644 index 00000000..19e222ac --- /dev/null +++ b/bootstrap/unix-48/OPS.h @@ -0,0 +1,28 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPS__h +#define OPS__h + +#include "SYSTEM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +import OPS_Name OPS_name; +import OPS_String OPS_str; +import INT16 OPS_numtyp; +import INT64 OPS_intval; +import REAL OPS_realval; +import LONGREAL OPS_lrlval; + + +import void OPS_Get (INT8 *sym); +import void OPS_Init (void); +import void *OPS__init(void); + + +#endif // OPS diff --git a/bootstrap/unix-48/OPT.c b/bootstrap/unix-48/OPT.c new file mode 100644 index 00000000..ebb47dd8 --- /dev/null +++ b/bootstrap/unix-48/OPT.c @@ -0,0 +1,2261 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_ExpCtxt { + INT32 reffp; + INT16 ref; + INT8 nofm; + INT8 locmno[64]; + } OPT_ExpCtxt; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_ImpCtxt { + INT32 nextTag, reffp; + INT16 nofr, minr, nofm; + BOOLEAN self; + OPT_Struct ref[255]; + OPT_Object old[255]; + INT32 pvfp[255]; + INT8 glbmno[64]; + } OPT_ImpCtxt; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused, fpdone, idfpdone; + INT32 idfp, pbfp, pvfp; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +export OPT_Object OPT_topScope; +export OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +export OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +export INT8 OPT_nofGmod; +export OPT_Object OPT_GlbMod[64]; +export OPS_Name OPT_SelfName; +export BOOLEAN OPT_SYSimported; +static OPT_Object OPT_universe, OPT_syslink; +static OPT_ImpCtxt OPT_impCtxt; +static OPT_ExpCtxt OPT_expCtxt; +static INT32 OPT_nofhdfld; +static BOOLEAN OPT_newsf, OPT_findpc, OPT_extsf, OPT_sfpresent, OPT_symExtended, OPT_symNew; +static INT32 OPT_recno; +export OPT_Link OPT_Links; + +export ADDRESS *OPT_ConstDesc__typ; +export ADDRESS *OPT_ObjDesc__typ; +export ADDRESS *OPT_StrDesc__typ; +export ADDRESS *OPT_NodeDesc__typ; +export ADDRESS *OPT_ImpCtxt__typ; +export ADDRESS *OPT_ExpCtxt__typ; +export ADDRESS *OPT_LinkDesc__typ; + +export void OPT_Align (INT32 *adr, INT32 base); +export INT32 OPT_BaseAlignment (OPT_Struct typ); +export void OPT_Close (void); +export void OPT_CloseScope (void); +static void OPT_DebugStruct (OPT_Struct btyp); +static void OPT_EnterBoolConst (OPS_Name name, INT32 value); +static void OPT_EnterProc (OPS_Name name, INT16 num); +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res); +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res); +export void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +export void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len); +export void OPT_FPrintObj (OPT_Object obj); +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par); +export void OPT_FPrintStr (OPT_Struct typ); +export void OPT_Find (OPT_Object *res); +export void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +export void OPT_FindImport (OPT_Object mod, OPT_Object *res); +export void OPT_IdFPrint (OPT_Struct typ); +export void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +static void OPT_InConstant (INT32 f, OPT_Const conval); +static OPT_Object OPT_InFld (void); +static void OPT_InLinks (void); +static void OPT_InMod (INT8 *mno); +static void OPT_InName (CHAR *name, ADDRESS name__len); +static OPT_Object OPT_InObj (INT8 mno); +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par); +static void OPT_InStruct (OPT_Struct *typ); +static OPT_Object OPT_InTProc (INT8 mno); +static OPT_Struct OPT_InTyp (INT32 tag); +export void OPT_Init (OPS_Name name, UINT32 opt); +export void OPT_InitRecno (void); +static void OPT_InitStruct (OPT_Struct *typ, INT8 form); +export void OPT_Insert (OPS_Name name, OPT_Object *obj); +export void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +export INT16 OPT_IntSize (INT64 n); +export OPT_Struct OPT_IntType (INT32 size); +export OPT_Const OPT_NewConst (void); +export OPT_ConstExt OPT_NewExt (void); +export OPT_Node OPT_NewNode (INT8 class); +export OPT_Object OPT_NewObj (void); +export OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +export void OPT_OpenScope (INT8 level, OPT_Object owner); +static void OPT_OutConstant (OPT_Object obj); +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void OPT_OutLinks (void); +static void OPT_OutMod (INT16 mno); +static void OPT_OutName (CHAR *name, ADDRESS name__len); +static void OPT_OutObj (OPT_Object obj); +static void OPT_OutSign (OPT_Struct result, OPT_Object par); +static void OPT_OutStr (OPT_Struct typ); +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj); +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len); +export OPT_Struct OPT_SetType (INT32 size); +export OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +export INT32 OPT_SizeAlignment (INT32 size); +export void OPT_TypSize (OPT_Struct typ); +static void OPT_err (INT16 n); + + +void OPT_InitRecno (void) +{ + OPT_recno = 0; +} + +static void OPT_err (INT16 n) +{ + OPM_err(n); +} + +INT16 OPT_IntSize (INT64 n) +{ + INT16 bytes; + if (n < 0) { + n = -(n + 1); + } + bytes = 1; + while ((bytes < 8 && __ASH(n, -(__ASHL(bytes, 3) - 1)) != 0)) { + bytes += 1; + } + return bytes; +} + +OPT_Struct OPT_IntType (INT32 size) +{ + if (size <= OPT_int8typ->size) { + return OPT_int8typ; + } + if (size <= OPT_int16typ->size) { + return OPT_int16typ; + } + if (size <= OPT_int32typ->size) { + return OPT_int32typ; + } + return OPT_int64typ; +} + +OPT_Struct OPT_SetType (INT32 size) +{ + if (size == OPT_set32typ->size) { + return OPT_set32typ; + } + return OPT_set64typ; +} + +OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir) +{ + INT16 i; + __ASSERT(x->form == 4, 0); + __ASSERT(x->BaseTyp == OPT_undftyp, 0); + __ASSERT(dir == 1 || dir == -1, 0); + if (dir > 0) { + if (x->size < OPT_sinttyp->size) { + return OPT_sinttyp; + } + if (x->size < OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size < OPT_linttyp->size) { + return OPT_linttyp; + } + return OPT_int64typ; + } else { + if (x->size > OPT_linttyp->size) { + return OPT_linttyp; + } + if (x->size > OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size > OPT_sinttyp->size) { + return OPT_sinttyp; + } + return OPT_int8typ; + } + __RETCHK; +} + +void OPT_Align (INT32 *adr, INT32 base) +{ + switch (base) { + case 2: + *adr += __MASK(*adr, -2); + break; + case 4: + *adr += __MASK(-*adr, -4); + break; + case 8: + *adr += __MASK(-*adr, -8); + break; + case 16: + *adr += __MASK(-*adr, -16); + break; + default: + break; + } +} + +INT32 OPT_SizeAlignment (INT32 size) +{ + INT32 alignment; + if (size < OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; + } + return alignment; +} + +INT32 OPT_BaseAlignment (OPT_Struct typ) +{ + INT32 alignment; + if (typ->form == 13) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPT_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPT_SizeAlignment(typ->size); + } + return alignment; +} + +void OPT_TypSize (OPT_Struct typ) +{ + INT16 f, c; + INT32 offset, size, base, fbase, off0; + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + if (typ == OPT_undftyp) { + OPM_err(58); + } else if (typ->size == -1) { + f = typ->form; + c = typ->comp; + if (c == 4) { + btyp = typ->BaseTyp; + if (btyp == NIL) { + offset = 0; + base = 1; + } else { + OPT_TypSize(btyp); + offset = btyp->size - __ASHR(btyp->sysflag, 8); + base = btyp->align; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + btyp = fld->typ; + OPT_TypSize(btyp); + size = btyp->size; + fbase = OPT_BaseAlignment(btyp); + OPT_Align(&offset, fbase); + fld->adr = offset; + offset += size; + if (fbase > base) { + base = fbase; + } + fld = fld->link; + } + off0 = offset; + if (offset == 0) { + offset = 1; + } + OPT_Align(&offset, base); + if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { + OPT_recno += 1; + base += __ASHL(OPT_recno, 16); + } + typ->size = offset; + typ->align = base; + typ->sysflag = __MASK(typ->sysflag, -256) + __SHORT(__ASHL(offset - off0, 8), 32768); + } else if (c == 2) { + OPT_TypSize(typ->BaseTyp); + typ->size = typ->n * typ->BaseTyp->size; + } else if (f == 11) { + typ->size = OPM_AddressSize; + if (typ->BaseTyp == OPT_undftyp) { + OPM_Mark(128, typ->n); + } else { + OPT_TypSize(typ->BaseTyp); + } + } else if (f == 12) { + typ->size = OPM_AddressSize; + } else if (c == 3) { + btyp = typ->BaseTyp; + OPT_TypSize(btyp); + if (btyp->comp == 3) { + typ->size = btyp->size + 4; + } else { + typ->size = 8; + } + } + } +} + +OPT_Const OPT_NewConst (void) +{ + OPT_Const const_ = NIL; + __NEW(const_, OPT_ConstDesc); + return const_; +} + +OPT_Object OPT_NewObj (void) +{ + OPT_Object obj = NIL; + __NEW(obj, OPT_ObjDesc); + obj->typ = NIL; + obj->conval = NIL; + obj->comment = NIL; + obj->name[0] = 0x00; + return obj; +} + +OPT_Struct OPT_NewStr (INT8 form, INT8 comp) +{ + OPT_Struct typ = NIL; + __NEW(typ, OPT_StrDesc); + typ->form = form; + typ->comp = comp; + typ->ref = 255; + if (form != 0) { + typ->txtpos = OPM_errpos; + } + typ->size = -1; + typ->BaseTyp = OPT_undftyp; + return typ; +} + +OPT_Node OPT_NewNode (INT8 class) +{ + OPT_Node node = NIL; + __NEW(node, OPT_NodeDesc); + node->class = class; + return node; +} + +OPT_ConstExt OPT_NewExt (void) +{ + OPT_ConstExt ext = NIL; + ext = __NEWARR(NIL, 1, 1, 1, 0, 256); + return ext; +} + +void OPT_OpenScope (INT8 level, OPT_Object owner) +{ + OPT_Object head = NIL; + head = OPT_NewObj(); + head->mode = 12; + head->mnolev = level; + head->link = owner; + if (owner != NIL) { + owner->scope = head; + } + head->left = OPT_topScope; + head->right = NIL; + head->scope = NIL; + OPT_topScope = head; +} + +void OPT_CloseScope (void) +{ + OPT_topScope = OPT_topScope->left; +} + +void OPT_Init (OPS_Name name, UINT32 opt) +{ + OPT_topScope = OPT_universe; + OPT_OpenScope(0, NIL); + OPT_SYSimported = 0; + __MOVE(name, OPT_SelfName, 256); + __MOVE(name, OPT_topScope->name, 256); + OPT_GlbMod[0] = OPT_topScope; + OPT_nofGmod = 1; + OPT_newsf = __IN(4, opt, 32); + OPT_findpc = __IN(8, opt, 32); + OPT_extsf = OPT_newsf || __IN(9, opt, 32); + OPT_sfpresent = 1; + __NEW(OPT_Links, OPT_LinkDesc); + __MOVE(name, OPT_Links->name, 256); +} + +void OPT_Close (void) +{ + INT16 i; + OPT_CloseScope(); + i = 0; + while (i < 64) { + OPT_GlbMod[__X(i, 64)] = NIL; + i += 1; + } + i = 14; + while (i < 255) { + OPT_impCtxt.ref[__X(i, 255)] = NIL; + OPT_impCtxt.old[__X(i, 255)] = NIL; + i += 1; + } +} + +void OPT_FindImport (OPT_Object mod, OPT_Object *res) +{ + OPT_Object obj = NIL; + obj = mod->scope; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + if ((obj->mode == 5 && obj->vis == 0)) { + obj = NIL; + } else { + obj->used = 1; + } + break; + } + } + *res = obj; +} + +void OPT_Find (OPT_Object *res) +{ + OPT_Object obj = NIL, head = NIL; + head = OPT_topScope; + for (;;) { + obj = head->right; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + break; + } + } + if (obj != NIL) { + break; + } + head = head->left; + if (head == NIL) { + break; + } + } + *res = obj; +} + +void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res) +{ + OPT_Object obj = NIL; + while (typ != NIL) { + obj = typ->link; + while (obj != NIL) { + if (__STRCMP(name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(name, obj->name) > 0) { + obj = obj->right; + } else { + *res = obj; + return; + } + } + typ = typ->BaseTyp; + } + *res = NIL; +} + +void OPT_Insert (OPS_Name name, OPT_Object *obj) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + INT8 mnolev; + CHAR commentText[256]; + INT16 j; + ob0 = OPT_topScope; + ob1 = ob0->right; + left = 0; + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob0->right; + left = 0; + } else { + OPT_err(1); + ob0 = ob1; + ob1 = ob0->right; + } + } else { + ob1 = OPT_NewObj(); + ob1->leaf = 1; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + __COPY(name, ob1->name, 256); + mnolev = OPT_topScope->mnolev; + ob1->mnolev = mnolev; + OPM_GetComment((void*)commentText, 256); + if (commentText[0] != 0x00) { + ob1->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((j < 255 && commentText[__X(j, 256)] != 0x00)) { + (*ob1->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*ob1->comment)[__X(j, 256)] = 0x00; + } + break; + } + } + *obj = ob1; +} + +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_FPrint(&*fp, (INT16)ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_DebugStruct (OPT_Struct btyp) +{ + OPM_LogWLn(); + if (btyp == NIL) { + OPM_LogWStr((CHAR*)"btyp is nil", 12); + OPM_LogWLn(); + } + OPM_LogWStr((CHAR*)"btyp^.strobji^.name = ", 23); + OPM_LogWStr(btyp->strobj->name, 256); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.form = ", 14); + OPM_LogWNum(btyp->form, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.comp = ", 14); + OPM_LogWNum(btyp->comp, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.mno = ", 13); + OPM_LogWNum(btyp->mno, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.extlev = ", 16); + OPM_LogWNum(btyp->extlev, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.size = ", 14); + OPM_LogWNum(btyp->size, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.align = ", 15); + OPM_LogWNum(btyp->align, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.txtpos = ", 16); + OPM_LogWNum(btyp->txtpos, 0); + OPM_LogWLn(); +} + +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par) +{ + OPT_IdFPrint(result); + OPM_FPrint(&*fp, result->idfp); + while (par != NIL) { + OPM_FPrint(&*fp, par->mode); + OPT_IdFPrint(par->typ); + OPM_FPrint(&*fp, par->typ->idfp); + par = par->link; + } +} + +void OPT_IdFPrint (OPT_Struct typ) +{ + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL; + INT32 idfp; + INT16 f, c; + if (!typ->idfpdone) { + typ->idfpdone = 1; + idfp = 0; + f = typ->form; + OPM_FPrint(&idfp, f); + if (__IN(f, 0x90, 32)) { + OPM_FPrint(&idfp, typ->size); + } + c = typ->comp; + OPM_FPrint(&idfp, c); + btyp = typ->BaseTyp; + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_FPrintName(&idfp, (void*)OPT_GlbMod[__X(typ->mno, 64)]->name, 256); + OPT_FPrintName(&idfp, (void*)strobj->name, 256); + } + if ((f == 11 || (c == 4 && btyp != NIL)) || c == 3) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + } else if (c == 2) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + OPM_FPrint(&idfp, typ->n); + } else if (f == 12) { + OPT_FPrintSign(&idfp, btyp, typ->link); + } + typ->idfp = idfp; + } +} + +static struct FPrintStr__15 { + INT32 *pbfp, *pvfp; + struct FPrintStr__15 *lnk; +} *FPrintStr__15_s; + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void FPrintTProcs__20 (OPT_Object obj); + +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + FPrintFlds__16(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + FPrintHdFld__18(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + FPrintHdFld__18(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_FPrint(&*FPrintStr__15_s->pvfp, 11); + OPM_FPrint(&*FPrintStr__15_s->pvfp, adr); + OPT_nofhdfld += 1; + } +} + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->vis); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)fld->name, 256); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->adr); + OPT_FPrintStr(fld->typ); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->typ->pbfp); + OPM_FPrint(&*FPrintStr__15_s->pvfp, fld->typ->pvfp); + } else { + FPrintHdFld__18(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void FPrintTProcs__20 (OPT_Object obj) +{ + if (obj != NIL) { + FPrintTProcs__20(obj->left); + if (obj->mode == 13) { + if (obj->vis != 0) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, 13); + OPM_FPrint(&*FPrintStr__15_s->pbfp, __ASHR(obj->adr, 16)); + OPT_FPrintSign(&*FPrintStr__15_s->pbfp, obj->typ, obj->link); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)obj->name, 256); + } + } + FPrintTProcs__20(obj->right); + } +} + +void OPT_FPrintStr (OPT_Struct typ) +{ + INT16 f, c; + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL, bstrobj = NIL; + INT32 pbfp, pvfp; + struct FPrintStr__15 _s; + _s.pbfp = &pbfp; + _s.pvfp = &pvfp; + _s.lnk = FPrintStr__15_s; + FPrintStr__15_s = &_s; + if (!typ->fpdone) { + OPT_IdFPrint(typ); + pbfp = typ->idfp; + if (typ->sysflag != 0) { + OPM_FPrint(&pbfp, typ->sysflag); + } + pvfp = pbfp; + typ->pbfp = pbfp; + typ->pvfp = pvfp; + typ->fpdone = 1; + f = typ->form; + c = typ->comp; + btyp = typ->BaseTyp; + if (f == 11) { + strobj = typ->strobj; + bstrobj = btyp->strobj; + if (((strobj == NIL || strobj->name[0] == 0x00) || bstrobj == NIL) || bstrobj->name[0] == 0x00) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + pvfp = pbfp; + } + } else if (f == 12) { + } else if (__IN(c, 0x0c, 32)) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pvfp); + pvfp = pbfp; + } else { + if (btyp != NIL) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + OPM_FPrint(&pvfp, btyp->pvfp); + } + OPM_FPrint(&pvfp, typ->size); + OPM_FPrint(&pvfp, typ->align); + OPM_FPrint(&pvfp, typ->n); + OPT_nofhdfld = 0; + FPrintFlds__16(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(225, typ->txtpos); + } + FPrintTProcs__20(typ->link); + OPM_FPrint(&pvfp, pbfp); + strobj = typ->strobj; + if (strobj == NIL || strobj->name[0] == 0x00) { + pbfp = pvfp; + } + } + typ->pbfp = pbfp; + typ->pvfp = pvfp; + } + FPrintStr__15_s = _s.lnk; +} + +void OPT_FPrintObj (OPT_Object obj) +{ + INT32 fprint; + INT16 f, m; + REAL rval; + OPT_ConstExt ext = NIL; + if (!obj->fpdone) { + fprint = 0; + obj->fpdone = 1; + OPM_FPrint(&fprint, obj->mode); + if (obj->mode == 3) { + f = obj->typ->form; + OPM_FPrint(&fprint, f); + switch (f) { + case 2: case 3: case 4: + OPM_FPrint(&fprint, obj->conval->intval); + break; + case 7: + OPM_FPrintSet(&fprint, obj->conval->setval); + break; + case 5: + rval = obj->conval->realval; + OPM_FPrintReal(&fprint, rval); + break; + case 6: + OPM_FPrintLReal(&fprint, obj->conval->realval); + break; + case 8: + OPT_FPrintName(&fprint, (void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } + } else if (obj->mode == 1) { + OPM_FPrint(&fprint, obj->vis); + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } else if (__IN(obj->mode, 0x0480, 32)) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + } else if (obj->mode == 9) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + ext = obj->conval->ext; + m = (INT16)(*ext)[0]; + f = 1; + OPM_FPrint(&fprint, m); + while (f <= m) { + OPM_FPrint(&fprint, (INT16)(*ext)[__X(f, 256)]); + f += 1; + } + } else if (obj->mode == 5) { + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } + obj->fprint = fprint; + } +} + +void OPT_FPrintErr (OPT_Object obj, INT16 errcode) +{ + INT16 i, j; + CHAR ch; + if (obj->mnolev != 0) { + __COPY(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, OPM_objname, 64); + i = 0; + while (OPM_objname[__X(i, 64)] != 0x00) { + i += 1; + } + OPM_objname[__X(i, 64)] = '.'; + j = 0; + i += 1; + do { + ch = obj->name[__X(j, 256)]; + OPM_objname[__X(i, 64)] = ch; + j += 1; + i += 1; + } while (!(ch == 0x00)); + } else { + __COPY(obj->name, OPM_objname, 64); + } + if (errcode == 249) { + if (OPM_noerr) { + OPT_err(errcode); + } + } else if (errcode == 253) { + if ((((!OPT_symNew && !OPT_symExtended)) && !OPT_extsf)) { + OPT_err(errcode); + } + OPT_symExtended = 1; + } else { + if ((!OPT_symNew && !OPT_newsf)) { + OPT_err(errcode); + } + OPT_symNew = 1; + } +} + +void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + if (*root == NIL) { + *root = obj; + *old = NIL; + } else { + ob0 = *root; + ob1 = ob0->right; + left = 0; + if (__STRCMP(obj->name, ob0->name) < 0) { + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(obj->name, ob0->name) > 0) { + ob1 = ob0->right; + left = 0; + } else { + *old = ob0; + return; + } + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(obj->name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob1->left; + left = 1; + } else if (__STRCMP(obj->name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob1->right; + left = 0; + } else { + *old = ob1; + break; + } + } else { + ob1 = obj; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + *old = NIL; + break; + } + } + } +} + +static void OPT_InName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + OPM_SymRCh(&ch); + name[__X(i, name__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_InMod (INT8 *mno) +{ + OPT_Object head = NIL; + OPS_Name name; + INT32 mn; + INT8 i; + mn = OPM_SymRInt(); + if (mn == 0) { + *mno = OPT_impCtxt.glbmno[0]; + } else { + if (mn == 16) { + OPT_InName((void*)name, 256); + if ((__STRCMP(name, OPT_SelfName) == 0 && !OPT_impCtxt.self)) { + OPT_err(154); + } + i = 0; + while ((i < OPT_nofGmod && __STRCMP(name, OPT_GlbMod[__X(i, 64)]->name) != 0)) { + i += 1; + } + if (i < OPT_nofGmod) { + *mno = i; + } else { + head = OPT_NewObj(); + head->mode = 12; + __COPY(name, head->name, 256); + *mno = OPT_nofGmod; + head->mnolev = -*mno; + if (OPT_nofGmod < 64) { + OPT_GlbMod[__X(*mno, 64)] = head; + OPT_nofGmod += 1; + } else { + OPT_err(227); + } + } + OPT_impCtxt.glbmno[__X(OPT_impCtxt.nofm, 64)] = *mno; + OPT_impCtxt.nofm += 1; + } else { + *mno = OPT_impCtxt.glbmno[__X(-mn, 64)]; + } + } +} + +static void OPT_InLinks (void) +{ + OPS_Name linkname; + OPT_Link l = NIL; + OPT_InName((void*)linkname, 256); + while (linkname[0] != 0x00) { + l = OPT_Links; + while ((l != NIL && __STRCMP(l->name, linkname) != 0)) { + l = l->next; + } + if (l == NIL) { + l = OPT_Links; + __NEW(OPT_Links, OPT_LinkDesc); + OPT_Links->next = l; + __MOVE(linkname, OPT_Links->name, 256); + } + OPT_InName((void*)linkname, 256); + } +} + +static void OPT_InConstant (INT32 f, OPT_Const conval) +{ + CHAR ch; + INT16 i; + OPT_ConstExt ext = NIL; + REAL rval; + switch (f) { + case 1: case 3: case 2: + OPM_SymRCh(&ch); + conval->intval = (INT16)ch; + break; + case 4: + conval->intval = OPM_SymRInt(); + break; + case 7: + OPM_SymRSet(&conval->setval); + break; + case 5: + OPM_SymRReal(&rval); + conval->realval = rval; + conval->intval = -1; + break; + case 6: + OPM_SymRLReal(&conval->realval); + conval->intval = -1; + break; + case 8: + ext = OPT_NewExt(); + conval->ext = ext; + i = 0; + do { + OPM_SymRCh(&ch); + (*ext)[__X(i, 256)] = ch; + i += 1; + } while (!(ch == 0x00)); + conval->intval2 = i; + conval->intval = -1; + break; + case 9: + conval->intval = 0; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", 37); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } +} + +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par) +{ + OPT_Object last = NIL, new = NIL; + INT32 tag; + OPT_InStruct(&*res); + tag = OPM_SymRInt(); + last = NIL; + while (tag != 18) { + if (tag < 0 || tag > 100) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag value in InSign: ", 37); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return; + } + new = OPT_NewObj(); + new->mnolev = -mno; + if (last == NIL) { + *par = new; + } else { + last->link = new; + } + if (tag == 23) { + new->mode = 1; + } else { + new->mode = 2; + } + OPT_InStruct(&new->typ); + new->adr = OPM_SymRInt(); + OPT_InName((void*)new->name, 256); + last = new; + tag = OPM_SymRInt(); + } +} + +static OPT_Object OPT_InFld (void) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + if (tag <= 26) { + obj->mode = 4; + if (tag == 26) { + obj->vis = 2; + } else { + obj->vis = 1; + } + OPT_InStruct(&obj->typ); + OPT_InName((void*)obj->name, 256); + obj->adr = OPM_SymRInt(); + } else { + obj->mode = 4; + if (tag == 27) { + __MOVE("@ptr", obj->name, 5); + } else { + __MOVE("@proc", obj->name, 6); + } + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = OPM_SymRInt(); + } + return obj; +} + +static OPT_Object OPT_InTProc (INT8 mno) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + obj->mnolev = -mno; + if (tag == 29) { + obj->mode = 13; + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + obj->vis = 1; + OPT_InName((void*)obj->name, 256); + obj->adr = __ASHL(OPM_SymRInt(), 16); + } else { + obj->mode = 13; + __MOVE("@tproc", obj->name, 7); + obj->link = OPT_NewObj(); + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = __ASHL(OPM_SymRInt(), 16); + } + return obj; +} + +static OPT_Struct OPT_InTyp (INT32 tag) +{ + if (tag == 4) { + return OPT_IntType(OPM_SymRInt()); + } else if (tag == 7) { + return OPT_SetType(OPM_SymRInt()); + } else { + return OPT_impCtxt.ref[__X(tag, 255)]; + } + __RETCHK; +} + +static void OPT_InStruct (OPT_Struct *typ) +{ + INT8 mno; + INT16 ref; + INT32 tag; + OPS_Name name; + OPT_Struct t = NIL; + OPT_Object obj = NIL, last = NIL, fld = NIL, old = NIL, dummy = NIL; + tag = OPM_SymRInt(); + if (tag != 34) { + *typ = OPT_InTyp(-tag); + } else { + ref = OPT_impCtxt.nofr; + OPT_impCtxt.nofr += 1; + if (ref < OPT_impCtxt.minr) { + OPT_impCtxt.minr = ref; + } + OPT_InMod(&mno); + OPT_InName((void*)name, 256); + obj = OPT_NewObj(); + if (name[0] == 0x00) { + if (OPT_impCtxt.self) { + old = NIL; + } else { + __MOVE("@", obj->name, 2); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + obj->name[0] = 0x00; + } + *typ = OPT_NewStr(0, 1); + } else { + __MOVE(name, obj->name, 256); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (old != NIL) { + OPT_FPrintObj(old); + OPT_impCtxt.pvfp[__X(ref, 255)] = old->typ->pvfp; + if (OPT_impCtxt.self) { + *typ = OPT_NewStr(0, 1); + } else { + *typ = old->typ; + (*typ)->link = NIL; + (*typ)->sysflag = 0; + (*typ)->fpdone = 0; + (*typ)->idfpdone = 0; + } + } else { + *typ = OPT_NewStr(0, 1); + } + } + OPT_impCtxt.ref[__X(ref, 255)] = *typ; + OPT_impCtxt.old[__X(ref, 255)] = old; + (*typ)->ref = ref + 255; + (*typ)->mno = mno; + (*typ)->allocated = 1; + (*typ)->strobj = obj; + obj->mode = 5; + obj->typ = *typ; + obj->mnolev = -mno; + obj->vis = 0; + tag = OPM_SymRInt(); + if (tag == 35) { + (*typ)->sysflag = __SHORTF(OPM_SymRInt(), 32768); + tag = OPM_SymRInt(); + } + switch (tag) { + case 36: + (*typ)->form = 11; + (*typ)->size = OPM_AddressSize; + (*typ)->n = 0; + OPT_InStruct(&(*typ)->BaseTyp); + break; + case 37: + (*typ)->form = 13; + (*typ)->comp = 2; + OPT_InStruct(&(*typ)->BaseTyp); + (*typ)->n = OPM_SymRInt(); + OPT_TypSize(*typ); + break; + case 38: + (*typ)->form = 13; + (*typ)->comp = 3; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + OPT_TypSize(*typ); + break; + case 39: + (*typ)->form = 13; + (*typ)->comp = 4; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp == OPT_notyp) { + (*typ)->BaseTyp = NIL; + } + (*typ)->extlev = 0; + t = (*typ)->BaseTyp; + while (t != NIL) { + (*typ)->extlev += 1; + t = t->BaseTyp; + } + (*typ)->size = OPM_SymRInt(); + (*typ)->align = OPM_SymRInt(); + (*typ)->n = OPM_SymRInt(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + last = NIL; + while ((OPT_impCtxt.nextTag >= 25 && OPT_impCtxt.nextTag <= 28)) { + fld = OPT_InFld(); + fld->mnolev = -mno; + if (last != NIL) { + last->link = fld; + } + last = fld; + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + while (OPT_impCtxt.nextTag != 18) { + fld = OPT_InTProc(mno); + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + break; + case 40: + (*typ)->form = 12; + (*typ)->size = OPM_AddressSize; + OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", 35); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + break; + } + if (ref == OPT_impCtxt.minr) { + while (ref < OPT_impCtxt.nofr) { + t = OPT_InTyp(ref); + OPT_FPrintStr(t); + obj = t->strobj; + if (obj->name[0] != 0x00) { + OPT_FPrintObj(obj); + } + old = OPT_impCtxt.old[__X(ref, 255)]; + if (old != NIL) { + t->strobj = old; + if (OPT_impCtxt.self) { + if (old->mnolev < 0) { + if (old->history != 5) { + if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } + } + } else if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } else if (old->vis == 0) { + old->history = 1; + } else { + old->history = 0; + } + } else { + if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 5; + } + if (old->fprint != obj->fprint) { + OPT_FPrintErr(old, 249); + } + } + } else if (OPT_impCtxt.self) { + obj->history = 4; + } else { + obj->history = 1; + } + ref += 1; + } + OPT_impCtxt.minr = 255; + } + } +} + +static OPT_Object OPT_InObj (INT8 mno) +{ + INT16 i, s; + CHAR ch; + OPT_Object obj = NIL, old = NIL; + OPT_Struct typ = NIL; + INT32 tag; + OPT_ConstExt ext = NIL; + OPS_Name commentText; + BOOLEAN hasComment; + INT16 j; + INT32 len; + tag = OPT_impCtxt.nextTag; + hasComment = 0; + while (tag == 41) { + len = OPM_SymRInt(); + if (len < 0) { + len = 0; + } + if (len > 255) { + len = 255; + } + i = 0; + while (i < len) { + OPM_SymRCh(&commentText[__X(i, 256)]); + i += 1; + } + commentText[__X(i, 256)] = 0x00; + hasComment = 1; + tag = OPM_SymRInt(); + } + OPT_impCtxt.nextTag = tag; + if (tag < 0 || tag > 50) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag in InObj: ", 30); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + if (tag == 19) { + OPT_InStruct(&typ); + obj = typ->strobj; + if (!OPT_impCtxt.self) { + obj->vis = 1; + } + } else { + obj = OPT_NewObj(); + obj->mnolev = -mno; + obj->vis = 1; + if (tag <= 11) { + obj->mode = 3; + obj->conval = OPT_NewConst(); + OPT_InConstant(tag, obj->conval); + obj->typ = OPT_InTyp(tag); + } else if ((tag >= 31 && tag <= 33)) { + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + switch (tag) { + case 31: + obj->mode = 7; + break; + case 32: + obj->mode = 10; + break; + case 33: + obj->mode = 9; + ext = OPT_NewExt(); + obj->conval->ext = ext; + s = __SHORTF(OPM_SymRInt(), 32768); + (*ext)[0] = __CHR(s); + i = 1; + while (i <= s) { + OPM_SymRCh(&(*ext)[__X(i, 256)]); + i += 1; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", 32); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + break; + } + } else if (tag == 20) { + obj->mode = 5; + OPT_InStruct(&obj->typ); + } else if (tag == 21 || tag == 22) { + obj->mode = 1; + if (tag == 22) { + obj->vis = 2; + } + OPT_InStruct(&obj->typ); + } else { + OPM_LogWStr((CHAR*)"ERROR: Unexpected tag in InObj: ", 33); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + OPT_InName((void*)obj->name, 256); + } + if ((hasComment && obj != NIL)) { + obj->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((((j < 255 && j < len)) && commentText[__X(j, 256)] != 0x00)) { + (*obj->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*obj->comment)[__X(j, 256)] = 0x00; + } + OPT_FPrintObj(obj); + if ((obj->mode == 1 && (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00))) { + OPM_FPrint(&OPT_impCtxt.reffp, obj->typ->ref - 255); + } + if (tag != 19) { + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (OPT_impCtxt.self) { + if (old != NIL) { + if (old->vis == 0) { + old->history = 4; + } else { + OPT_FPrintObj(old); + if (obj->fprint != old->fprint) { + old->history = 2; + } else if (obj->typ->pvfp != old->typ->pvfp) { + old->history = 3; + } else { + old->history = 1; + } + } + } else { + obj->history = 4; + } + } + } else { + if (OPT_impCtxt.self) { + if (obj->vis == 0) { + obj->history = 4; + } else if (obj->history == 0) { + obj->history = 1; + } + } + } + return obj; +} + +void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done) +{ + OPT_Object obj = NIL; + INT8 mno; + OPS_Name aliasName__copy; + __DUPARR(aliasName, OPS_Name); + if (__STRCMP(name, "SYSTEM") == 0) { + OPT_SYSimported = 1; + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->mnolev = 0; + obj->scope = OPT_syslink; + obj->typ = OPT_notyp; + } else { + OPT_impCtxt.nofr = 14; + OPT_impCtxt.minr = 255; + OPT_impCtxt.nofm = 0; + OPT_impCtxt.self = __STRCMP(aliasName, "@self") == 0; + OPT_impCtxt.reffp = 0; + if ((OPT_impCtxt.self && __IN(17, OPM_Options, 32))) { + OPM_DeleteSym((void*)name, 256); + *done = 0; + } else { + OPM_OldSym((void*)name, 256, &*done); + } + if (*done) { + OPT_InMod(&mno); + OPT_InLinks(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + while (!OPM_eofSF()) { + obj = OPT_InObj(mno); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->scope = OPT_GlbMod[__X(mno, 64)]->right; + OPT_GlbMod[__X(mno, 64)]->link = obj; + obj->mnolev = -mno; + obj->typ = OPT_notyp; + OPM_CloseOldSym(); + } else if (OPT_impCtxt.self) { + OPT_newsf = 1; + OPT_extsf = 1; + OPT_sfpresent = 0; + } else { + OPT_err(152); + } + } +} + +static void OPT_OutName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_SymWCh(ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_OutMod (INT16 mno) +{ + if (OPT_expCtxt.locmno[__X(mno, 64)] < 0) { + OPM_SymWInt(16); + OPT_expCtxt.locmno[__X(mno, 64)] = OPT_expCtxt.nofm; + OPT_expCtxt.nofm += 1; + OPT_OutName((void*)OPT_GlbMod[__X(mno, 64)]->name, 256); + } else { + OPM_SymWInt(-OPT_expCtxt.locmno[__X(mno, 64)]); + } +} + +static void OPT_OutLinks (void) +{ + OPT_Link l = NIL; + l = OPT_Links; + while (l != NIL) { + OPT_OutName((void*)l->name, 256); + l = l->next; + } + OPM_SymWCh(0x00); +} + +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + OPT_OutFlds(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + OPT_OutHdFld(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + OPT_OutHdFld(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_SymWInt(27); + OPM_SymWInt(adr); + OPT_nofhdfld += 1; + } +} + +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + if (fld->vis == 2) { + OPM_SymWInt(26); + } else { + OPM_SymWInt(25); + } + OPT_OutStr(fld->typ); + OPT_OutName((void*)fld->name, 256); + OPM_SymWInt(fld->adr); + } else { + OPT_OutHdFld(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void OPT_OutSign (OPT_Struct result, OPT_Object par) +{ + OPT_OutStr(result); + while (par != NIL) { + if (par->mode == 1) { + OPM_SymWInt(23); + } else { + OPM_SymWInt(24); + } + OPT_OutStr(par->typ); + OPM_SymWInt(par->adr); + OPT_OutName((void*)par->name, 256); + par = par->link; + } + OPM_SymWInt(18); +} + +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj) +{ + if (obj != NIL) { + OPT_OutTProcs(typ, obj->left); + if (obj->mode == 13) { + if ((((typ->BaseTyp != NIL && __ASHR(obj->adr, 16) < typ->BaseTyp->n)) && obj->vis == 0)) { + OPM_Mark(109, typ->txtpos); + } + if (obj->vis != 0) { + if (obj->vis != 0) { + OPM_SymWInt(29); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } else { + OPM_SymWInt(30); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } + } + } + OPT_OutTProcs(typ, obj->right); + } +} + +static void OPT_OutStr (OPT_Struct typ) +{ + OPT_Object strobj = NIL; + if (typ->ref < OPT_expCtxt.ref) { + OPM_SymWInt(-typ->ref); + if (__IN(typ->ref, 0x90, 32)) { + OPM_SymWInt(typ->size); + } + } else { + OPM_SymWInt(34); + typ->ref = OPT_expCtxt.ref; + OPT_expCtxt.ref += 1; + if (OPT_expCtxt.ref >= 255) { + OPT_err(228); + } + OPT_OutMod(typ->mno); + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_OutName((void*)strobj->name, 256); + switch (strobj->history) { + case 2: + OPT_FPrintErr(strobj, 252); + break; + case 3: + OPT_FPrintErr(strobj, 251); + break; + case 5: + OPT_FPrintErr(strobj, 249); + break; + default: + break; + } + } else { + OPM_SymWCh(0x00); + } + if (typ->sysflag != 0) { + OPM_SymWInt(35); + OPM_SymWInt(typ->sysflag); + } + switch (typ->form) { + case 11: + OPM_SymWInt(36); + OPT_OutStr(typ->BaseTyp); + break; + case 12: + OPM_SymWInt(40); + OPT_OutSign(typ->BaseTyp, typ->link); + break; + case 13: + switch (typ->comp) { + case 2: + OPM_SymWInt(37); + OPT_OutStr(typ->BaseTyp); + OPM_SymWInt(typ->n); + break; + case 3: + OPM_SymWInt(38); + OPT_OutStr(typ->BaseTyp); + break; + case 4: + OPM_SymWInt(39); + if (typ->BaseTyp == NIL) { + OPT_OutStr(OPT_notyp); + } else { + OPT_OutStr(typ->BaseTyp); + } + OPM_SymWInt(typ->size); + OPM_SymWInt(typ->align); + OPM_SymWInt(typ->n); + OPT_nofhdfld = 0; + OPT_OutFlds(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(223, typ->txtpos); + } + OPT_OutTProcs(typ, typ->link); + OPM_SymWInt(18); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", 39); + OPM_LogWNum(typ->comp, 0); + OPM_LogWLn(); + break; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", 39); + OPM_LogWNum(typ->form, 0); + OPM_LogWLn(); + break; + } + } +} + +static void OPT_OutConstant (OPT_Object obj) +{ + INT16 f; + REAL rval; + f = obj->typ->form; + OPM_SymWInt(f); + switch (f) { + case 2: case 3: + OPM_SymWCh(__CHR(obj->conval->intval)); + break; + case 4: + OPM_SymWInt(obj->conval->intval); + OPM_SymWInt(obj->typ->size); + break; + case 7: + OPM_SymWSet(obj->conval->setval); + OPM_SymWInt(obj->typ->size); + break; + case 5: + rval = obj->conval->realval; + OPM_SymWReal(rval); + break; + case 6: + OPM_SymWLReal(obj->conval->realval); + break; + case 8: + OPT_OutName((void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } +} + +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_SymWCh(text[__X(i, text__len)]); + i += 1; + } + OPM_SymWCh(0x00); + __DEL(text); +} + +static void OPT_OutObj (OPT_Object obj) +{ + INT16 i, j; + OPT_ConstExt ext = NIL; + INT16 k, l; + if (obj != NIL) { + OPT_OutObj(obj->left); + if (__IN(obj->mode, 0x06ea, 32)) { + if (obj->comment != NIL) { + OPM_SymWInt(41); + k = 0; + while ((k < 255 && (*obj->comment)[__X(k, 256)] != 0x00)) { + k += 1; + } + OPM_SymWInt(k); + l = 0; + while (l < k) { + OPM_SymWCh((*obj->comment)[__X(l, 256)]); + l += 1; + } + } + if (obj->history == 4) { + OPT_FPrintErr(obj, 250); + } else if (obj->vis != 0) { + switch (obj->history) { + case 0: + OPT_FPrintErr(obj, 253); + break; + case 1: + break; + case 2: + OPT_FPrintErr(obj, 252); + break; + case 3: + OPT_FPrintErr(obj, 251); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", 42); + OPM_LogWNum(obj->history, 0); + OPM_LogWLn(); + break; + } + switch (obj->mode) { + case 3: + OPT_OutConstant(obj); + OPT_OutName((void*)obj->name, 256); + break; + case 5: + if (obj->typ->strobj == obj) { + OPM_SymWInt(19); + OPT_OutStr(obj->typ); + } else { + OPM_SymWInt(20); + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + } + break; + case 1: + if (obj->vis == 2) { + OPM_SymWInt(22); + } else { + OPM_SymWInt(21); + } + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + if (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00) { + OPM_FPrint(&OPT_expCtxt.reffp, obj->typ->ref); + } + break; + case 7: + OPM_SymWInt(31); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 10: + OPM_SymWInt(32); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 9: + OPM_SymWInt(33); + OPT_OutSign(obj->typ, obj->link); + ext = obj->conval->ext; + j = (INT16)(*ext)[0]; + i = 1; + OPM_SymWInt(j); + while (i <= j) { + OPM_SymWCh((*ext)[__X(i, 256)]); + i += 1; + } + OPT_OutName((void*)obj->name, 256); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", 38); + OPM_LogWNum(obj->mode, 0); + OPM_LogWLn(); + break; + } + } + } + OPT_OutObj(obj->right); + } +} + +void OPT_Export (BOOLEAN *ext, BOOLEAN *new) +{ + INT16 i; + INT8 nofmod; + BOOLEAN done; + OPT_symExtended = 0; + OPT_symNew = 0; + nofmod = OPT_nofGmod; + OPT_Import((CHAR*)"@self", OPT_SelfName, &done); + OPT_nofGmod = nofmod; + if (OPM_noerr) { + OPM_NewSym((void*)OPT_SelfName, 256); + if (OPM_noerr) { + OPM_SymWInt(16); + OPT_OutName((void*)OPT_SelfName, 256); + OPT_OutLinks(); + OPT_expCtxt.reffp = 0; + OPT_expCtxt.ref = 14; + OPT_expCtxt.nofm = 1; + OPT_expCtxt.locmno[0] = 0; + i = 1; + while (i < 64) { + OPT_expCtxt.locmno[__X(i, 64)] = -1; + i += 1; + } + OPT_OutObj(OPT_topScope->right); + *ext = (OPT_sfpresent && OPT_symExtended); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); + if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { + *new = 1; + if (!OPT_extsf) { + OPT_err(155); + } + } + OPT_newsf = 0; + OPT_symNew = 0; + if (!OPM_noerr || OPT_findpc) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } +} + +static void OPT_InitStruct (OPT_Struct *typ, INT8 form) +{ + *typ = OPT_NewStr(form, 1); + (*typ)->ref = form; + (*typ)->size = 1; + (*typ)->allocated = 1; + (*typ)->strobj = OPT_NewObj(); + (*typ)->pbfp = form; + (*typ)->pvfp = form; + (*typ)->fpdone = 1; + (*typ)->idfp = form; + (*typ)->idfpdone = 1; +} + +static void OPT_EnterBoolConst (OPS_Name name, INT32 value) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->conval = OPT_NewConst(); + obj->mode = 3; + obj->typ = OPT_booltyp; + obj->conval->intval = value; +} + +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + typ = OPT_NewStr(form, 1); + obj->mode = 5; + obj->typ = typ; + obj->vis = 1; + typ->strobj = obj; + typ->size = size; + typ->ref = form; + typ->allocated = 1; + typ->pbfp = form; + typ->pvfp = form; + typ->fpdone = 1; + typ->idfp = form; + typ->idfpdone = 1; + if (__IN(form, 0x90, 32)) { + OPM_FPrint(&typ->idfp, typ->size); + } + *res = typ; +} + +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 5; + obj->typ = NIL; + obj->vis = 1; + *res = obj; +} + +static void OPT_EnterProc (OPS_Name name, INT16 num) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 8; + obj->typ = OPT_notyp; + obj->adr = num; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPT_topScope); + P(OPT_undftyp); + P(OPT_niltyp); + P(OPT_notyp); + P(OPT_bytetyp); + P(OPT_cpbytetyp); + P(OPT_booltyp); + P(OPT_chartyp); + P(OPT_sinttyp); + P(OPT_inttyp); + P(OPT_linttyp); + P(OPT_hinttyp); + P(OPT_int8typ); + P(OPT_int16typ); + P(OPT_int32typ); + P(OPT_int64typ); + P(OPT_settyp); + P(OPT_set32typ); + P(OPT_set64typ); + P(OPT_realtyp); + P(OPT_lrltyp); + P(OPT_stringtyp); + P(OPT_adrtyp); + P(OPT_sysptrtyp); + P(OPT_sintobj); + P(OPT_intobj); + P(OPT_lintobj); + P(OPT_setobj); + __ENUMP(OPT_GlbMod, 64, P); + P(OPT_universe); + P(OPT_syslink); + __ENUMR(&OPT_impCtxt, OPT_ImpCtxt__typ, 3140, 1, P); + P(OPT_Links); +} + +__TDESC(OPT_ConstDesc, 1, 1) = {__TDFLDS("ConstDesc", 40), {0, -8}}; +__TDESC(OPT_ObjDesc, 1, 7) = {__TDFLDS("ObjDesc", 308), {0, 4, 8, 12, 284, 288, 304, -32}}; +__TDESC(OPT_StrDesc, 1, 3) = {__TDFLDS("StrDesc", 56), {44, 48, 52, -16}}; +__TDESC(OPT_NodeDesc, 1, 6) = {__TDFLDS("NodeDesc", 28), {0, 4, 8, 16, 20, 24, -28}}; +__TDESC(OPT_ImpCtxt, 1, 510) = {__TDFLDS("ImpCtxt", 3140), {16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60, 64, 68, 72, 76, + 80, 84, 88, 92, 96, 100, 104, 108, 112, 116, 120, 124, 128, 132, 136, 140, + 144, 148, 152, 156, 160, 164, 168, 172, 176, 180, 184, 188, 192, 196, 200, 204, + 208, 212, 216, 220, 224, 228, 232, 236, 240, 244, 248, 252, 256, 260, 264, 268, + 272, 276, 280, 284, 288, 292, 296, 300, 304, 308, 312, 316, 320, 324, 328, 332, + 336, 340, 344, 348, 352, 356, 360, 364, 368, 372, 376, 380, 384, 388, 392, 396, + 400, 404, 408, 412, 416, 420, 424, 428, 432, 436, 440, 444, 448, 452, 456, 460, + 464, 468, 472, 476, 480, 484, 488, 492, 496, 500, 504, 508, 512, 516, 520, 524, + 528, 532, 536, 540, 544, 548, 552, 556, 560, 564, 568, 572, 576, 580, 584, 588, + 592, 596, 600, 604, 608, 612, 616, 620, 624, 628, 632, 636, 640, 644, 648, 652, + 656, 660, 664, 668, 672, 676, 680, 684, 688, 692, 696, 700, 704, 708, 712, 716, + 720, 724, 728, 732, 736, 740, 744, 748, 752, 756, 760, 764, 768, 772, 776, 780, + 784, 788, 792, 796, 800, 804, 808, 812, 816, 820, 824, 828, 832, 836, 840, 844, + 848, 852, 856, 860, 864, 868, 872, 876, 880, 884, 888, 892, 896, 900, 904, 908, + 912, 916, 920, 924, 928, 932, 936, 940, 944, 948, 952, 956, 960, 964, 968, 972, + 976, 980, 984, 988, 992, 996, 1000, 1004, 1008, 1012, 1016, 1020, 1024, 1028, 1032, 1036, + 1040, 1044, 1048, 1052, 1056, 1060, 1064, 1068, 1072, 1076, 1080, 1084, 1088, 1092, 1096, 1100, + 1104, 1108, 1112, 1116, 1120, 1124, 1128, 1132, 1136, 1140, 1144, 1148, 1152, 1156, 1160, 1164, + 1168, 1172, 1176, 1180, 1184, 1188, 1192, 1196, 1200, 1204, 1208, 1212, 1216, 1220, 1224, 1228, + 1232, 1236, 1240, 1244, 1248, 1252, 1256, 1260, 1264, 1268, 1272, 1276, 1280, 1284, 1288, 1292, + 1296, 1300, 1304, 1308, 1312, 1316, 1320, 1324, 1328, 1332, 1336, 1340, 1344, 1348, 1352, 1356, + 1360, 1364, 1368, 1372, 1376, 1380, 1384, 1388, 1392, 1396, 1400, 1404, 1408, 1412, 1416, 1420, + 1424, 1428, 1432, 1436, 1440, 1444, 1448, 1452, 1456, 1460, 1464, 1468, 1472, 1476, 1480, 1484, + 1488, 1492, 1496, 1500, 1504, 1508, 1512, 1516, 1520, 1524, 1528, 1532, 1536, 1540, 1544, 1548, + 1552, 1556, 1560, 1564, 1568, 1572, 1576, 1580, 1584, 1588, 1592, 1596, 1600, 1604, 1608, 1612, + 1616, 1620, 1624, 1628, 1632, 1636, 1640, 1644, 1648, 1652, 1656, 1660, 1664, 1668, 1672, 1676, + 1680, 1684, 1688, 1692, 1696, 1700, 1704, 1708, 1712, 1716, 1720, 1724, 1728, 1732, 1736, 1740, + 1744, 1748, 1752, 1756, 1760, 1764, 1768, 1772, 1776, 1780, 1784, 1788, 1792, 1796, 1800, 1804, + 1808, 1812, 1816, 1820, 1824, 1828, 1832, 1836, 1840, 1844, 1848, 1852, 1856, 1860, 1864, 1868, + 1872, 1876, 1880, 1884, 1888, 1892, 1896, 1900, 1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, + 1936, 1940, 1944, 1948, 1952, 1956, 1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, + 2000, 2004, 2008, 2012, 2016, 2020, 2024, 2028, 2032, 2036, 2040, 2044, 2048, 2052, -2044}}; +__TDESC(OPT_ExpCtxt, 1, 0) = {__TDFLDS("ExpCtxt", 72), {-4}}; +__TDESC(OPT_LinkDesc, 1, 1) = {__TDFLDS("LinkDesc", 260), {256, -8}}; + +export void *OPT__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __REGMOD("OPT", EnumPtrs); + __REGCMD("Close", OPT_Close); + __REGCMD("CloseScope", OPT_CloseScope); + __REGCMD("InitRecno", OPT_InitRecno); + __INITYP(OPT_ConstDesc, OPT_ConstDesc, 0); + __INITYP(OPT_ObjDesc, OPT_ObjDesc, 0); + __INITYP(OPT_StrDesc, OPT_StrDesc, 0); + __INITYP(OPT_NodeDesc, OPT_NodeDesc, 0); + __INITYP(OPT_ImpCtxt, OPT_ImpCtxt, 0); + __INITYP(OPT_ExpCtxt, OPT_ExpCtxt, 0); + __INITYP(OPT_LinkDesc, OPT_LinkDesc, 0); +/* BEGIN */ + OPT_topScope = NIL; + OPT_OpenScope(0, NIL); + OPM_errpos = 0; + OPT_InitStruct(&OPT_undftyp, 0); + OPT_undftyp->BaseTyp = OPT_undftyp; + OPT_InitStruct(&OPT_notyp, 10); + OPT_InitStruct(&OPT_stringtyp, 8); + OPT_InitStruct(&OPT_niltyp, 9); + OPT_EnterTyp((CHAR*)"BYTE", 1, 1, &OPT_bytetyp); + OPT_EnterTyp((CHAR*)"PTR", 11, -1, &OPT_sysptrtyp); + OPT_EnterTyp((CHAR*)"ADDRESS", 4, -1, &OPT_adrtyp); + OPT_EnterTyp((CHAR*)"INT8", 4, 1, &OPT_int8typ); + OPT_EnterTyp((CHAR*)"INT16", 4, 2, &OPT_int16typ); + OPT_EnterTyp((CHAR*)"INT32", 4, 4, &OPT_int32typ); + OPT_EnterTyp((CHAR*)"INT64", 4, 8, &OPT_int64typ); + OPT_EnterTyp((CHAR*)"SET32", 7, 4, &OPT_set32typ); + OPT_EnterTyp((CHAR*)"SET64", 7, 8, &OPT_set64typ); + OPT_EnterProc((CHAR*)"ADR", 20); + OPT_EnterProc((CHAR*)"CC", 21); + OPT_EnterProc((CHAR*)"LSH", 22); + OPT_EnterProc((CHAR*)"ROT", 23); + OPT_EnterProc((CHAR*)"GET", 24); + OPT_EnterProc((CHAR*)"PUT", 25); + OPT_EnterProc((CHAR*)"GETREG", 26); + OPT_EnterProc((CHAR*)"PUTREG", 27); + OPT_EnterProc((CHAR*)"BIT", 28); + OPT_EnterProc((CHAR*)"VAL", 29); + OPT_EnterProc((CHAR*)"NEW", 30); + OPT_EnterProc((CHAR*)"MOVE", 31); + OPT_syslink = OPT_topScope->right; + OPT_universe = OPT_topScope; + OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, 1, &OPT_booltyp); + OPT_EnterTyp((CHAR*)"CHAR", 3, 1, &OPT_chartyp); + OPT_EnterTyp((CHAR*)"REAL", 5, 4, &OPT_realtyp); + OPT_EnterTyp((CHAR*)"LONGREAL", 6, 8, &OPT_lrltyp); + OPT_EnterTyp((CHAR*)"HUGEINT", 4, 8, &OPT_hinttyp); + OPT_EnterTyp((CHAR*)"BYTE@", 4, 1, &OPT_cpbytetyp); + OPT_EnterTypeAlias((CHAR*)"SHORTINT", &OPT_sintobj); + OPT_EnterTypeAlias((CHAR*)"INTEGER", &OPT_intobj); + OPT_EnterTypeAlias((CHAR*)"LONGINT", &OPT_lintobj); + OPT_EnterTypeAlias((CHAR*)"SET", &OPT_setobj); + OPT_EnterBoolConst((CHAR*)"FALSE", 0); + OPT_EnterBoolConst((CHAR*)"TRUE", 1); + OPT_EnterProc((CHAR*)"HALT", 0); + OPT_EnterProc((CHAR*)"NEW", 1); + OPT_EnterProc((CHAR*)"ABS", 2); + OPT_EnterProc((CHAR*)"CAP", 3); + OPT_EnterProc((CHAR*)"ORD", 4); + OPT_EnterProc((CHAR*)"ENTIER", 5); + OPT_EnterProc((CHAR*)"ODD", 6); + OPT_EnterProc((CHAR*)"MIN", 7); + OPT_EnterProc((CHAR*)"MAX", 8); + OPT_EnterProc((CHAR*)"CHR", 9); + OPT_EnterProc((CHAR*)"SHORT", 10); + OPT_EnterProc((CHAR*)"LONG", 11); + OPT_EnterProc((CHAR*)"SIZE", 12); + OPT_EnterProc((CHAR*)"INC", 13); + OPT_EnterProc((CHAR*)"DEC", 14); + OPT_EnterProc((CHAR*)"INCL", 15); + OPT_EnterProc((CHAR*)"EXCL", 16); + OPT_EnterProc((CHAR*)"LEN", 17); + OPT_EnterProc((CHAR*)"COPY", 18); + OPT_EnterProc((CHAR*)"ASH", 19); + OPT_EnterProc((CHAR*)"ASSERT", 32); + OPT_impCtxt.ref[0] = OPT_undftyp; + OPT_impCtxt.ref[1] = OPT_bytetyp; + OPT_impCtxt.ref[2] = OPT_booltyp; + OPT_impCtxt.ref[3] = OPT_chartyp; + OPT_impCtxt.ref[4] = OPT_int32typ; + OPT_impCtxt.ref[5] = OPT_realtyp; + OPT_impCtxt.ref[6] = OPT_lrltyp; + OPT_impCtxt.ref[7] = OPT_settyp; + OPT_impCtxt.ref[8] = OPT_stringtyp; + OPT_impCtxt.ref[9] = OPT_niltyp; + OPT_impCtxt.ref[10] = OPT_notyp; + OPT_impCtxt.ref[11] = OPT_sysptrtyp; + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPT.h b/bootstrap/unix-48/OPT.h new file mode 100644 index 00000000..cf456af5 --- /dev/null +++ b/bootstrap/unix-48/OPT.h @@ -0,0 +1,128 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPT__h +#define OPT__h + +#include "SYSTEM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused; + char _prvt0[4]; + INT32 idfp; + char _prvt1[8]; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +import OPT_Object OPT_topScope; +import OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +import OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +import INT8 OPT_nofGmod; +import OPT_Object OPT_GlbMod[64]; +import OPS_Name OPT_SelfName; +import BOOLEAN OPT_SYSimported; +import OPT_Link OPT_Links; + +import ADDRESS *OPT_ConstDesc__typ; +import ADDRESS *OPT_ObjDesc__typ; +import ADDRESS *OPT_StrDesc__typ; +import ADDRESS *OPT_NodeDesc__typ; +import ADDRESS *OPT_LinkDesc__typ; + +import void OPT_Align (INT32 *adr, INT32 base); +import INT32 OPT_BaseAlignment (OPT_Struct typ); +import void OPT_Close (void); +import void OPT_CloseScope (void); +import void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +import void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +import void OPT_FPrintObj (OPT_Object obj); +import void OPT_FPrintStr (OPT_Struct typ); +import void OPT_Find (OPT_Object *res); +import void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +import void OPT_FindImport (OPT_Object mod, OPT_Object *res); +import void OPT_IdFPrint (OPT_Struct typ); +import void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +import void OPT_Init (OPS_Name name, UINT32 opt); +import void OPT_InitRecno (void); +import void OPT_Insert (OPS_Name name, OPT_Object *obj); +import void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +import INT16 OPT_IntSize (INT64 n); +import OPT_Struct OPT_IntType (INT32 size); +import OPT_Const OPT_NewConst (void); +import OPT_ConstExt OPT_NewExt (void); +import OPT_Node OPT_NewNode (INT8 class); +import OPT_Object OPT_NewObj (void); +import OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +import void OPT_OpenScope (INT8 level, OPT_Object owner); +import OPT_Struct OPT_SetType (INT32 size); +import OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +import INT32 OPT_SizeAlignment (INT32 size); +import void OPT_TypSize (OPT_Struct typ); +import void *OPT__init(void); + + +#endif // OPT diff --git a/bootstrap/unix-48/OPV.c b/bootstrap/unix-48/OPV.c new file mode 100644 index 00000000..0425b2e0 --- /dev/null +++ b/bootstrap/unix-48/OPV.c @@ -0,0 +1,1585 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPC.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +typedef + struct OPV_ExitInfo { + INT16 level, label; + } OPV_ExitInfo; + + +static INT16 OPV_stamp; +static OPV_ExitInfo OPV_exit; +static INT16 OPV_nofExitLabels; + +export ADDRESS *OPV_ExitInfo__typ; + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp); +export void OPV_AdrAndSize (OPT_Object topScope); +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec); +static void OPV_DefineTDescs (OPT_Node n); +static void OPV_Entier (OPT_Node n, INT16 prec); +static void OPV_GetTProcNum (OPT_Object obj); +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc); +static BOOLEAN OPV_ImplicitReturn (OPT_Node n); +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim); +export void OPV_Init (void); +static void OPV_InitTDescs (OPT_Node n); +static void OPV_Len (OPT_Node n, INT64 dim); +export void OPV_Module (OPT_Node prog); +static void OPV_NewArr (OPT_Node d, OPT_Node x); +static void OPV_ParIntLiteral (INT64 n, INT32 size); +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp); +static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (OPT_Node n, INT32 to); +static void OPV_Stamp (OPS_Name s); +static OPT_Object OPV_SuperProc (OPT_Node n); +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); +static void OPV_TraverseRecord (OPT_Struct typ); +static void OPV_TypeOf (OPT_Node n); +static void OPV_design (OPT_Node n, INT16 prec); +static void OPV_expr (OPT_Node n, INT16 prec); +static void OPV_stat (OPT_Node n, OPT_Object outerProc); + + +void OPV_Init (void) +{ + OPV_stamp = 0; + OPV_nofExitLabels = 0; +} + +static void OPV_GetTProcNum (OPT_Object obj) +{ + INT32 oldPos; + OPT_Struct typ = NIL; + OPT_Object redef = NIL; + oldPos = OPM_errpos; + OPM_errpos = obj->scope->adr; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(obj->name, typ->BaseTyp, &redef); + if (redef != NIL) { + obj->adr = __ASHL(__ASHR(redef->adr, 16), 16); + if (!__IN(2, obj->conval->setval, 64)) { + OPM_err(119); + } + } else { + obj->adr += __ASHL(typ->n, 16); + typ->n += 1; + } + OPM_errpos = oldPos; +} + +static void OPV_TraverseRecord (OPT_Struct typ) +{ + if (!typ->allocated) { + if (typ->BaseTyp != NIL) { + OPV_TraverseRecord(typ->BaseTyp); + typ->n = typ->BaseTyp->n; + } + typ->allocated = 1; + OPV_Traverse(typ->link, typ->strobj, 0); + } +} + +static void OPV_Stamp (OPS_Name s) +{ + INT16 i, j, k; + CHAR n[10]; + OPV_stamp += 1; + i = 0; + j = OPV_stamp; + while (s[__X(i, 256)] != 0x00) { + i += 1; + } + if (i > 25) { + i = 25; + } + s[__X(i, 256)] = '_'; + s[__X(i + 1, 256)] = '_'; + i += 2; + k = 0; + do { + n[__X(k, 10)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } while (!(j == 0)); + do { + k -= 1; + s[__X(i, 256)] = n[__X(k, 10)]; + i += 1; + } while (!(k == 0)); + s[__X(i, 256)] = 0x00; +} + +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported) +{ + INT16 mode; + OPT_Object scope = NIL; + OPT_Struct typ = NIL; + if (obj != NIL) { + OPV_Traverse(obj->left, outerScope, exported); + if (obj->name[0] == '@') { + obj->name[0] = '_'; + OPV_Stamp(obj->name); + } + obj->linkadr = 0; + mode = obj->mode; + if ((mode == 5 && (obj->vis != 0) == exported)) { + typ = obj->typ; + OPT_TypSize(obj->typ); + if (typ->form == 11) { + typ = typ->BaseTyp; + } + if (typ->comp == 4) { + OPV_TraverseRecord(typ); + } + } else if (mode == 13) { + OPV_GetTProcNum(obj); + } else if (mode == 1) { + OPT_TypSize(obj->typ); + } + if (!exported) { + if ((__IN(mode, 0x60, 32) && obj->mnolev > 0)) { + OPV_Stamp(obj->name); + } + if (__IN(mode, 0x26, 32)) { + obj->scope = outerScope; + } else if (__IN(mode, 0x26c0, 32)) { + if (obj->conval->setval == 0x0) { + OPM_err(129); + } + scope = obj->scope; + scope->leaf = 1; + __MOVE(obj->name, scope->name, 256); + OPV_Stamp(scope->name); + if (mode == 9) { + obj->adr = 1; + } + if (scope->mnolev > 1) { + outerScope->leaf = 0; + } + OPV_Traverse(obj->scope->right, obj->scope, 0); + } + } + OPV_Traverse(obj->right, outerScope, exported); + } +} + +void OPV_AdrAndSize (OPT_Object topScope) +{ + __ASSERT(OPT_sinttyp != NIL, 0); + __ASSERT(OPT_inttyp != NIL, 0); + __ASSERT(OPT_linttyp != NIL, 0); + OPM_errpos = topScope->adr; + topScope->leaf = 1; + OPV_Traverse(topScope->right, topScope, 1); + OPV_Traverse(topScope->right, topScope, 0); + OPT_chartyp->strobj->linkadr = 2; + OPT_cpbytetyp->strobj->linkadr = 2; + OPT_settyp->strobj->linkadr = 2; + OPT_realtyp->strobj->linkadr = 2; + OPT_adrtyp->strobj->linkadr = 2; + OPT_int8typ->strobj->linkadr = 2; + OPT_int16typ->strobj->linkadr = 2; + OPT_int32typ->strobj->linkadr = 2; + OPT_int64typ->strobj->linkadr = 2; + OPT_set32typ->strobj->linkadr = 2; + OPT_set64typ->strobj->linkadr = 2; + OPT_hinttyp->strobj->linkadr = 2; + OPT_lrltyp->strobj->linkadr = 2; + OPT_booltyp->strobj->linkadr = 2; + OPT_bytetyp->strobj->linkadr = 2; + OPT_sysptrtyp->strobj->linkadr = 2; +} + +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp) +{ + switch (class) { + case 7: case 0: case 2: case 4: case 9: + case 13: + return 10; + break; + case 5: + if (__IN(3, OPM_Options, 32)) { + return 10; + } else { + return 9; + } + break; + case 1: + if (__IN(comp, 0x0c, 32)) { + return 10; + } else { + return 9; + } + break; + case 3: + return 9; + break; + case 11: + switch (subclass) { + case 33: case 7: case 24: case 29: case 20: + return 9; + break; + case 16: case 21: case 22: case 23: case 25: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 12: + switch (subclass) { + case 1: + if (form == 7) { + return 4; + } else { + return 8; + } + break; + case 2: + if (form == 7) { + return 3; + } else { + return 8; + } + break; + case 3: case 4: + return 10; + break; + case 6: + if (form == 7) { + return 2; + } else { + return 7; + } + break; + case 7: + if (form == 7) { + return 4; + } else { + return 7; + } + break; + case 11: case 12: case 13: case 14: + return 6; + break; + case 9: case 10: + return 5; + break; + case 5: + return 1; + break; + case 8: + return 0; + break; + case 19: case 15: case 17: case 18: case 26: + case 27: case 28: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 10: + return 10; + break; + case 8: case 6: + return 12; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence, class = ", 43); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + __RETCHK; +} + +static void OPV_Len (OPT_Node n, INT64 dim) +{ + INT64 d; + OPT_Struct array = NIL; + while ((n->class == 4 && n->typ->comp == 3)) { + dim += 1; + n = n->left; + } + if ((n->class == 3 && n->typ->comp == 3)) { + d = dim; + array = n->typ; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->len[", 7); + OPM_WriteInt(dim); + OPM_Write(']'); + } else { + OPM_WriteInt(array->n); + } + } else { + OPC_Len(n->obj, n->typ, dim); + } +} + +static BOOLEAN OPV_SideEffects (OPT_Node n) +{ + if (n != NIL) { + return (n->class == 13 || OPV_SideEffects(n->left)) || OPV_SideEffects(n->right); + } else { + return 0; + } + __RETCHK; +} + +static void OPV_Entier (OPT_Node n, INT16 prec) +{ + if (__IN(n->typ->form, 0x60, 32)) { + OPM_WriteString((CHAR*)"__ENTIER(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else { + OPV_expr(n, prec); + } +} + +static void OPV_SizeCast (OPT_Node n, INT32 to) +{ + if ((to < n->typ->size && __IN(2, OPM_Options, 32))) { + OPM_WriteString((CHAR*)"__SHORT", 8); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPM_SignedMaximum(to) + 1); + OPM_Write(')'); + } else { + if ((n->typ->size != to && (n->typ->size > 4 || to != 4))) { + OPM_WriteString((CHAR*)"(INT", 5); + OPM_WriteInt(__ASHL(to, 3)); + OPM_WriteString((CHAR*)")", 2); + } + OPV_Entier(n, 9); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec) +{ + INT16 from, to; + from = n->typ->form; + to = newtype->form; + if (to == 7) { + if (from == 7) { + OPV_SizeCast(n, newtype->size); + } else { + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(newtype->size, 3)); + OPM_Write(')'); + } + } else if (to == 4) { + OPV_SizeCast(n, newtype->size); + } else if (to == 3) { + if (__IN(2, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__CHR", 6); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_Write(')'); + } else { + OPM_WriteString((CHAR*)"(CHAR)", 7); + OPV_Entier(n, 9); + } + } else { + OPV_expr(n, prec); + } +} + +static void OPV_TypeOf (OPT_Node n) +{ + if (n->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else if (__IN(n->class, 0x15, 32)) { + OPC_Andent(n->typ); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (n->class == 3) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n->left, -1); + OPM_Write(')'); + } else if (n->class == 5) { + OPV_TypeOf(n->left); + } else if ((n->class == 11 && n->subcl == 29)) { + OPC_TypeOf(n->left->obj); + } else { + OPC_TypeOf(n->obj); + } +} + +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim) +{ + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + OPV_expr(n->right, prec); + } else { + if (OPV_SideEffects(n->right)) { + OPM_WriteString((CHAR*)"__XF(", 6); + } else { + OPM_WriteString((CHAR*)"__X(", 5); + } + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(d, dim); + OPM_Write(')'); + } +} + +static void OPV_design (OPT_Node n, INT16 prec) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT16 class, designPrec, comp; + OPT_Node d = NIL, x = NIL; + INT16 dims, i, _for__26; + comp = n->typ->comp; + obj = n->obj; + class = n->class; + designPrec = OPV_Precedence(class, n->subcl, n->typ->form, comp); + if ((((((class == 0 && obj->mnolev > 0)) && (INT16)obj->mnolev != OPM_level)) && prec == 10)) { + designPrec = 9; + } + if (prec > designPrec) { + OPM_Write('('); + } + if (prec == 11) { + OPM_Write('*'); + } + switch (class) { + case 9: + OPC_Ident(n->obj); + break; + case 0: + OPC_CompleteIdent(n->obj); + break; + case 1: + if (!__IN(comp, 0x0c, 32)) { + OPM_Write('*'); + } + OPC_CompleteIdent(n->obj); + break; + case 2: + if (n->left->class == 3) { + OPV_design(n->left->left, designPrec); + OPM_WriteString((CHAR*)"->", 3); + } else { + OPV_design(n->left, designPrec); + OPM_Write('.'); + } + OPC_Ident(n->obj); + break; + case 3: + if (n->typ->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->data", 7); + } else { + OPM_Write('*'); + OPV_design(n->left, designPrec); + } + break; + case 4: + d = n->left; + if (d->typ->comp == 3) { + dims = 0; + while (d->class == 4) { + d = d->left; + dims += 1; + } + if (n->typ->comp == 3) { + OPM_Write('&'); + } + OPV_design(d, designPrec); + OPM_Write('['); + if (n->typ->comp == 3) { + OPM_Write('('); + } + i = dims; + x = n; + while (x != d) { + if (x->left != d) { + OPV_Index(x, d, 7, i); + OPM_WriteString((CHAR*)" + ", 4); + OPV_Len(d, i); + OPM_WriteString((CHAR*)" * (", 5); + i -= 1; + } else { + OPV_Index(x, d, -1, i); + } + x = x->left; + } + _for__26 = dims; + i = 1; + while (i <= _for__26) { + OPM_Write(')'); + i += 1; + } + if (n->typ->comp == 3) { + OPM_Write(')'); + while (i < __ASHR(d->typ->size - 4, 2)) { + OPM_WriteString((CHAR*)" * ", 4); + OPV_Len(d, i); + i += 1; + } + } + OPM_Write(']'); + } else { + OPV_design(n->left, designPrec); + OPM_Write('['); + OPV_Index(n, n->left, -1, 0); + OPM_Write(']'); + } + break; + case 5: + typ = n->typ; + obj = n->left->obj; + if (__IN(3, OPM_Options, 32)) { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__GUARDR(", 10); + if ((INT16)obj->mnolev != OPM_level) { + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"__curr->", 9); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } + } else { + if (typ->BaseTyp->strobj == NIL) { + OPM_WriteString((CHAR*)"__GUARDA(", 10); + } else { + OPM_WriteString((CHAR*)"__GUARDP(", 10); + } + OPV_expr(n->left, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + } else { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + OPC_CompleteIdent(obj); + } else { + OPM_Write('('); + OPC_Ident(typ->strobj); + OPM_Write(')'); + OPV_expr(n->left, designPrec); + } + } + break; + case 6: + if (__IN(3, OPM_Options, 32)) { + if (n->left->class == 1) { + OPM_WriteString((CHAR*)"__GUARDEQR(", 12); + OPC_CompleteIdent(n->left->obj); + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n->left); + } else { + OPM_WriteString((CHAR*)"__GUARDEQP(", 12); + OPV_expr(n->left->left, -1); + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + } else { + OPV_expr(n->left, -1); + } + break; + case 11: + if (n->subcl == 29) { + OPV_design(n->left, prec); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.design, class = ", 39); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + if (prec > designPrec) { + OPM_Write(')'); + } +} + +static void OPV_ParIntLiteral (INT64 n, INT32 size) +{ + OPM_WriteInt(n); +} + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp) +{ + OPT_Struct typ = NIL, aptyp = NIL; + INT16 comp, form, mode, prec, dim; + OPM_Write('('); + while (n != NIL) { + typ = fp->typ; + comp = typ->comp; + form = typ->form; + mode = fp->mode; + prec = -1; + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + prec = 10; + } + if (!__IN(n->typ->comp, 0x0c, 32)) { + if (mode == 2) { + if (typ != n->typ) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPM_Write('&'); + prec = 9; + } else { + if ((__IN(comp, 0x0c, 32) && n->class == 7)) { + OPM_WriteString((CHAR*)"(CHAR*)", 8); + } else if ((((form == 11 && typ != n->typ)) && n->typ != OPT_niltyp)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + } else { + if ((((mode == 2 && typ != n->typ)) && prec == -1)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPV_expr(n->left, prec); + } else if ((form == 4 && n->class == 7)) { + OPV_ParIntLiteral(n->conval->intval, n->typ->size); + } else { + OPV_expr(n, prec); + } + if ((comp == 4 && mode == 2)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n); + } else if (comp == 3) { + if (n->class == 7) { + OPM_WriteString((CHAR*)", ", 3); + OPV_ParIntLiteral(n->conval->intval2, OPM_AddressSize); + } else { + aptyp = n->typ; + dim = 0; + while ((typ->comp == 3 && typ->BaseTyp->form != 1)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n, dim); + typ = typ->BaseTyp; + aptyp = aptyp->BaseTyp; + dim += 1; + } + if ((typ->comp == 3 && typ->BaseTyp->form == 1)) { + OPM_WriteString((CHAR*)", ", 3); + while (aptyp->comp == 3) { + OPV_Len(n, dim); + OPM_WriteString((CHAR*)" * ", 4); + dim += 1; + aptyp = aptyp->BaseTyp; + } + OPV_ParIntLiteral(aptyp->size, OPM_AddressSize); + } + } + } + n = n->link; + fp = fp->link; + if (n != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static OPT_Object OPV_SuperProc (OPT_Node n) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + typ = n->right->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(n->left->obj->name, typ->BaseTyp, &obj); + return obj; +} + +static void OPV_expr (OPT_Node n, INT16 prec) +{ + INT16 class, subclass, form, exprPrec; + OPT_Struct typ = NIL; + OPT_Node l = NIL, r = NIL; + OPT_Object proc = NIL; + class = n->class; + subclass = n->subcl; + form = n->typ->form; + l = n->left; + r = n->right; + exprPrec = OPV_Precedence(class, subclass, form, n->typ->comp); + if ((exprPrec <= prec && __IN(class, 0x3ce0, 32))) { + OPM_Write('('); + } + switch (class) { + case 7: + OPC_Constant(n->conval, form); + break; + case 10: + OPM_WriteString((CHAR*)"__SETRNG(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(__ASHL(n->typ->size, 3)); + OPM_Write(')'); + break; + case 11: + switch (subclass) { + case 33: + OPM_Write('!'); + OPV_expr(l, exprPrec); + break; + case 7: + if (form == 7) { + OPM_Write('~'); + } else { + OPM_Write('-'); + } + OPV_expr(l, exprPrec); + break; + case 16: + typ = n->obj->typ; + if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"__IS(", 6); + OPC_TypeOf(l->obj); + } else { + OPM_WriteString((CHAR*)"__ISP(", 7); + OPV_expr(l, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + break; + case 20: + OPV_Convert(l, n->typ, exprPrec); + break; + case 21: + if (OPV_SideEffects(l)) { + if (l->typ->form < 5) { + if (l->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__ABSF(", 8); + } else { + OPM_WriteString((CHAR*)"__ABSFD(", 9); + } + } else { + OPM_WriteString((CHAR*)"__ABS(", 7); + } + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 22: + OPM_WriteString((CHAR*)"__CAP(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 23: + OPM_WriteString((CHAR*)"__ODD(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + if (l->class == 1) { + OPC_CompleteIdent(l->obj); + } else { + if ((l->typ->form != 8 && !__IN(l->typ->comp, 0x0c, 32))) { + OPM_Write('&'); + } + OPV_expr(l, exprPrec); + } + break; + case 29: + if (!__IN(l->class, 0x17, 32) || (((__IN(n->typ->form, 0x1890, 32) && __IN(l->typ->form, 0x1890, 32))) && n->typ->size == l->typ->size)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + if (__IN(n->typ->form, 0x1800, 32) || __IN(l->typ->form, 0x1800, 32)) { + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + } + OPV_expr(l, exprPrec); + } else { + OPM_WriteString((CHAR*)"__VAL(", 7); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_Write(')'); + } + break; + default: + OPM_err(200); + break; + } + break; + case 12: + switch (subclass) { + case 19: + OPV_Len(l, r->conval->intval); + break; + case 15: case 17: case 18: case 26: case 27: + case 28: case 3: case 4: + switch (subclass) { + case 15: + OPM_WriteString((CHAR*)"__IN(", 6); + break; + case 17: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ASHL(", 8); + } else { + OPM_WriteString((CHAR*)"__ASHR(", 8); + } + } else if (OPV_SideEffects(r)) { + OPM_WriteString((CHAR*)"__ASHF(", 8); + } else { + OPM_WriteString((CHAR*)"__ASH(", 7); + } + break; + case 18: + OPM_WriteString((CHAR*)"__MASK(", 8); + break; + case 26: + OPM_WriteString((CHAR*)"__BIT(", 7); + break; + case 27: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__LSHL(", 8); + } else { + OPM_WriteString((CHAR*)"__LSHR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__LSH(", 7); + } + break; + case 28: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ROTL(", 8); + } else { + OPM_WriteString((CHAR*)"__ROTR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__ROT(", 7); + } + break; + case 3: + if (OPV_SideEffects(n)) { + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__DIVF(", 8); + } else { + OPM_WriteString((CHAR*)"__DIV(", 7); + } + break; + case 4: + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + if (OPV_SideEffects(n)) { + OPM_WriteString((CHAR*)"__MODF(", 8); + } else { + OPM_WriteString((CHAR*)"__MOD(", 7); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if ((((__IN(subclass, 0x18020000, 32) && r->class == 7)) && r->conval->intval < 0)) { + OPM_WriteInt(-r->conval->intval); + } else { + OPV_expr(r, -1); + } + if (__IN(subclass, 0x18008000, 32)) { + OPM_WriteString((CHAR*)", ", 3); + if (subclass == 15) { + OPM_WriteInt(__ASHL(r->typ->size, 3)); + } else { + OPM_WriteInt(__ASHL(l->typ->size, 3)); + } + } + OPM_Write(')'); + break; + case 9: case 10: case 11: case 12: case 13: + case 14: + if (__IN(l->typ->form, 0x2100, 32)) { + OPM_WriteString((CHAR*)"__STRCMP(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_Write(')'); + OPC_Cmp(subclass); + OPM_Write('0'); + } else { + OPV_expr(l, exprPrec); + OPC_Cmp(subclass); + typ = l->typ; + if ((((((typ->form == 11 && r->typ->form != 9)) && r->typ != typ)) && r->typ != OPT_sysptrtyp)) { + OPM_WriteString((CHAR*)"(void *) ", 10); + } + OPV_expr(r, exprPrec); + } + break; + default: + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write('('); + } + OPV_expr(l, exprPrec); + switch (subclass) { + case 1: + if (form == 7) { + OPM_WriteString((CHAR*)" & ", 4); + } else { + OPM_WriteString((CHAR*)" * ", 4); + } + break; + case 2: + if (form == 7) { + OPM_WriteString((CHAR*)" ^ ", 4); + } else { + OPM_WriteString((CHAR*)" / ", 4); + if (r->obj == NIL || r->obj->typ->form == 4) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + } + } + break; + case 5: + OPM_WriteString((CHAR*)" && ", 5); + break; + case 6: + if (form == 7) { + OPM_WriteString((CHAR*)" | ", 4); + } else { + OPM_WriteString((CHAR*)" + ", 4); + } + break; + case 7: + if (form == 7) { + OPM_WriteString((CHAR*)" & ~", 5); + } else { + OPM_WriteString((CHAR*)" - ", 4); + } + break; + case 8: + OPM_WriteString((CHAR*)" || ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(r, exprPrec); + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write(')'); + } + break; + } + break; + case 13: + if ((l->obj != NIL && l->obj->mode == 13)) { + if (l->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(l->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (l->class == 9) { + OPV_design(l, 10); + } else { + OPV_design(l, 11); + } + OPV_ActualPar(r, n->obj); + break; + default: + OPV_design(n, prec); + break; + } + if ((exprPrec <= prec && __IN(class, 0x3ca0, 32))) { + OPM_Write(')'); + } +} + +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc) +{ + OPT_Node if_ = NIL; + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT32 adr; + if_ = n->left; + while (if_ != NIL) { + OPM_WriteString((CHAR*)"if ", 4); + OPV_expr(if_->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + if ((n->class == 27 && if_->left->left != NIL)) { + obj = if_->left->left->obj; + typ = obj->typ; + adr = obj->adr; + if (typ->comp == 4) { + OPC_BegStat(); + OPC_Ident(if_->left->obj); + OPM_WriteString((CHAR*)" *", 3); + OPM_WriteString(obj->name, 256); + OPM_WriteString((CHAR*)"__ = (void*)", 13); + obj->adr = 0; + OPC_CompleteIdent(obj); + OPC_EndStat(); + } + obj->adr = 1; + obj->typ = if_->left->obj->typ; + OPV_stat(if_->right, outerProc); + obj->typ = typ; + obj->adr = adr; + } else { + OPV_stat(if_->right, outerProc); + } + if_ = if_->link; + if ((if_ != NIL || n->right != NIL) || withtrap) { + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" else ", 7); + } else { + OPC_EndBlk(); + } + } + if (withtrap) { + OPM_WriteString((CHAR*)"__WITHCHK", 10); + OPC_EndStat(); + } else if (n->right != NIL) { + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + } +} + +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Node switchCase = NIL, label = NIL; + INT64 low, high; + INT16 form, i; + OPM_WriteString((CHAR*)"switch ", 8); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + form = n->left->typ->form; + switchCase = n->right->left; + while (switchCase != NIL) { + label = switchCase->left; + i = 0; + while (label != NIL) { + low = label->conval->intval; + high = label->conval->intval2; + while (low <= high) { + if (i == 0) { + OPC_BegStat(); + } + OPC_Case(low, form); + low += 1; + i += 1; + if (i == 5) { + OPM_WriteLn(); + i = 0; + } + } + label = label->link; + } + if (i > 0) { + OPM_WriteLn(); + } + OPC_Indent(1); + OPV_stat(switchCase->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_EndStat(); + OPC_Indent(-1); + switchCase = switchCase->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"default: ", 10); + if (n->right->conval->setval != 0x0) { + OPC_Indent(1); + OPM_WriteLn(); + OPV_stat(n->right->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_Indent(-1); + } else { + OPM_WriteString((CHAR*)"__CASECHK", 10); + } + OPC_EndStat(); + OPC_EndBlk(); +} + +static BOOLEAN OPV_ImplicitReturn (OPT_Node n) +{ + while ((n != NIL && n->class != 26)) { + n = n->link; + } + return n == NIL; +} + +static void OPV_NewArr (OPT_Node d, OPT_Node x) +{ + OPT_Struct typ = NIL, base = NIL; + INT16 nofdim, nofdyn; + typ = d->typ->BaseTyp; + base = typ; + nofdim = 0; + nofdyn = 0; + while (base->comp == 3) { + nofdim += 1; + nofdyn += 1; + base = base->BaseTyp; + } + OPV_design(d, -1); + OPM_WriteString((CHAR*)" = __NEWARR(", 13); + while (base->comp == 2) { + nofdim += 1; + base = base->BaseTyp; + } + if ((base->comp == 4 && OPC_NofPtrs(base) != 0)) { + OPC_Andent(base); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (base->form == 11) { + OPM_WriteString((CHAR*)"POINTER__typ", 13); + } else { + OPM_WriteString((CHAR*)"NIL", 4); + } + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(base->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPT_BaseAlignment(base)); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdim); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdyn); + while (typ != base) { + OPM_WriteString((CHAR*)", ", 3); + if (typ->comp == 3) { + if (x->class == 7) { + OPC_IntLiteral(x->conval->intval, OPM_AddressSize); + } else { + OPM_WriteString((CHAR*)"((ADDRESS)(", 12); + OPV_expr(x, 10); + OPM_WriteString((CHAR*)"))", 3); + } + x = x->link; + } else { + OPC_IntLiteral(typ->n, OPM_AddressSize); + } + typ = typ->BaseTyp; + } + OPM_Write(')'); +} + +static void OPV_DefineTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_TDescDecl(n->typ); + n = n->link; + } +} + +static void OPV_InitTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_InitTDesc(n->typ); + n = n->link; + } +} + +static void OPV_stat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Object proc = NIL; + OPV_ExitInfo saved; + OPT_Node l = NIL, r = NIL; + while ((n != NIL && OPM_noerr)) { + OPM_errpos = OPM_Longint(n->conval->intval); + if (n->class != 14) { + OPC_BegStat(); + } + switch (n->class) { + case 18: + if (n->obj == NIL) { + OPM_level += 1; + OPV_stat(n->left, outerProc); + OPM_level -= 1; + OPC_GenEnumPtrs(OPT_topScope->scope); + OPV_DefineTDescs(n->right); + OPC_EnterBody(); + OPV_InitTDescs(n->right); + OPM_WriteString((CHAR*)"/* BEGIN */", 12); + OPM_WriteLn(); + OPV_stat(n->right, outerProc); + OPC_ExitBody(); + } else { + proc = n->obj; + OPC_TypeDefs(proc->scope->right, 0); + if (!proc->scope->leaf) { + OPC_DefineInter(proc); + } + OPM_level += 1; + OPV_stat(n->left, proc); + OPM_level -= 1; + OPC_EnterProc(proc); + OPV_stat(n->right, proc); + OPC_ExitProc(proc, 1, OPV_ImplicitReturn(n->right)); + } + break; + case 14: + break; + case 19: + switch (n->subcl) { + case 0: + l = n->left; + r = n->right; + if (l->typ->comp == 2) { + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if (r->typ == OPT_stringtyp) { + OPM_WriteInt(r->conval->intval2); + } else if (r->typ->comp == 3) { + OPM_WriteString((CHAR*)"__X(", 5); + OPC_Len(r->obj, r->typ, 0); + OPM_WriteString((CHAR*)" * ", 4); + OPM_WriteInt(r->typ->BaseTyp->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(l->typ->size + 1); + OPM_Write(')'); + } else { + __ASSERT(r->typ->comp == 2, 0); + __ASSERT(r->typ->size <= l->typ->size, 0); + OPM_WriteInt(r->typ->size); + } + OPM_Write(')'); + } else { + if ((((((l->typ->form == 11 && l->obj != NIL)) && l->obj->adr == 1)) && l->obj->mode == 1)) { + l->obj->adr = 0; + OPV_design(l, -1); + l->obj->adr = 1; + if (r->typ->form != 9) { + OPM_WriteString((CHAR*)" = (void*)", 11); + } else { + OPM_WriteString((CHAR*)" = ", 4); + } + } else { + OPV_design(l, -1); + OPM_WriteString((CHAR*)" = ", 4); + } + if (l->typ == r->typ) { + OPV_expr(r, -1); + } else if ((((l->typ->form == 11 && r->typ->form != 9)) && l->typ->strobj != NIL)) { + OPM_Write('('); + OPC_Ident(l->typ->strobj); + OPM_Write(')'); + OPV_expr(r, -1); + } else if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Andent(l->typ); + OPM_WriteString((CHAR*)"*)&", 4); + OPV_expr(r, 9); + } else { + OPV_expr(r, -1); + } + } + break; + case 1: + if (n->left->typ->BaseTyp->comp == 4) { + OPM_WriteString((CHAR*)"__NEW(", 7); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(n->left->typ->BaseTyp); + OPM_WriteString((CHAR*)")", 2); + } else if (__IN(n->left->typ->BaseTyp->comp, 0x0c, 32)) { + OPV_NewArr(n->left, n->right); + } + break; + case 13: case 14: + OPV_expr(n->left, -1); + OPC_Increment(n->subcl == 14); + OPV_expr(n->right, -1); + break; + case 15: case 16: + OPV_expr(n->left, -1); + OPC_SetInclude(n->subcl == 16); + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(n->left->typ->size, 3)); + OPM_Write(')'); + break; + case 18: + OPM_WriteString((CHAR*)"__COPY(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n->left, 0); + OPM_Write(')'); + break; + case 31: + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right->link, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"__GET(", 7); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + break; + case 25: + OPM_WriteString((CHAR*)"__PUT(", 7); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->right->typ->strobj); + OPM_Write(')'); + break; + case 26: case 27: + OPM_err(200); + break; + case 30: + OPM_WriteString((CHAR*)"__SYSNEW(", 10); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_Write(')'); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.subcl = ", 40); + OPM_LogWNum(n->subcl, 0); + OPM_LogWLn(); + break; + } + break; + case 13: + if ((n->left->obj != NIL && n->left->obj->mode == 13)) { + if (n->left->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(n->left->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (n->left->class == 9) { + OPV_design(n->left, 10); + } else { + OPV_design(n->left, 11); + } + OPV_ActualPar(n->right, n->obj); + break; + case 20: + if (n->subcl != 32) { + OPV_IfStat(n, 0, outerProc); + } else if (__IN(7, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__ASSERT(", 10); + OPV_expr(n->left->left->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(n->left->right->right->conval->intval); + OPM_Write(')'); + OPC_EndStat(); + } + break; + case 21: + OPV_exit.level += 1; + OPV_CaseStat(n, outerProc); + OPV_exit.level -= 1; + break; + case 22: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"while ", 7); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + OPV_exit.level -= 1; + break; + case 23: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"do ", 4); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" while (!", 10); + OPV_expr(n->right, 9); + OPM_Write(')'); + OPV_exit.level -= 1; + break; + case 24: + saved = OPV_exit; + OPV_exit.level = 0; + OPV_exit.label = -1; + OPM_WriteString((CHAR*)"for (;;) ", 10); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk(); + if (OPV_exit.label != -1) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"exit__", 7); + OPM_WriteInt(OPV_exit.label); + OPM_Write(':'); + OPC_EndStat(); + } + OPV_exit = saved; + break; + case 25: + if (OPV_exit.level == 0) { + OPM_WriteString((CHAR*)"break", 6); + } else { + if (OPV_exit.label == -1) { + OPV_exit.label = OPV_nofExitLabels; + OPV_nofExitLabels += 1; + } + OPM_WriteString((CHAR*)"goto exit__", 12); + OPM_WriteInt(OPV_exit.label); + } + break; + case 26: + if (OPM_level == 0) { + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI", 7); + } else { + OPM_WriteString((CHAR*)"__ENDMOD", 9); + } + } else if (OPC_NeedsRetval(outerProc)) { + OPM_WriteString((CHAR*)"__retval = ", 12); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + OPC_EndStat(); + OPC_BegStat(); + OPC_ExitProc(outerProc, 0, 0); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"return __retval", 16); + } else { + OPC_ExitProc(outerProc, 0, 0); + OPM_WriteString((CHAR*)"return", 7); + if (n->left != NIL) { + OPM_Write(' '); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + } + } + break; + case 27: + OPV_IfStat(n, n->subcl == 0, outerProc); + break; + case 28: + OPC_Halt(OPM_Longint(n->right->conval->intval)); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.class = ", 40); + OPM_LogWNum(n->class, 0); + OPM_LogWLn(); + break; + } + if (!__IN(n->class, 0x09744000, 32)) { + OPC_EndStat(); + } + n = n->link; + } +} + +void OPV_Module (OPT_Node prog) +{ + if (!__IN(10, OPM_Options, 32)) { + OPC_GenHdr(prog->right); + OPC_GenHdrIncludes(); + } + OPC_GenBdy(prog->right); + OPV_stat(prog, NIL); +} + +__TDESC(OPV_ExitInfo, 1, 0) = {__TDFLDS("ExitInfo", 4), {-4}}; + +export void *OPV__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPV", 0); + __REGCMD("Init", OPV_Init); + __INITYP(OPV_ExitInfo, OPV_ExitInfo, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/OPV.h b/bootstrap/unix-48/OPV.h new file mode 100644 index 00000000..fbabd8f4 --- /dev/null +++ b/bootstrap/unix-48/OPV.h @@ -0,0 +1,18 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPV__h +#define OPV__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPV_AdrAndSize (OPT_Object topScope); +import void OPV_Init (void); +import void OPV_Module (OPT_Node prog); +import void *OPV__init(void); + + +#endif // OPV diff --git a/bootstrap/unix-48/Out.c b/bootstrap/unix-48/Out.c new file mode 100644 index 00000000..ce936589 --- /dev/null +++ b/bootstrap/unix-48/Out.c @@ -0,0 +1,345 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export BOOLEAN Out_IsConsole; +static CHAR Out_buf[128]; +static INT16 Out_in; + + +export void Out_Char (CHAR ch); +export void Out_Flush (void); +export void Out_Hex (INT64 x, INT64 n); +export void Out_Int (INT64 x, INT64 n); +static INT32 Out_Length (CHAR *s, ADDRESS s__len); +export void Out_Ln (void); +export void Out_LongReal (LONGREAL x, INT16 n); +export void Out_Open (void); +export void Out_Real (REAL x, INT16 n); +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_); +export void Out_String (CHAR *str, ADDRESS str__len); +export LONGREAL Out_Ten (INT16 e); +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i); +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i); + +#define Out_Entier64(x) (INT64)(x) + +void Out_Flush (void) +{ + INT16 error; + if (Out_in > 0) { + error = Platform_Write(1, (ADDRESS)Out_buf, Out_in); + } + Out_in = 0; +} + +void Out_Open (void) +{ +} + +void Out_Char (CHAR ch) +{ + if (Out_in >= 128) { + Out_Flush(); + } + Out_buf[__X(Out_in, 128)] = ch; + Out_in += 1; + if (ch == 0x0a) { + Out_Flush(); + } +} + +static INT32 Out_Length (CHAR *s, ADDRESS s__len) +{ + INT32 l; + l = 0; + while ((l < s__len && s[__X(l, s__len)] != 0x00)) { + l += 1; + } + return l; +} + +void Out_String (CHAR *str, ADDRESS str__len) +{ + INT32 l; + INT16 error; + __DUP(str, str__len, CHAR); + l = Out_Length((void*)str, str__len); + if (Out_in + l > 128) { + Out_Flush(); + } + if (l > 128) { + error = Platform_Write(1, (ADDRESS)str, l); + } else { + __MOVE((ADDRESS)str, (ADDRESS)&Out_buf[__X(Out_in, 128)], l); + Out_in += __SHORT(l, 32768); + } + __DEL(str); +} + +void Out_Int (INT64 x, INT64 n) +{ + CHAR s[22]; + INT16 i; + BOOLEAN negative; + negative = x < 0; + if (x == (-9223372036854775807LL-1)) { + __MOVE("8085774586302733229", s, 20); + i = 19; + } else { + if (x < 0) { + x = -x; + } + s[0] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i = 1; + while (x != 0) { + s[__X(i, 22)] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i += 1; + } + } + if (negative) { + s[__X(i, 22)] = '-'; + i += 1; + } + while (n > (INT64)i) { + Out_Char(' '); + n -= 1; + } + while (i > 0) { + i -= 1; + Out_Char(s[__X(i, 22)]); + } +} + +void Out_Hex (INT64 x, INT64 n) +{ + if (n < 1) { + n = 1; + } else if (n > 16) { + n = 16; + } + if (x >= 0) { + while ((n < 16 && __LSH(x, -__ASHL(n, 2), 64) != 0)) { + n += 1; + } + } + x = __ROT(x, __ASHL(16 - n, 2), 64); + while (n > 0) { + x = __ROTL(x, 4, 64); + n -= 1; + if (__MASK(x, -16) < 10) { + Out_Char(__CHR(__MASK(x, -16) + 48)); + } else { + Out_Char(__CHR((__MASK(x, -16) - 10) + 65)); + } + } +} + +void Out_Ln (void) +{ + Out_String(Platform_NL, 3); + Out_Flush(); +} + +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i) +{ + *i -= 1; + s[__X(*i, s__len)] = __CHR(__MOD(n, 10) + 48); +} + +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i) +{ + INT16 j; + INT32 l; + __DUP(t, t__len, CHAR); + l = Out_Length((void*)t, t__len); + if (l > *i) { + l = *i; + } + *i -= __SHORT(l, 32768); + j = 0; + while (j < l) { + s[__X(*i + j, s__len)] = t[__X(j, t__len)]; + j += 1; + } + __DEL(t); +} + +LONGREAL Out_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_) +{ + INT16 e; + INT64 f; + CHAR s[30]; + INT16 i, el; + LONGREAL x0; + BOOLEAN nn, en; + INT64 m; + INT16 d, dr; + e = (INT16)__MASK(__ASHR((__VAL(INT64, x)), 52), -2048); + f = __MASK((__VAL(INT64, x)), -4503599627370496LL); + nn = (__VAL(INT64, x) < 0 && !((e == 2047 && f != 0))); + if (nn) { + n -= 1; + } + i = 30; + if (e == 2047) { + if (f == 0) { + Out_prepend((CHAR*)"Infinity", 9, (void*)s, 30, &i); + } else { + Out_prepend((CHAR*)"NaN", 4, (void*)s, 30, &i); + } + } else { + if (long_) { + el = 3; + dr = n - 6; + if (dr > 17) { + dr = 17; + } + d = dr; + if (d < 15) { + d = 15; + } + } else { + el = 2; + dr = n - 5; + if (dr > 9) { + dr = 9; + } + d = dr; + if (d < 6) { + d = 6; + } + } + if (e == 0) { + while (el > 0) { + i -= 1; + s[__X(i, 30)] = '0'; + el -= 1; + } + i -= 1; + s[__X(i, 30)] = '+'; + m = 0; + } else { + if (nn) { + x = -x; + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Out_Ten(e); + } else { + x = Out_Ten(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + en = e < 0; + if (en) { + e = -e; + } + while (el > 0) { + Out_digit(e, (void*)s, 30, &i); + e = __DIV(e, 10); + el -= 1; + } + i -= 1; + if (en) { + s[__X(i, 30)] = '-'; + } else { + s[__X(i, 30)] = '+'; + } + x0 = Out_Ten(d - 1); + x = x0 * x; + x = x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + m = Out_Entier64(x); + } + i -= 1; + if (long_) { + s[__X(i, 30)] = 'D'; + } else { + s[__X(i, 30)] = 'E'; + } + if (dr < 2) { + dr = 2; + } + while ((d > dr && __MOD(m, 10) == 0)) { + m = __DIV(m, 10); + d -= 1; + } + while (d > 1) { + Out_digit(m, (void*)s, 30, &i); + m = __DIV(m, 10); + d -= 1; + } + i -= 1; + s[__X(i, 30)] = '.'; + Out_digit(m, (void*)s, 30, &i); + } + n -= 30 - i; + while (n > 0) { + Out_Char(' '); + n -= 1; + } + if (nn) { + Out_Char('-'); + } + while (i < 30) { + Out_Char(s[__X(i, 30)]); + i += 1; + } +} + +void Out_Real (REAL x, INT16 n) +{ + Out_RealP(x, n, 0); +} + +void Out_LongReal (LONGREAL x, INT16 n) +{ + Out_RealP(x, n, 1); +} + + +export void *Out__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Out", 0); + __REGCMD("Flush", Out_Flush); + __REGCMD("Ln", Out_Ln); + __REGCMD("Open", Out_Open); +/* BEGIN */ + Out_IsConsole = Platform_IsConsole(1); + Out_in = 0; + __ENDMOD; +} diff --git a/bootstrap/unix-48/Out.h b/bootstrap/unix-48/Out.h new file mode 100644 index 00000000..a72547f4 --- /dev/null +++ b/bootstrap/unix-48/Out.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Out__h +#define Out__h + +#include "SYSTEM.h" + + +import BOOLEAN Out_IsConsole; + + +import void Out_Char (CHAR ch); +import void Out_Flush (void); +import void Out_Hex (INT64 x, INT64 n); +import void Out_Int (INT64 x, INT64 n); +import void Out_Ln (void); +import void Out_LongReal (LONGREAL x, INT16 n); +import void Out_Open (void); +import void Out_Real (REAL x, INT16 n); +import void Out_String (CHAR *str, ADDRESS str__len); +import LONGREAL Out_Ten (INT16 e); +import void *Out__init(void); + + +#endif // Out diff --git a/bootstrap/unix-48/Platform.c b/bootstrap/unix-48/Platform.c new file mode 100644 index 00000000..befa6033 --- /dev/null +++ b/bootstrap/unix-48/Platform.c @@ -0,0 +1,535 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 volume, index, mtime; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +export BOOLEAN Platform_LittleEndian; +export INT16 Platform_PID; +export CHAR Platform_CWD[256]; +static INT32 Platform_TimeStart; +export INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +export CHAR Platform_NL[3]; + +export ADDRESS *Platform_FileIdentity__typ; + +export BOOLEAN Platform_Absent (INT16 e); +export INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +export INT16 Platform_Close (INT32 h); +export BOOLEAN Platform_ConnectionFailed (INT16 e); +export void Platform_Delay (INT32 ms); +export BOOLEAN Platform_DifferentFilesystems (INT16 e); +export INT16 Platform_Error (void); +export void Platform_Exit (INT32 code); +export void Platform_GetClock (INT32 *t, INT32 *d); +export void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +export void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +export INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export BOOLEAN Platform_Inaccessible (INT16 e); +export BOOLEAN Platform_Interrupted (INT16 e); +export BOOLEAN Platform_IsConsole (INT32 h); +export void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +export INT16 Platform_MaxNameLength (void); +export INT16 Platform_MaxPathLength (void); +export INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +export BOOLEAN Platform_NoSuchDirectory (INT16 e); +export INT32 Platform_OSAllocate (INT32 size); +export void Platform_OSFree (INT32 address); +export INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +export INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +export INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +export BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +export BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +export INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +export void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +export void Platform_SetInterruptHandler (Platform_SignalHandler handler); +export void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +export void Platform_SetQuitHandler (Platform_SignalHandler handler); +export INT16 Platform_Size (INT32 h, INT32 *l); +export INT16 Platform_Sync (INT32 h); +export INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +static void Platform_TestLittleEndian (void); +export INT32 Platform_Time (void); +export BOOLEAN Platform_TimedOut (INT16 e); +export BOOLEAN Platform_TooManyFiles (INT16 e); +export INT16 Platform_Truncate (INT32 h, INT32 l); +export INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +export INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d); +export BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#define Platform_EACCES() EACCES +#define Platform_EAGAIN() EAGAIN +#define Platform_ECONNABORTED() ECONNABORTED +#define Platform_ECONNREFUSED() ECONNREFUSED +#define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR +#define Platform_EMFILE() EMFILE +#define Platform_ENETUNREACH() ENETUNREACH +#define Platform_ENFILE() ENFILE +#define Platform_ENOENT() ENOENT +#define Platform_EROFS() EROFS +#define Platform_ETIMEDOUT() ETIMEDOUT +#define Platform_EXDEV() EXDEV +#define Platform_NAMEMAX() NAME_MAX +#define Platform_PATHMAX() PATH_MAX +#define Platform_allocate(size) (ADDRESS)((void*)malloc((size_t)size)) +#define Platform_chdir(n, n__len) chdir((char*)n) +#define Platform_closefile(fd) close(fd) +#define Platform_err() errno +#define Platform_exit(code) exit((int)code) +#define Platform_free(address) free((void*)address) +#define Platform_fstat(fd) fstat(fd, &s) +#define Platform_fsync(fd) fsync(fd) +#define Platform_ftruncate(fd, l) ftruncate(fd, l) +#define Platform_getcwd(cwd, cwd__len) getcwd((char*)cwd, cwd__len) +#define Platform_getenv(var, var__len) getenv((char*)var) +#define Platform_getpid() (INTEGER)getpid() +#define Platform_gettimeval() struct timeval tv; gettimeofday(&tv,0) +#define Platform_isatty(fd) isatty(fd) +#define Platform_lseek(fd, o, w) lseek(fd, o, w) +#define Platform_nanosleep(s, ns) struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem) +#define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) +#define Platform_openro(n, n__len) open((char*)n, O_RDONLY) +#define Platform_openrw(n, n__len) open((char*)n, O_RDWR) +#define Platform_readfile(fd, p, l) (LONGINT)read(fd, (void*)(ADDRESS)(p), l) +#define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) +#define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) +#define Platform_seekcur() SEEK_CUR +#define Platform_seekend() SEEK_END +#define Platform_seekset() SEEK_SET +#define Platform_sethandler(s, h) SystemSetHandler(s, (ADDRESS)h) +#define Platform_stat(n, n__len) stat((char*)n, &s) +#define Platform_statdev() (LONGINT)s.st_dev +#define Platform_statino() (LONGINT)s.st_ino +#define Platform_statmtime() (LONGINT)s.st_mtime +#define Platform_statsize() (ADDRESS)s.st_size +#define Platform_structstats() struct stat s +#define Platform_system(str, str__len) system((char*)str) +#define Platform_tmhour() (LONGINT)time->tm_hour +#define Platform_tmmday() (LONGINT)time->tm_mday +#define Platform_tmmin() (LONGINT)time->tm_min +#define Platform_tmmon() (LONGINT)time->tm_mon +#define Platform_tmsec() (LONGINT)time->tm_sec +#define Platform_tmyear() (LONGINT)time->tm_year +#define Platform_tvsec() tv.tv_sec +#define Platform_tvusec() tv.tv_usec +#define Platform_unlink(n, n__len) unlink((char*)n) +#define Platform_writefile(fd, p, l) write(fd, (void*)(ADDRESS)(p), l) + +BOOLEAN Platform_TooManyFiles (INT16 e) +{ + return e == Platform_EMFILE() || e == Platform_ENFILE(); +} + +BOOLEAN Platform_NoSuchDirectory (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_DifferentFilesystems (INT16 e) +{ + return e == Platform_EXDEV(); +} + +BOOLEAN Platform_Inaccessible (INT16 e) +{ + return (e == Platform_EACCES() || e == Platform_EROFS()) || e == Platform_EAGAIN(); +} + +BOOLEAN Platform_Absent (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_TimedOut (INT16 e) +{ + return e == Platform_ETIMEDOUT(); +} + +BOOLEAN Platform_ConnectionFailed (INT16 e) +{ + return ((e == Platform_ECONNREFUSED() || e == Platform_ECONNABORTED()) || e == Platform_ENETUNREACH()) || e == Platform_EHOSTUNREACH(); +} + +BOOLEAN Platform_Interrupted (INT16 e) +{ + return e == Platform_EINTR(); +} + +INT16 Platform_MaxNameLength (void) +{ + return Platform_NAMEMAX(); +} + +INT16 Platform_MaxPathLength (void) +{ + return Platform_PATHMAX(); +} + +INT32 Platform_OSAllocate (INT32 size) +{ + return Platform_allocate(size); +} + +void Platform_OSFree (INT32 address) +{ + Platform_free(address); +} + +typedef + CHAR (*EnvPtr__83)[1024]; + +BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + EnvPtr__83 p = NIL; + __DUP(var, var__len, CHAR); + p = (EnvPtr__83)(ADDRESS)Platform_getenv(var, var__len); + if (p != NIL) { + __COPY(*p, val, val__len); + } + __DEL(var); + return p != NIL; +} + +void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + __DUP(var, var__len, CHAR); + if (!Platform_getEnv(var, var__len, (void*)val, val__len)) { + val[0] = 0x00; + } + __DEL(var); +} + +void Platform_SetInterruptHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(2, handler); +} + +void Platform_SetQuitHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(3, handler); +} + +void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(4, handler); +} + +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d) +{ + *d = (__ASHL((int)__MOD(ye, 100), 9) + __ASHL(mo + 1, 5)) + da; + *t = (__ASHL(ho, 12) + __ASHL(mi, 6)) + se; +} + +void Platform_GetClock (INT32 *t, INT32 *d) +{ + Platform_gettimeval(); + Platform_sectotm(Platform_tvsec()); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec) +{ + Platform_gettimeval(); + *sec = Platform_tvsec(); + *usec = Platform_tvusec(); +} + +INT32 Platform_Time (void) +{ + INT32 ms; + Platform_gettimeval(); + ms = (int)__DIVF(Platform_tvusec(), 1000) + Platform_tvsec() * 1000; + return (int)__MOD(ms - Platform_TimeStart, 2147483647); +} + +void Platform_Delay (INT32 ms) +{ + INT32 s, ns; + s = __DIV(ms, 1000); + ns = (int)__MOD(ms, 1000) * 1000000; + Platform_nanosleep(s, ns); +} + +INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len) +{ + __DUP(cmd, cmd__len, CHAR); + __DEL(cmd); + return Platform_system(cmd, cmd__len); +} + +INT16 Platform_Error (void) +{ + return Platform_err(); +} + +INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openro(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openrw(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_opennew(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_Close (INT32 h) +{ + if (Platform_closefile(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +BOOLEAN Platform_IsConsole (INT32 h) +{ + return Platform_isatty(h) != 0; +} + +INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + return 0; +} + +INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + __DUP(n, n__len, CHAR); + Platform_structstats(); + if (Platform_stat(n, n__len) < 0) { + __DEL(n); + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + __DEL(n); + return 0; +} + +BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (i1.index == i2.index && i1.volume == i2.volume); +} + +BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return i1.mtime == i2.mtime; +} + +void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source) +{ + (*target).mtime = source.mtime; +} + +void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d) +{ + Platform_sectotm(i.mtime); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +INT16 Platform_Size (INT32 h, INT32 *l) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + *l = Platform_statsize(); + return 0; +} + +INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n) +{ + *n = Platform_readfile(h, p, l); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n) +{ + *n = Platform_readfile(h, (ADDRESS)b, b__len); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Write (INT32 h, INT32 p, INT32 l) +{ + INT32 written; + written = Platform_writefile(h, p, l); + if (written < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Sync (INT32 h) +{ + if (Platform_fsync(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence) +{ + if (Platform_lseek(h, offset, whence) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Truncate (INT32 h, INT32 l) +{ + if (Platform_ftruncate(h, l) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Unlink (CHAR *n, ADDRESS n__len) +{ + if (Platform_unlink(n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Chdir (CHAR *n, ADDRESS n__len) +{ + INT16 r; + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + return 0; + } else { + return Platform_err(); + } + __RETCHK; +} + +INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len) +{ + if (Platform_rename(o, o__len, n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +void Platform_Exit (INT32 code) +{ + Platform_exit(code); +} + +static void Platform_TestLittleEndian (void) +{ + INT16 i; + i = 1; + __GET((ADDRESS)&i, Platform_LittleEndian, BOOLEAN); +} + +__TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 12), {-4}}; + +export void *Platform__init(void) +{ + __DEFMOD; + __REGMOD("Platform", 0); + __INITYP(Platform_FileIdentity, Platform_FileIdentity, 0); +/* BEGIN */ + Platform_TestLittleEndian(); + Platform_TimeStart = 0; + Platform_TimeStart = Platform_Time(); + Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } + Platform_SeekSet = Platform_seekset(); + Platform_SeekCur = Platform_seekcur(); + Platform_SeekEnd = Platform_seekend(); + Platform_NL[0] = 0x0a; + Platform_NL[1] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-48/Platform.h b/bootstrap/unix-48/Platform.h new file mode 100644 index 00000000..fbeef8c7 --- /dev/null +++ b/bootstrap/unix-48/Platform.h @@ -0,0 +1,74 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Platform__h +#define Platform__h + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 _prvt0; + char _prvt1[8]; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +import BOOLEAN Platform_LittleEndian; +import INT16 Platform_PID; +import CHAR Platform_CWD[256]; +import INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +import CHAR Platform_NL[3]; + +import ADDRESS *Platform_FileIdentity__typ; + +import BOOLEAN Platform_Absent (INT16 e); +import INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +import INT16 Platform_Close (INT32 h); +import BOOLEAN Platform_ConnectionFailed (INT16 e); +import void Platform_Delay (INT32 ms); +import BOOLEAN Platform_DifferentFilesystems (INT16 e); +import INT16 Platform_Error (void); +import void Platform_Exit (INT32 code); +import void Platform_GetClock (INT32 *t, INT32 *d); +import void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +import INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import BOOLEAN Platform_Inaccessible (INT16 e); +import BOOLEAN Platform_Interrupted (INT16 e); +import BOOLEAN Platform_IsConsole (INT32 h); +import void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +import INT16 Platform_MaxNameLength (void); +import INT16 Platform_MaxPathLength (void); +import INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +import BOOLEAN Platform_NoSuchDirectory (INT16 e); +import INT32 Platform_OSAllocate (INT32 size); +import void Platform_OSFree (INT32 address); +import INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +import INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +import INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +import BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +import BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +import INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +import void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +import void Platform_SetInterruptHandler (Platform_SignalHandler handler); +import void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +import void Platform_SetQuitHandler (Platform_SignalHandler handler); +import INT16 Platform_Size (INT32 h, INT32 *l); +import INT16 Platform_Sync (INT32 h); +import INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +import INT32 Platform_Time (void); +import BOOLEAN Platform_TimedOut (INT16 e); +import BOOLEAN Platform_TooManyFiles (INT16 e); +import INT16 Platform_Truncate (INT32 h, INT32 l); +import INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +import INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +import BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void *Platform__init(void); + + +#endif // Platform diff --git a/bootstrap/unix-48/Reals.c b/bootstrap/unix-48/Reals.c new file mode 100644 index 00000000..512ec2c4 --- /dev/null +++ b/bootstrap/unix-48/Reals.c @@ -0,0 +1,157 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + + + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len); +export void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +export void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +export void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +export void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +export INT16 Reals_Expo (REAL x); +export INT16 Reals_ExpoL (LONGREAL x); +export void Reals_SetExpo (REAL *x, INT16 ex); +export REAL Reals_Ten (INT16 e); +export LONGREAL Reals_TenL (INT16 e); +static CHAR Reals_ToHex (INT16 i); + + +REAL Reals_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +LONGREAL Reals_TenL (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + for (;;) { + if (__ODD(e)) { + r = r * power; + } + e = __ASHR(e, 1); + if (e <= 0) { + return r; + } + power = power * power; + } + __RETCHK; +} + +INT16 Reals_Expo (REAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 2, i, INT16); + return __MASK(__ASHR(i, 7), -256); +} + +void Reals_SetExpo (REAL *x, INT16 ex) +{ + CHAR c; + __GET((ADDRESS)x + 3, c, CHAR); + __PUT((ADDRESS)x + 3, __CHR(__ASHL(__ASHR((INT16)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((ADDRESS)x + 2, c, CHAR); + __PUT((ADDRESS)x + 2, __CHR(__MASK((INT16)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); +} + +INT16 Reals_ExpoL (LONGREAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 6, i, INT16); + return __MASK(__ASHR(i, 4), -2048); +} + +void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + INT32 i, j, k; + if (x < (LONGREAL)0) { + x = -x; + } + k = 0; + if (n > 9) { + i = __SHORT(__ENTIER(x / (LONGREAL)(LONGREAL)1000000000), 2147483648LL); + j = __SHORT(__ENTIER(x - i * (LONGREAL)1000000000), 2147483648LL); + if (j < 0) { + j = 0; + } + while (k < 9) { + d[__X(k, d__len)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } + } else { + i = __SHORT(__ENTIER(x), 2147483648LL); + } + while (k < n) { + d[__X(k, d__len)] = __CHR((int)__MOD(i, 10) + 48); + i = __DIV(i, 10); + k += 1; + } +} + +void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + Reals_ConvertL(x, n, (void*)d, d__len); +} + +static CHAR Reals_ToHex (INT16 i) +{ + if (i < 10) { + return __CHR(i + 48); + } else { + return __CHR(i + 55); + } + __RETCHK; +} + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len) +{ + INT16 i; + INT32 l; + CHAR by; + i = 0; + l = b__len; + while (i < l) { + by = __VAL(CHAR, b[__X(i, b__len)]); + d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((INT16)by, 4)); + d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((INT16)by, -16)); + i += 1; + } +} + +void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&y, 4, (void*)d, d__len * 1); +} + +void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&x, 8, (void*)d, d__len * 1); +} + + +export void *Reals__init(void) +{ + __DEFMOD; + __REGMOD("Reals", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/Reals.h b/bootstrap/unix-48/Reals.h new file mode 100644 index 00000000..93e7fa75 --- /dev/null +++ b/bootstrap/unix-48/Reals.h @@ -0,0 +1,23 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Reals__h +#define Reals__h + +#include "SYSTEM.h" + + + + +import void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +import void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +import void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +import void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +import INT16 Reals_Expo (REAL x); +import INT16 Reals_ExpoL (LONGREAL x); +import void Reals_SetExpo (REAL *x, INT16 ex); +import REAL Reals_Ten (INT16 e); +import LONGREAL Reals_TenL (INT16 e); +import void *Reals__init(void); + + +#endif // Reals diff --git a/bootstrap/unix-48/Strings.c b/bootstrap/unix-48/Strings.c new file mode 100644 index 00000000..4b18812f --- /dev/null +++ b/bootstrap/unix-48/Strings.c @@ -0,0 +1,374 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Reals.h" + + + + +export void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +export void Strings_Cap (CHAR *s, ADDRESS s__len); +export void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +export void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +export void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export INT16 Strings_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +export INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +export void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +export void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); + + +INT16 Strings_Length (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + if (i <= 32767) { + __DEL(s); + return __SHORT(i, 32768); + } else { + __DEL(s); + return 32767; + } + __RETCHK; +} + +void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(extra, extra__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(extra, extra__len); + i = 0; + while ((i < n2 && (i + n1) < dest__len)) { + dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; + i += 1; + } + if ((i + n1) < dest__len) { + dest[__X(i + n1, dest__len)] = 0x00; + } + __DEL(extra); +} + +void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(source, source__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(source, source__len); + if (pos < 0) { + pos = 0; + } + if (pos > n1) { + Strings_Append(dest, dest__len, (void*)source, source__len); + __DEL(source); + return; + } + if ((pos + n2) < dest__len) { + i = n1; + while (i >= pos) { + if ((i + n2) < dest__len) { + dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; + } + i -= 1; + } + } + i = 0; + while (i < n2) { + dest[__X(pos + i, dest__len)] = source[__X(i, source__len)]; + i += 1; + } + __DEL(source); +} + +void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n) +{ + INT16 len, i; + len = Strings_Length(s, s__len); + if (pos < 0) { + pos = 0; + } else if (pos >= len) { + return; + } + if (pos + n < len) { + i = pos + n; + while (i < len) { + s[__X(i - n, s__len)] = s[__X(i, s__len)]; + i += 1; + } + if ((i - n) < s__len) { + s[__X(i - n, s__len)] = 0x00; + } + } else { + s[__X(pos, s__len)] = 0x00; + } +} + +void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + __DUP(source, source__len, CHAR); + Strings_Delete((void*)dest, dest__len, pos, pos + Strings_Length(source, source__len)); + Strings_Insert(source, source__len, pos, (void*)dest, dest__len); + __DEL(source); +} + +void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len) +{ + INT16 len, destLen, i; + __DUP(source, source__len, CHAR); + len = Strings_Length(source, source__len); + destLen = __SHORT(dest__len, 32768) - 1; + if (pos < 0) { + pos = 0; + } + if (pos >= len) { + dest[0] = 0x00; + __DEL(source); + return; + } + i = 0; + while (((((pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + if (i < destLen) { + dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; + } + i += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(source); +} + +INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos) +{ + INT16 n1, n2, i, j; + __DUP(pattern, pattern__len, CHAR); + __DUP(s, s__len, CHAR); + n1 = Strings_Length(s, s__len); + n2 = Strings_Length(pattern, pattern__len); + if (n2 == 0) { + __DEL(pattern); + __DEL(s); + return 0; + } + i = pos; + while (i <= n1 - n2) { + if (s[__X(i, s__len)] == pattern[0]) { + j = 1; + while ((j < n2 && s[__X(i + j, s__len)] == pattern[__X(j, pattern__len)])) { + j += 1; + } + if (j == n2) { + __DEL(pattern); + __DEL(s); + return i; + } + } + i += 1; + } + __DEL(pattern); + __DEL(s); + return -1; +} + +void Strings_Cap (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + if (('a' <= s[__X(i, s__len)] && s[__X(i, s__len)] <= 'z')) { + s[__X(i, s__len)] = __CAP(s[__X(i, s__len)]); + } + i += 1; + } +} + +static struct Match__7 { + struct Match__7 *lnk; +} *Match__7_s; + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m); + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m) +{ + while ((((n >= 0 && m >= 0)) && mask[__X(m, mask__len)] != '*')) { + if (name[__X(n, name__len)] != mask[__X(m, mask__len)]) { + return 0; + } + n -= 1; + m -= 1; + } + if (m < 0) { + return n < 0; + } + while ((m >= 0 && mask[__X(m, mask__len)] == '*')) { + m -= 1; + } + if (m < 0) { + return 1; + } + while (n >= 0) { + if (M__8(name, name__len, mask, mask__len, n, m)) { + return 1; + } + n -= 1; + } + return 0; +} + +BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len) +{ + struct Match__7 _s; + BOOLEAN __retval; + __DUP(string, string__len, CHAR); + __DUP(pattern, pattern__len, CHAR); + _s.lnk = Match__7_s; + Match__7_s = &_s; + __retval = M__8((void*)string, string__len, (void*)pattern, pattern__len, Strings_Length(string, string__len) - 1, Strings_Length(pattern, pattern__len) - 1); + Match__7_s = _s.lnk; + __DEL(string); + __DEL(pattern); + ; + return __retval; +} + +void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r) +{ + INT16 p, e; + REAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (REAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (REAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (REAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (REAL)(REAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (REAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + +void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r) +{ + INT16 p, e; + LONGREAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (LONGREAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (LONGREAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (LONGREAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (LONGREAL)(LONGREAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (LONGREAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + + +export void *Strings__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Reals); + __REGMOD("Strings", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/Strings.h b/bootstrap/unix-48/Strings.h new file mode 100644 index 00000000..f0e3ae34 --- /dev/null +++ b/bootstrap/unix-48/Strings.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Strings__h +#define Strings__h + +#include "SYSTEM.h" + + + + +import void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +import void Strings_Cap (CHAR *s, ADDRESS s__len); +import void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +import void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +import void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import INT16 Strings_Length (CHAR *s, ADDRESS s__len); +import BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +import INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +import void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +import void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); +import void *Strings__init(void); + + +#endif // Strings diff --git a/bootstrap/unix-48/Texts.c b/bootstrap/unix-48/Texts.c new file mode 100644 index 00000000..43c3858f --- /dev/null +++ b/bootstrap/unix-48/Texts.c @@ -0,0 +1,1833 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Files.h" +#include "Modules.h" +#include "Reals.h" + +typedef + struct Texts_RunDesc *Texts_Run; + +typedef + struct Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_RunDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + } Texts_RunDesc; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + struct Texts_ElemDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + } Texts_ElemDesc; + +struct Texts__1 { /* Texts_ElemDesc */ + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + Files_File file; + INT32 org, span; + CHAR mod[32], proc[32]; +}; + +typedef + struct Texts__1 *Texts_Alien; + +typedef + struct Texts_BufDesc { + INT32 len; + Texts_Run head; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + CHAR name[32]; + } Texts_FontDesc; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_PieceDesc *Texts_Piece; + +typedef + struct Texts_PieceDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + Files_File file; + INT32 org; + } Texts_PieceDesc; + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + Texts_Run head, cache; + INT32 corg; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + Files_Rider rider; + Files_File file; + } Texts_Writer; + + +export Texts_Elem Texts_new; +static Texts_Buffer Texts_del; +static Texts_FontsFont Texts_FontsDefault; + +export ADDRESS *Texts_FontDesc__typ; +export ADDRESS *Texts_RunDesc__typ; +export ADDRESS *Texts_PieceDesc__typ; +export ADDRESS *Texts_ElemMsg__typ; +export ADDRESS *Texts_ElemDesc__typ; +export ADDRESS *Texts_FileMsg__typ; +export ADDRESS *Texts_CopyMsg__typ; +export ADDRESS *Texts_IdentifyMsg__typ; +export ADDRESS *Texts_BufDesc__typ; +export ADDRESS *Texts_TextDesc__typ; +export ADDRESS *Texts_Reader__typ; +export ADDRESS *Texts_Scanner__typ; +export ADDRESS *Texts_Writer__typ; +export ADDRESS *Texts__1__typ; + +export void Texts_Append (Texts_Text T, Texts_Buffer B); +export void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +static Texts_Elem Texts_CloneElem (Texts_Elem e); +static Texts_Piece Texts_ClonePiece (Texts_Piece p); +export void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +export void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +export void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +export Texts_Text Texts_ElemBase (Texts_Elem E); +export INT32 Texts_ElemPos (Texts_Elem E); +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off); +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len); +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ); +export void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +export void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v); +export void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_OpenBuf (Texts_Buffer B); +export void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +export void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +export void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +export INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +export void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Recall (Texts_Buffer *B); +export void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +export void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +export void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +export void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +export void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base); +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un); +export void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +export void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +export void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +export void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +export void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +export void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +export void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +export void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +export void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +export void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +export void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +export void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +export void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); + + +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len) +{ + Texts_FontsFont F = NIL; + __NEW(F, Texts_FontDesc); + __COPY(name, F->name, 32); + return F; +} + +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off) +{ + Texts_Run v = NIL; + INT32 m; + if (*pos >= T->len) { + *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) { + while (m >= v->len) { + m -= v->len; + v = v->next; + } + } else { + while (m < 0) { + v = v->prev; + m += v->len; + } + } + *u = v; + *org = *pos - m; + *off = m; + T->cache = v->prev; + T->corg = *org; + } +} + +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un) +{ + Texts_Piece p = NIL, U = NIL; + if (off == 0) { + *un = *u; + *u = (*un)->prev; + } else if (off >= (*u)->len) { + *un = (*u)->next; + } else { + __NEW(p, Texts_PieceDesc); + *un = (Texts_Run)p; + U = __GUARDP(*u, Texts_PieceDesc, 1); + __GUARDEQP(p, Texts_PieceDesc) = *U; + p->org += off; + p->len -= off; + U->len -= p->len; + p->ascii = (*u)->ascii; + p->prev = (Texts_Run)U; + p->next = U->next; + p->next->prev = (Texts_Run)p; + U->next = (Texts_Run)p; + } +} + +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v) +{ + Texts_Piece p = NIL, q = NIL; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __ISP(*v, Texts_PieceDesc, 1))) && __STRCMP(u->fnt->name, (*v)->fnt->name) == 0)) && u->col == (*v)->col)) && u->voff == (*v)->voff)) && __GUARDP(u, Texts_PieceDesc, 1)->ascii == __GUARDP(*v, Texts_PieceDesc, 1)->ascii)) { + p = __GUARDP(u, Texts_PieceDesc, 1); + q = __GUARDP(*v, Texts_PieceDesc, 1); + if ((p->file == q->file && p->org + p->len == q->org)) { + if (T->cache == u) { + T->corg += q->len; + } else if (T->cache == *v) { + T->cache = T->head; + T->corg = 0; + } + p->len += q->len; + *v = (*v)->next; + } + } +} + +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base) +{ + Texts_Run u = NIL; + if (v != w->next) { + u = un->prev; + u->next = v; + v->prev = u; + un->prev = w; + w->next = un; + do { + if (__ISP(v, Texts_ElemDesc, 1)) { + __GUARDP(v, Texts_ElemDesc, 1)->base = base; + } + v = v->next; + } while (!(v == un)); + } +} + +static Texts_Piece Texts_ClonePiece (Texts_Piece p) +{ + Texts_Piece q = NIL; + __NEW(q, Texts_PieceDesc); + __GUARDEQP(q, Texts_PieceDesc) = *p; + return q; +} + +static Texts_Elem Texts_CloneElem (Texts_Elem e) +{ + Texts_CopyMsg msg; + msg.e = NIL; + (*e->handle)(e, (void*)&msg, Texts_CopyMsg__typ); + return msg.e; +} + +void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE) +{ + 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; +} + +Texts_Text Texts_ElemBase (Texts_Elem E) +{ + return E->base; +} + +INT32 Texts_ElemPos (Texts_Elem E) +{ + Texts_Run u = NIL; + INT32 pos; + u = E->base->head->next; + pos = 0; + while (u != (void *) E) { + pos = pos + u->len; + u = u->next; + } + return pos; +} + +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ) +{ + Texts_Alien e = NIL; + Files_Rider r; + INT32 i; + CHAR ch; + if (__ISP(E, Texts__1, 2)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + Texts_CopyMsg *msg__ = (void*)msg; + __NEW(e, Texts__1); + Texts_CopyElem((void*)(*(Texts_Alien*)&E), (void*)e); + e->file = (*(Texts_Alien*)&E)->file; + e->org = (*(Texts_Alien*)&E)->org; + e->span = (*(Texts_Alien*)&E)->span; + __MOVE((*(Texts_Alien*)&E)->mod, e->mod, 32); + __MOVE((*(Texts_Alien*)&E)->proc, e->proc, 32); + (*msg__).e = (Texts_Elem)e; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + Texts_IdentifyMsg *msg__ = (void*)msg; + __COPY((*(Texts_Alien*)&E)->mod, (*msg__).mod, 32); + __COPY((*(Texts_Alien*)&E)->proc, (*msg__).proc, 32); + (*msg__).mod[31] = 0x01; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_FileMsg, 1)) { + if (__IS(msg__typ, Texts_FileMsg, 1)) { + Texts_FileMsg *msg__ = (void*)msg; + if ((*msg__).id == 1) { + Files_Set(&r, Files_Rider__typ, (*(Texts_Alien*)&E)->file, (*(Texts_Alien*)&E)->org); + i = (*(Texts_Alien*)&E)->span; + while (i > 0) { + Files_Read(&r, Files_Rider__typ, (void*)&ch); + Files_Write(&(*msg__).r, Files_Rider__typ, ch); + i -= 1; + } + } + } else __WITHCHK; + } + } else __WITHCHK; +} + +void Texts_OpenBuf (Texts_Buffer B) +{ + Texts_Run u = NIL; + __NEW(u, Texts_RunDesc); + u->next = u; + u->prev = u; + B->head = u; + B->len = 0; +} + +void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB) +{ + Texts_Run u = NIL, v = NIL, vn = NIL; + u = SB->head->next; + v = DB->head->prev; + while (u != SB->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + vn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + } else { + vn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + v->next = vn; + vn->prev = v; + v = vn; + u = u->next; + } + v->next = DB->head; + DB->head->prev = v; + DB->len += SB->len; +} + +void Texts_Recall (Texts_Buffer *B) +{ + *B = Texts_del; + Texts_del = NIL; +} + +void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B) +{ + Texts_Run u = NIL, v = NIL, w = NIL, wn = NIL; + INT32 uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Find(T, &end, &v, &vo, &vd); + w = B->head->prev; + while (u != v) { + if (__ISP(u, Texts_PieceDesc, 1)) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + wn->len -= ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + } else { + wn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + w->next = wn; + wn->prev = w; + w = wn; + u = u->next; + ud = 0; + } + if (vd > 0) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(v, Texts_PieceDesc, 1)); + wn->len = vd - ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + w->next = wn; + wn->prev = w; + w = wn; + } + w->next = B->head; + B->head->prev = w; + B->len += end - beg; +} + +void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B) +{ + Texts_Run u = NIL, un = NIL, v = NIL; + Texts_Piece p = NIL, q = NIL; + INT32 uo, ud, len; + Texts_Find(T, &pos, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + len = B->len; + v = B->head->next; + Texts_Merge(T, u, &v); + Texts_Splice(un, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Append (Texts_Text T, Texts_Buffer B) +{ + Texts_Run v = NIL; + INT32 pos, len; + pos = T->len; + len = B->len; + v = B->head->next; + Texts_Merge(T, T->head->prev, &v); + Texts_Splice(T->head, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Delete (Texts_Text T, INT32 beg, INT32 end) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + __NEW(Texts_del, Texts_BufDesc); + Texts_OpenBuf(Texts_del); + Texts_del->len = end - beg; + Texts_Splice(Texts_del->head, un, v, NIL); + Texts_Merge(T, u, &vn); + u->next = vn; + vn->prev = u; + T->len -= end - beg; + if (T->notify != NIL) { + (*T->notify)(T, 2, beg, end); + } +} + +void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + while (un != vn) { + if ((__IN(0, sel, 32) && fnt != NIL)) { + un->fnt = fnt; + } + if (__IN(1, sel, 32)) { + un->col = col; + } + if (__IN(2, sel, 32)) { + un->voff = voff; + } + Texts_Merge(T, u, &un); + if (u->next == un) { + u = un; + un = un->next; + } else { + u->next = un; + un->prev = u; + } + } + Texts_Merge(T, u, &un); + u->next = un; + un->prev = u; + if (T->notify != NIL) { + (*T->notify)(T, 0, beg, end); + } +} + +void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos) +{ + Texts_Run u = NIL; + if (pos >= T->len) { + pos = T->len; + } + Texts_Find(T, &pos, &u, &(*R).org, &(*R).off); + (*R).run = u; + (*R).eot = 0; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, __GUARDP(u, Texts_PieceDesc, 1)->org + (*R).off); + } +} + +void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch) +{ + Texts_Run u = NIL; + INT32 pos; + CHAR nextch; + u = (*R).run; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).off += 1; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&*ch); + (*R).elem = NIL; + if ((*ch == 0x0a && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + *ch = 0x0d; + } else if ((*ch == 0x0d && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + pos = Files_Pos(&(*R).rider, Files_Rider__typ); + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&nextch); + if (nextch == 0x0a) { + (*R).off += 1; + } else { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, pos); + } + } + } else if (__ISP(u, Texts_ElemDesc, 1)) { + *ch = 0x1c; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + *ch = 0x00; + (*R).elem = NIL; + (*R).eot = 1; + } + if ((*R).off == u->len) { + (*R).org += u->len; + u = u->next; + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + } else __WITHCHK; + } + (*R).run = u; + (*R).off = 0; + } +} + +void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL, un = NIL; + u = (*R).run; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org += u->len; + u = u->next; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + un = u->next; + (*R).run = un; + (*R).org += 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + if (__ISP(un, Texts_PieceDesc, 1)) { + if (__ISP(un, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&un)->file, (*(Texts_Piece*)&un)->org); + } else __WITHCHK; + } + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL; + u = (*R).run->prev; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org -= u->len; + u = u->prev; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + (*R).run = u; + (*R).org -= 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ) +{ + return (*R).org + (*R).off; +} + +void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos) +{ + Texts_OpenReader((void*)&*S, S__typ, T, pos); + (*S).line = 0; + (*S).nextCh = ' '; +} + +static struct Scan__31 { + Texts_Scanner *S; + ADDRESS *S__typ; + CHAR *ch; + BOOLEAN *negE; + INT16 *e; + struct Scan__31 *lnk; +} *Scan__31_s; + +static void ReadScaleFactor__32 (void); + +static void ReadScaleFactor__32 (void) +{ + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + if (*Scan__31_s->ch == '-') { + *Scan__31_s->negE = 1; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } else { + *Scan__31_s->negE = 0; + if (*Scan__31_s->ch == '+') { + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } + } + while (('0' <= *Scan__31_s->ch && *Scan__31_s->ch <= '9')) { + *Scan__31_s->e = (*Scan__31_s->e * 10 + (INT16)*Scan__31_s->ch) - 48; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } +} + +void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ) +{ + CHAR ch, term; + BOOLEAN neg, negE, hex; + INT8 i, j, h; + INT16 e; + INT32 k; + REAL x, f; + LONGREAL y, g; + CHAR d[32]; + struct Scan__31 _s; + _s.S = S; _s.S__typ = S__typ; + _s.ch = &ch; + _s.negE = &negE; + _s.e = &e; + _s.lnk = Scan__31_s; + Scan__31_s = &_s; + ch = (*S).nextCh; + i = 0; + for (;;) { + if (ch == 0x0d) { + (*S).line += 1; + } else if ((ch != ' ' && ch != 0x09)) { + break; + } + Texts_Read((void*)&*S, S__typ, &ch); + } + if ((('A' <= __CAP(ch) && __CAP(ch) <= 'Z') || ch == '/') || ch == '.') { + do { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } while (!((((__CAP(ch) > 'Z' && ch != '_') || ('A' > __CAP(ch) && ch > '9')) || ((('0' > ch && ch != '.')) && ch != '/')) || i == 63)); + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i; + (*S).class = 1; + } else if (ch == '"') { + Texts_Read((void*)&*S, S__typ, &ch); + while ((((ch != '"' && ch >= ' ')) && i != 63)) { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i + 1; + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 2; + } else { + if (ch == '-') { + neg = 1; + Texts_Read((void*)&*S, S__typ, &ch); + } else { + neg = 0; + } + if (('0' <= ch && ch <= '9')) { + hex = 0; + j = 0; + for (;;) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + if (ch < '0') { + break; + } + if ('9' < ch) { + if (('A' <= ch && ch <= 'F')) { + hex = 1; + ch = __CHR((INT16)ch - 7); + } else if (('a' <= ch && ch <= 'f')) { + hex = 1; + ch = __CHR((INT16)ch - 39); + } else { + break; + } + } + } + if (ch == 'H') { + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 3; + if (i - j > 8) { + j = i - 8; + } + k = (INT16)d[__X(j, 32)] - 48; + j += 1; + if ((i - j == 7 && k >= 8)) { + k -= 16; + } + while (j < i) { + k = __ASHL(k, 4) + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + } else if (ch == '.') { + Texts_Read((void*)&*S, S__typ, &ch); + h = i; + while (('0' <= ch && ch <= '9')) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + if (ch == 'D') { + e = 0; + y = (LONGREAL)0; + g = (LONGREAL)1; + do { + y = y * (LONGREAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + g = g / (LONGREAL)(LONGREAL)10; + y = ((INT16)d[__X(j, 32)] - 48) * g + y; + j += 1; + } + ReadScaleFactor__32(); + if (negE) { + if (e <= 308) { + y = y / (LONGREAL)Reals_TenL(e); + } else { + y = (LONGREAL)0; + } + } else if (e > 0) { + if (e <= 308) { + y = Reals_TenL(e) * y; + } else { + __HALT(40); + } + } + if (neg) { + y = -y; + } + (*S).class = 5; + (*S).y = y; + } else { + e = 0; + x = (REAL)0; + f = (REAL)1; + do { + x = x * (REAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + f = f / (REAL)(REAL)10; + x = ((INT16)d[__X(j, 32)] - 48) * f + x; + j += 1; + } + if (ch == 'E') { + ReadScaleFactor__32(); + } + if (negE) { + if (e <= 38) { + x = x / (REAL)Reals_Ten(e); + } else { + x = (REAL)0; + } + } else if (e > 0) { + if (e <= 38) { + x = Reals_Ten(e) * x; + } else { + __HALT(40); + } + } + if (neg) { + x = -x; + } + (*S).class = 4; + (*S).x = x; + } + if (hex) { + (*S).class = 0; + } + } else { + (*S).class = 3; + k = 0; + do { + k = k * 10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == i)); + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + if (hex) { + (*S).class = 0; + } else { + (*S).class = 3; + } + } + } else { + (*S).class = 6; + if (neg) { + (*S).c = '-'; + } else { + (*S).c = ch; + Texts_Read((void*)&*S, S__typ, &ch); + } + } + } + (*S).nextCh = ch; + Scan__31_s = _s.lnk; +} + +void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ) +{ + __NEW((*W).buf, Texts_BufDesc); + Texts_OpenBuf((*W).buf); + (*W).fnt = Texts_FontsDefault; + (*W).col = 15; + (*W).voff = 0; + (*W).file = Files_New((CHAR*)"", 1); + Files_Set(&(*W).rider, Files_Rider__typ, (*W).file, 0); +} + +void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt) +{ + (*W).fnt = fnt; +} + +void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col) +{ + (*W).col = col; +} + +void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff) +{ + (*W).voff = voff; +} + +void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Files_Write(&(*W).rider, Files_Rider__typ, ch); + (*W).buf->len += 1; + un = (*W).buf->head; + u = un->prev; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __GUARDP(u, Texts_PieceDesc, 1)->file == (*W).file)) && __STRCMP(u->fnt->name, (*W).fnt->name) == 0)) && u->col == (*W).col)) && u->voff == (*W).voff)) && !__GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + u->len += 1; + } else { + __NEW(p, Texts_PieceDesc); + u->next = (Texts_Run)p; + p->prev = u; + p->next = un; + un->prev = (Texts_Run)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 = 0; + } +} + +void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e) +{ + Texts_Run u = NIL, un = NIL; + if (e->base != NIL) { + __HALT(99); + } + (*W).buf->len += 1; + e->len = 1; + e->fnt = (*W).fnt; + e->col = (*W).col; + e->voff = (*W).voff; + un = (*W).buf->head; + u = un->prev; + u->next = (Texts_Run)e; + e->prev = u; + e->next = un; + un->prev = (Texts_Run)e; +} + +void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ) +{ + Texts_Write(&*W, W__typ, 0x0d); +} + +void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while (s[__X(i, s__len)] >= ' ') { + Texts_Write(&*W, W__typ, s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n) +{ + INT16 i; + INT64 x0; + CHAR a[24]; + i = 0; + if (x < 0) { + if (x == (-9223372036854775807LL-1)) { + Texts_WriteString(&*W, W__typ, (CHAR*)" -9223372036854775808", 22); + return; + } else { + n -= 1; + x0 = -x; + } + } else { + x0 = x; + } + do { + a[__X(i, 24)] = __CHR(__MOD(x0, 10) + 48); + x0 = __DIV(x0, 10); + i += 1; + } while (!(x0 == 0)); + while (n > (INT64)i) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + if (x < 0) { + Texts_Write(&*W, W__typ, '-'); + } + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 24)]); + } while (!(i == 0)); +} + +void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x) +{ + INT16 i; + INT32 y; + CHAR a[20]; + i = 0; + Texts_Write(&*W, W__typ, ' '); + do { + y = __MASK(x, -16); + if (y < 10) { + a[__X(i, 20)] = __CHR(y + 48); + } else { + a[__X(i, 20)] = __CHR(y + 55); + } + x = __ASHR(x, 4); + i += 1; + } while (!(i == 8)); + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 20)]); + } while (!(i == 0)); +} + +void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n) +{ + INT16 e; + REAL x0; + CHAR d[9]; + e = Reals_Expo(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 9) { + n = 3; + } else { + n -= 6; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 8)); + if (x < (REAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __ASHR((e - 127) * 77, 8); + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + x0 = Reals_Ten(n - 1); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + x = x * 1.0000000e-001; + e += 1; + } + Reals_Convert(x, n, (void*)d, 9); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'E'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +static struct WriteRealFix__53 { + Texts_Writer *W; + ADDRESS *W__typ; + INT16 *i; + CHAR (*d)[9]; + struct WriteRealFix__53 *lnk; +} *WriteRealFix__53_s; + +static void dig__54 (INT16 n); +static void seq__56 (CHAR ch, INT16 n); + +static void seq__56 (CHAR ch, INT16 n) +{ + while (n > 0) { + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, ch); + n -= 1; + } +} + +static void dig__54 (INT16 n) +{ + while (n > 0) { + *WriteRealFix__53_s->i -= 1; + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, (*WriteRealFix__53_s->d)[__X(*WriteRealFix__53_s->i, 9)]); + n -= 1; + } +} + +void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k) +{ + INT16 e, i; + CHAR sign; + REAL x0; + CHAR d[9]; + struct WriteRealFix__53 _s; + _s.W = W; _s.W__typ = W__typ; + _s.i = &i; + _s.d = (void*)d; + _s.lnk = WriteRealFix__53_s; + WriteRealFix__53_s = &_s; + e = Reals_Expo(x); + if (k < 0) { + k = 0; + } + if (e == 0) { + seq__56(' ', (n - k) - 2); + Texts_Write(&*W, W__typ, '0'); + seq__56(' ', k + 1); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + seq__56(' ', n - 4); + } else { + e = __ASHR((e - 127) * 77, 8); + if (x < (REAL)0) { + sign = '-'; + x = -x; + } else { + sign = ' '; + } + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + if (k + e >= 8) { + k = 8 - e; + } else if (k + e < 0) { + k = -e; + x = (REAL)0; + } + x0 = Reals_Ten(k + e); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + e += 1; + } + e += 1; + i = k + e; + Reals_Convert(x, i, (void*)d, 9); + if (e > 0) { + seq__56(' ', ((n - e) - k) - 2); + Texts_Write(&*W, W__typ, sign); + dig__54(e); + Texts_Write(&*W, W__typ, '.'); + dig__54(k); + } else { + seq__56(' ', (n - k) - 3); + Texts_Write(&*W, W__typ, sign); + Texts_Write(&*W, W__typ, '0'); + Texts_Write(&*W, W__typ, '.'); + seq__56('0', -e); + dig__54(k + e); + } + } + WriteRealFix__53_s = _s.lnk; +} + +void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x) +{ + INT16 i; + CHAR d[8]; + Reals_ConvertH(x, (void*)d, 8); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 8)]); + i += 1; + } while (!(i == 8)); +} + +void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n) +{ + INT16 e; + LONGREAL x0; + CHAR d[16]; + e = Reals_ExpoL(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 2047) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 10) { + n = 3; + } else { + n -= 7; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 16)); + if (x < (LONGREAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Reals_TenL(e); + } else { + x = Reals_TenL(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + x0 = Reals_TenL(n - 1); + x = x0 * x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + Reals_ConvertL(x, n, (void*)d, 16); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'D'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 100) + 48)); + e = (int)__MOD(e, 100); + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x) +{ + INT16 i; + CHAR d[16]; + Reals_ConvertHL(x, (void*)d, 16); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 16)]); + i += 1; + } while (!(i == 16)); +} + +static struct WriteDate__43 { + Texts_Writer *W; + ADDRESS *W__typ; + struct WriteDate__43 *lnk; +} *WriteDate__43_s; + +static void WritePair__44 (CHAR ch, INT32 x); + +static void WritePair__44 (CHAR ch, INT32 x) +{ + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, ch); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR(__DIV(x, 10) + 48)); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR((int)__MOD(x, 10) + 48)); +} + +void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d) +{ + struct WriteDate__43 _s; + _s.W = W; _s.W__typ = W__typ; + _s.lnk = WriteDate__43_s; + WriteDate__43_s = &_s; + WritePair__44(' ', __MASK(d, -32)); + WritePair__44('.', __MASK(__ASHR(d, 5), -16)); + WritePair__44('.', __MASK(__ASHR(d, 9), -128)); + WritePair__44(' ', __MASK(__ASHR(t, 12), -32)); + WritePair__44(':', __MASK(__ASHR(t, 6), -64)); + WritePair__44(':', __MASK(t, -64)); + WriteDate__43_s = _s.lnk; +} + +static struct Load0__16 { + Texts_Text *T; + INT8 *ecnt; + Files_File *f; + Texts_FileMsg *msg; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Load0__16 *lnk; +} *Load0__16_s; + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e); + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e) +{ + Heap_Module M = NIL; + Heap_Command Cmd; + Texts_Alien a = NIL; + INT32 org, ew, eh; + INT8 eno; + Texts_new = NIL; + Files_ReadLInt(&*r, r__typ, &ew); + Files_ReadLInt(&*r, r__typ, &eh); + Files_Read(&*r, r__typ, (void*)&eno); + if (eno > *Load0__16_s->ecnt) { + *Load0__16_s->ecnt = eno; + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->mods)[__X(eno, 64)], 32); + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->procs)[__X(eno, 64)], 32); + } + org = Files_Pos(&*r, r__typ); + M = Modules_ThisMod((*Load0__16_s->mods)[__X(eno, 64)], 32); + if (M != NIL) { + Cmd = Modules_ThisCommand(M, (*Load0__16_s->procs)[__X(eno, 64)], 32); + if (Cmd != NIL) { + (*Cmd)(); + } + } + *e = Texts_new; + if (*e != NIL) { + (*e)->W = ew; + (*e)->H = eh; + (*e)->base = *Load0__16_s->T; + (*Load0__16_s->msg).pos = pos; + (*(*e)->handle)(*e, (void*)&*Load0__16_s->msg, Texts_FileMsg__typ); + if (Files_Pos(&*r, r__typ) != org + span) { + *e = NIL; + } + } + if (*e == NIL) { + Files_Set(&*r, r__typ, *Load0__16_s->f, org + span); + __NEW(a, Texts__1); + a->W = ew; + a->H = eh; + a->handle = Texts_HandleAlien; + a->base = *Load0__16_s->T; + a->file = *Load0__16_s->f; + a->org = org; + a->span = span; + __COPY((*Load0__16_s->mods)[__X(eno, 64)], a->mod, 32); + __COPY((*Load0__16_s->procs)[__X(eno, 64)], a->proc, 32); + *e = (Texts_Elem)a; + } +} + +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Texts_Elem e = NIL; + INT32 org, pos, hlen, plen; + INT8 ecnt, fcnt, fno, col, voff; + Files_File f = NIL; + Texts_FileMsg msg; + CHAR mods[64][32], procs[64][32]; + CHAR name[32]; + Texts_FontsFont fnts[32]; + struct Load0__16 _s; + _s.T = &T; + _s.ecnt = &ecnt; + _s.f = &f; + _s.msg = &msg; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Load0__16_s; + Load0__16_s = &_s; + pos = Files_Pos(&*r, r__typ); + f = Files_Base(&*r, r__typ); + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + T->head = u; + ecnt = 0; + fcnt = 0; + msg.id = 0; + msg.r = *r; + Files_ReadLInt(&msg.r, Files_Rider__typ, &hlen); + org = (pos - 2) + hlen; + pos = org; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + while (fno != 0) { + if (fno > fcnt) { + fcnt = fno; + Files_ReadString(&msg.r, Files_Rider__typ, (void*)name, 32); + fnts[__X(fno, 32)] = Texts_FontsThis((void*)name, 32); + } + Files_Read(&msg.r, Files_Rider__typ, (void*)&col); + Files_Read(&msg.r, Files_Rider__typ, (void*)&voff); + Files_ReadLInt(&msg.r, Files_Rider__typ, &plen); + if (plen > 0) { + __NEW(p, Texts_PieceDesc); + p->file = f; + p->org = pos; + p->ascii = 0; + un = (Texts_Run)p; + un->len = plen; + } else { + LoadElem__17(&msg.r, Files_Rider__typ, pos - org, -plen, &e); + un = (Texts_Run)e; + un->len = 1; + } + un->col = col; + un->voff = voff; + pos += un->len; + u->next = un; + un->prev = u; + u = un; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + } + u->next = T->head; + T->head->prev = u; + T->cache = T->head; + T->corg = 0; + Files_ReadLInt(&msg.r, Files_Rider__typ, &T->len); + Files_Set(&*r, r__typ, f, Files_Pos(&msg.r, Files_Rider__typ) + T->len); + Load0__16_s = _s.lnk; +} + +void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + INT16 tag; + Files_ReadInt(&*r, r__typ, &tag); + if (tag != -4095) { + Files_Set(&*r, r__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ) - 2); + } + Texts_Load0(&*r, r__typ, T); +} + +void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + Texts_Run u = NIL; + Texts_Piece p = NIL; + CHAR tag, version; + INT32 hlen; + __DUP(name, name__len, CHAR); + f = Files_Old(name, name__len); + if (f == NIL) { + f = Files_New((CHAR*)"", 1); + } + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Read(&r, Files_Rider__typ, (void*)&tag); + Files_Read(&r, Files_Rider__typ, (void*)&version); + if (tag == 0xf0 || (tag == 0x01 && version == 0xf0)) { + Texts_Load0(&r, Files_Rider__typ, T); + } else { + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + __NEW(p, Texts_PieceDesc); + if ((tag == 0xf7 && version == 0x07)) { + Files_Set(&r, Files_Rider__typ, f, 28); + Files_ReadLInt(&r, Files_Rider__typ, &hlen); + Files_Set(&r, Files_Rider__typ, f, 22 + hlen); + Files_ReadLInt(&r, Files_Rider__typ, &T->len); + p->org = 26 + hlen; + } else { + T->len = Files_Length(f); + p->org = 0; + } + if (T->len > 0) { + p->len = T->len; + p->fnt = Texts_FontsDefault; + p->col = 15; + p->voff = 0; + p->file = f; + p->ascii = 1; + u->next = (Texts_Run)p; + u->prev = (Texts_Run)p; + p->next = u; + p->prev = u; + } else { + u->next = u; + u->prev = u; + } + T->head = u; + T->cache = T->head; + T->corg = 0; + } + __DEL(name); +} + +static struct Store__39 { + INT8 *ecnt; + Texts_FileMsg *msg; + Texts_IdentifyMsg *iden; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Store__39 *lnk; +} *Store__39_s; + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e); + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e) +{ + Files_Rider r1; + INT32 org, span; + INT8 eno; + __COPY((*Store__39_s->iden).mod, (*Store__39_s->mods)[__X(*Store__39_s->ecnt, 64)], 32); + __COPY((*Store__39_s->iden).proc, (*Store__39_s->procs)[__X(*Store__39_s->ecnt, 64)], 32); + eno = 1; + while (__STRCMP((*Store__39_s->mods)[__X(eno, 64)], (*Store__39_s->iden).mod) != 0 || __STRCMP((*Store__39_s->procs)[__X(eno, 64)], (*Store__39_s->iden).proc) != 0) { + eno += 1; + } + Files_Set(&r1, Files_Rider__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ)); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_Write(&*r, r__typ, eno); + if (eno == *Store__39_s->ecnt) { + *Store__39_s->ecnt += 1; + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).mod, 32); + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).proc, 32); + } + (*Store__39_s->msg).pos = pos; + org = Files_Pos(&*r, r__typ); + (*e->handle)(e, (void*)&*Store__39_s->msg, Texts_FileMsg__typ); + span = Files_Pos(&*r, r__typ) - org; + Files_WriteLInt(&r1, Files_Rider__typ, -span); + Files_WriteLInt(&r1, Files_Rider__typ, e->W); + Files_WriteLInt(&r1, Files_Rider__typ, e->H); +} + +void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Files_Rider r1; + Texts_Run u = NIL, un = NIL; + Texts_Elem e = NIL; + INT32 org, pos, delta, hlen, rlen; + INT8 ecnt, fcnt; + CHAR ch; + INT8 fno; + Texts_FileMsg msg; + Texts_IdentifyMsg iden; + CHAR mods[64][32], procs[64][32]; + Texts_FontsFont fnts[32]; + CHAR block[1024]; + struct Store__39 _s; + _s.ecnt = &ecnt; + _s.msg = &msg; + _s.iden = &iden; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Store__39_s; + Store__39_s = &_s; + org = Files_Pos(&*r, r__typ); + msg.id = 1; + msg.r = *r; + Files_WriteLInt(&msg.r, Files_Rider__typ, 0); + u = T->head->next; + pos = 0; + delta = 0; + fcnt = 1; + ecnt = 1; + while (u != T->head) { + if (__ISP(u, Texts_ElemDesc, 1)) { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + } else { + iden.mod[0] = 0x01; + } + if (iden.mod[0] != 0x00) { + fnts[__X(fcnt, 32)] = u->fnt; + fno = 1; + while (__STRCMP(fnts[__X(fno, 32)]->name, u->fnt->name) != 0) { + fno += 1; + } + Files_Write(&msg.r, Files_Rider__typ, fno); + if (fno == fcnt) { + fcnt += 1; + Files_WriteString(&msg.r, Files_Rider__typ, u->fnt->name, 32); + } + Files_Write(&msg.r, Files_Rider__typ, u->col); + Files_Write(&msg.r, Files_Rider__typ, u->voff); + } + if (__ISP(u, Texts_PieceDesc, 1)) { + rlen = u->len; + un = u->next; + while ((((((__ISP(un, Texts_PieceDesc, 1) && un->fnt == u->fnt)) && un->col == u->col)) && un->voff == u->voff)) { + rlen += un->len; + un = un->next; + } + Files_WriteLInt(&msg.r, Files_Rider__typ, rlen); + pos += rlen; + u = un; + } else if (iden.mod[0] != 0x00) { + StoreElem__40(&msg.r, Files_Rider__typ, pos, __GUARDP(u, Texts_ElemDesc, 1)); + pos += 1; + u = u->next; + } else { + delta += 1; + u = u->next; + } + } + Files_Write(&msg.r, Files_Rider__typ, 0); + Files_WriteLInt(&msg.r, Files_Rider__typ, T->len - delta); + hlen = (Files_Pos(&msg.r, Files_Rider__typ) - org) + 2; + Files_Set(&r1, Files_Rider__typ, Files_Base(&msg.r, Files_Rider__typ), org); + Files_WriteLInt(&r1, Files_Rider__typ, hlen); + u = T->head->next; + while (u != T->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if ((*(Texts_Piece*)&u)->ascii) { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 0) { + Files_Read(&r1, Files_Rider__typ, (void*)&ch); + delta -= 1; + if (ch == 0x0a) { + Files_Write(&msg.r, Files_Rider__typ, 0x0d); + } else { + Files_Write(&msg.r, Files_Rider__typ, ch); + } + } + } else { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 1024) { + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, 1024); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, 1024); + delta -= 1024; + } + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, delta); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, delta); + } + } else __WITHCHK; + } else { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + if (iden.mod[0] != 0x00) { + Files_Write(&msg.r, Files_Rider__typ, 0x1c); + } + } + u = u->next; + } + __GUARDEQR(r, r__typ, Files_Rider) = msg.r; + if (T->notify != NIL) { + (*T->notify)(T, 3, 0, 0); + } + Store__39_s = _s.lnk; +} + +void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + INT16 i, res; + CHAR bak[64]; + __DUP(name, name__len, CHAR); + f = Files_New(name, name__len); + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Write(&r, Files_Rider__typ, 0xf0); + Files_Write(&r, Files_Rider__typ, 0x01); + Texts_Store(&r, Files_Rider__typ, T); + i = 0; + while (name[__X(i, name__len)] != 0x00) { + i += 1; + } + __COPY(name, bak, 64); + bak[__X(i, 64)] = '.'; + bak[__X(i + 1, 64)] = 'B'; + bak[__X(i + 2, 64)] = 'a'; + bak[__X(i + 3, 64)] = 'k'; + bak[__X(i + 4, 64)] = 0x00; + Files_Rename(name, name__len, bak, 64, &res); + Files_Register(f); + __DEL(name); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Texts_new); + P(Texts_del); + P(Texts_FontsDefault); +} + +__TDESC(Texts_FontDesc, 1, 0) = {__TDFLDS("FontDesc", 32), {-4}}; +__TDESC(Texts_RunDesc, 1, 3) = {__TDFLDS("RunDesc", 20), {0, 4, 12, -16}}; +__TDESC(Texts_PieceDesc, 1, 4) = {__TDFLDS("PieceDesc", 28), {0, 4, 12, 20, -20}}; +__TDESC(Texts_ElemMsg, 1, 0) = {__TDFLDS("ElemMsg", 1), {-4}}; +__TDESC(Texts_ElemDesc, 1, 4) = {__TDFLDS("ElemDesc", 36), {0, 4, 12, 32, -20}}; +__TDESC(Texts_FileMsg, 1, 1) = {__TDFLDS("FileMsg", 28), {16, -8}}; +__TDESC(Texts_CopyMsg, 1, 1) = {__TDFLDS("CopyMsg", 4), {0, -8}}; +__TDESC(Texts_IdentifyMsg, 1, 0) = {__TDFLDS("IdentifyMsg", 64), {-4}}; +__TDESC(Texts_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 8), {4, -8}}; +__TDESC(Texts_TextDesc, 1, 2) = {__TDFLDS("TextDesc", 20), {8, 12, -12}}; +__TDESC(Texts_Reader, 1, 4) = {__TDFLDS("Reader", 48), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Scanner, 1, 4) = {__TDFLDS("Scanner", 144), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Writer, 1, 4) = {__TDFLDS("Writer", 36), {0, 4, 20, 32, -20}}; +__TDESC(Texts__1, 1, 5) = {__TDFLDS("", 112), {0, 4, 12, 32, 36, -24}}; + +export void *Texts__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Reals); + __REGMOD("Texts", EnumPtrs); + __INITYP(Texts_FontDesc, Texts_FontDesc, 0); + __INITYP(Texts_RunDesc, Texts_RunDesc, 0); + __INITYP(Texts_PieceDesc, Texts_RunDesc, 1); + __INITYP(Texts_ElemMsg, Texts_ElemMsg, 0); + __INITYP(Texts_ElemDesc, Texts_RunDesc, 1); + __INITYP(Texts_FileMsg, Texts_ElemMsg, 1); + __INITYP(Texts_CopyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_IdentifyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_BufDesc, Texts_BufDesc, 0); + __INITYP(Texts_TextDesc, Texts_TextDesc, 0); + __INITYP(Texts_Reader, Texts_Reader, 0); + __INITYP(Texts_Scanner, Texts_Reader, 1); + __INITYP(Texts_Writer, Texts_Writer, 0); + __INITYP(Texts__1, Texts_ElemDesc, 2); +/* BEGIN */ + Texts_del = NIL; + __NEW(Texts_FontsDefault, Texts_FontDesc); + __MOVE("Syntax10.Scn.Fnt", Texts_FontsDefault->name, 17); + __ENDMOD; +} diff --git a/bootstrap/unix-48/Texts.h b/bootstrap/unix-48/Texts.h new file mode 100644 index 00000000..fd0c0fa5 --- /dev/null +++ b/bootstrap/unix-48/Texts.h @@ -0,0 +1,173 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Texts__h +#define Texts__h + +#include "SYSTEM.h" +#include "Files.h" + +typedef + struct Texts_BufDesc { + INT32 len; + char _prvt0[4]; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_RunDesc { + INT32 _prvt0; + char _prvt1[15]; + } Texts_RunDesc; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_ElemDesc { + char _prvt0[20]; + INT32 W, H; + Texts_Handler handle; + char _prvt1[4]; + } Texts_ElemDesc; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + char _prvt0[32]; + } Texts_FontDesc; + +typedef + Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[32]; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + INT64 _prvt0; + char _prvt1[24]; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + char _prvt0[12]; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + char _prvt0[26]; + } Texts_Writer; + + +import Texts_Elem Texts_new; + +import ADDRESS *Texts_FontDesc__typ; +import ADDRESS *Texts_RunDesc__typ; +import ADDRESS *Texts_ElemMsg__typ; +import ADDRESS *Texts_ElemDesc__typ; +import ADDRESS *Texts_FileMsg__typ; +import ADDRESS *Texts_CopyMsg__typ; +import ADDRESS *Texts_IdentifyMsg__typ; +import ADDRESS *Texts_BufDesc__typ; +import ADDRESS *Texts_TextDesc__typ; +import ADDRESS *Texts_Reader__typ; +import ADDRESS *Texts_Scanner__typ; +import ADDRESS *Texts_Writer__typ; + +import void Texts_Append (Texts_Text T, Texts_Buffer B); +import void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +import void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +import void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +import void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +import Texts_Text Texts_ElemBase (Texts_Elem E); +import INT32 Texts_ElemPos (Texts_Elem E); +import void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +import void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_OpenBuf (Texts_Buffer B); +import void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +import void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +import void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +import INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +import void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Recall (Texts_Buffer *B); +import void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +import void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +import void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +import void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +import void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +import void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +import void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +import void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +import void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +import void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +import void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +import void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +import void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +import void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +import void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +import void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +import void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); +import void *Texts__init(void); + + +#endif // Texts diff --git a/bootstrap/unix-48/VT100.c b/bootstrap/unix-48/VT100.c new file mode 100644 index 00000000..346fb37b --- /dev/null +++ b/bootstrap/unix-48/VT100.c @@ -0,0 +1,275 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Out.h" +#include "Strings.h" + + +export CHAR VT100_CSI[5]; +static CHAR VT100_tmpstr[32]; + + +export void VT100_CHA (INT16 n); +export void VT100_CNL (INT16 n); +export void VT100_CPL (INT16 n); +export void VT100_CUB (INT16 n); +export void VT100_CUD (INT16 n); +export void VT100_CUF (INT16 n); +export void VT100_CUP (INT16 n, INT16 m); +export void VT100_CUU (INT16 n); +export void VT100_DECTCEMh (void); +export void VT100_DECTCEMl (void); +export void VT100_DSR (INT16 n); +export void VT100_ED (INT16 n); +export void VT100_EL (INT16 n); +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len); +export void VT100_HVP (INT16 n, INT16 m); +export void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +export void VT100_RCP (void); +export void VT100_Reset (void); +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end); +export void VT100_SCP (void); +export void VT100_SD (INT16 n); +export void VT100_SGR (INT16 n); +export void VT100_SGR2 (INT16 n, INT16 m); +export void VT100_SU (INT16 n); +export void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); + + +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end) +{ + CHAR h; + while (start < end) { + h = str[__X(start, str__len)]; + str[__X(start, str__len)] = str[__X(end, str__len)]; + str[__X(end, str__len)] = h; + start += 1; + end -= 1; + } +} + +void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len) +{ + CHAR b[21]; + INT16 s, e; + INT8 maxLength; + maxLength = 11; + if (int_ == (-2147483647-1)) { + __MOVE("-2147483648", b, 12); + e = 11; + } else { + if (int_ < 0) { + b[0] = '-'; + int_ = -int_; + s = 1; + } else { + s = 0; + } + e = s; + do { + b[__X(e, 21)] = __CHR((int)__MOD(int_, 10) + 48); + int_ = __DIV(int_, 10); + e += 1; + } while (!(int_ == 0)); + b[__X(e, 21)] = 0x00; + VT100_Reverse0((void*)b, 21, s, e - 1); + } + __COPY(b, str, str__len); +} + +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len) +{ + CHAR cmd[9]; + __DUP(letter, letter__len, CHAR); + __COPY(VT100_CSI, cmd, 9); + Strings_Append(letter, letter__len, (void*)cmd, 9); + Out_String(cmd, 9); + __DEL(letter); +} + +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[5], mstr[5]; + CHAR cmd[12]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 5); + VT100_IntToStr(m, (void*)mstr, 5); + __COPY(VT100_CSI, cmd, 12); + Strings_Append(nstr, 5, (void*)cmd, 12); + Strings_Append((CHAR*)";", 2, (void*)cmd, 12); + Strings_Append(mstr, 5, (void*)cmd, 12); + Strings_Append(letter, letter__len, (void*)cmd, 12); + Out_String(cmd, 12); + __DEL(letter); +} + +void VT100_Reset (void) +{ + CHAR cmd[6]; + __COPY("\033", cmd, 6); + Strings_Append((CHAR*)"c", 2, (void*)cmd, 6); + Out_String(cmd, 6); + Out_Ln(); +} + +void VT100_CUU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"A", 2); +} + +void VT100_CUD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"B", 2); +} + +void VT100_CUF (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"C", 2); +} + +void VT100_CUB (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"D", 2); +} + +void VT100_CNL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"E", 2); +} + +void VT100_CPL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"F", 2); +} + +void VT100_CHA (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"G", 2); +} + +void VT100_CUP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"H", 2); +} + +void VT100_ED (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"J", 2); +} + +void VT100_EL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"K", 2); +} + +void VT100_SU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"S", 2); +} + +void VT100_SD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"T", 2); +} + +void VT100_HVP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"f", 2); +} + +void VT100_SGR (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"m", 2); +} + +void VT100_SGR2 (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"m", 2); +} + +void VT100_DSR (INT16 n) +{ + VT100_EscSeq(6, (CHAR*)"n", 2); +} + +void VT100_SCP (void) +{ + VT100_EscSeq0((CHAR*)"s", 2); +} + +void VT100_RCP (void) +{ + VT100_EscSeq0((CHAR*)"u", 2); +} + +void VT100_DECTCEMl (void) +{ + VT100_EscSeq0((CHAR*)"\?25l", 5); +} + +void VT100_DECTCEMh (void) +{ + VT100_EscSeq0((CHAR*)"\?25h", 5); +} + +void VT100_SetAttr (CHAR *attr, ADDRESS attr__len) +{ + CHAR tmpstr[16]; + __DUP(attr, attr__len, CHAR); + __COPY(VT100_CSI, tmpstr, 16); + Strings_Append(attr, attr__len, (void*)tmpstr, 16); + Out_String(tmpstr, 16); + __DEL(attr); +} + + +export void *VT100__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Strings); + __REGMOD("VT100", 0); + __REGCMD("DECTCEMh", VT100_DECTCEMh); + __REGCMD("DECTCEMl", VT100_DECTCEMl); + __REGCMD("RCP", VT100_RCP); + __REGCMD("Reset", VT100_Reset); + __REGCMD("SCP", VT100_SCP); +/* BEGIN */ + __COPY("\033", VT100_CSI, 5); + Strings_Append((CHAR*)"[", 2, (void*)VT100_CSI, 5); + __ENDMOD; +} diff --git a/bootstrap/unix-48/VT100.h b/bootstrap/unix-48/VT100.h new file mode 100644 index 00000000..4e708647 --- /dev/null +++ b/bootstrap/unix-48/VT100.h @@ -0,0 +1,38 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef VT100__h +#define VT100__h + +#include "SYSTEM.h" + + +import CHAR VT100_CSI[5]; + + +import void VT100_CHA (INT16 n); +import void VT100_CNL (INT16 n); +import void VT100_CPL (INT16 n); +import void VT100_CUB (INT16 n); +import void VT100_CUD (INT16 n); +import void VT100_CUF (INT16 n); +import void VT100_CUP (INT16 n, INT16 m); +import void VT100_CUU (INT16 n); +import void VT100_DECTCEMh (void); +import void VT100_DECTCEMl (void); +import void VT100_DSR (INT16 n); +import void VT100_ED (INT16 n); +import void VT100_EL (INT16 n); +import void VT100_HVP (INT16 n, INT16 m); +import void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +import void VT100_RCP (void); +import void VT100_Reset (void); +import void VT100_SCP (void); +import void VT100_SD (INT16 n); +import void VT100_SGR (INT16 n); +import void VT100_SGR2 (INT16 n, INT16 m); +import void VT100_SU (INT16 n); +import void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); +import void *VT100__init(void); + + +#endif // VT100 diff --git a/bootstrap/unix-48/extTools.c b/bootstrap/unix-48/extTools.c new file mode 100644 index 00000000..ce2fc413 --- /dev/null +++ b/bootstrap/unix-48/extTools.c @@ -0,0 +1,139 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "Modules.h" +#include "OPM.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + CHAR extTools_CommandString[4096]; + + +static extTools_CommandString extTools_CFLAGS; + + +export void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len); +export void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len); + + +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len) +{ + INT16 r, status, exitcode; + extTools_CommandString fullcmd; + __DUP(title, title__len, CHAR); + __DUP(cmd, cmd__len, CHAR); + if (__IN(18, OPM_Options, 32)) { + Out_String((CHAR*)" ", 3); + Out_String(cmd, cmd__len); + Out_Ln(); + } + __COPY(cmd, fullcmd, 4096); + Heap_GC(0); + r = Platform_System(fullcmd, 4096); + status = __MASK(r, -128); + exitcode = __ASHR(r, 8); + if (exitcode > 127) { + exitcode = exitcode - 256; + } + if (r != 0) { + Out_String(title, title__len); + Out_String(cmd, cmd__len); + Out_Ln(); + Out_String((CHAR*)"-- failed: status ", 19); + Out_Int(status, 1); + Out_String((CHAR*)", exitcode ", 12); + Out_Int(exitcode, 1); + Out_String((CHAR*)".", 2); + Out_Ln(); + if ((status == 0 && exitcode == 127)) { + Out_String((CHAR*)"Is the C compiler in the current command path\?", 47); + Out_Ln(); + } + if (status != 0) { + Modules_Halt(status); + } else { + Modules_Halt(exitcode); + } + } + __DEL(title); + __DEL(cmd); +} + +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + __DUP(additionalopts, additionalopts__len, CHAR); + __COPY("gcc -fPIC -g -Wno-stringop-overflow", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Strings_Append(additionalopts, additionalopts__len, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 4096); + Strings_Append(extTools_CFLAGS, 4096, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + __DEL(additionalopts); +} + +void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len) +{ + extTools_CommandString cmd; + __DUP(moduleName, moduleName__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, (CHAR*)"", 1); + Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c", 3, (void*)cmd, 4096); + extTools_execute((CHAR*)"C compile: ", 12, cmd, 4096); + __DEL(moduleName); +} + +void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + extTools_CommandString cmd; + __DUP(additionalopts, additionalopts__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, additionalopts, additionalopts__len); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c ", 4, (void*)cmd, 4096); + if (statically) { + Strings_Append((CHAR*)" -static", 9, (void*)cmd, 4096); + } + Strings_Append((CHAR*)" -o ", 5, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + if (!statically || 1) { + Strings_Append((CHAR*)" -L\"", 5, (void*)cmd, 4096); + Strings_Append(OPM_InstallDir, 1024, (void*)cmd, 4096); + Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 4096); + Strings_Append((CHAR*)" -lvoc", 7, (void*)cmd, 4096); + Strings_Append((CHAR*)"-O", 3, (void*)cmd, 4096); + Strings_Append(OPM_Model, 10, (void*)cmd, 4096); + Strings_Append((CHAR*)"", 1, (void*)cmd, 4096); + } + extTools_execute((CHAR*)"C compile and link: ", 21, cmd, 4096); + __DEL(additionalopts); +} + + +export void *extTools__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("extTools", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-48/extTools.h b/bootstrap/unix-48/extTools.h new file mode 100644 index 00000000..686f0b4e --- /dev/null +++ b/bootstrap/unix-48/extTools.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef extTools__h +#define extTools__h + +#include "SYSTEM.h" + + + + +import void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +import void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +import void *extTools__init(void); + + +#endif // extTools diff --git a/bootstrap/unix-88/Compiler.c b/bootstrap/unix-88/Compiler.c new file mode 100644 index 00000000..4460479d --- /dev/null +++ b/bootstrap/unix-88/Compiler.c @@ -0,0 +1,213 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspamS */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "OPB.h" +#include "OPC.h" +#include "OPM.h" +#include "OPP.h" +#include "OPT.h" +#include "OPV.h" +#include "Platform.h" +#include "Strings.h" +#include "VT100.h" +#include "extTools.h" + + + + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len); +export void Compiler_Module (BOOLEAN *done); +static void Compiler_PropagateElementaryTypeSizes (void); +export void Compiler_Translate (void); +static void Compiler_Trap (INT32 sig); + + +void Compiler_Module (BOOLEAN *done) +{ + BOOLEAN ext, new; + OPT_Node p = NIL; + OPP_Module(&p, OPM_Options); + if (OPM_noerr) { + OPV_Init(); + OPT_InitRecno(); + OPV_AdrAndSize(OPT_topScope); + OPT_Export(&ext, &new); + if (OPM_noerr) { + OPM_OpenFiles((void*)OPT_SelfName, 256); + OPM_DeleteObj((void*)OPT_SelfName, 256); + OPC_Init(); + OPV_Module(p); + if (OPM_noerr) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" Main program.", 16); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + if (new) { + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" New symbol file.", 19); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_RegisterNewSym(); + } else if (ext) { + OPM_LogWStr((CHAR*)" Extended symbol file.", 24); + OPM_RegisterNewSym(); + } + } + } else { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } + OPM_CloseFiles(); + OPT_Close(); + OPM_LogWLn(); + *done = OPM_noerr; +} + +static void Compiler_PropagateElementaryTypeSizes (void) +{ + OPT_Struct adrinttyp = NIL; + OPT_sysptrtyp->size = OPM_AddressSize; + OPT_sysptrtyp->idfp = OPT_sysptrtyp->form; + OPM_FPrint(&OPT_sysptrtyp->idfp, OPT_sysptrtyp->size); + OPT_adrtyp->size = OPM_AddressSize; + OPT_adrtyp->idfp = OPT_adrtyp->form; + OPM_FPrint(&OPT_adrtyp->idfp, OPT_adrtyp->size); + adrinttyp = OPT_IntType(OPM_AddressSize); + OPT_adrtyp->strobj = adrinttyp->strobj; + OPT_sinttyp = OPT_IntType(OPM_ShortintSize); + OPT_inttyp = OPT_IntType(OPM_IntegerSize); + OPT_linttyp = OPT_IntType(OPM_LongintSize); + OPT_sintobj->typ = OPT_sinttyp; + OPT_intobj->typ = OPT_inttyp; + OPT_lintobj->typ = OPT_linttyp; + switch (OPM_SetSize) { + case 4: + OPT_settyp = OPT_set32typ; + break; + default: + OPT_settyp = OPT_set64typ; + break; + } + OPT_setobj->typ = OPT_settyp; + if (__STRCMP(OPM_Model, "C") == 0) { + OPT_cpbytetyp->strobj->name[4] = 0x00; + } else { + OPT_cpbytetyp->strobj->name[4] = '@'; + } +} + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len) +{ + OPT_Link l = NIL; + CHAR fn[64]; + Platform_FileIdentity id; + objectnames[0] = 0x00; + l = OPT_Links; + while (l != NIL) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".sym", 5, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".o", 3, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + Strings_Append((CHAR*)" ", 2, (void*)objectnames, objectnames__len); + Strings_Append(fn, 64, (void*)objectnames, objectnames__len); + } else { + OPM_LogVT100((CHAR*)"91m", 4); + OPM_LogWStr((CHAR*)"Link warning: a local symbol file is present for module ", 57); + OPM_LogWStr(l->name, 256); + OPM_LogWStr((CHAR*)", but local object file '", 26); + OPM_LogWStr(fn, 64); + OPM_LogWStr((CHAR*)"' is missing.", 14); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_LogWLn(); + } + } + l = l->next; + } +} + +void Compiler_Translate (void) +{ + BOOLEAN done; + CHAR linkfiles[2048]; + if (OPM_OpenPar()) { + for (;;) { + OPM_Init(&done); + if (!done) { + return; + } + OPM_InitOptions(); + Compiler_PropagateElementaryTypeSizes(); + Heap_GC(0); + Compiler_Module(&done); + if (!done) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Module compilation failed.", 27); + OPM_LogWLn(); + Platform_Exit(1); + } + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + if (!__IN(10, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + Compiler_FindLocalObjectFiles((void*)linkfiles, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), linkfiles, 2048); + } + } + } + } + } +} + +static void Compiler_Trap (INT32 sig) +{ + Heap_FINALL(); + if (sig == 3) { + Platform_Exit(0); + } else { + if (sig == 4) { + OPM_LogWStr((CHAR*)" --- Oberon compiler internal error", 36); + OPM_LogWLn(); + } + Platform_Exit(2); + } +} + + +export int main(int argc, char **argv) +{ + __INIT(argc, argv); + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPP); + __MODULE_IMPORT(OPT); + __MODULE_IMPORT(OPV); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(VT100); + __MODULE_IMPORT(extTools); + __REGMAIN("Compiler", 0); + __REGCMD("Translate", Compiler_Translate); +/* BEGIN */ + Platform_SetInterruptHandler(Compiler_Trap); + Platform_SetQuitHandler(Compiler_Trap); + Platform_SetBadInstructionHandler(Compiler_Trap); + Compiler_Translate(); + __FINI; +} diff --git a/bootstrap/unix-88/Configuration.c b/bootstrap/unix-88/Configuration.c new file mode 100644 index 00000000..fa87c9de --- /dev/null +++ b/bootstrap/unix-88/Configuration.c @@ -0,0 +1,24 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + +export CHAR Configuration_versionLong[76]; + + + + + +export void *Configuration__init(void) +{ + __DEFMOD; + __REGMOD("Configuration", 0); +/* BEGIN */ + __MOVE("2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 76); + __ENDMOD; +} diff --git a/bootstrap/unix-88/Configuration.h b/bootstrap/unix-88/Configuration.h new file mode 100644 index 00000000..c3c54eed --- /dev/null +++ b/bootstrap/unix-88/Configuration.h @@ -0,0 +1,15 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Configuration__h +#define Configuration__h + +#include "SYSTEM.h" + + +import CHAR Configuration_versionLong[76]; + + +import void *Configuration__init(void); + + +#endif // Configuration diff --git a/bootstrap/unix-88/Files.c b/bootstrap/unix-88/Files.c new file mode 100644 index 00000000..57e78310 --- /dev/null +++ b/bootstrap/unix-88/Files.c @@ -0,0 +1,1097 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_BufDesc { + Files_File f; + BOOLEAN chg; + INT32 org, size; + SYSTEM_BYTE data[4096]; + } Files_BufDesc; + +typedef + Files_BufDesc *Files_Buffer; + +typedef + CHAR Files_FileName[256]; + +typedef + struct Files_FileDesc { + Files_FileName workName, registerName; + BOOLEAN tempFile; + Platform_FileIdentity identity; + INT32 fd, len, pos; + Files_Buffer bufs[4]; + INT16 swapper, state; + struct Files_FileDesc *next; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + Files_Buffer buf; + INT32 org, offset; + } Files_Rider; + + +export INT16 Files_MaxPathLength, Files_MaxNameLength; +static Files_FileDesc *Files_files; +static INT16 Files_tempno; +static CHAR Files_HOME[1024]; +static struct { + ADDRESS len[1]; + CHAR data[1]; +} *Files_SearchPath; + +export ADDRESS *Files_FileDesc__typ; +export ADDRESS *Files_BufDesc__typ; +export ADDRESS *Files_Rider__typ; + +static void Files_Assert (BOOLEAN truth); +export Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +static Files_File Files_CacheEntry (Platform_FileIdentity identity); +export void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +export void Files_Close (Files_File f); +static void Files_CloseOSFile (Files_File f); +static void Files_Create (Files_File f); +export void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +static void Files_Deregister (CHAR *name, ADDRESS name__len); +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode); +static void Files_Finalize (SYSTEM_PTR o); +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len); +static void Files_Flush (Files_Buffer buf); +export void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +export void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len); +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len); +export INT32 Files_Length (Files_File f); +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len); +export Files_File Files_New (CHAR *name, ADDRESS name__len); +export Files_File Files_Old (CHAR *name, ADDRESS name__len); +export INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +export void Files_Purge (Files_File f); +export void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +export void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +export void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +export void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +export void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +export void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +export void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +export void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_Register (Files_File f); +export void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len); +export void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +export void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +export void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +export void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +export void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +export void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +export void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +export void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +export void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +export void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +export void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); + +#define Files_IdxTrap() __HALT(-1) + +static void Files_Assert (BOOLEAN truth) +{ + if (!truth) { + Out_Ln(); + __ASSERT(truth, 0); + } +} + +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode) +{ + __DUP(s, s__len, CHAR); + Out_Ln(); + Out_String((CHAR*)"-- ", 4); + Out_String(s, s__len); + Out_String((CHAR*)": ", 3); + if (f != NIL) { + if (f->registerName[0] != 0x00) { + Out_String(f->registerName, 256); + } else { + Out_String(f->workName, 256); + } + if (f->fd != 0) { + Out_String((CHAR*)", f.fd = ", 10); + Out_Int(f->fd, 1); + } + } + if (errcode != 0) { + Out_String((CHAR*)", errcode = ", 13); + Out_Int(errcode, 1); + } + Out_Ln(); + __HALT(99); + __DEL(s); +} + +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 i, j, ld, ln; + __DUP(dir, dir__len, CHAR); + __DUP(name, name__len, CHAR); + ld = Strings_Length(dir, dir__len); + ln = Strings_Length(name, name__len); + while ((ld > 0 && dir[__X(ld - 1, dir__len)] == '/')) { + ld -= 1; + } + if (((ld + ln) + 2) > dest__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + i = 0; + while (i < ld) { + dest[__X(i, dest__len)] = dir[__X(i, dir__len)]; + i += 1; + } + if (i > 0) { + dest[__X(i, dest__len)] = '/'; + i += 1; + } + j = 0; + while (j < ln) { + dest[__X(i, dest__len)] = name[__X(j, name__len)]; + i += 1; + j += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(dir); + __DEL(name); +} + +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len) +{ + INT16 i, n; + __DUP(finalName, finalName__len, CHAR); + if (finalName[0] == '/') { + __COPY(finalName, name, name__len); + } else { + Files_MakeFileName(Platform_CWD, 256, finalName, finalName__len, (void*)name, name__len); + } + i = Strings_Length(name, name__len) - 1; + while ((i > 0 && name[__X(i, name__len)] != '/')) { + i -= 1; + } + if ((i + 16) >= name__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + Files_tempno += 1; + n = Files_tempno; + name[__X(i + 1, name__len)] = '.'; + name[__X(i + 2, name__len)] = 't'; + name[__X(i + 3, name__len)] = 'm'; + name[__X(i + 4, name__len)] = 'p'; + name[__X(i + 5, name__len)] = '.'; + i += 6; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = '.'; + i += 1; + n = Platform_PID; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = 0x00; + __DEL(finalName); +} + +static void Files_Deregister (CHAR *name, ADDRESS name__len) +{ + Platform_FileIdentity identity; + Files_File osfile = NIL; + INT16 error; + __DUP(name, name__len, CHAR); + if (Platform_IdentifyByName(name, name__len, &identity, Platform_FileIdentity__typ) == 0) { + osfile = (Files_File)Files_files; + while ((osfile != NIL && !Platform_SameFile(osfile->identity, identity))) { + osfile = (Files_File)osfile->next; + } + if (osfile != NIL) { + __ASSERT(!osfile->tempFile, 0); + __ASSERT(osfile->fd >= 0, 0); + __MOVE(osfile->workName, osfile->registerName, 256); + Files_GetTempName(osfile->registerName, 256, (void*)osfile->workName, 256); + osfile->tempFile = 1; + osfile->state = 0; + error = Platform_Rename((void*)osfile->registerName, 256, (void*)osfile->workName, 256); + if (error != 0) { + Files_Err((CHAR*)"Couldn't rename previous version of file being registered", 58, osfile, error); + } + } + } + __DEL(name); +} + +static void Files_Create (Files_File f) +{ + BOOLEAN done; + INT16 error; + CHAR err[32]; + if (f->fd == -1) { + if (f->state == 1) { + Files_GetTempName(f->registerName, 256, (void*)f->workName, 256); + f->tempFile = 1; + } else { + __ASSERT(f->state == 2, 0); + Files_Deregister(f->registerName, 256); + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } + error = Platform_Unlink((void*)f->workName, 256); + error = Platform_New((void*)f->workName, 256, &f->fd); + done = error == 0; + if (done) { + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->state = 0; + f->pos = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + } else { + if (Platform_NoSuchDirectory(error)) { + __MOVE("no such directory", err, 18); + } else if (Platform_TooManyFiles(error)) { + __MOVE("too many files open", err, 20); + } else { + __MOVE("file not created", err, 17); + } + Files_Err(err, 32, f, error); + } + } +} + +static void Files_Flush (Files_Buffer buf) +{ + INT16 error; + Files_File f = NIL; + if (buf->chg) { + f = buf->f; + Files_Create(f); + if (buf->org != f->pos) { + error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); + } + error = Platform_Write(f->fd, (ADDRESS)buf->data, buf->size); + if (error != 0) { + Files_Err((CHAR*)"error writing file", 19, f, error); + } + f->pos = buf->org + buf->size; + buf->chg = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + if (error != 0) { + Files_Err((CHAR*)"error identifying file", 23, f, error); + } + } +} + +void Files_Close (Files_File f) +{ + INT32 i; + INT16 error; + if (f->state != 1 || f->registerName[0] != 0x00) { + Files_Create(f); + i = 0; + while ((i < 4 && f->bufs[__X(i, 4)] != NIL)) { + Files_Flush(f->bufs[__X(i, 4)]); + i += 1; + } + } +} + +INT32 Files_Length (Files_File f) +{ + return f->len; +} + +Files_File Files_New (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + __DUP(name, name__len, CHAR); + __NEW(f, Files_FileDesc); + f->workName[0] = 0x00; + __COPY(name, f->registerName, 256); + f->fd = -1; + f->state = 1; + f->len = 0; + f->pos = 0; + f->swapper = -1; + __DEL(name); + return f; +} + +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len) +{ + INT16 i; + CHAR ch; + i = 0; + if (Files_SearchPath == NIL) { + if (*pos == 0) { + dir[0] = '.'; + i = 1; + *pos += 1; + } + } else { + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (ch == ' ' || ch == ';') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + if (ch == '~') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (Files_HOME[__X(i, 1024)] != 0x00) { + dir[__X(i, dir__len)] = Files_HOME[__X(i, 1024)]; + i += 1; + } + if ((((((ch != '/' && ch != 0x00)) && ch != ';')) && ch != ' ')) { + while ((i > 0 && dir[__X(i - 1, dir__len)] != '/')) { + i -= 1; + } + } + } + while ((ch != 0x00 && ch != ';')) { + dir[__X(i, dir__len)] = ch; + i += 1; + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + while ((i > 0 && dir[__X(i - 1, dir__len)] == ' ')) { + i -= 1; + } + } + dir[__X(i, dir__len)] = 0x00; +} + +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + ch = name[0]; + while ((ch != 0x00 && ch != '/')) { + i += 1; + ch = name[__X(i, name__len)]; + } + return ch == '/'; +} + +static Files_File Files_CacheEntry (Platform_FileIdentity identity) +{ + Files_File f = NIL; + INT16 i, error; + f = (Files_File)Files_files; + while (f != NIL) { + if (Platform_SameFile(identity, f->identity)) { + if (!Platform_SameFileTime(identity, f->identity)) { + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + f->swapper = -1; + f->identity = identity; + error = Platform_Size(f->fd, &f->len); + } + return f; + } + f = (Files_File)f->next; + } + return NIL; +} + +Files_File Files_Old (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + INT32 fd; + INT16 pos; + BOOLEAN done; + CHAR dir[256], path[256]; + INT16 error; + Platform_FileIdentity identity; + __DUP(name, name__len, CHAR); + if (name[0] != 0x00) { + if (Files_HasDir((void*)name, name__len)) { + dir[0] = 0x00; + __COPY(name, path, 256); + } else { + pos = 0; + Files_ScanPath(&pos, (void*)dir, 256); + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + for (;;) { + error = Platform_OldRW((void*)path, 256, &fd); + done = error == 0; + if ((!done && Platform_TooManyFiles(error))) { + Files_Err((CHAR*)"too many files open", 20, f, error); + } + if ((!done && Platform_Inaccessible(error))) { + error = Platform_OldRO((void*)path, 256, &fd); + done = error == 0; + } + if ((!done && !Platform_Absent(error))) { + Out_String((CHAR*)"Warning: Files.Old ", 20); + Out_String(name, name__len); + Out_String((CHAR*)" error = ", 10); + Out_Int(error, 0); + Out_Ln(); + } + if (done) { + error = Platform_Identify(fd, &identity, Platform_FileIdentity__typ); + f = Files_CacheEntry(identity); + if (f != NIL) { + error = Platform_Close(fd); + __DEL(name); + return f; + } else { + __NEW(f, Files_FileDesc); + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->fd = fd; + f->state = 0; + f->pos = 0; + f->swapper = -1; + error = Platform_Size(fd, &f->len); + __COPY(name, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + f->identity = identity; + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + __DEL(name); + return f; + } + } else if (dir[0] == 0x00) { + __DEL(name); + return NIL; + } else { + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + } + } else { + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Files_Purge (Files_File f) +{ + INT16 i; + Platform_FileIdentity identity; + INT16 error; + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + if (f->fd != -1) { + error = Platform_Truncate(f->fd, 0); + error = Platform_Seek(f->fd, 0, Platform_SeekSet); + } + f->pos = 0; + f->len = 0; + f->swapper = -1; + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_SetMTime(&f->identity, Platform_FileIdentity__typ, identity); +} + +void Files_GetDate (Files_File f, INT32 *t, INT32 *d) +{ + Platform_FileIdentity identity; + INT16 error; + Files_Create(f); + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_MTimeAsClock(identity, &*t, &*d); +} + +INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ) +{ + Files_Assert((*r).offset <= 4096); + return (*r).org + (*r).offset; +} + +void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos) +{ + INT32 org, offset, i, n; + Files_Buffer buf = NIL; + INT16 error; + if (f != NIL) { + if (pos > f->len) { + pos = f->len; + } else if (pos < 0) { + pos = 0; + } + offset = __MASK(pos, -4096); + org = pos - offset; + i = 0; + while ((((i < 4 && f->bufs[__X(i, 4)] != NIL)) && org != f->bufs[__X(i, 4)]->org)) { + i += 1; + } + if (i < 4) { + if (f->bufs[__X(i, 4)] == NIL) { + __NEW(buf, Files_BufDesc); + buf->chg = 0; + buf->org = -1; + buf->f = f; + f->bufs[__X(i, 4)] = buf; + } else { + buf = f->bufs[__X(i, 4)]; + } + } else { + f->swapper = __MASK(f->swapper + 1, -4); + buf = f->bufs[__X(f->swapper, 4)]; + Files_Flush(buf); + } + if (buf->org != org) { + if (org == f->len) { + buf->size = 0; + } else { + Files_Create(f); + if (f->pos != org) { + error = Platform_Seek(f->fd, org, Platform_SeekSet); + } + error = Platform_ReadBuf(f->fd, (void*)buf->data, 4096, &n); + if (error != 0) { + Files_Err((CHAR*)"read from file not done", 24, f, error); + } + f->pos = org + n; + buf->size = n; + } + buf->org = org; + buf->chg = 0; + } + } else { + buf = NIL; + org = 0; + offset = 0; + } + Files_Assert(offset <= 4096); + (*r).buf = buf; + (*r).org = org; + (*r).offset = offset; + (*r).eof = 0; + (*r).res = 0; +} + +void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + INT32 offset; + Files_Buffer buf = NIL; + buf = (*r).buf; + offset = (*r).offset; + if ((*r).org != buf->org) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= buf->size); + if (offset < buf->size) { + *x = buf->data[__X(offset, 4096)]; + (*r).offset = offset + 1; + } else if ((*r).org + offset < buf->f->len) { + Files_Set(&*r, r__typ, (*r).buf->f, (*r).org + offset); + *x = (*r).buf->data[0]; + (*r).offset = 1; + } else { + *x = 0x00; + (*r).eof = 1; + } +} + +void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + Files_Read(&*r, r__typ, &*x); +} + +void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + restInBuf = buf->size - offset; + if (restInBuf == 0) { + (*r).res = n; + (*r).eof = 1; + return; + } else if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&buf->data[__X(offset, 4096)], (ADDRESS)&x[__X(xpos, x__len)], min); + offset += min; + (*r).offset = offset; + xpos += min; + n -= min; + Files_Assert(offset <= 4096); + } + (*r).res = 0; + (*r).eof = 0; +} + +Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ) +{ + return (*r).buf->f; +} + +void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x) +{ + Files_Buffer buf = NIL; + INT32 offset; + buf = (*r).buf; + offset = (*r).offset; + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset < 4096); + buf->data[__X(offset, 4096)] = x; + buf->chg = 1; + if (offset == buf->size) { + buf->size += 1; + buf->f->len += 1; + } + (*r).offset = offset + 1; + (*r).res = 0; +} + +void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= 4096); + restInBuf = 4096 - offset; + if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&x[__X(xpos, x__len)], (ADDRESS)&buf->data[__X(offset, 4096)], min); + offset += min; + (*r).offset = offset; + Files_Assert(offset <= 4096); + if (offset > buf->size) { + buf->f->len += offset - buf->size; + buf->size = offset; + } + xpos += min; + n -= min; + buf->chg = 1; + } + (*r).res = 0; +} + +void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res) +{ + __DUP(name, name__len, CHAR); + Files_Deregister(name, name__len); + *res = Platform_Unlink((void*)name, name__len); + __DEL(name); +} + +void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res) +{ + INT32 fdold, fdnew, n; + INT16 error, ignore; + Platform_FileIdentity oldidentity, newidentity; + CHAR buf[4096]; + __DUP(old, old__len, CHAR); + __DUP(new, new__len, CHAR); + error = Platform_IdentifyByName(old, old__len, &oldidentity, Platform_FileIdentity__typ); + if (error == 0) { + error = Platform_IdentifyByName(new, new__len, &newidentity, Platform_FileIdentity__typ); + if ((error != 0 && !Platform_SameFile(oldidentity, newidentity))) { + Files_Delete(new, new__len, &error); + } + error = Platform_Rename((void*)old, old__len, (void*)new, new__len); + if (!Platform_DifferentFilesystems(error)) { + *res = error; + __DEL(old); + __DEL(new); + return; + } else { + error = Platform_OldRO((void*)old, old__len, &fdold); + if (error != 0) { + *res = 2; + __DEL(old); + __DEL(new); + return; + } + error = Platform_New((void*)new, new__len, &fdnew); + if (error != 0) { + error = Platform_Close(fdold); + *res = 3; + __DEL(old); + __DEL(new); + return; + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + while (n > 0) { + error = Platform_Write(fdnew, (ADDRESS)buf, n); + if (error != 0) { + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + } + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + if (n == 0) { + error = Platform_Unlink((void*)old, old__len); + *res = 0; + } else { + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + } + } else { + *res = 2; + } + __DEL(old); + __DEL(new); +} + +void Files_Register (Files_File f) +{ + INT16 idx, errcode; + Files_File f1 = NIL; + if ((f->state == 1 && f->registerName[0] != 0x00)) { + f->state = 2; + } + Files_Close(f); + if (f->registerName[0] != 0x00) { + Files_Deregister(f->registerName, 256); + Files_Rename(f->workName, 256, f->registerName, 256, &errcode); + if (errcode != 0) { + Files_Err((CHAR*)"Couldn't rename temp name as register name", 43, f, errcode); + } + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } +} + +void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res) +{ + __DUP(path, path__len, CHAR); + *res = Platform_Chdir((void*)path, path__len); + __DEL(path); +} + +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len) +{ + INT32 i, j; + if (!Platform_LittleEndian) { + i = src__len; + j = 0; + while (i > 0) { + i -= 1; + dest[__X(j, dest__len)] = src[__X(i, src__len)]; + j += 1; + } + } else { + __MOVE((ADDRESS)src, (ADDRESS)dest, src__len); + } +} + +void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x) +{ + Files_Read(&*R, R__typ, (CHAR*)(void*)&*x); +} + +void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x) +{ + CHAR b[2]; + Files_ReadBytes(&*R, R__typ, (void*)b, 2, 2); + *x = (INT16)b[0] + __ASHL((INT16)b[1], 8); +} + +void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + *x = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); +} + +void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x) +{ + CHAR b[4]; + INT32 l; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + l = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); + *x = (UINT32)l; +} + +void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + Files_FlipBytes((void*)b, 4, (void*)&*x, 4); +} + +void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x) +{ + CHAR b[8]; + Files_ReadBytes(&*R, R__typ, (void*)b, 8, 8); + Files_FlipBytes((void*)b, 8, (void*)&*x, 8); +} + +void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&ch); + x[__X(i, x__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&x[__X(i, x__len)]); + i += 1; + } while (!(x[__X(i - 1, x__len)] == 0x00 || x[__X(i - 1, x__len)] == 0x0a)); + if (x[__X(i - 1, x__len)] == 0x0a) { + i -= 1; + } + if ((i > 0 && x[__X(i - 1, x__len)] == 0x0d)) { + i -= 1; + } + x[__X(i, x__len)] = 0x00; +} + +void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len) +{ + INT8 s, b; + INT64 q; + s = 0; + q = 0; + Files_Read(&*R, R__typ, (void*)&b); + while (b < 0) { + q += (INT64)__ASH(((INT16)b + 128), s); + s += 7; + Files_Read(&*R, R__typ, (void*)&b); + } + q += (INT64)__ASH((__MASK(b, -64) - __ASHL(__ASHR(b, 6), 6)), s); + Files_Assert(x__len <= 8); + __MOVE((ADDRESS)&q, (ADDRESS)x, x__len); +} + +void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x) +{ + Files_Write(&*R, R__typ, __VAL(CHAR, x)); +} + +void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x) +{ + CHAR b[2]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + Files_WriteBytes(&*R, R__typ, (void*)b, 2, 2); +} + +void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x) +{ + CHAR b[4]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + b[2] = __CHR(__ASHR(x, 16)); + b[3] = __CHR(__ASHR(x, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x) +{ + CHAR b[4]; + INT32 i; + UINT64 y; + y = x; + i = __VAL(INT32, y); + b[0] = __CHR(i); + b[1] = __CHR(__ASHR(i, 8)); + b[2] = __CHR(__ASHR(i, 16)); + b[3] = __CHR(__ASHR(i, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x) +{ + CHAR b[4]; + Files_FlipBytes((void*)&x, 4, (void*)b, 4); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x) +{ + CHAR b[8]; + Files_FlipBytes((void*)&x, 8, (void*)b, 8); + Files_WriteBytes(&*R, R__typ, (void*)b, 8, 8); +} + +void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + while (x[__X(i, x__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&*R, R__typ, (void*)x, x__len * 1, i + 1); +} + +void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x) +{ + while (x < -64 || x > 63) { + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128) + 128)); + x = __ASHR(x, 7); + } + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128))); +} + +void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len) +{ + __COPY(f->workName, name, name__len); +} + +static void Files_CloseOSFile (Files_File f) +{ + Files_File prev = NIL; + INT16 error; + if (Files_files == (void *) f) { + Files_files = f->next; + } else { + prev = (Files_File)Files_files; + while ((prev != NIL && prev->next != (void *) f)) { + prev = (Files_File)prev->next; + } + if (prev->next != NIL) { + prev->next = f->next; + } + } + error = Platform_Close(f->fd); + f->fd = -1; + f->state = 1; + Heap_FileCount -= 1; +} + +static void Files_Finalize (SYSTEM_PTR o) +{ + Files_File f = NIL; + INT32 res; + f = (Files_File)(ADDRESS)o; + if (f->fd >= 0) { + Files_CloseOSFile(f); + if (f->tempFile) { + res = Platform_Unlink((void*)f->workName, 256); + } + } +} + +void Files_SetSearchPath (CHAR *path, ADDRESS path__len) +{ + __DUP(path, path__len, CHAR); + if (Strings_Length(path, path__len) != 0) { + Files_SearchPath = __NEWARR(NIL, 1, 1, 1, 1, ((ADDRESS)((Strings_Length(path, path__len) + 1)))); + __COPY(path, Files_SearchPath->data, Files_SearchPath->len[0]); + } else { + Files_SearchPath = NIL; + } + __DEL(path); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Files_SearchPath); +} + +__TDESC(Files_FileDesc, 1, 4) = {__TDFLDS("FileDesc", 592), {544, 552, 560, 568, -40}}; +__TDESC(Files_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 4120), {0, -16}}; +__TDESC(Files_Rider, 1, 1) = {__TDFLDS("Rider", 24), {8, -16}}; + +export void *Files__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("Files", EnumPtrs); + __INITYP(Files_FileDesc, Files_FileDesc, 0); + __INITYP(Files_BufDesc, Files_BufDesc, 0); + __INITYP(Files_Rider, Files_Rider, 0); +/* BEGIN */ + Files_tempno = -1; + Heap_FileCount = 0; + Files_HOME[0] = 0x00; + Platform_GetEnv((CHAR*)"HOME", 5, (void*)Files_HOME, 1024); + Files_MaxPathLength = Platform_MaxPathLength(); + Files_MaxNameLength = Platform_MaxNameLength(); + __ENDMOD; +} diff --git a/bootstrap/unix-88/Files.h b/bootstrap/unix-88/Files.h new file mode 100644 index 00000000..676f434c --- /dev/null +++ b/bootstrap/unix-88/Files.h @@ -0,0 +1,71 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Files__h +#define Files__h + +#include "SYSTEM.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_FileDesc { + INT64 _prvt0; + char _prvt1[584]; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + INT64 _prvt0; + char _prvt1[8]; + } Files_Rider; + + +import INT16 Files_MaxPathLength, Files_MaxNameLength; + +import ADDRESS *Files_FileDesc__typ; +import ADDRESS *Files_Rider__typ; + +import Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +import void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +import void Files_Close (Files_File f); +import void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +import void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +import void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +import INT32 Files_Length (Files_File f); +import Files_File Files_New (CHAR *name, ADDRESS name__len); +import Files_File Files_Old (CHAR *name, ADDRESS name__len); +import INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +import void Files_Purge (Files_File f); +import void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +import void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +import void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +import void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +import void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +import void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +import void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +import void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_Register (Files_File f); +import void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +import void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +import void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +import void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +import void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +import void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +import void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +import void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +import void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +import void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +import void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +import void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void *Files__init(void); + + +#endif // Files diff --git a/bootstrap/unix-88/Heap.c b/bootstrap/unix-88/Heap.c new file mode 100644 index 00000000..7b004b60 --- /dev/null +++ b/bootstrap/unix-88/Heap.c @@ -0,0 +1,799 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +struct Heap__1 { + CHAR ch; + SYSTEM_PTR p; +}; + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + struct Heap_FinDesc *Heap_FinNode; + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_FinDesc { + Heap_FinNode next; + INT64 obj; + BOOLEAN marked; + Heap_Finalizer finalize; + } Heap_FinDesc; + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT64 types; + Heap_EnumProc enumPtrs; + INT32 reserved1, reserved2; + } Heap_ModuleDesc; + + +export SYSTEM_PTR Heap_modules; +static INT64 Heap_freeList[10]; +static INT64 Heap_bigBlocks; +export INT64 Heap_allocated; +static BOOLEAN Heap_firstTry; +static INT16 Heap_ldUnit; +export INT64 Heap_heap; +static INT64 Heap_heapMin, Heap_heapMax; +export INT64 Heap_heapsize, Heap_heapMinExpand; +static Heap_FinNode Heap_fin; +static INT16 Heap_lockdepth; +static BOOLEAN Heap_interrupted; +export INT16 Heap_FileCount; + +export ADDRESS *Heap_ModuleDesc__typ; +export ADDRESS *Heap_CmdDesc__typ; +export ADDRESS *Heap_FinDesc__typ; +export ADDRESS *Heap__1__typ; + +static void Heap_CheckFin (void); +static void Heap_ExtendHeap (INT64 blksz); +export void Heap_FINALL (void); +static void Heap_Finalize (void); +export INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +export void Heap_GC (BOOLEAN markStack); +static void Heap_HeapSort (INT32 n, INT64 *a, ADDRESS a__len); +export void Heap_INCREF (Heap_Module m); +export void Heap_InitHeap (void); +export void Heap_Lock (void); +static void Heap_Mark (INT64 q); +static void Heap_MarkCandidates (INT32 n, INT64 *cand, ADDRESS cand__len); +static void Heap_MarkP (SYSTEM_PTR p); +static void Heap_MarkStack (INT64 n, INT64 *cand, ADDRESS cand__len); +export SYSTEM_PTR Heap_NEWBLK (INT64 size); +export SYSTEM_PTR Heap_NEWREC (INT64 tag); +static INT64 Heap_NewChunk (INT64 blksz); +export void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +export SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +export void Heap_REGTYP (Heap_Module m, INT64 typ); +export void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +static void Heap_Scan (void); +static void Heap_Sift (INT32 l, INT32 r, INT64 *a, ADDRESS a__len); +export void Heap_Unlock (void); + +extern void *Heap__init(); +extern ADDRESS Modules_MainStackFrame; +extern ADDRESS Platform_OSAllocate(ADDRESS size); +#define Heap_HeapModuleInit() Heap__init() +#define Heap_ModulesHalt(code) Modules_Halt(code) +#define Heap_ModulesMainStackFrame() Modules_MainStackFrame +#define Heap_OSAllocate(size) Platform_OSAllocate(size) +#define Heap_uLE(x, y) ((size_t)x <= (size_t)y) +#define Heap_uLT(x, y) ((size_t)x < (size_t)y) + +void Heap_Lock (void) +{ + Heap_lockdepth += 1; +} + +void Heap_Unlock (void) +{ + Heap_lockdepth -= 1; + if ((Heap_interrupted && Heap_lockdepth == 0)) { + Heap_ModulesHalt(-9); + } +} + +SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) +{ + Heap_Module m; + if (__STRCMP(name, "Heap") == 0) { + __SYSNEW(m, 64); + } else { + __NEW(m, Heap_ModuleDesc); + } + m->types = 0; + m->cmds = NIL; + __COPY(name, m->name, 20); + m->refcnt = 0; + m->enumPtrs = enumPtrs; + m->next = (Heap_Module)(ADDRESS)Heap_modules; + Heap_modules = (SYSTEM_PTR)m; + return (void*)m; +} + +INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len) +{ + Heap_Module m, p; + __DUP(name, name__len, CHAR); + m = (Heap_Module)(ADDRESS)Heap_modules; + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + p = m; + m = m->next; + } + if ((m != NIL && m->refcnt == 0)) { + if (m == (Heap_Module)(ADDRESS)Heap_modules) { + Heap_modules = (SYSTEM_PTR)m->next; + } else { + p->next = m->next; + } + __DEL(name); + return 0; + } else { + if (m == NIL) { + __DEL(name); + return -1; + } else { + __DEL(name); + return m->refcnt; + } + } + __RETCHK; +} + +void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd) +{ + Heap_Cmd c; + if (__STRCMP(m->name, "Heap") == 0) { + __SYSNEW(c, 40); + } else { + __NEW(c, Heap_CmdDesc); + } + __COPY(name, c->name, 24); + c->cmd = cmd; + c->next = m->cmds; + m->cmds = c; +} + +void Heap_REGTYP (Heap_Module m, INT64 typ) +{ + __PUT(typ, m->types, INT64); + m->types = typ; +} + +void Heap_INCREF (Heap_Module m) +{ + m->refcnt += 1; +} + +static INT64 Heap_NewChunk (INT64 blksz) +{ + INT64 chnk, blk, end; + chnk = Heap_OSAllocate(blksz + 24); + if (chnk != 0) { + blk = chnk + 24; + end = blk + blksz; + __PUT(chnk + 8, end, INT64); + __PUT(blk, blk + 8, INT64); + __PUT(blk + 8, blksz, INT64); + __PUT(blk + 16, -8, INT64); + __PUT(blk + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = blk; + Heap_heapsize += blksz; + if (Heap_uLT(blk + 8, Heap_heapMin)) { + Heap_heapMin = blk + 8; + } + if (Heap_uLT(Heap_heapMax, end)) { + Heap_heapMax = end; + } + } + return chnk; +} + +static void Heap_ExtendHeap (INT64 blksz) +{ + INT64 size, chnk, j, next; + if (Heap_uLT(Heap_heapMinExpand, blksz)) { + size = blksz; + } else { + size = Heap_heapMinExpand; + } + chnk = Heap_NewChunk(size); + if (chnk != 0) { + if (Heap_uLT(chnk, Heap_heap)) { + __PUT(chnk, Heap_heap, INT64); + Heap_heap = chnk; + } else { + j = Heap_heap; + __GET(j, next, INT64); + while ((next != 0 && Heap_uLT(next, chnk))) { + j = next; + __GET(j, next, INT64); + } + __PUT(chnk, next, INT64); + __PUT(j, chnk, INT64); + } + } else if (!Heap_firstTry) { + Heap_heapMinExpand = 32; + } +} + +SYSTEM_PTR Heap_NEWREC (INT64 tag) +{ + INT64 i, i0, di, blksz, restsize, t, adr, end, next, prev; + SYSTEM_PTR new; + Heap_Lock(); + __GET(tag, blksz, INT64); + i0 = __LSH(blksz, -Heap_ldUnit, 64); + i = i0; + if (i < 9) { + adr = Heap_freeList[i]; + while (adr == 0) { + i += 1; + adr = Heap_freeList[i]; + } + } + if (i < 9) { + __GET(adr + 24, next, INT64); + Heap_freeList[i] = next; + if (i != i0) { + di = i - i0; + restsize = __ASHL(di, 5); + end = adr + restsize; + __PUT(end + 8, blksz, INT64); + __PUT(end + 16, -8, INT64); + __PUT(end, end + 8, INT64); + __PUT(adr + 8, restsize, INT64); + __PUT(adr + 24, Heap_freeList[di], INT64); + Heap_freeList[di] = adr; + adr += restsize; + } + } else { + adr = Heap_bigBlocks; + prev = 0; + for (;;) { + if (adr == 0) { + if (Heap_firstTry) { + Heap_GC(1); + blksz += 32; + t = __LSH(Heap_allocated + blksz, -(2 + Heap_ldUnit), 64) * 160; + if (Heap_uLT(Heap_heapsize, t)) { + Heap_ExtendHeap(t - Heap_heapsize); + } + Heap_firstTry = 0; + new = Heap_NEWREC(tag); + if (new == NIL) { + Heap_ExtendHeap(blksz); + new = Heap_NEWREC(tag); + } + Heap_firstTry = 1; + Heap_Unlock(); + return new; + } else { + Heap_Unlock(); + return NIL; + } + } + __GET(adr + 8, t, INT64); + if (Heap_uLE(blksz, t)) { + break; + } + prev = adr; + __GET(adr + 24, adr, INT64); + } + restsize = t - blksz; + end = adr + restsize; + __PUT(end + 8, blksz, INT64); + __PUT(end + 16, -8, INT64); + __PUT(end, end + 8, INT64); + if (Heap_uLT(288, restsize)) { + __PUT(adr + 8, restsize, INT64); + } else { + __GET(adr + 24, next, INT64); + if (prev == 0) { + Heap_bigBlocks = next; + } else { + __PUT(prev + 24, next, INT64); + } + if (restsize != 0) { + di = __ASHR(restsize, 5); + __PUT(adr + 8, restsize, INT64); + __PUT(adr + 24, Heap_freeList[di], INT64); + Heap_freeList[di] = adr; + } + } + adr += restsize; + } + i = adr + 32; + end = adr + blksz; + while (Heap_uLT(i, end)) { + __PUT(i, 0, INT64); + __PUT(i + 8, 0, INT64); + __PUT(i + 16, 0, INT64); + __PUT(i + 24, 0, INT64); + i += 32; + } + __PUT(adr + 24, 0, INT64); + __PUT(adr, tag, INT64); + __PUT(adr + 8, 0, INT64); + __PUT(adr + 16, 0, INT64); + Heap_allocated += blksz; + Heap_Unlock(); + return (SYSTEM_PTR)(ADDRESS)(adr + 8); +} + +SYSTEM_PTR Heap_NEWBLK (INT64 size) +{ + INT64 blksz, tag; + SYSTEM_PTR new; + Heap_Lock(); + blksz = __ASHL(__ASHR(size + 63, 5), 5); + new = Heap_NEWREC((ADDRESS)&blksz); + tag = ((INT64)(ADDRESS)new + blksz) - 24; + __PUT(tag - 8, 0, INT64); + __PUT(tag, blksz, INT64); + __PUT(tag + 8, -8, INT64); + __PUT((INT64)(ADDRESS)new - 8, tag, INT64); + Heap_Unlock(); + return new; +} + +static void Heap_Mark (INT64 q) +{ + INT64 p, tag, offset, fld, n, tagbits; + if (q != 0) { + __GET(q - 8, tagbits, INT64); + if (!__ODD(tagbits)) { + __PUT(q - 8, tagbits + 1, INT64); + p = 0; + tag = tagbits + 8; + for (;;) { + __GET(tag, offset, INT64); + if (offset < 0) { + __PUT(q - 8, (tag + offset) + 1, INT64); + if (p == 0) { + break; + } + n = q; + q = p; + __GET(q - 8, tag, INT64); + tag -= 1; + __GET(tag, offset, INT64); + fld = q + offset; + __GET(fld, p, INT64); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)n, SYSTEM_PTR); + } else { + fld = q + offset; + __GET(fld, n, INT64); + if (n != 0) { + __GET(n - 8, tagbits, INT64); + if (!__ODD(tagbits)) { + __PUT(n - 8, tagbits + 1, INT64); + __PUT(q - 8, tag + 1, INT64); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)p, SYSTEM_PTR); + p = q; + q = n; + tag = tagbits; + } + } + } + tag += 8; + } + } + } +} + +static void Heap_MarkP (SYSTEM_PTR p) +{ + Heap_Mark((INT64)(ADDRESS)p); +} + +static void Heap_Scan (void) +{ + INT64 chnk, adr, end, start, tag, i, size, freesize; + Heap_bigBlocks = 0; + i = 1; + while (i < 9) { + Heap_freeList[i] = 0; + i += 1; + } + freesize = 0; + Heap_allocated = 0; + chnk = Heap_heap; + while (chnk != 0) { + adr = chnk + 24; + __GET(chnk + 8, end, INT64); + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT64); + if (__ODD(tag)) { + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 8, INT64); + __PUT(start + 8, freesize, INT64); + __PUT(start + 16, -8, INT64); + i = __LSH(freesize, -Heap_ldUnit, 64); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 24, Heap_freeList[i], INT64); + Heap_freeList[i] = start; + } else { + __PUT(start + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = start; + } + } + tag -= 1; + __PUT(adr, tag, INT64); + __GET(tag, size, INT64); + Heap_allocated += size; + adr += size; + } else { + __GET(tag, size, INT64); + freesize += size; + adr += size; + } + } + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 8, INT64); + __PUT(start + 8, freesize, INT64); + __PUT(start + 16, -8, INT64); + i = __LSH(freesize, -Heap_ldUnit, 64); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 24, Heap_freeList[i], INT64); + Heap_freeList[i] = start; + } else { + __PUT(start + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = start; + } + } + __GET(chnk, chnk, INT64); + } +} + +static void Heap_Sift (INT32 l, INT32 r, INT64 *a, ADDRESS a__len) +{ + INT32 i, j; + INT64 x; + j = l; + x = a[j]; + for (;;) { + i = j; + j = __ASHL(j, 1) + 1; + if ((j < r && Heap_uLT(a[j], a[j + 1]))) { + j += 1; + } + if (j > r || Heap_uLE(a[j], x)) { + break; + } + a[i] = a[j]; + } + a[i] = x; +} + +static void Heap_HeapSort (INT32 n, INT64 *a, ADDRESS a__len) +{ + INT32 l, r; + INT64 x; + l = __ASHR(n, 1); + r = n - 1; + while (l > 0) { + l -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } + while (r > 0) { + x = a[0]; + a[0] = a[r]; + a[r] = x; + r -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } +} + +static void Heap_MarkCandidates (INT32 n, INT64 *cand, ADDRESS cand__len) +{ + INT64 chnk, end, adr, tag, next, i, ptr, size; + chnk = Heap_heap; + i = 0; + while (chnk != 0) { + __GET(chnk + 8, end, INT64); + adr = chnk + 24; + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT64); + if (__ODD(tag)) { + __GET(tag - 1, size, INT64); + adr += size; + ptr = adr + 8; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == (INT64)n) { + return; + } + } + } else { + __GET(tag, size, INT64); + ptr = adr + 8; + adr += size; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == (INT64)n) { + return; + } + } + if (Heap_uLT(cand[i], adr)) { + Heap_Mark(ptr); + } + } + if (Heap_uLE(end, cand[i])) { + adr = end; + } + } + __GET(chnk, chnk, INT64); + } +} + +static void Heap_CheckFin (void) +{ + Heap_FinNode n; + INT64 tag; + n = Heap_fin; + while (n != NIL) { + __GET(n->obj - 8, tag, INT64); + if (!__ODD(tag)) { + n->marked = 0; + Heap_Mark(n->obj); + } else { + n->marked = 1; + } + n = n->next; + } +} + +static void Heap_Finalize (void) +{ + Heap_FinNode n, prev; + n = Heap_fin; + prev = NIL; + while (n != NIL) { + if (!n->marked) { + if (n == Heap_fin) { + Heap_fin = Heap_fin->next; + } else { + prev->next = n->next; + } + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + if (prev == NIL) { + n = Heap_fin; + } else { + n = n->next; + } + } else { + prev = n; + n = n->next; + } + } +} + +void Heap_FINALL (void) +{ + Heap_FinNode n; + while (Heap_fin != NIL) { + n = Heap_fin; + Heap_fin = Heap_fin->next; + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + } +} + +static void Heap_MarkStack (INT64 n, INT64 *cand, ADDRESS cand__len) +{ + SYSTEM_PTR frame; + INT32 nofcand; + INT64 inc, sp, p, stack0; + struct Heap__1 align; + if (n > 0) { + Heap_MarkStack(n - 1, cand, cand__len); + if (n > 100) { + return; + } + } + if (n == 0) { + nofcand = 0; + sp = (ADDRESS)&frame; + stack0 = Heap_ModulesMainStackFrame(); + inc = (ADDRESS)&align.p - (ADDRESS)&align; + if (Heap_uLT(stack0, sp)) { + inc = -inc; + } + while (sp != stack0) { + __GET(sp, p, INT64); + if ((Heap_uLE(Heap_heapMin, p) && Heap_uLT(p, Heap_heapMax))) { + if (nofcand == cand__len) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + nofcand = 0; + } + cand[nofcand] = p; + nofcand += 1; + } + sp += inc; + } + if (nofcand > 0) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + } + } +} + +void Heap_GC (BOOLEAN markStack) +{ + Heap_Module m; + INT64 i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23; + INT64 cand[10000]; + Heap_Lock(); + m = (Heap_Module)(ADDRESS)Heap_modules; + while (m != NIL) { + if (m->enumPtrs != NIL) { + (*m->enumPtrs)(Heap_MarkP); + } + m = m->next; + } + if (markStack) { + 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; + for (;;) { + i0 += 1; + i1 += 2; + i2 += 3; + i3 += 4; + i4 += 5; + i5 += 6; + i6 += 7; + i7 += 8; + i8 += 9; + i9 += 10; + i10 += 11; + i11 += 12; + i12 += 13; + i13 += 14; + i14 += 15; + i15 += 16; + i16 += 17; + i17 += 18; + i18 += 19; + i19 += 20; + i20 += 21; + i21 += 22; + i22 += 23; + i23 += 24; + if ((i0 == -99 && i15 == 24)) { + Heap_MarkStack(32, (void*)cand, 10000); + break; + } + } + 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) { + return; + } + } + Heap_CheckFin(); + Heap_Scan(); + Heap_Finalize(); + Heap_Unlock(); +} + +void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) +{ + Heap_FinNode f; + __NEW(f, Heap_FinDesc); + f->obj = (INT64)(ADDRESS)obj; + f->finalize = finalize; + f->marked = 1; + f->next = Heap_fin; + Heap_fin = f; +} + +void Heap_InitHeap (void) +{ + Heap_heap = 0; + Heap_heapsize = 0; + Heap_allocated = 0; + Heap_lockdepth = 0; + Heap_heapMin = -1; + Heap_heapMax = 0; + Heap_bigBlocks = 0; + Heap_heapMinExpand = 256000; + Heap_ldUnit = 5; + Heap_heap = Heap_NewChunk(256000); + __PUT(Heap_heap, 0, INT64); + Heap_firstTry = 1; + Heap_freeList[9] = 1; + Heap_FileCount = 0; + Heap_modules = NIL; + Heap_fin = NIL; + Heap_interrupted = 0; + Heap_HeapModuleInit(); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Heap_modules); + P(Heap_fin); +} + +__TDESC(Heap_ModuleDesc, 1, 2) = {__TDFLDS("ModuleDesc", 64), {0, 32, -24}}; +__TDESC(Heap_CmdDesc, 1, 1) = {__TDFLDS("CmdDesc", 40), {0, -16}}; +__TDESC(Heap_FinDesc, 1, 1) = {__TDFLDS("FinDesc", 32), {0, -16}}; +__TDESC(Heap__1, 1, 1) = {__TDFLDS("", 16), {8, -16}}; + +export void *Heap__init(void) +{ + __DEFMOD; + __REGMOD("Heap", EnumPtrs); + __REGCMD("FINALL", Heap_FINALL); + __REGCMD("InitHeap", Heap_InitHeap); + __REGCMD("Lock", Heap_Lock); + __REGCMD("Unlock", Heap_Unlock); + __INITYP(Heap_ModuleDesc, Heap_ModuleDesc, 0); + __INITYP(Heap_CmdDesc, Heap_CmdDesc, 0); + __INITYP(Heap_FinDesc, Heap_FinDesc, 0); + __INITYP(Heap__1, Heap__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/Heap.h b/bootstrap/unix-88/Heap.h new file mode 100644 index 00000000..45a9c6d2 --- /dev/null +++ b/bootstrap/unix-88/Heap.h @@ -0,0 +1,73 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#ifndef Heap__h +#define Heap__h + +#include "SYSTEM.h" + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT64 types; + Heap_EnumProc enumPtrs; + char _prvt0[8]; + } Heap_ModuleDesc; + + +import SYSTEM_PTR Heap_modules; +import INT64 Heap_allocated; +import INT64 Heap_heap; +import INT64 Heap_heapsize, Heap_heapMinExpand; +import INT16 Heap_FileCount; + +import ADDRESS *Heap_ModuleDesc__typ; +import ADDRESS *Heap_CmdDesc__typ; + +import void Heap_FINALL (void); +import INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +import void Heap_GC (BOOLEAN markStack); +import void Heap_INCREF (Heap_Module m); +import void Heap_InitHeap (void); +import void Heap_Lock (void); +import SYSTEM_PTR Heap_NEWBLK (INT64 size); +import SYSTEM_PTR Heap_NEWREC (INT64 tag); +import void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +import SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +import void Heap_REGTYP (Heap_Module m, INT64 typ); +import void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +import void Heap_Unlock (void); +import void *Heap__init(void); + + +#endif // Heap diff --git a/bootstrap/unix-88/Modules.c b/bootstrap/unix-88/Modules.c new file mode 100644 index 00000000..a5b989e5 --- /dev/null +++ b/bootstrap/unix-88/Modules.c @@ -0,0 +1,506 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export INT16 Modules_res; +export CHAR Modules_resMsg[256]; +export Heap_ModuleName Modules_imported, Modules_importing; +export INT64 Modules_MainStackFrame; +export INT16 Modules_ArgCount; +export INT64 Modules_ArgVector; +export CHAR Modules_BinaryDir[1024]; + + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +export void Modules_AssertFail (INT32 code); +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len); +static void Modules_DisplayHaltCode (INT32 code); +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len); +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len); +export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +export void Modules_GetIntArg (INT16 n, INT32 *val); +export void Modules_Halt (INT32 code); +export void Modules_Init (INT32 argc, INT64 argvadr); +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len); +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len); +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len); +export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_errch (CHAR c); +static void Modules_errint (INT32 l); +static void Modules_errstring (CHAR *s, ADDRESS s__len); + +extern void Heap_InitHeap(); +extern void *Modules__init(void); +#define Modules_InitHeap() Heap_InitHeap() +#define Modules_ModulesInit() Modules__init() +#define Modules_modules() (Heap_Module)Heap_modules + +void Modules_Init (INT32 argc, INT64 argvadr) +{ + Modules_MainStackFrame = argvadr; + Modules_ArgCount = __VAL(INT16, argc); + __GET(argvadr, Modules_ArgVector, INT64); + Modules_InitHeap(); + Modules_ModulesInit(); +} + +typedef + CHAR (*argptr__15)[1024]; + +void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len) +{ + argptr__15 arg = NIL; + if (n < Modules_ArgCount) { + __GET(Modules_ArgVector + (INT64)__ASHL(n, 3), arg, argptr__15); + __COPY(*arg, val, val__len); + } +} + +void Modules_GetIntArg (INT16 n, INT32 *val) +{ + CHAR s[64]; + INT32 k, d, i; + s[0] = 0x00; + Modules_GetArg(n, (void*)s, 64); + i = 0; + if (s[0] == '-') { + i = 1; + } + k = 0; + d = (INT16)s[__X(i, 64)] - 48; + while ((d >= 0 && d <= 9)) { + k = k * 10 + d; + i += 1; + d = (INT16)s[__X(i, 64)] - 48; + } + if (s[0] == '-') { + k = -k; + i -= 1; + } + if (i > 0) { + *val = k; + } +} + +INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len) +{ + INT16 i; + CHAR arg[256]; + __DUP(s, s__len, CHAR); + i = 0; + Modules_GetArg(i, (void*)arg, 256); + while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) { + i += 1; + Modules_GetArg(i, (void*)arg, 256); + } + __DEL(s); + return i; +} + +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return i; +} + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + if ((j > 0 && d[__X(j - 1, d__len)] != c)) { + d[__X(j, d__len)] = c; + j += 1; + } + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + if (c == 0x00) { + __DEL(s); + return 0; + } + i = 0; + while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return s[__X(i, s__len)] == c; +} + +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len) +{ + __DUP(d, d__len, CHAR); + if (d[0] == 0x00) { + __DEL(d); + return 0; + } + if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) { + __DEL(d); + return 1; + } + if (d[__X(1, d__len)] == ':') { + __DEL(d); + return 1; + } + __DEL(d); + return 0; +} + +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + __DUP(s, s__len, CHAR); + if (Modules_IsAbsolute(s, s__len)) { + __COPY(s, d, d__len); + } else { + __COPY(Platform_CWD, d, d__len); + Modules_AppendPart('/', s, s__len, (void*)d, d__len); + } + __DEL(s); +} + +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len) +{ + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __DEL(s); + return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0; +} + +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len) +{ + INT16 j; + __DUP(s, s__len, CHAR); + __DUP(p, p__len, CHAR); + j = 0; + while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) { + d[__X(j, d__len)] = s[__X(*i, s__len)]; + *i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) { + *i += 1; + } + __DEL(s); + __DEL(p); +} + +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + CHAR part[1024]; + __DUP(s, s__len, CHAR); + i = 0; + j = 0; + while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) { + i += 1; + d[__X(j, d__len)] = '/'; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (s[__X(i, s__len)] != 0x00) { + Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024); + if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) { + Modules_AppendPart('/', part, 1024, (void*)d, d__len); + } + } + __DEL(s); +} + +typedef + CHAR pathstring__12[4096]; + +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len) +{ + pathstring__12 arg0, pathlist, pathdir, tempstr; + INT16 i, j, k; + BOOLEAN present; + if (Modules_ArgCount < 1) { + binarydir[0] = 0x00; + return; + } + Modules_GetArg(0, (void*)arg0, 4096); + i = 0; + while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) { + i += 1; + } + if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') { + Modules_Trim(arg0, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } else { + Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096); + i = 0; + present = 0; + while ((!present && pathlist[__X(i, 4096)] != 0x00)) { + Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096); + Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096); + Modules_Trim(pathdir, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } + } + if (present) { + k = Modules_CharCount(binarydir, binarydir__len); + while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) { + k -= 1; + } + if (k == 0) { + binarydir[__X(k, binarydir__len)] = 0x00; + } else { + binarydir[__X(k - 1, binarydir__len)] = 0x00; + } + } else { + binarydir[0] = 0x00; + } +} + +Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len) +{ + Heap_Module m = NIL; + CHAR bodyname[64]; + Heap_Command body; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + m = m->next; + } + if (m != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + } else { + Modules_res = 1; + __COPY(name, Modules_importing, 20); + __MOVE(" module \"", Modules_resMsg, 10); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + } + __DEL(name); + return m; +} + +Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len) +{ + Heap_Cmd c = NIL; + __DUP(name, name__len, CHAR); + c = mod->cmds; + while ((c != NIL && __STRCMP(c->name, name) != 0)) { + c = c->next; + } + if (c != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + __DEL(name); + return c->cmd; + } else { + Modules_res = 2; + __MOVE(" command \"", Modules_resMsg, 11); + __COPY(name, Modules_importing, 20); + Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all) +{ + Heap_Module m = NIL, p = NIL; + INT32 refcount; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + if (all) { + Modules_res = 1; + __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34); + } else { + refcount = Heap_FreeModule(name, name__len); + if (refcount == 0) { + Modules_res = 0; + } else { + if (refcount < 0) { + __MOVE("module not found", Modules_resMsg, 17); + } else { + __MOVE("clients of this module exist", Modules_resMsg, 29); + } + Modules_res = 1; + } + } + __DEL(name); +} + +static void Modules_errch (CHAR c) +{ + INT16 e; + e = Platform_Write(1, (ADDRESS)&c, 1); +} + +static void Modules_errstring (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + Modules_errch(s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +static void Modules_errint (INT32 l) +{ + if (l < 0) { + Modules_errch('-'); + l = -l; + } + if (l >= 10) { + Modules_errint(__DIV(l, 10)); + } + Modules_errch(__CHR((int)__MOD(l, 10) + 48)); +} + +static void Modules_DisplayHaltCode (INT32 code) +{ + switch (code) { + case -1: + Modules_errstring((CHAR*)"Assertion failure.", 19); + break; + case -2: + Modules_errstring((CHAR*)"Index out of range.", 20); + break; + case -3: + Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49); + break; + case -4: + Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47); + break; + case -5: + Modules_errstring((CHAR*)"Type guard failed.", 19); + break; + case -6: + Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49); + break; + case -7: + Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32); + break; + case -8: + Modules_errstring((CHAR*)"Value out of range.", 20); + break; + case -9: + Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60); + break; + case -10: + Modules_errstring((CHAR*)"NIL access.", 12); + break; + case -11: + Modules_errstring((CHAR*)"Alignment error.", 17); + break; + case -12: + Modules_errstring((CHAR*)"Divide by zero.", 16); + break; + case -13: + Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31); + break; + case -14: + Modules_errstring((CHAR*)"Invalid function argument.", 27); + break; + case -15: + Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52); + break; + case -20: + Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60); + break; + default: + break; + } +} + +void Modules_Halt (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Terminated by Halt(", 20); + Modules_errint(code); + Modules_errstring((CHAR*)"). ", 4); + if (code < 0) { + Modules_DisplayHaltCode(code); + } + Modules_errstring(Platform_NL, 3); + Platform_Exit(code); +} + +void Modules_AssertFail (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Assertion failure.", 19); + if (code != 0) { + Modules_errstring((CHAR*)" ASSERT code ", 14); + Modules_errint(code); + Modules_errstring((CHAR*)".", 2); + } + Modules_errstring(Platform_NL, 3); + if (code > 0) { + Platform_Exit(code); + } else { + Platform_Exit(-1); + } +} + + +export void *Modules__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Modules", 0); +/* BEGIN */ + Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024); + __ENDMOD; +} diff --git a/bootstrap/unix-88/Modules.h b/bootstrap/unix-88/Modules.h new file mode 100644 index 00000000..ee65a938 --- /dev/null +++ b/bootstrap/unix-88/Modules.h @@ -0,0 +1,31 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Modules__h +#define Modules__h + +#include "SYSTEM.h" +#include "Heap.h" + + +import INT16 Modules_res; +import CHAR Modules_resMsg[256]; +import Heap_ModuleName Modules_imported, Modules_importing; +import INT64 Modules_MainStackFrame; +import INT16 Modules_ArgCount; +import INT64 Modules_ArgVector; +import CHAR Modules_BinaryDir[1024]; + + +import INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +import void Modules_AssertFail (INT32 code); +import void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +import void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +import void Modules_GetIntArg (INT16 n, INT32 *val); +import void Modules_Halt (INT32 code); +import void Modules_Init (INT32 argc, INT64 argvadr); +import Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +import Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +import void *Modules__init(void); + + +#endif // Modules diff --git a/bootstrap/unix-88/OPB.c b/bootstrap/unix-88/OPB.c new file mode 100644 index 00000000..913fbf2d --- /dev/null +++ b/bootstrap/unix-88/OPB.c @@ -0,0 +1,2592 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + + +static INT16 OPB_exp; +static INT64 OPB_maxExp; + + +export void OPB_Assign (OPT_Node *x, OPT_Node y); +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static INT16 OPB_BoolToInt (BOOLEAN b); +export void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +static void OPB_CharToString (OPT_Node n); +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode); +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo); +export void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +static void OPB_CheckProc (OPT_Struct x, OPT_Object y); +static void OPB_CheckPtr (OPT_Node x, OPT_Node y); +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x); +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp); +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y); +export void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +static void OPB_Convert (OPT_Node *x, OPT_Struct typ); +export void OPB_DeRef (OPT_Node *x); +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar); +export OPT_Node OPB_EmptySet (void); +export void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +export void OPB_Field (OPT_Node *x, OPT_Object y); +export void OPB_In (OPT_Node *x, OPT_Node y); +export void OPB_Index (OPT_Node *x, OPT_Node y); +export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +static BOOLEAN OPB_IntToBool (INT64 i); +export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +export void OPB_MOp (INT8 op, OPT_Node *x); +export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +export OPT_Node OPB_NewIntConst (INT64 intval); +export OPT_Node OPB_NewLeaf (OPT_Object obj); +export OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +export OPT_Node OPB_NewString (OPS_String str, INT64 len); +export OPT_Node OPB_Nil (void); +static BOOLEAN OPB_NotVar (OPT_Node x); +export void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +export void OPB_OptIf (OPT_Node *x); +export void OPB_Param (OPT_Node ap, OPT_Object fp); +export void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +export void OPB_Return (OPT_Node *x, OPT_Object proc); +export void OPB_SetElem (OPT_Node *x); +static void OPB_SetIntType (OPT_Node node); +export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static void OPB_SetSetType (OPT_Node node); +export void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +export void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +export void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +export void OPB_StaticLink (INT8 dlev); +export void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +static void OPB_err (INT16 n); +static INT64 OPB_log (INT64 x); + + +static void OPB_err (INT16 n) +{ + OPM_err(n); +} + +OPT_Node OPB_NewLeaf (OPT_Object obj) +{ + OPT_Node node = NIL; + switch (obj->mode) { + case 1: + node = OPT_NewNode(0); + node->readonly = (obj->vis == 2 && obj->mnolev < 0); + break; + case 2: + node = OPT_NewNode(1); + break; + case 3: + node = OPT_NewNode(7); + node->conval = OPT_NewConst(); + __GUARDEQP(node->conval, OPT_ConstDesc) = *obj->conval; + break; + case 5: + node = OPT_NewNode(8); + break; + case 6: case 7: case 8: case 9: case 10: + node = OPT_NewNode(9); + break; + default: + node = OPT_NewNode(0); + OPB_err(127); + break; + } + node->obj = obj; + node->typ = obj->typ; + return node; +} + +void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = OPT_notyp; + node->left = *x; + node->right = y; + *x = node; +} + +void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y) +{ + if (*x == NIL) { + *x = y; + } else { + (*last)->link = y; + } + while (y->link != NIL) { + y = y->link; + } + *last = y; +} + +static INT16 OPB_BoolToInt (BOOLEAN b) +{ + if (b) { + return 1; + } else { + return 0; + } + __RETCHK; +} + +static BOOLEAN OPB_IntToBool (INT64 i) +{ + return i != 0; +} + +OPT_Node OPB_NewBoolConst (BOOLEAN boolval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_booltyp; + x->conval = OPT_NewConst(); + x->conval->intval = OPB_BoolToInt(boolval); + return x; +} + +void OPB_OptIf (OPT_Node *x) +{ + OPT_Node if_ = NIL, pred = NIL; + if_ = (*x)->left; + while (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + *x = if_->right; + return; + } else if (if_->link == NIL) { + *x = (*x)->right; + return; + } else { + if_ = if_->link; + (*x)->left = if_; + } + } + pred = if_; + if_ = if_->link; + while (if_ != NIL) { + if (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + pred->link = NIL; + (*x)->right = if_->right; + return; + } else { + if_ = if_->link; + pred->link = if_; + } + } else { + pred = if_; + if_ = if_->link; + } + } +} + +OPT_Node OPB_Nil (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_niltyp; + x->conval = OPT_NewConst(); + x->conval->intval = 0; + return x; +} + +OPT_Node OPB_EmptySet (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_settyp; + x->conval = OPT_NewConst(); + x->conval->setval = 0x0; + return x; +} + +static void OPB_SetIntType (OPT_Node node) +{ + node->typ = OPT_IntType(OPT_IntSize(node->conval->intval)); +} + +static void OPB_SetSetType (OPT_Node node) +{ + INT32 i32; + __GET((ADDRESS)&node->conval->setval + 4, i32, INT32); + if (i32 == 0) { + node->typ = OPT_set32typ; + } else { + node->typ = OPT_set64typ; + } +} + +OPT_Node OPB_NewIntConst (INT64 intval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->intval = intval; + OPB_SetIntType(x); + return x; +} + +OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->realval = realval; + x->typ = typ; + x->conval->intval = -1; + return x; +} + +OPT_Node OPB_NewString (OPS_String str, INT64 len) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->typ = OPT_stringtyp; + x->conval->intval = -1; + x->conval->intval2 = OPM_Longint(len); + x->conval->ext = OPT_NewExt(); + __MOVE(str, *x->conval->ext, 256); + return x; +} + +static void OPB_CharToString (OPT_Node n) +{ + CHAR ch; + n->typ = OPT_stringtyp; + ch = __CHR(n->conval->intval); + n->conval->ext = OPT_NewExt(); + if (ch == 0x00) { + n->conval->intval2 = 1; + } else { + n->conval->intval2 = 2; + (*n->conval->ext)[1] = 0x00; + } + (*n->conval->ext)[0] = ch; + n->conval->intval = -1; + n->obj = NIL; +} + +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN OPB_NotVar (OPT_Node x) +{ + return (x->class >= 7 && ((x->class != 11 || x->subcl != 29) || x->left->class >= 7)); +} + +void OPB_DeRef (OPT_Node *x) +{ + OPT_Object strobj = NIL, bstrobj = NIL; + OPT_Struct typ = NIL, btyp = NIL; + typ = (*x)->typ; + if ((*x)->class >= 7) { + OPB_err(78); + } else if (typ->form == 11) { + if (typ == OPT_sysptrtyp) { + OPB_err(57); + } + btyp = typ->BaseTyp; + strobj = typ->strobj; + bstrobj = btyp->strobj; + if ((((((strobj != NIL && strobj->name[0] != 0x00)) && bstrobj != NIL)) && bstrobj->name[0] != 0x00)) { + btyp->pbused = 1; + } + OPB_BindNodes(3, btyp, &*x, NIL); + } else { + OPB_err(84); + } +} + +void OPB_Index (OPT_Node *x, OPT_Node y) +{ + INT16 f; + OPT_Struct typ = NIL; + f = y->typ->form; + if ((*x)->class >= 7) { + OPB_err(79); + } else if (f != 4 || __IN(y->class, 0x0300, 32)) { + OPB_err(80); + y->typ = OPT_inttyp; + } + if ((*x)->typ->comp == 2) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && (y->conval->intval < 0 || y->conval->intval >= (INT64)(*x)->typ->n))) { + OPB_err(81); + } + } else if ((*x)->typ->comp == 3) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && y->conval->intval < 0)) { + OPB_err(81); + } + } else { + OPB_err(82); + typ = OPT_undftyp; + } + OPB_BindNodes(4, typ, &*x, y); + (*x)->readonly = (*x)->left->readonly; +} + +void OPB_Field (OPT_Node *x, OPT_Object y) +{ + if ((*x)->class >= 7) { + OPB_err(77); + } + if ((y != NIL && __IN(y->mode, 0x2010, 32))) { + OPB_BindNodes(2, y->typ, &*x, NIL); + (*x)->obj = y; + (*x)->readonly = (*x)->left->readonly || (y->vis == 2 && y->mnolev < 0); + } else { + OPB_err(83); + (*x)->typ = OPT_undftyp; + } +} + +static struct TypTest__58 { + OPT_Node *x; + OPT_Object *obj; + BOOLEAN *guard; + struct TypTest__58 *lnk; +} *TypTest__58_s; + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1); + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1) +{ + OPT_Node node = NIL; + OPT_Struct t = NIL; + t = t0; + while ((((t != NIL && t != t1)) && t != OPT_undftyp)) { + t = t->BaseTyp; + } + if (t != t1) { + while ((((t1 != NIL && t1 != t0)) && t1 != OPT_undftyp)) { + t1 = t1->BaseTyp; + } + if (t1 == t0 || t0->form == 0) { + if (*TypTest__58_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__58_s->x, NIL); + (*TypTest__58_s->x)->readonly = (*TypTest__58_s->x)->left->readonly; + } else { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } + } else { + OPB_err(85); + } + } else if (t0 != t1) { + OPB_err(85); + } else if (!*TypTest__58_s->guard) { + if ((*TypTest__58_s->x)->class == 5) { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } else { + *TypTest__58_s->x = OPB_NewBoolConst(1); + } + } +} + +void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) +{ + struct TypTest__58 _s; + _s.x = x; + _s.obj = &obj; + _s.guard = &guard; + _s.lnk = TypTest__58_s; + TypTest__58_s = &_s; + if (OPB_NotVar(*x)) { + OPB_err(112); + } else if ((*x)->typ->form == 11) { + if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { + OPB_err(85); + } else if (obj->typ->form == 11) { + GTT__59((*x)->typ->BaseTyp, obj->typ->BaseTyp); + } else { + OPB_err(86); + } + } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { + GTT__59((*x)->typ, obj->typ); + } else { + OPB_err(87); + } + if (guard) { + (*x)->typ = obj->typ; + } else { + (*x)->typ = OPT_booltyp; + } + TypTest__58_s = _s.lnk; +} + +void OPB_In (OPT_Node *x, OPT_Node y) +{ + INT16 f; + INT64 k; + f = (*x)->typ->form; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((f == 4 && y->typ->form == 7)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (k < 0 || k >= (INT64)__ASHL(y->typ->size, 3)) { + OPB_err(202); + } else if (y->class == 7) { + (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval, 64)); + (*x)->obj = NIL; + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_err(92); + } + (*x)->typ = OPT_booltyp; +} + +static INT64 OPB_log (INT64 x) +{ + OPB_exp = 0; + if (x > 0) { + while (!__ODD(x)) { + x = __ASHR(x, 1); + OPB_exp += 1; + } + } + return x; +} + +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x) +{ + LONGREAL min, max, r; + if (f == 5) { + min = OPM_MinReal; + max = OPM_MaxReal; + } else { + min = OPM_MinLReal; + max = OPM_MaxLReal; + } + r = __ABS(x->realval); + if (r > max || r < min) { + OPB_err(nr); + x->realval = (LONGREAL)1; + } else if (f == 5) { + x->realval = x->realval; + } + x->intval = -1; +} + +static struct MOp__28 { + struct MOp__28 *lnk; +} *MOp__28_s; + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z); + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z) +{ + OPT_Node node = NIL; + node = OPT_NewNode(11); + node->subcl = op; + node->typ = typ; + node->left = z; + return node; +} + +void OPB_MOp (INT8 op, OPT_Node *x) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node z = NIL; + struct MOp__28 _s; + _s.lnk = MOp__28_s; + MOp__28_s = &_s; + z = *x; + if (z->class == 8 || z->class == 9) { + OPB_err(126); + } else { + typ = z->typ; + f = typ->form; + switch (op) { + case 33: + if (f == 2) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(98); + } + break; + case 6: + if (!__IN(f, 0x70, 32)) { + OPB_err(96); + } + break; + case 7: + if (__IN(f, 0xf0, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = -z->conval->intval; + OPB_SetIntType(z); + } + } else if (__IN(f, 0x60, 32)) { + z->conval->realval = -z->conval->realval; + } else { + if (z->typ->size == 8) { + z->conval->setval = ~z->conval->setval; + } else { + z->conval->setval = z->conval->setval ^ 0xffffffff; + } + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(97); + } + break; + case 21: + if (__IN(f, 0x70, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = __ABS(z->conval->intval); + OPB_SetIntType(z); + } + } else { + z->conval->realval = __ABS(z->conval->realval); + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + break; + case 22: + if (f == 3) { + if (z->class == 7) { + z->conval->intval = (INT16)__CAP(__CHR(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + z->typ = OPT_chartyp; + } + break; + case 23: + if (f == 4) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + z->typ = OPT_booltyp; + break; + case 24: + if ((((z->class == 7 && f == 3)) && z->conval->intval >= 32)) { + OPB_CharToString(z); + f = 8; + } + if (z->class < 7 || f == 8) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(127); + } + z->typ = OPT_adrtyp; + break; + case 25: + if ((f == 4 && z->class == 7)) { + if ((0 <= z->conval->intval && z->conval->intval <= -1)) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(219); + } + } else { + OPB_err(69); + } + z->typ = OPT_booltyp; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.MOp, op = ", 33); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + MOp__28_s = _s.lnk; +} + +static void OPB_CheckPtr (OPT_Node x, OPT_Node y) +{ + INT16 g; + OPT_Struct p = NIL, q = NIL, t = NIL; + g = y->typ->form; + if (g == 11) { + p = x->typ->BaseTyp; + q = y->typ->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + if (p->extlev < q->extlev) { + t = p; + p = q; + q = t; + } + while ((((p != q && p != NIL)) && p != OPT_undftyp)) { + p = p->BaseTyp; + } + if (p == NIL) { + OPB_err(100); + } + } else { + OPB_err(100); + } + } else if (g != 9) { + OPB_err(100); + } +} + +void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames) +{ + OPT_Struct ft = NIL, at = NIL; + while (fp != NIL) { + if (ap != NIL) { + ft = fp->typ; + at = ap->typ; + while ((ft->comp == 3 && at->comp == 3)) { + ft = ft->BaseTyp; + at = at->BaseTyp; + } + if (ft != at) { + if ((ft->form == 12 && at->form == 12)) { + if (ft->BaseTyp == at->BaseTyp) { + OPB_CheckParameters(ft->link, at->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(115); + } + } + if (fp->mode != ap->mode || (checkNames && __STRCMP(fp->name, ap->name) != 0)) { + OPB_err(115); + } + ap = ap->link; + } else { + OPB_err(116); + } + fp = fp->link; + } + if (ap != NIL) { + OPB_err(116); + } +} + +static void OPB_CheckProc (OPT_Struct x, OPT_Object y) +{ + if (__IN(y->mode, 0x04c0, 32)) { + if (y->mode == 6) { + if (y->mnolev == 0) { + y->mode = 7; + } else { + OPB_err(73); + } + } + if (x->BaseTyp == y->typ) { + OPB_CheckParameters(x->link, y->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(113); + } +} + +static struct ConstOp__13 { + OPT_Node *x; + INT16 *f; + OPT_Const *xval, *yval; + struct ConstOp__13 *lnk; +} *ConstOp__13_s; + +static INT16 ConstCmp__14 (void); + +static INT16 ConstCmp__14 (void) +{ + INT16 res; + switch (*ConstOp__13_s->f) { + case 0: + res = 9; + break; + case 1: case 3: case 4: + if ((*ConstOp__13_s->xval)->intval < (*ConstOp__13_s->yval)->intval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->intval > (*ConstOp__13_s->yval)->intval) { + res = 13; + } else { + res = 9; + } + break; + case 5: case 6: + if ((*ConstOp__13_s->xval)->realval < (*ConstOp__13_s->yval)->realval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->realval > (*ConstOp__13_s->yval)->realval) { + res = 13; + } else { + res = 9; + } + break; + case 2: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + case 7: + if ((*ConstOp__13_s->xval)->setval != (*ConstOp__13_s->yval)->setval) { + res = 10; + } else { + res = 9; + } + break; + case 8: + if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) < 0) { + res = 11; + } else if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) > 0) { + res = 13; + } else { + res = 9; + } + break; + case 9: case 11: case 12: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstCmp, f = ", 37); + OPM_LogWNum(*ConstOp__13_s->f, 0); + OPM_LogWLn(); + break; + } + (*ConstOp__13_s->x)->typ = OPT_booltyp; + return res; +} + +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y) +{ + INT16 f, g; + OPT_Const xval = NIL, yval = NIL; + INT64 xv, yv; + BOOLEAN temp; + struct ConstOp__13 _s; + _s.x = &x; + _s.f = &f; + _s.xval = &xval; + _s.yval = &yval; + _s.lnk = ConstOp__13_s; + ConstOp__13_s = &_s; + f = x->typ->form; + g = y->typ->form; + xval = x->conval; + yval = y->conval; + if (f != g) { + switch (f) { + case 3: + if (g == 8) { + OPB_CharToString(x); + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 4: + if (g == 4) { + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPT_IntType(x->typ->size); + } + } else if (g == 5) { + x->typ = OPT_realtyp; + xval->realval = xval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + xval->realval = xval->intval; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 5: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 6: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 5) { + y->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 8: + if (g == 3) { + OPB_CharToString(y); + g = 8; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(x, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + default: + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + break; + } + f = x->typ->form; + } + switch (op) { + case 1: + if (f == 4) { + xv = xval->intval; + yv = yval->intval; + if (((((xv == 0 || yv == 0) || (((xv > 0 && yv > 0)) && yv <= __DIV(9223372036854775807LL, xv))) || (((xv > 0 && yv < 0)) && yv >= __DIV((-9223372036854775807LL-1), xv))) || (((xv < 0 && yv > 0)) && xv >= __DIV((-9223372036854775807LL-1), yv))) || (((((((xv < 0 && yv < 0)) && xv != (-9223372036854775807LL-1))) && yv != (-9223372036854775807LL-1))) && -xv <= __DIV(9223372036854775807LL, -yv))) { + xval->intval = xv * yv; + OPB_SetIntType(x); + } else { + OPB_err(204); + } + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) <= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 / (LONGREAL)__ABS(yval->realval)) { + xval->realval = xval->realval * yval->realval; + OPB_CheckRealType(f, 204, xval); + } else { + OPB_err(204); + } + } else if (f == 7) { + xval->setval = (xval->setval & yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(101); + } + break; + case 2: + if (f == 4) { + if (yval->intval != 0) { + xval->realval = xval->intval / (REAL)yval->intval; + OPB_CheckRealType(5, 205, xval); + } else { + OPB_err(205); + xval->realval = (LONGREAL)1; + } + x->typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) >= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 * __ABS(yval->realval)) { + xval->realval = xval->realval / yval->realval; + OPB_CheckRealType(f, 205, xval); + } else { + OPB_err(205); + } + } else if (f == 7) { + xval->setval = xval->setval ^ yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(102); + } + break; + case 3: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __DIV(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(103); + } + break; + case 4: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __MOD(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(104); + } + break; + case 5: + if (f == 2) { + xval->intval = OPB_BoolToInt((OPB_IntToBool(xval->intval) && OPB_IntToBool(yval->intval))); + } else { + OPB_err(94); + } + break; + case 6: + if (f == 4) { + temp = (yval->intval >= 0 && xval->intval <= 9223372036854775807LL - yval->intval); + if (temp || (yval->intval < 0 && xval->intval >= (-9223372036854775807LL-1) - yval->intval)) { + xval->intval += yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(206); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 - yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 - yval->realval)) { + xval->realval = xval->realval + yval->realval; + OPB_CheckRealType(f, 206, xval); + } else { + OPB_err(206); + } + } else if (f == 7) { + xval->setval = xval->setval | yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(105); + } + break; + case 7: + if (f == 4) { + if ((yval->intval >= 0 && xval->intval >= (-9223372036854775807LL-1) + yval->intval) || (yval->intval < 0 && xval->intval <= 9223372036854775807LL + yval->intval)) { + xval->intval -= yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(207); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 + yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 + yval->realval)) { + xval->realval = xval->realval - yval->realval; + OPB_CheckRealType(f, 207, xval); + } else { + OPB_err(207); + } + } else if (f == 7) { + xval->setval = (xval->setval & ~yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(106); + } + break; + case 8: + if (f == 2) { + xval->intval = OPB_BoolToInt(OPB_IntToBool(xval->intval) || OPB_IntToBool(yval->intval)); + } else { + OPB_err(95); + } + break; + case 9: + xval->intval = OPB_BoolToInt(ConstCmp__14() == 9); + break; + case 10: + xval->intval = OPB_BoolToInt(ConstCmp__14() != 9); + break; + case 11: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 11); + } + break; + case 12: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 13); + } + break; + case 13: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 13); + } + break; + case 14: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 11); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstOp, op = ", 37); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + ConstOp__13_s = _s.lnk; +} + +static void OPB_Convert (OPT_Node *x, OPT_Struct typ) +{ + OPT_Node node = NIL; + INT16 f, g; + INT64 k; + LONGREAL r; + f = (*x)->typ->form; + g = typ->form; + if ((*x)->class == 7) { + if ((((f == 7 && g == 7)) && (*x)->typ->size > typ->size)) { + OPB_SetSetType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->setval = 0x0; + } + } else if (f == 4) { + if (g == 4) { + if ((*x)->typ->size > typ->size) { + OPB_SetIntType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->intval = 1; + } + } + } else if (__IN(g, 0x60, 32)) { + (*x)->conval->realval = (*x)->conval->intval; + (*x)->conval->intval = -1; + } else { + k = (*x)->conval->intval; + if (0 > k || k > 255) { + OPB_err(220); + } + } + } else if (__IN(f, 0x60, 32)) { + if (__IN(g, 0x60, 32)) { + OPB_CheckRealType(g, 203, (*x)->conval); + } else { + r = (*x)->conval->realval; + if (r < -9.22337203685478e+018 || r > 9.22337203685478e+018) { + OPB_err(203); + r = (LONGREAL)1; + } + (*x)->conval->intval = __SHORT(__ENTIER(r), 2147483648LL); + OPB_SetIntType(*x); + } + } + (*x)->obj = NIL; + } else if (((((*x)->class == 11 && (*x)->subcl == 20)) && ((INT16)(*x)->left->typ->form < f || f > g))) { + if ((*x)->left->typ == typ) { + *x = (*x)->left; + } + } else { + node = OPT_NewNode(11); + node->subcl = 20; + node->left = *x; + *x = node; + } + (*x)->typ = typ; +} + +static struct Op__38 { + INT16 *f, *g; + struct Op__38 *lnk; +} *Op__38_s; + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(12); + node->subcl = op; + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +{ + BOOLEAN ok, xCharArr, yCharArr; + xCharArr = (__IN((*x)->typ->comp, 0x0c, 32) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 8; + yCharArr = (__IN((*y)->typ->comp, 0x0c, 32) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 8; + if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + OPB_CharToString(*y); + *Op__38_s->g = 8; + yCharArr = 1; + } + if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + OPB_CharToString(*x); + *Op__38_s->f = 8; + xCharArr = 1; + } + ok = (xCharArr && yCharArr); + if (ok) { + if ((*Op__38_s->f == 8 && (*x)->conval->intval2 == 1)) { + (*x)->typ = OPT_chartyp; + (*x)->conval->intval = 0; + OPB_Index(&*y, OPB_NewIntConst(0)); + } else if ((*Op__38_s->g == 8 && (*y)->conval->intval2 == 1)) { + (*y)->typ = OPT_chartyp; + (*y)->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + } + return ok; +} + +void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y) +{ + INT16 f, g; + OPT_Node t = NIL, z = NIL; + OPT_Struct typ = NIL; + BOOLEAN do_; + INT64 val; + struct Op__38 _s; + _s.f = &f; + _s.g = &g; + _s.lnk = Op__38_s; + Op__38_s = &_s; + z = *x; + if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((z->class == 7 && y->class == 7)) { + OPB_ConstOp(op, z, y); + z->obj = NIL; + } else { + if (z->typ != y->typ) { + g = y->typ->form; + switch (z->typ->form) { + case 3: + if (z->class == 7) { + OPB_CharToString(z); + } else { + OPB_err(100); + } + break; + case 4: + if ((g == 4 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x70, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 7: + if ((g == 7 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (g == 7) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 5: + if (g == 4) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 6: + if (__IN(g, 0x70, 32)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&y, z->typ); + } else { + OPB_err(100); + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(z, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + case 8: + break; + case 13: + if (z->typ->comp == 4) { + OPB_err(100); + } + break; + default: + OPB_err(100); + break; + } + } + typ = z->typ; + f = typ->form; + g = y->typ->form; + switch (op) { + case 1: + do_ = 1; + if (f == 4) { + if (z->class == 7) { + val = z->conval->intval; + if (val == 1) { + do_ = 0; + z = y; + } else if (val == 0) { + do_ = 0; + } else if (OPB_log(val) == 1) { + t = y; + y = z; + z = t; + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } else if (y->class == 7) { + val = y->conval->intval; + if (val == 1) { + do_ = 0; + } else if (val == 0) { + do_ = 0; + z = y; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } + } else if (!__IN(f, 0xe1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 2: + if (f == 4) { + if ((y->class == 7 && y->conval->intval == 0)) { + OPB_err(205); + } + OPB_Convert(&z, OPT_realtyp); + OPB_Convert(&y, OPT_realtyp); + typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + if ((y->class == 7 && y->conval->realval == (LONGREAL)0)) { + OPB_err(205); + } + } else if ((f != 7 && f != 0)) { + OPB_err(102); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 3: + do_ = 1; + if (f == 4) { + if (y->class == 7) { + val = y->conval->intval; + if (val == 0) { + OPB_err(205); + } else if (val == 1) { + do_ = 0; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = -OPB_exp; + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(103); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 4: + if (f == 4) { + if (y->class == 7) { + if (y->conval->intval == 0) { + OPB_err(205); + } else if (OPB_log(y->conval->intval) == 1) { + op = 18; + y->conval->intval = __ASH(-1, OPB_exp); + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(104); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 5: + if (f == 2) { + if (z->class == 7) { + if (OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(94); + z->typ = OPT_undftyp; + } + break; + case 6: + if (!__IN(f, 0xf1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + do_ = 1; + if (f == 4) { + if ((z->class == 7 && z->conval->intval == 0)) { + do_ = 0; + z = y; + } + if ((y->class == 7 && y->conval->intval == 0)) { + do_ = 0; + } + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 7: + if (!__IN(f, 0xf1, 32)) { + OPB_err(106); + typ = OPT_undftyp; + } + if ((f != 4 || y->class != 7) || y->conval->intval != 0) { + NewOp__39(op, typ, &z, y); + } + break; + case 8: + if (f == 2) { + if (z->class == 7) { + if (!OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(95); + z->typ = OPT_undftyp; + } + break; + case 9: case 10: + if (__IN(f, 0x1aff, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPB_err(107); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 11: case 12: case 13: case 14: + if (__IN(f, 0x79, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ELSE in Op()", 13); + OPM_LogWLn(); + OPB_err(108); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", 32); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + Op__38_s = _s.lnk; +} + +void OPB_SetRange (OPT_Node *x, OPT_Node y) +{ + INT64 k, l; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if (((*x)->typ->form == 4 && y->typ->form == 4)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (0 > k || k > 63) { + OPB_err(202); + } + } + if (y->class == 7) { + l = y->conval->intval; + if (0 > l || l > 63) { + OPB_err(202); + } + } + if (((*x)->class == 7 && y->class == 7)) { + if (k <= l) { + (*x)->conval->setval = __SETRNG(k, l, 32); + OPB_SetSetType(*x); + } else { + OPB_err(201); + (*x)->conval->setval = __SETRNG(l, k, 32); + } + (*x)->obj = NIL; + } else { + OPB_BindNodes(10, OPT_settyp, &*x, y); + } + } else { + OPB_err(93); + } + (*x)->typ = OPT_settyp; +} + +void OPB_SetElem (OPT_Node *x) +{ + INT64 k; + if ((*x)->class == 8 || (*x)->class == 9) { + OPB_err(126); + } else if ((*x)->typ->form != 4) { + OPB_err(93); + } else if ((*x)->class == 7) { + k = (*x)->conval->intval; + if ((0 <= k && k <= 63)) { + (*x)->conval->setval = 0x0; + (*x)->conval->setval |= __SETOF(k,64); + } else { + OPB_err(202); + } + OPB_SetSetType(*x); + (*x)->obj = NIL; + } else { + OPB_Convert(&*x, OPT_settyp); + (*x)->typ = OPT_settyp; + } +} + +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) +{ + OPT_Struct y = NIL; + INT16 f, g; + OPT_Struct p = NIL, q = NIL; + y = ynode->typ; + f = x->form; + g = y->form; + if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { + OPB_err(126); + } + switch (f) { + case 0: case 8: + break; + case 1: + if (!((__IN(g, 0x1a, 32) && y->size == 1))) { + OPB_err(113); + } + break; + case 2: case 3: + if (g != f) { + OPB_err(113); + } + break; + case 4: case 7: + if (g != f || x->size < y->size) { + OPB_err(113); + } + break; + case 5: + if (!__IN(g, 0x30, 32)) { + OPB_err(113); + } + break; + case 6: + if (!__IN(g, 0x70, 32)) { + OPB_err(113); + } + break; + case 11: + if ((x == y || g == 9) || (x == OPT_sysptrtyp && g == 11)) { + } else if (g == 11) { + p = x->BaseTyp; + q = y->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + while ((((q != p && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + case 12: + if (ynode->class == 9) { + OPB_CheckProc(x, ynode->obj); + } else if (x == y || g == 9) { + } else { + OPB_err(113); + } + break; + case 10: case 9: + OPB_err(113); + break; + case 13: + x->pvused = 1; + if (x->comp == 2) { + if ((ynode->class == 7 && g == 3)) { + OPB_CharToString(ynode); + y = ynode->typ; + g = 8; + } + if (x == y) { + } else if ((((y->comp == 2 && y->BaseTyp == x->BaseTyp)) && y->n <= x->n)) { + } else if ((y->comp == 3 && y->BaseTyp == x->BaseTyp)) { + OPB_err(113); + } else if (x->BaseTyp == OPT_chartyp) { + if (g == 8) { + if (ynode->conval->intval2 > x->n) { + OPB_err(114); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else if (x->comp == 4) { + if (x == y) { + } else if (y->comp == 4) { + q = y->BaseTyp; + while ((((q != NIL && q != x)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.CheckAssign, f = ", 40); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } + if ((((((ynode->class == 7 && g < f)) && __IN(g, 0x30, 32))) && __IN(f, 0x70, 32))) { + OPB_Convert(&ynode, x); + } +} + +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo) +{ +} + +void OPB_StPar0 (OPT_Node *par0, INT16 fctno) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node x = NIL; + x = *par0; + f = x->typ->form; + switch (fctno) { + case 0: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + x->typ = OPT_notyp; + break; + case 1: + typ = OPT_notyp; + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + if (x->readonly) { + OPB_err(76); + } + f = x->typ->BaseTyp->comp; + if (__IN(f, 0x1c, 32)) { + if (f == 3) { + typ = x->typ->BaseTyp; + } + OPB_BindNodes(19, OPT_notyp, &x, NIL); + x->subcl = 1; + } else { + OPB_err(111); + } + } else { + OPB_err(111); + } + x->typ = typ; + break; + case 2: + OPB_MOp(21, &x); + break; + case 3: + OPB_MOp(22, &x); + break; + case 4: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 3) { + OPB_Convert(&x, OPT_inttyp); + } else { + OPB_err(111); + } + x->typ = OPT_inttyp; + break; + case 5: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x60, 32)) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + x->typ = OPT_linttyp; + break; + case 6: + OPB_MOp(23, &x); + break; + case 7: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(0); + break; + case 3: + x = OPB_NewIntConst(0); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(0); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MinReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MinLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 8: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(1); + break; + case 3: + x = OPB_NewIntConst(255); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(__ASHL(x->typ->size, 3) - 1); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MaxReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MaxLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 9: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x11, 32)) { + OPB_Convert(&x, OPT_chartyp); + } else { + OPB_err(111); + x->typ = OPT_chartyp; + } + break; + case 10: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, -1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 6) { + OPB_Convert(&x, OPT_realtyp); + } else { + OPB_err(111); + } + break; + case 11: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, 1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 5) { + OPB_Convert(&x, OPT_lrltyp); + } else if (f == 3) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + break; + case 13: case 14: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f != 4) { + OPB_err(111); + } else if (x->readonly) { + OPB_err(76); + } + break; + case 15: case 16: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (x->typ->form != 7) { + OPB_err(111); + x->typ = OPT_settyp; + } else if (x->readonly) { + OPB_err(76); + } + break; + case 17: + if (!__IN(x->typ->comp, 0x0c, 32)) { + OPB_err(131); + } + break; + case 18: + if ((x->class == 7 && f == 3)) { + OPB_CharToString(x); + f = 8; + } + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (((!__IN(x->typ->comp, 0x0c, 32) || x->typ->BaseTyp->form != 3) && f != 8)) { + OPB_err(111); + } + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if (x->typ->size < OPT_linttyp->size) { + OPB_Convert(&x, OPT_linttyp); + } + } else { + OPB_err(111); + x->typ = OPT_linttyp; + } + break; + case 20: + OPB_CheckLeaf(x, 0); + OPB_MOp(24, &x); + break; + case 12: + if (x->class != 8) { + OPB_err(110); + x = OPB_NewIntConst(1); + } else if (__IN(f, 0x18fe, 32) || __IN(x->typ->comp, 0x14, 32)) { + OPT_TypSize(x->typ); + x->typ->pvused = 1; + x = OPB_NewIntConst(x->typ->size); + } else { + OPB_err(111); + x = OPB_NewIntConst(1); + } + break; + case 21: + OPB_MOp(25, &x); + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (!__IN(f, 0x9a, 32)) { + OPB_err(111); + } + break; + case 24: case 25: case 28: case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + break; + case 26: case 27: + if ((f == 4 && x->class == 7)) { + if (x->conval->intval < 0 || x->conval->intval > -1) { + OPB_err(220); + } + } else { + OPB_err(69); + } + break; + case 29: + if (x->class != 8) { + OPB_err(110); + } else if (__IN(f, 0x0501, 32) || x->typ->comp == 3) { + OPB_err(111); + } + break; + case 30: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + } else { + OPB_err(111); + } + break; + case 32: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + x = OPB_NewBoolConst(0); + } else if (f != 2) { + OPB_err(120); + x = OPB_NewBoolConst(0); + } else { + OPB_MOp(33, &x); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.StPar0, fctno = ", 39); + OPM_LogWNum(fctno, 0); + OPM_LogWLn(); + break; + } + *par0 = x; +} + +static struct StPar1__53 { + struct StPar1__53 *lnk; +} *StPar1__53_s; + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right); + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->subcl = subcl; + node->left = left; + node->right = right; + return node; +} + +void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno) +{ + INT16 f, L; + OPT_Struct typ = NIL; + OPT_Node p = NIL, t = NIL; + struct StPar1__53 _s; + _s.lnk = StPar1__53_s; + StPar1__53_s = &_s; + p = *par0; + f = x->typ->form; + switch (fctno) { + case 13: case 14: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + p->typ = OPT_notyp; + } else { + if (x->typ != p->typ) { + if ((f == 4 && (x->class == 7 || (p->typ->form == 4 && x->typ->size <= p->typ->size)))) { + OPB_Convert(&x, p->typ); + } else { + OPB_err(111); + } + } + p = NewOp__54(19, fctno, p, x); + p->typ = OPT_notyp; + } + break; + case 15: case 16: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval >= (INT64)__ASHL(p->typ->size, 3)))) { + OPB_err(202); + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 17: + if (!(f == 4) || x->class != 7) { + OPB_err(69); + } else if (x->typ->size == 1) { + L = OPM_Integer(x->conval->intval); + typ = p->typ; + while ((L > 0 && __IN(typ->comp, 0x0c, 32))) { + typ = typ->BaseTyp; + L -= 1; + } + if (L != 0 || !__IN(typ->comp, 0x0c, 32)) { + OPB_err(132); + } else { + x->obj = NIL; + if (typ->comp == 3) { + while (p->class == 4) { + p = p->left; + x->conval->intval += 1; + } + p = NewOp__54(12, 19, p, x); + p->typ = OPT_linttyp; + } else { + p = x; + p->conval->intval = typ->n; + OPB_SetIntType(p); + } + } + } else { + OPB_err(132); + } + break; + case 18: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if ((__IN(x->typ->comp, 0x0c, 32) && x->typ->BaseTyp->form == 3)) { + if (x->readonly) { + OPB_err(76); + } + t = x; + x = p; + p = t; + p = NewOp__54(19, 18, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((p->class == 7 && x->class == 7)) { + if (-OPB_maxExp > x->conval->intval || x->conval->intval > OPB_maxExp) { + OPB_err(208); + p->conval->intval = 1; + } else if (x->conval->intval >= 0) { + if (__ABS(p->conval->intval) <= __DIV(9223372036854775807LL, (INT64)__ASH(1, x->conval->intval))) { + p->conval->intval = p->conval->intval * (INT64)__ASH(1, x->conval->intval); + } else { + OPB_err(208); + p->conval->intval = 1; + } + } else { + p->conval->intval = __ASH(p->conval->intval, x->conval->intval); + } + p->obj = NIL; + } else { + p = NewOp__54(12, 17, p, x); + p->typ = p->left->typ; + } + } else { + OPB_err(111); + } + break; + case 1: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp == 3) { + if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + } else { + OPB_err(111); + } + p->right = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(64); + } + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f != 4) { + OPB_err(111); + } else { + if (fctno == 22) { + p = NewOp__54(12, 27, p, x); + } else { + p = NewOp__54(12, 28, p, x); + } + p->typ = p->left->typ; + } + break; + case 24: case 25: case 26: case 27: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x18ff, 32)) { + if (fctno == 24 || fctno == 26) { + if (OPB_NotVar(x)) { + OPB_err(112); + } + t = x; + x = p; + p = t; + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 28: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(12, 26, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_booltyp; + break; + case 29: + if (((x->class == 8 || x->class == 9) || __IN(f, 0x0501, 32)) || x->typ->comp == 3) { + OPB_err(126); + } + OPT_TypSize(x->typ); + OPT_TypSize(p->typ); + if ((x->class != 7 && x->typ->size < p->typ->size)) { + OPB_err(-308); + } + if ((((x->class == 7 && x->typ->form == 4)) && p->typ->form == 4)) { + OPB_Convert(&x, p->typ); + } else { + t = OPT_NewNode(11); + t->subcl = 29; + t->left = x; + x = t; + x->typ = p->typ; + } + p = x; + break; + case 30: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(19, 30, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + p->link = x; + break; + case 32: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + break; + default: + OPB_err(64); + break; + } + *par0 = p; + StPar1__53_s = _s.lnk; +} + +void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n) +{ + OPT_Node node = NIL; + INT16 f; + OPT_Node p = NIL; + p = *par0; + f = x->typ->form; + if (fctno == 1) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp != 3) { + OPB_err(64); + } else if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + node = p->right; + while (node->link != NIL) { + node = node->link; + } + node->link = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(111); + } + } else if ((fctno == 31 && n == 2)) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + node = OPT_NewNode(19); + node->subcl = 31; + node->right = p; + node->left = p->link; + p->link = x; + p = node; + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + } else { + OPB_err(64); + } + *par0 = p; +} + +void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno) +{ + INT16 dim; + OPT_Node x = NIL, p = NIL; + p = *par0; + if (fctno <= 19) { + if ((fctno == 1 && p->typ != OPT_notyp)) { + if (p->typ->comp == 3) { + OPB_err(65); + } + p->typ = OPT_notyp; + } else if (fctno <= 12) { + if (parno < 1) { + OPB_err(65); + } + } else { + if (((fctno == 13 || fctno == 14) && parno == 1)) { + OPB_BindNodes(19, OPT_notyp, &p, OPB_NewIntConst(1)); + p->subcl = fctno; + p->right->typ = p->left->typ; + } else if ((fctno == 17 && parno == 1)) { + if (p->typ->comp == 3) { + dim = 0; + while (p->class == 4) { + p = p->left; + dim += 1; + } + OPB_BindNodes(12, OPT_linttyp, &p, OPB_NewIntConst(dim)); + p->subcl = 19; + } else { + p = OPB_NewIntConst(p->typ->n); + } + } else if (parno < 2) { + OPB_err(65); + } + } + } else if (fctno == 32) { + if (parno == 1) { + x = NIL; + OPB_BindNodes(28, OPT_notyp, &x, OPB_NewIntConst(0)); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else if (parno < 1) { + OPB_err(65); + } + } else { + if ((parno < 1 || (fctno > 21 && parno < 2)) || (fctno == 31 && parno < 3)) { + OPB_err(65); + } + } + *par0 = p; +} + +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar) +{ + INT16 f; + f = atyp->comp; + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((fvarpar && ftyp == OPT_bytetyp)) { + if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { + if (__IN(18, OPM_Options, 32)) { + OPB_err(-301); + } + } + } else if (__IN(f, 0x0c, 32)) { + if (ftyp->comp == 3) { + OPB_DynArrParCheck(ftyp, atyp, fvarpar); + } else if (ftyp != atyp) { + if ((((!fvarpar && ftyp->form == 11)) && atyp->form == 11)) { + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((ftyp->comp == 4 && atyp->comp == 4)) { + while ((((ftyp != atyp && atyp != NIL)) && atyp != OPT_undftyp)) { + atyp = atyp->BaseTyp; + } + if (atyp == NIL) { + OPB_err(113); + } + } else { + OPB_err(66); + } + } else { + OPB_err(66); + } + } + } else { + OPB_err(67); + } +} + +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp) +{ + if (fp->typ->form == 11) { + if ((*x)->class == 3) { + *x = (*x)->left; + } else { + OPB_err(71); + } + } +} + +void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar) +{ + if (((*x)->obj != NIL && __IN((*x)->obj->mode, 0x22c0, 32))) { + *fpar = (*x)->obj->link; + if ((*x)->obj->mode == 13) { + OPB_CheckReceiver(&(*x)->left, *fpar); + *fpar = (*fpar)->link; + } + } else if (((((*x)->class != 8 && (*x)->typ != NIL)) && (*x)->typ->form == 12)) { + *fpar = (*x)->typ->link; + } else { + OPB_err(121); + *fpar = NIL; + (*x)->typ = OPT_undftyp; + } +} + +void OPB_Param (OPT_Node ap, OPT_Object fp) +{ + OPT_Struct q = NIL; + if (fp->typ->form != 0) { + if (fp->mode == 2) { + if (OPB_NotVar(ap)) { + OPB_err(122); + } else { + OPB_CheckLeaf(ap, 0); + } + if (ap->readonly) { + OPB_err(76); + } + if (fp->typ->comp == 3) { + OPB_DynArrParCheck(fp->typ, ap->typ, 1); + } else if ((fp->typ->comp == 4 && ap->typ->comp == 4)) { + q = ap->typ; + while ((((q != fp->typ && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(111); + } + } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 11)) { + } else if ((ap->typ != fp->typ && !((((fp->typ->form == 1 && __IN(ap->typ->form, 0x1e, 32))) && ap->typ->size == 1)))) { + OPB_err(123); + } else if ((fp->typ->form == 11 && ap->class == 5)) { + OPB_err(123); + } + } else if (fp->typ->comp == 3) { + if ((ap->class == 7 && ap->typ->form == 3)) { + OPB_CharToString(ap); + } + if ((ap->typ->form == 8 && fp->typ->BaseTyp->form == 3)) { + } else if (ap->class >= 7) { + OPB_err(59); + } else { + OPB_DynArrParCheck(fp->typ, ap->typ, 0); + } + } else { + OPB_CheckAssign(fp->typ, ap); + } + } +} + +void OPB_StaticLink (INT8 dlev) +{ + OPT_Object scope = NIL; + scope = OPT_topScope; + while (dlev > 0) { + dlev -= 1; + scope->link->conval->setval |= __SETOF(3,64); + scope = scope->left; + } +} + +void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp) +{ + OPT_Struct typ = NIL; + OPT_Node p = NIL; + INT8 lev; + if ((*x)->class == 9) { + typ = (*x)->typ; + lev = (*x)->obj->mnolev; + if (lev > 0) { + OPB_StaticLink(OPT_topScope->mnolev - lev); + } + if ((*x)->obj->mode == 10) { + OPB_err(121); + } + } else if (((*x)->class == 2 && (*x)->obj->mode == 13)) { + typ = (*x)->typ; + (*x)->class = 9; + p = (*x)->left; + (*x)->left = NIL; + p->link = apar; + apar = p; + fp = (*x)->obj->link; + } else { + typ = (*x)->typ->BaseTyp; + } + OPB_BindNodes(13, typ, &*x, apar); + (*x)->obj = fp; +} + +void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc) +{ + OPT_Node x = NIL; + x = OPT_NewNode(18); + x->typ = OPT_notyp; + x->obj = proc; + x->left = *procdec; + x->right = stat; + *procdec = x; +} + +void OPB_Return (OPT_Node *x, OPT_Object proc) +{ + OPT_Node node = NIL; + if (proc == NIL) { + if (*x != NIL) { + OPB_err(124); + } + } else { + if (*x != NIL) { + OPB_CheckAssign(proc->typ, *x); + } else if (proc->typ != OPT_notyp) { + OPB_err(124); + } + } + node = OPT_NewNode(26); + node->typ = OPT_notyp; + node->obj = proc; + node->left = *x; + *x = node; +} + +void OPB_Assign (OPT_Node *x, OPT_Node y) +{ + OPT_Node z = NIL; + if ((*x)->class >= 7) { + OPB_err(56); + } + OPB_CheckAssign((*x)->typ, y); + if ((*x)->readonly) { + OPB_err(76); + } + if ((*x)->typ->comp == 4) { + if ((*x)->class == 5) { + z = (*x)->left; + } else { + z = *x; + } + if ((z->class == 3 && z->left->class == 5)) { + z->left = z->left->left; + } + if (((*x)->typ->strobj != NIL && (z->class == 3 || z->class == 1))) { + OPB_BindNodes(6, (*x)->typ, &z, NIL); + *x = z; + } + } else if (((((((*x)->typ->comp == 2 && (*x)->typ->BaseTyp == OPT_chartyp)) && y->typ->form == 8)) && y->conval->intval2 == 1)) { + y->typ = OPT_chartyp; + y->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + OPB_BindNodes(19, OPT_notyp, &*x, y); + (*x)->subcl = 0; +} + +void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ) +{ + OPT_Node node = NIL; + node = OPT_NewNode(14); + node->typ = typ; + node->conval = OPT_NewConst(); + node->conval->intval = typ->txtpos; + if (*inittd == NIL) { + *inittd = node; + } else { + (*last)->link = node; + } + *last = node; +} + + +export void *OPB__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPB", 0); +/* BEGIN */ + OPB_maxExp = OPB_log(4611686018427387904LL); + OPB_maxExp = OPB_exp; + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPB.h b/bootstrap/unix-88/OPB.h new file mode 100644 index 00000000..f66fcd66 --- /dev/null +++ b/bootstrap/unix-88/OPB.h @@ -0,0 +1,48 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPB__h +#define OPB__h + +#include "SYSTEM.h" +#include "OPS.h" +#include "OPT.h" + + + + +import void OPB_Assign (OPT_Node *x, OPT_Node y); +import void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +import void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +import void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +import void OPB_DeRef (OPT_Node *x); +import OPT_Node OPB_EmptySet (void); +import void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +import void OPB_Field (OPT_Node *x, OPT_Object y); +import void OPB_In (OPT_Node *x, OPT_Node y); +import void OPB_Index (OPT_Node *x, OPT_Node y); +import void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +import void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +import void OPB_MOp (INT8 op, OPT_Node *x); +import OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +import OPT_Node OPB_NewIntConst (INT64 intval); +import OPT_Node OPB_NewLeaf (OPT_Object obj); +import OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +import OPT_Node OPB_NewString (OPS_String str, INT64 len); +import OPT_Node OPB_Nil (void); +import void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +import void OPB_OptIf (OPT_Node *x); +import void OPB_Param (OPT_Node ap, OPT_Object fp); +import void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +import void OPB_Return (OPT_Node *x, OPT_Object proc); +import void OPB_SetElem (OPT_Node *x); +import void OPB_SetRange (OPT_Node *x, OPT_Node y); +import void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +import void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +import void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +import void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +import void OPB_StaticLink (INT8 dlev); +import void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +import void *OPB__init(void); + + +#endif // OPB diff --git a/bootstrap/unix-88/OPC.c b/bootstrap/unix-88/OPC.c new file mode 100644 index 00000000..7b92ccc1 --- /dev/null +++ b/bootstrap/unix-88/OPC.c @@ -0,0 +1,2025 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "OPM.h" +#include "OPT.h" + + +static INT16 OPC_indentLevel; +static INT8 OPC_hashtab[105]; +static CHAR OPC_keytab[50][9]; +static BOOLEAN OPC_GlbPtrs; +static CHAR OPC_BodyNameExt[13]; + + +export void OPC_Andent (OPT_Struct typ); +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); +export OPT_Object OPC_BaseTProc (OPT_Object obj); +export void OPC_BegBlk (void); +export void OPC_BegStat (void); +static void OPC_CProcDefs (OPT_Object obj, INT16 vis); +export void OPC_Case (INT64 caseVal, INT16 form); +static void OPC_CharacterLiteral (INT64 c); +export void OPC_Cmp (INT16 rel); +export void OPC_CompleteIdent (OPT_Object obj); +export void OPC_Constant (OPT_Const con, INT16 form); +static void OPC_DeclareBase (OPT_Object dcl); +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef); +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro); +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefAnonRecs (OPT_Node n); +export void OPC_DefineInter (OPT_Object proc); +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefineTProcTypes (OPT_Object obj); +static void OPC_DefineType (OPT_Struct str); +export void OPC_EndBlk (void); +export void OPC_EndBlk0 (void); +export void OPC_EndStat (void); +export void OPC_EnterBody (void); +export void OPC_EnterProc (OPT_Object proc); +export void OPC_ExitBody (void); +export void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign); +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign); +export void OPC_GenBdy (OPT_Node n); +static void OPC_GenDynTypes (OPT_Node n, INT16 vis); +export void OPC_GenEnumPtrs (OPT_Object var); +export void OPC_GenHdr (OPT_Node n); +export void OPC_GenHdrIncludes (void); +static void OPC_GenHeaderMsg (void); +export void OPC_Halt (INT32 n); +export void OPC_Ident (OPT_Object obj); +static void OPC_IdentList (OPT_Object obj, INT16 vis); +static void OPC_Include (CHAR *name, ADDRESS name__len); +static void OPC_IncludeImports (OPT_Object obj, INT16 vis); +export void OPC_Increment (BOOLEAN decrement); +export void OPC_Indent (INT16 count); +export void OPC_Init (void); +static void OPC_InitImports (OPT_Object obj); +static void OPC_InitKeywords (void); +export void OPC_InitTDesc (OPT_Struct typ); +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj); +export void OPC_IntLiteral (INT64 n, INT32 size); +export void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName); +static INT16 OPC_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN OPC_NeedsRetval (OPT_Object proc); +export INT32 OPC_NofPtrs (OPT_Struct typ); +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len); +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len); +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define); +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis); +static void OPC_PutBase (OPT_Struct typ); +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt); +static void OPC_RegCmds (OPT_Object obj); +export void OPC_SetInclude (BOOLEAN exclude); +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x); +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l); +export void OPC_TDescDecl (OPT_Struct typ); +export void OPC_TypeDefs (OPT_Object obj, INT16 vis); +export void OPC_TypeOf (OPT_Object ap); +static BOOLEAN OPC_Undefined (OPT_Object obj); + + +void OPC_Init (void) +{ + OPC_indentLevel = 0; + __MOVE("__init(void)", OPC_BodyNameExt, 13); +} + +void OPC_Indent (INT16 count) +{ + OPC_indentLevel += count; +} + +void OPC_BegStat (void) +{ + INT16 i; + i = OPC_indentLevel; + while (i > 0) { + OPM_Write(0x09); + i -= 1; + } +} + +void OPC_EndStat (void) +{ + OPM_Write(';'); + OPM_WriteLn(); +} + +void OPC_BegBlk (void) +{ + OPM_Write('{'); + OPM_WriteLn(); + OPC_indentLevel += 1; +} + +void OPC_EndBlk (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); + OPM_WriteLn(); +} + +void OPC_EndBlk0 (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); +} + +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x) +{ + CHAR ch; + INT16 i; + __DUP(s, s__len, CHAR); + ch = s[0]; + i = 0; + while (ch != 0x00) { + if (ch == '#') { + OPM_WriteInt(x); + } else { + OPM_Write(ch); + } + i += 1; + ch = s[__X(i, s__len)]; + } + __DEL(s); +} + +static INT16 OPC_Length (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + return i; +} + +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len) +{ + INT16 i, h; + i = 0; + h = 0; + while ((s[__X(i, s__len)] != 0x00 && i < 5)) { + h = 3 * h + (INT16)s[__X(i, s__len)]; + i += 1; + } + return (int)__MOD(h, 105); +} + +void OPC_Ident (OPT_Object obj) +{ + INT16 mode, level, h; + mode = obj->mode; + level = obj->mnolev; + if ((__IN(mode, 0x62, 32) && level > 0) || __IN(mode, 0x14, 32)) { + OPM_WriteStringVar((void*)obj->name, 256); + h = OPC_PerfectHash((void*)obj->name, 256); + if (OPC_hashtab[__X(h, 105)] >= 0) { + if (__STRCMP(OPC_keytab[__X(OPC_hashtab[__X(h, 105)], 50)], obj->name) == 0) { + OPM_Write('_'); + } + } + } else if ((mode == 5 && __IN(obj->typ->form, 0x90, 32))) { + if (obj->typ == OPT_adrtyp) { + OPM_WriteString((CHAR*)"ADDRESS", 8); + } else { + if (obj->typ->form == 4) { + OPM_WriteString((CHAR*)"INT", 4); + } else { + OPM_WriteString((CHAR*)"UINT", 5); + } + OPM_WriteInt(__ASHL(obj->typ->size, 3)); + } + } else { + if (mode != 5 || obj->linkadr != 2) { + if (mode == 13) { + OPC_Ident(obj->link->typ->strobj); + } else if (level < 0) { + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-level, 64)]->name, 256); + if (OPM_currFile == 0) { + OPT_GlbMod[__X(-level, 64)]->vis = 1; + } + } else { + OPM_WriteStringVar((void*)OPM_modName, 32); + } + OPM_Write('_'); + } else if (obj == OPT_sysptrtyp->strobj || obj == OPT_bytetyp->strobj) { + OPM_WriteString((CHAR*)"SYSTEM_", 8); + } + OPM_WriteStringVar((void*)obj->name, 256); + } +} + +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause) +{ + INT16 pointers; + *openClause = 0; + if (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->comp != 4)) { + if (__IN(typ->comp, 0x0c, 32)) { + OPC_Stars(typ->BaseTyp, &*openClause); + *openClause = typ->comp == 2; + } else if (typ->form == 12) { + OPM_Write('('); + OPM_Write('*'); + } else { + pointers = 0; + while (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->form == 11)) { + pointers += 1; + typ = typ->BaseTyp; + } + if (pointers > 0) { + if (typ->comp != 3) { + OPC_Stars(typ, &*openClause); + } + if (*openClause) { + OPM_Write('('); + *openClause = 0; + } + while (pointers > 0) { + OPM_Write('*'); + pointers -= 1; + } + } + } + } +} + +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef) +{ + OPT_Struct typ = NIL; + BOOLEAN varPar, openClause; + INT16 form, comp; + typ = dcl->typ; + varPar = ((dcl->mode == 2 && typ->comp != 2) || typ->comp == 3) || scopeDef; + OPC_Stars(typ, &openClause); + if (varPar) { + if (openClause) { + OPM_Write('('); + } + OPM_Write('*'); + } + if (dcl->name[0] != 0x00) { + OPC_Ident(dcl); + } + if ((varPar && openClause)) { + OPM_Write(')'); + } + openClause = 0; + for (;;) { + form = typ->form; + comp = typ->comp; + if (((typ->strobj != NIL && typ->strobj->name[0] != 0x00) || form == 10) || comp == 4) { + break; + } else if ((form == 11 && typ->BaseTyp->comp != 3)) { + openClause = 1; + } else if (form == 12 || __IN(comp, 0x0c, 32)) { + if (openClause) { + OPM_Write(')'); + openClause = 0; + } + if (form == 12) { + OPM_Write(')'); + OPC_AnsiParamList(typ->link, 0); + break; + } else if (comp == 2) { + OPM_Write('['); + OPM_WriteInt(typ->n); + OPM_Write(']'); + } + } else { + break; + } + typ = typ->BaseTyp; + } +} + +void OPC_Andent (OPT_Struct typ) +{ + if (typ->strobj == NIL || typ->align >= 65536) { + OPM_WriteStringVar((void*)OPM_modName, 32); + OPC_Str1((CHAR*)"__#", 4, __ASHR(typ->align, 16)); + } else { + OPC_Ident(typ->strobj); + } +} + +static BOOLEAN OPC_Undefined (OPT_Object obj) +{ + return obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (3 + OPM_currFile))) && obj->linkadr != 2); +} + +static void OPC_DeclareBase (OPT_Object dcl) +{ + OPT_Struct typ = NIL, prev = NIL; + OPT_Object obj = NIL; + INT16 nofdims; + INT32 off, n, dummy; + typ = dcl->typ; + prev = typ; + while ((((((((typ->strobj == NIL || typ->comp == 3) || OPC_Undefined(typ->strobj)) && typ->comp != 4)) && typ->form != 10)) && !((typ->form == 11 && typ->BaseTyp->comp == 3)))) { + prev = typ; + typ = typ->BaseTyp; + } + obj = typ->strobj; + if (typ->form == 10) { + OPM_WriteString((CHAR*)"void", 5); + } else if ((obj != NIL && !OPC_Undefined(obj))) { + OPC_Ident(obj); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"struct ", 8); + OPC_Andent(typ); + if ((prev->form != 11 && (obj != NIL || dcl->name[0] == 0x00))) { + if ((typ->BaseTyp != NIL && typ->BaseTyp->strobj->vis != 0)) { + OPM_WriteString((CHAR*)" { /* ", 7); + OPC_Ident(typ->BaseTyp->strobj); + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); + OPC_Indent(1); + } else { + OPM_Write(' '); + OPC_BegBlk(); + } + OPC_FieldList(typ, 1, &off, &n, &dummy); + OPC_EndBlk0(); + } + } else if ((typ->form == 11 && typ->BaseTyp->comp == 3)) { + typ = typ->BaseTyp->BaseTyp; + nofdims = 1; + while (typ->comp == 3) { + nofdims += 1; + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)"struct ", 8); + OPC_BegBlk(); + OPC_BegStat(); + OPC_Str1((CHAR*)"ADDRESS len[#]", 15, nofdims); + OPC_EndStat(); + OPC_BegStat(); + __NEW(obj, OPT_ObjDesc); + __NEW(obj->typ, OPT_StrDesc); + obj->typ->form = 13; + obj->typ->comp = 2; + obj->typ->n = 1; + obj->typ->BaseTyp = typ; + obj->mode = 4; + __MOVE("data", obj->name, 5); + obj->linkadr = 0; + OPC_DeclareBase(obj); + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + OPC_EndStat(); + OPC_EndBlk0(); + } +} + +INT32 OPC_NofPtrs (OPT_Struct typ) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n; + if ((typ->form == 11 && typ->sysflag == 0)) { + return 1; + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + n = OPC_NofPtrs(btyp); + } else { + n = 0; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + n = n + OPC_NofPtrs(fld->typ); + } else { + n += 1; + } + fld = fld->link; + } + return n; + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + return OPC_NofPtrs(btyp) * n; + } else { + return 0; + } + __RETCHK; +} + +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n, i; + if ((typ->form == 11 && typ->sysflag == 0)) { + OPM_WriteInt(adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + OPC_PutPtrOffsets(btyp, adr, &*cnt); + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + OPC_PutPtrOffsets(fld->typ, adr + fld->adr, &*cnt); + } else { + OPM_WriteInt(adr + fld->adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } + fld = fld->link; + } + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (OPC_NofPtrs(btyp) > 0) { + i = 0; + while (i < n) { + OPC_PutPtrOffsets(btyp, adr + i * btyp->size, &*cnt); + i += 1; + } + } + } +} + +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitTProcs(typ, obj->left); + if (obj->mode == 13) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITBP(", 10); + OPC_Ident(typ); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(obj); + OPC_Str1((CHAR*)", #)", 5, __ASHR(obj->adr, 16)); + OPC_EndStat(); + } + OPC_InitTProcs(typ, obj->right); + } +} + +static void OPC_PutBase (OPT_Struct typ) +{ + if (typ != NIL) { + OPC_PutBase(typ->BaseTyp); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)", ", 3); + } +} + +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName) +{ + OPT_Struct typ = NIL; + INT16 dim; + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + } + dim = 1; + typ = par->typ->BaseTyp; + while (typ->comp == 3) { + if (ansiDefine) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + } else { + OPM_WriteString((CHAR*)", ", 3); + } + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + dim += 1; + } +} + +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro) +{ + OPM_Write('('); + while (par != NIL) { + if (macro) { + OPM_WriteStringVar((void*)par->name, 256); + } else { + if ((par->mode == 1 && par->typ->form == 5)) { + OPM_Write('_'); + } + OPC_Ident(par); + } + if (par->typ->comp == 3) { + OPM_WriteString((CHAR*)", ", 3); + OPC_LenList(par, 0, 1); + } else if ((par->mode == 2 && par->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteStringVar((void*)par->name, 256); + OPM_WriteString((CHAR*)"__typ", 6); + } + par = par->link; + if (par != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static void OPC_DefineTProcTypes (OPT_Object obj) +{ + OPT_Object par = NIL; + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + par = obj->link; + while (par != NIL) { + OPC_DefineType(par->typ); + par = par->link; + } +} + +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DeclareTProcs(obj->left, &*empty); + if (obj->mode == 13) { + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + if (OPM_currFile == 0) { + if (obj->vis == 1) { + OPC_DefineTProcTypes(obj); + OPM_WriteString((CHAR*)"import ", 8); + *empty = 0; + OPC_ProcHeader(obj, 0); + } + } else { + *empty = 0; + OPC_DefineTProcTypes(obj); + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + } + OPC_DeclareTProcs(obj->right, &*empty); + } +} + +OPT_Object OPC_BaseTProc (OPT_Object obj) +{ + OPT_Struct typ = NIL, base = NIL; + INT32 mno; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + base = typ->BaseTyp; + mno = __ASHR(obj->adr, 16); + while ((base != NIL && mno < base->n)) { + typ = base; + base = typ->BaseTyp; + } + OPT_FindField(obj->name, typ, &obj); + return obj; +} + +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DefineTProcMacros(obj->left, &*empty); + if ((obj->mode == 13 && obj == OPC_BaseTProc(obj))) { + if (OPM_currFile == 1 || (OPM_currFile == 0 && obj->vis == 1)) { + OPM_WriteString((CHAR*)"#define __", 11); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_WriteString((CHAR*)" __SEND(", 9); + if (obj->link->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPC_Ident(obj->link); + OPM_Write(')'); + } else { + OPC_Ident(obj->link); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_Str1((CHAR*)", #, ", 6, __ASHR(obj->adr, 16)); + if (obj->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(obj->typ->strobj); + } + OPM_WriteString((CHAR*)"(*)", 4); + OPC_AnsiParamList(obj->link, 0); + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareParams(obj->link, 1); + OPM_Write(')'); + OPM_WriteLn(); + } + } + OPC_DefineTProcMacros(obj->right, &*empty); + } +} + +static void OPC_DefineType (OPT_Struct str) +{ + OPT_Object obj = NIL, field = NIL, par = NIL; + BOOLEAN empty; + if ((OPM_currFile == 1 || str->ref < 255) || (((OPM_currFile == 0 && str->strobj != NIL)) && str->strobj->vis == 1)) { + obj = str->strobj; + if (obj == NIL || OPC_Undefined(obj)) { + if (obj != NIL) { + if (obj->linkadr == 1) { + if (str->form != 11) { + OPM_Mark(244, str->txtpos); + obj->linkadr = 2; + } + } else { + obj->linkadr = 1; + } + } + if (str->comp == 4) { + if (str->BaseTyp != NIL) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while ((field != NIL && field->mode == 4)) { + if (field->vis != 0 || OPM_currFile == 1) { + OPC_DefineType(field->typ); + } + field = field->link; + } + } else if (str->form == 11) { + if (str->BaseTyp->comp != 4) { + OPC_DefineType(str->BaseTyp); + } + } else if (__IN(str->comp, 0x0c, 32)) { + if ((str->BaseTyp->strobj != NIL && str->BaseTyp->strobj->linkadr == 1)) { + OPM_Mark(244, str->txtpos); + str->BaseTyp->strobj->linkadr = 2; + } + OPC_DefineType(str->BaseTyp); + } else if (str->form == 12) { + if (str->BaseTyp != OPT_notyp) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while (field != NIL) { + OPC_DefineType(field->typ); + field = field->link; + } + } + } + if ((obj != NIL && OPC_Undefined(obj))) { + OPM_WriteString((CHAR*)"typedef", 8); + OPM_WriteLn(); + OPM_Write(0x09); + OPC_Indent(1); + obj->linkadr = 1; + OPC_DeclareBase(obj); + OPM_Write(' '); + obj->typ->strobj = NIL; + OPC_DeclareObj(obj, 0); + obj->typ->strobj = obj; + obj->linkadr = 3 + OPM_currFile; + OPC_EndStat(); + OPC_Indent(-1); + OPM_WriteLn(); + if (obj->typ->comp == 4) { + empty = 1; + OPC_DeclareTProcs(str->link, &empty); + OPC_DefineTProcMacros(str->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } else if ((obj->typ->form == 11 && obj->typ->BaseTyp->comp == 4)) { + empty = 1; + OPC_DeclareTProcs(obj->typ->BaseTyp->link, &empty); + OPC_DefineTProcMacros(obj->typ->BaseTyp->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } + } + } +} + +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len) +{ + INT16 i; + __DUP(y, y__len, CHAR); + i = 0; + while ((*x)[__X(i + 1, 256)] == y[__X(i, y__len)]) { + i += 1; + } + __DEL(y); + return y[__X(i, y__len)] == 0x00; +} + +static void OPC_CProcDefs (OPT_Object obj, INT16 vis) +{ + INT16 i; + OPT_ConstExt ext = NIL; + INT16 _for__7; + if (obj != NIL) { + OPC_CProcDefs(obj->left, vis); + if ((((obj->mode == 9 && (INT16)obj->vis >= vis)) && obj->adr == 1)) { + ext = obj->conval->ext; + i = 1; + if (((*ext)[1] != '#' && !(OPC_Prefixed(ext, (CHAR*)"extern ", 8) || OPC_Prefixed(ext, (CHAR*)"import ", 8)))) { + OPM_WriteString((CHAR*)"#define ", 9); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_Write(0x09); + } + _for__7 = (INT16)(*obj->conval->ext)[0]; + i = i; + while (i <= _for__7) { + OPM_Write((*obj->conval->ext)[__X(i, 256)]); + i += 1; + } + OPM_WriteLn(); + } + OPC_CProcDefs(obj->right, vis); + } +} + +void OPC_TypeDefs (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_TypeDefs(obj->left, vis); + if ((obj->mode == 5 && obj->typ->txtpos > 0)) { + OPC_DefineType(obj->typ); + } + OPC_TypeDefs(obj->right, vis); + } +} + +static void OPC_DefAnonRecs (OPT_Node n) +{ + OPT_Object o = NIL; + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if ((typ->strobj == NIL && (OPM_currFile == 1 || typ->ref < 255))) { + OPC_DefineType(typ); + __NEW(o, OPT_ObjDesc); + o->typ = typ; + o->name[0] = 0x00; + OPC_DeclareBase(o); + OPC_EndStat(); + OPM_WriteLn(); + } + n = n->link; + } +} + +void OPC_TDescDecl (OPT_Struct typ) +{ + INT32 nofptrs; + OPT_Object o = NIL; + OPC_BegStat(); + OPM_WriteString((CHAR*)"__TDESC(", 9); + OPC_Andent(typ); + OPC_Str1((CHAR*)", #", 4, typ->n + 1); + OPC_Str1((CHAR*)", #) = {__TDFLDS(", 18, OPC_NofPtrs(typ)); + OPM_Write('"'); + if (typ->strobj != NIL) { + OPM_WriteStringVar((void*)typ->strobj->name, 256); + } + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", 8, typ->size); + nofptrs = 0; + OPC_PutPtrOffsets(typ, 0, &nofptrs); + OPC_Str1((CHAR*)"#}}", 4, -((nofptrs + 1) * OPM_AddressSize)); + OPC_EndStat(); +} + +void OPC_InitTDesc (OPT_Struct typ) +{ + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITYP(", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + if (typ->BaseTyp != NIL) { + OPC_Andent(typ->BaseTyp); + } else { + OPC_Andent(typ); + } + OPC_Str1((CHAR*)", #)", 5, typ->extlev); + OPC_EndStat(); + if (typ->strobj != NIL) { + OPC_InitTProcs(typ->strobj, typ->link); + } +} + +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign) +{ + INT32 adr; + adr = off; + OPT_Align(&adr, align); + if ((*curAlign < align && gap - (adr - off) >= align)) { + gap -= (adr - off) + align; + OPC_BegStat(); + switch (align) { + case 2: + OPM_WriteString((CHAR*)"INT16", 6); + break; + case 4: + OPM_WriteString((CHAR*)"INT32", 6); + break; + case 8: + OPM_WriteString((CHAR*)"INT64", 6); + break; + default: + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected enclosing alignment in FillGap.", 43); + break; + } + OPC_Str1((CHAR*)" _prvt#", 8, *n); + *n += 1; + OPC_EndStat(); + *curAlign = align; + } + if (gap > 0) { + OPC_BegStat(); + OPC_Str1((CHAR*)"char _prvt#", 12, *n); + *n += 1; + OPC_Str1((CHAR*)"[#]", 4, gap); + OPC_EndStat(); + } +} + +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign) +{ + OPT_Object fld = NIL; + OPT_Struct base = NIL; + INT32 gap, adr, align, fldAlign; + fld = typ->link; + align = __MASK(typ->align, -65536); + if (typ->BaseTyp != NIL) { + OPC_FieldList(typ->BaseTyp, 0, &*off, &*n, &*curAlign); + } else { + *off = 0; + *n = 0; + *curAlign = 1; + } + while ((fld != NIL && fld->mode == 4)) { + if ((OPM_currFile == 0 && fld->vis == 0) || (((OPM_currFile == 1 && fld->vis == 0)) && typ->mno != 0)) { + fld = fld->link; + while ((((fld != NIL && fld->mode == 4)) && fld->vis == 0)) { + fld = fld->link; + } + } else { + adr = *off; + fldAlign = OPT_BaseAlignment(fld->typ); + OPT_Align(&adr, fldAlign); + gap = fld->adr - adr; + if (fldAlign > *curAlign) { + *curAlign = fldAlign; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + OPC_BegStat(); + OPC_DeclareBase(fld); + OPM_Write(' '); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + base = fld->typ; + fld = fld->link; + while ((((((((fld != NIL && fld->mode == 4)) && fld->typ == base)) && fld->adr == *off)) && ((OPM_currFile == 1 || fld->vis != 0) || fld->typ->strobj == NIL))) { + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + fld = fld->link; + } + OPC_EndStat(); + } + } + if (last) { + adr = typ->size - __ASHR(typ->sysflag, 8); + if (adr == 0) { + gap = 1; + } else { + gap = adr - *off; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + } +} + +static void OPC_IdentList (OPT_Object obj, INT16 vis) +{ + OPT_Struct base = NIL; + BOOLEAN first; + INT16 lastvis; + base = NIL; + first = 1; + while ((obj != NIL && obj->mode != 13)) { + if ((__IN(vis, 0x05, 32) || (vis == 1 && obj->vis != 0)) || (vis == 3 && !obj->leaf)) { + if (obj->typ != base || (INT16)obj->vis != lastvis) { + if (!first) { + OPC_EndStat(); + } + first = 0; + base = obj->typ; + lastvis = obj->vis; + OPC_BegStat(); + if ((vis == 1 && obj->vis != 0)) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((obj->mnolev == 0 && vis == 0)) { + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + } + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_WriteString((CHAR*)"double", 7); + } else { + OPC_DeclareBase(obj); + } + } else { + OPM_Write(','); + } + OPM_Write(' '); + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_Write('_'); + } + OPC_DeclareObj(obj, vis == 3); + if (obj->typ->comp == 3) { + OPC_EndStat(); + OPC_BegStat(); + base = OPT_adrtyp; + OPM_WriteString((CHAR*)"ADDRESS ", 9); + OPC_LenList(obj, 0, 1); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + base = NIL; + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + OPM_WriteString((CHAR*)" = NIL", 7); + } + } + obj = obj->link; + } + if (!first) { + OPC_EndStat(); + } +} + +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames) +{ + CHAR name[32]; + OPM_Write('('); + if (obj == NIL || obj->mode == 13) { + OPM_WriteString((CHAR*)"void", 5); + } else { + for (;;) { + OPC_DeclareBase(obj); + if (showParamNames) { + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + } else { + __COPY(obj->name, name, 32); + obj->name[0] = 0x00; + OPC_DeclareObj(obj, 0); + __COPY(name, obj->name, 256); + } + if (obj->typ->comp == 3) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + OPC_LenList(obj, 1, showParamNames); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ADDRESS *", 12); + if (showParamNames) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + } + } + if (obj->link == NIL || obj->link->mode == 13) { + break; + } + OPM_WriteString((CHAR*)", ", 3); + obj = obj->link; + } + } + OPM_Write(')'); +} + +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define) +{ + if (proc->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(proc->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(proc); + OPM_Write(' '); + OPC_AnsiParamList(proc->link, 1); + if (!define) { + OPM_Write(';'); + } + OPM_WriteLn(); +} + +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis) +{ + if (obj != NIL) { + OPC_ProcPredefs(obj->left, vis); + if ((((__IN(obj->mode, 0xc0, 32) && obj->vis >= vis)) && (obj->history != 4 || obj->mode == 6))) { + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + OPC_ProcPredefs(obj->right, vis); + } +} + +static void OPC_Include (CHAR *name, ADDRESS name__len) +{ + __DUP(name, name__len, CHAR); + OPM_WriteString((CHAR*)"#include ", 10); + OPM_Write('"'); + OPM_WriteStringVar((void*)name, name__len); + OPM_WriteString((CHAR*)".h", 3); + OPM_Write('"'); + OPM_WriteLn(); + __DEL(name); +} + +static void OPC_IncludeImports (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_IncludeImports(obj->left, vis); + if ((((obj->mode == 11 && obj->mnolev != 0)) && (INT16)OPT_GlbMod[__X(-obj->mnolev, 64)]->vis >= vis)) { + OPC_Include(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + } + OPC_IncludeImports(obj->right, vis); + } +} + +static void OPC_GenDynTypes (OPT_Node n, INT16 vis) +{ + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if (vis == 0 || typ->ref < 255) { + OPC_BegStat(); + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((typ->strobj != NIL && typ->strobj->mnolev > 0)) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_EndStat(); + } + n = n->link; + } +} + +void OPC_GenHdr (OPT_Node n) +{ + OPM_currFile = 0; + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 1); + OPM_WriteLn(); + OPC_GenDynTypes(n, 1); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 1); + OPM_WriteString((CHAR*)"import ", 8); + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPC_EndStat(); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#endif // ", 11); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteLn(); +} + +static void OPC_GenHeaderMsg (void) +{ + INT16 i; + OPM_WriteString((CHAR*)"/* ", 4); + OPM_WriteString((CHAR*)"voc", 4); + OPM_Write(' '); + OPM_WriteString(Configuration_versionLong, 76); + OPM_Write(' '); + i = 0; + while (i <= 31) { + if (__IN(i, OPM_Options, 32)) { + switch (i) { + case 0: + OPM_Write('x'); + break; + case 2: + OPM_Write('r'); + break; + case 3: + OPM_Write('t'); + break; + case 4: + OPM_Write('s'); + break; + case 5: + OPM_Write('p'); + break; + case 7: + OPM_Write('a'); + break; + case 9: + OPM_Write('e'); + break; + case 10: + OPM_Write('m'); + break; + case 13: + OPM_Write('S'); + break; + case 14: + OPM_Write('c'); + break; + case 15: + OPM_Write('M'); + break; + case 16: + OPM_Write('f'); + break; + case 17: + OPM_Write('F'); + break; + case 18: + OPM_Write('v'); + break; + default: + OPM_LogWStr((CHAR*)"( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg", 126); + OPM_LogWLn(); + break; + } + } + i += 1; + } + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); +} + +void OPC_GenHdrIncludes (void) +{ + OPM_currFile = 2; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#ifndef ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 1); + OPM_WriteLn(); +} + +void OPC_GenBdy (OPT_Node n) +{ + OPM_currFile = 1; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SHORTINT INT", 21); + OPM_WriteInt(__ASHL(OPT_sinttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define INTEGER INT", 21); + OPM_WriteInt(__ASHL(OPT_inttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define LONGINT INT", 21); + OPM_WriteInt(__ASHL(OPT_linttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SET UINT", 22); + OPM_WriteInt(__ASHL(OPT_settyp->size, 3)); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 0); + OPM_WriteLn(); + OPC_GenDynTypes(n, 0); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 0); + OPM_WriteLn(); +} + +static void OPC_RegCmds (OPT_Object obj) +{ + if (obj != NIL) { + OPC_RegCmds(obj->left); + if ((obj->mode == 7 && obj->history != 4)) { + if ((((obj->vis != 0 && obj->link == NIL)) && obj->typ == OPT_notyp)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__REGCMD(\"", 11); + OPM_WriteStringVar((void*)obj->name, 256); + OPM_WriteString((CHAR*)"\", ", 4); + OPC_Ident(obj); + OPM_Write(')'); + OPC_EndStat(); + } + } + OPC_RegCmds(obj->right); + } +} + +static void OPC_InitImports (OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitImports(obj->left); + if ((obj->mode == 11 && obj->mnolev != 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__MODULE_IMPORT(", 17); + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + OPM_Write(')'); + OPC_EndStat(); + } + OPC_InitImports(obj->right); + } +} + +void OPC_GenEnumPtrs (OPT_Object var) +{ + OPT_Struct typ = NIL; + INT32 n; + OPC_GlbPtrs = 0; + while (var != NIL) { + typ = var->typ; + if (OPC_NofPtrs(typ) > 0) { + if (!OPC_GlbPtrs) { + OPC_GlbPtrs = 1; + OPM_WriteString((CHAR*)"static void EnumPtrs(void (*P)(void*))", 39); + OPM_WriteLn(); + OPC_BegBlk(); + } + OPC_BegStat(); + if (typ->form == 11) { + OPM_WriteString((CHAR*)"P(", 3); + OPC_Ident(var); + OPM_Write(')'); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(&", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPM_WriteString((CHAR*)", 1, P)", 8); + } else if (typ->comp == 2) { + n = typ->n; + typ = typ->BaseTyp; + while (typ->comp == 2) { + n = n * typ->n; + typ = typ->BaseTyp; + } + if (typ->form == 11) { + OPM_WriteString((CHAR*)"__ENUMP(", 9); + OPC_Ident(var); + OPC_Str1((CHAR*)", #, P)", 8, n); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(", 9); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPC_Str1((CHAR*)", #, P)", 8, n); + } + } + OPC_EndStat(); + } + var = var->link; + } + if (OPC_GlbPtrs) { + OPC_EndBlk(); + OPM_WriteLn(); + } +} + +void OPC_EnterBody (void) +{ + OPM_WriteLn(); + OPM_WriteString((CHAR*)"export ", 8); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); + OPM_WriteLn(); + } else { + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteString(OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPM_WriteLn(); + } + OPC_BegBlk(); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); + } else { + OPM_WriteString((CHAR*)"__DEFMOD", 9); + } + OPC_EndStat(); + if ((__IN(10, OPM_Options, 32) && 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); + OPC_EndStat(); + } + OPC_InitImports(OPT_topScope->right); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); + } else { + OPM_WriteString((CHAR*)"__REGMOD(\"", 11); + } + OPM_WriteString(OPM_modName, 32); + if (OPC_GlbPtrs) { + OPM_WriteString((CHAR*)"\", EnumPtrs)", 13); + } else { + OPM_WriteString((CHAR*)"\", 0)", 6); + } + OPC_EndStat(); + if (__STRCMP(OPM_modName, "SYSTEM") != 0) { + OPC_RegCmds(OPT_topScope); + } +} + +void OPC_ExitBody (void) +{ + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI;", 8); + } else { + OPM_WriteString((CHAR*)"__ENDMOD;", 10); + } + OPM_WriteLn(); + OPC_EndBlk(); +} + +void OPC_DefineInter (OPT_Object proc) +{ + OPT_Object scope = NIL; + scope = proc->scope; + OPM_WriteString((CHAR*)"static ", 8); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPC_BegBlk(); + OPC_IdentList(proc->link, 3); + OPC_IdentList(scope->scope, 3); + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + OPC_EndBlk0(); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPM_WriteLn(); + OPC_ProcPredefs(scope->right, 0); + OPM_WriteLn(); +} + +BOOLEAN OPC_NeedsRetval (OPT_Object proc) +{ + return (proc->typ != OPT_notyp && !proc->scope->leaf); +} + +void OPC_EnterProc (OPT_Object proc) +{ + OPT_Object var = NIL, scope = NIL; + OPT_Struct typ = NIL; + INT16 dim; + if (proc->vis != 1) { + OPM_WriteString((CHAR*)"static ", 8); + } + OPC_ProcHeader(proc, 1); + OPC_BegBlk(); + scope = proc->scope; + OPC_IdentList(scope->scope, 0); + if (!scope->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } + if (OPC_NeedsRetval(proc)) { + OPC_BegStat(); + OPC_Ident(proc->typ->strobj); + OPM_WriteString((CHAR*)" __retval", 10); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((var->typ->comp == 2 && var->mode == 1)) { + OPC_BegStat(); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__copy", 7); + OPC_EndStat(); + } + var = var->link; + } + var = proc->link; + while (var != NIL) { + if ((((__IN(var->typ->comp, 0x0c, 32) && var->mode == 1)) && var->typ->sysflag == 0)) { + OPC_BegStat(); + if (var->typ->comp == 2) { + OPM_WriteString((CHAR*)"__DUPARR(", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + } else { + OPM_WriteString((CHAR*)"__DUP(", 7); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + typ = var->typ->BaseTyp; + dim = 1; + while (typ->comp == 3) { + OPM_WriteString((CHAR*)" * ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + typ = typ->BaseTyp; + dim += 1; + } + OPM_WriteString((CHAR*)", ", 3); + if (typ->strobj == NIL) { + OPM_Mark(200, typ->txtpos); + } else { + OPC_Ident(typ->strobj); + } + } + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + if (!scope->leaf) { + var = proc->link; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (__IN(var->typ->comp, 0x0c, 32)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } else if (var->mode != 2) { + OPM_Write('&'); + } + OPC_Ident(var); + if (var->typ->comp == 3) { + typ = var->typ; + dim = 0; + do { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + } while (!(typ->comp != 3)); + } else if ((var->mode == 2 && var->typ->comp == 4)) { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_EndStat(); + } + var = var->link; + } + var = scope->scope; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (var->typ->comp != 2) { + OPM_Write('&'); + } else { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPC_Ident(var); + OPC_EndStat(); + } + var = var->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_Write('&'); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } +} + +void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet) +{ + OPT_Object var = NIL; + BOOLEAN indent; + indent = eoBlock; + if ((implicitRet && proc->typ != OPT_notyp)) { + OPM_Write(0x09); + OPM_WriteString((CHAR*)"__RETCHK;", 10); + OPM_WriteLn(); + } else if (!eoBlock || implicitRet) { + if (!proc->scope->leaf) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteStringVar((void*)proc->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((((var->typ->comp == 3 && var->mode == 1)) && var->typ->sysflag == 0)) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteString((CHAR*)"__DEL(", 7); + OPC_Ident(var); + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + } + if (eoBlock) { + OPC_EndBlk(); + OPM_WriteLn(); + } else if (indent) { + OPC_BegStat(); + } +} + +void OPC_CompleteIdent (OPT_Object obj) +{ + INT16 comp, level; + level = obj->mnolev; + if (obj->adr == 1) { + if (obj->typ->comp == 4) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__", 3); + } else { + OPM_WriteString((CHAR*)"(*(", 4); + OPC_Ident(obj->typ->strobj); + OPM_WriteString((CHAR*)"*)&", 4); + OPC_Ident(obj); + OPM_Write(')'); + } + } else if ((level != OPM_level && level > 0)) { + comp = obj->typ->comp; + if ((obj->mode != 2 && comp != 3)) { + OPM_Write('*'); + } + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)"->", 3); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } +} + +void OPC_TypeOf (OPT_Object ap) +{ + INT16 i; + __ASSERT(ap->typ->comp == 4, 0); + if (ap->mode == 2) { + if ((INT16)ap->mnolev != OPM_level) { + OPM_WriteStringVar((void*)ap->scope->name, 256); + OPM_WriteString((CHAR*)"_s->", 5); + OPC_Ident(ap); + } else { + OPC_Ident(ap); + } + OPM_WriteString((CHAR*)"__typ", 6); + } else if (ap->typ->strobj != NIL) { + OPC_Ident(ap->typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + } else { + OPC_Andent(ap->typ); + } +} + +void OPC_Cmp (INT16 rel) +{ + switch (rel) { + case 9: + OPM_WriteString((CHAR*)" == ", 5); + break; + case 10: + OPM_WriteString((CHAR*)" != ", 5); + break; + case 11: + OPM_WriteString((CHAR*)" < ", 4); + break; + case 12: + OPM_WriteString((CHAR*)" <= ", 5); + break; + case 13: + OPM_WriteString((CHAR*)" > ", 4); + break; + case 14: + OPM_WriteString((CHAR*)" >= ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Cmp, rel = ", 34); + OPM_LogWNum(rel, 0); + OPM_LogWLn(); + break; + } +} + +static void OPC_CharacterLiteral (INT64 c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", 3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l) +{ + INT32 i; + INT16 c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (INT16)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write(__CHR(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write(__CHR(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write(__CHR(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + +void OPC_Case (INT64 caseVal, INT16 form) +{ + CHAR ch; + OPM_WriteString((CHAR*)"case ", 6); + switch (form) { + case 3: + OPC_CharacterLiteral(caseVal); + break; + case 4: + OPM_WriteInt(caseVal); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Case, form = ", 36); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } + OPM_WriteString((CHAR*)": ", 3); +} + +void OPC_SetInclude (BOOLEAN exclude) +{ + if (exclude) { + OPM_WriteString((CHAR*)" &= ~", 6); + } else { + OPM_WriteString((CHAR*)" |= ", 5); + } +} + +void OPC_Increment (BOOLEAN decrement) +{ + if (decrement) { + OPM_WriteString((CHAR*)" -= ", 5); + } else { + OPM_WriteString((CHAR*)" += ", 5); + } +} + +void OPC_Halt (INT32 n) +{ + OPC_Str1((CHAR*)"__HALT(#)", 10, n); +} + +void OPC_IntLiteral (INT64 n, INT32 size) +{ + if ((((size > 4 && n <= 2147483647)) && n > (-2147483647-1))) { + OPM_WriteString((CHAR*)"((INT", 6); + OPM_WriteInt(__ASHL(size, 3)); + OPM_WriteString((CHAR*)")(", 3); + OPM_WriteInt(n); + OPM_WriteString((CHAR*)"))", 3); + } else { + OPM_WriteInt(n); + } +} + +void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim) +{ + INT64 d; + d = dim; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPC_CompleteIdent(obj); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + } else { + OPM_WriteInt(array->n); + } +} + +void OPC_Constant (OPT_Const con, INT16 form) +{ + INT16 i; + UINT64 s; + INT64 hex; + BOOLEAN skipLeading; + switch (form) { + case 1: + OPM_WriteInt(con->intval); + break; + case 2: + OPM_WriteInt(con->intval); + break; + case 3: + OPC_CharacterLiteral(con->intval); + break; + case 4: + OPM_WriteInt(con->intval); + break; + case 5: + OPM_WriteReal(con->realval, 'f'); + break; + case 6: + OPM_WriteReal(con->realval, 0x00); + break; + case 7: + OPM_WriteString((CHAR*)"0x", 3); + skipLeading = 1; + s = con->setval; + i = 64; + do { + hex = 0; + do { + i -= 1; + hex = __ASHL(hex, 1); + if (__IN(i, s, 64)) { + hex += 1; + } + } while (!(__MASK(i, -8) == 0)); + if (hex != 0 || !skipLeading) { + OPM_WriteHex(hex); + skipLeading = 0; + } + } while (!(i == 0)); + if (skipLeading) { + OPM_Write('0'); + } + break; + case 8: + OPC_StringLiteral(*con->ext, 256, con->intval2 - 1); + break; + case 9: + OPM_WriteString((CHAR*)"NIL", 4); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Constant, form = ", 40); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } +} + +static struct InitKeywords__46 { + INT8 *n; + struct InitKeywords__46 *lnk; +} *InitKeywords__46_s; + +static void Enter__47 (CHAR *s, ADDRESS s__len); + +static void Enter__47 (CHAR *s, ADDRESS s__len) +{ + INT16 h; + __DUP(s, s__len, CHAR); + h = OPC_PerfectHash((void*)s, s__len); + OPC_hashtab[__X(h, 105)] = *InitKeywords__46_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__46_s->n, 50)], 9); + *InitKeywords__46_s->n += 1; + __DEL(s); +} + +static void OPC_InitKeywords (void) +{ + INT8 n, i; + struct InitKeywords__46 _s; + _s.n = &n; + _s.lnk = InitKeywords__46_s; + InitKeywords__46_s = &_s; + n = 0; + i = 0; + while (i <= 104) { + OPC_hashtab[__X(i, 105)] = -1; + i += 1; + } + Enter__47((CHAR*)"ADDRESS", 8); + Enter__47((CHAR*)"INT16", 6); + Enter__47((CHAR*)"INT32", 6); + Enter__47((CHAR*)"INT64", 6); + Enter__47((CHAR*)"INT8", 5); + Enter__47((CHAR*)"UINT16", 7); + Enter__47((CHAR*)"UINT32", 7); + Enter__47((CHAR*)"UINT64", 7); + Enter__47((CHAR*)"UINT8", 6); + Enter__47((CHAR*)"asm", 4); + Enter__47((CHAR*)"auto", 5); + Enter__47((CHAR*)"break", 6); + Enter__47((CHAR*)"case", 5); + Enter__47((CHAR*)"char", 5); + Enter__47((CHAR*)"const", 6); + Enter__47((CHAR*)"continue", 9); + Enter__47((CHAR*)"default", 8); + Enter__47((CHAR*)"do", 3); + Enter__47((CHAR*)"double", 7); + Enter__47((CHAR*)"else", 5); + Enter__47((CHAR*)"enum", 5); + Enter__47((CHAR*)"extern", 7); + Enter__47((CHAR*)"export", 7); + Enter__47((CHAR*)"float", 6); + Enter__47((CHAR*)"for", 4); + Enter__47((CHAR*)"fortran", 8); + Enter__47((CHAR*)"goto", 5); + Enter__47((CHAR*)"if", 3); + Enter__47((CHAR*)"import", 7); + Enter__47((CHAR*)"int", 4); + Enter__47((CHAR*)"long", 5); + Enter__47((CHAR*)"register", 9); + Enter__47((CHAR*)"return", 7); + Enter__47((CHAR*)"short", 6); + Enter__47((CHAR*)"signed", 7); + Enter__47((CHAR*)"sizeof", 7); + Enter__47((CHAR*)"size_t", 7); + Enter__47((CHAR*)"static", 7); + Enter__47((CHAR*)"struct", 7); + Enter__47((CHAR*)"switch", 7); + Enter__47((CHAR*)"typedef", 8); + Enter__47((CHAR*)"union", 6); + Enter__47((CHAR*)"unsigned", 9); + Enter__47((CHAR*)"void", 5); + Enter__47((CHAR*)"volatile", 9); + Enter__47((CHAR*)"while", 6); + InitKeywords__46_s = _s.lnk; +} + + +export void *OPC__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPT); + __REGMOD("OPC", 0); + __REGCMD("BegBlk", OPC_BegBlk); + __REGCMD("BegStat", OPC_BegStat); + __REGCMD("EndBlk", OPC_EndBlk); + __REGCMD("EndBlk0", OPC_EndBlk0); + __REGCMD("EndStat", OPC_EndStat); + __REGCMD("EnterBody", OPC_EnterBody); + __REGCMD("ExitBody", OPC_ExitBody); + __REGCMD("GenHdrIncludes", OPC_GenHdrIncludes); + __REGCMD("Init", OPC_Init); +/* BEGIN */ + OPC_InitKeywords(); + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPC.h b/bootstrap/unix-88/OPC.h new file mode 100644 index 00000000..3bfd88b8 --- /dev/null +++ b/bootstrap/unix-88/OPC.h @@ -0,0 +1,49 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPC__h +#define OPC__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPC_Andent (OPT_Struct typ); +import OPT_Object OPC_BaseTProc (OPT_Object obj); +import void OPC_BegBlk (void); +import void OPC_BegStat (void); +import void OPC_Case (INT64 caseVal, INT16 form); +import void OPC_Cmp (INT16 rel); +import void OPC_CompleteIdent (OPT_Object obj); +import void OPC_Constant (OPT_Const con, INT16 form); +import void OPC_DefineInter (OPT_Object proc); +import void OPC_EndBlk (void); +import void OPC_EndBlk0 (void); +import void OPC_EndStat (void); +import void OPC_EnterBody (void); +import void OPC_EnterProc (OPT_Object proc); +import void OPC_ExitBody (void); +import void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +import void OPC_GenBdy (OPT_Node n); +import void OPC_GenEnumPtrs (OPT_Object var); +import void OPC_GenHdr (OPT_Node n); +import void OPC_GenHdrIncludes (void); +import void OPC_Halt (INT32 n); +import void OPC_Ident (OPT_Object obj); +import void OPC_Increment (BOOLEAN decrement); +import void OPC_Indent (INT16 count); +import void OPC_Init (void); +import void OPC_InitTDesc (OPT_Struct typ); +import void OPC_IntLiteral (INT64 n, INT32 size); +import void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +import BOOLEAN OPC_NeedsRetval (OPT_Object proc); +import INT32 OPC_NofPtrs (OPT_Struct typ); +import void OPC_SetInclude (BOOLEAN exclude); +import void OPC_TDescDecl (OPT_Struct typ); +import void OPC_TypeDefs (OPT_Object obj, INT16 vis); +import void OPC_TypeOf (OPT_Object ap); +import void *OPC__init(void); + + +#endif // OPC diff --git a/bootstrap/unix-88/OPM.c b/bootstrap/unix-88/OPM.c new file mode 100644 index 00000000..b486b3b9 --- /dev/null +++ b/bootstrap/unix-88/OPM.c @@ -0,0 +1,1183 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Files.h" +#include "Modules.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" +#include "Texts.h" +#include "VT100.h" + +typedef + CHAR OPM_FileName[32]; + + +static CHAR OPM_currentComment[256]; +static BOOLEAN OPM_hasComment; +static CHAR OPM_SourceFileName[256]; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static INT16 OPM_GlobalAddressSize; +export INT16 OPM_AddressSize; +static INT16 OPM_GlobalAlignment; +export INT16 OPM_Alignment; +export UINT32 OPM_GlobalOptions, OPM_Options; +export INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +export INT64 OPM_MaxIndex; +export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +export BOOLEAN OPM_noerr; +export INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +export INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +export CHAR OPM_modName[32]; +export CHAR OPM_objname[64]; +static INT32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; +static Texts_Reader OPM_inR; +static Texts_Text OPM_Log, OPM_Errors; +static Files_Rider OPM_oldSF, OPM_newSF; +static Files_Rider OPM_R[3]; +static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; +static INT16 OPM_S; +export CHAR OPM_InstallDir[1024]; +export CHAR OPM_ResourceDir[1024]; + + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F); +export void OPM_CloseFiles (void); +export void OPM_CloseOldSym (void); +export void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +export void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +export void OPM_FPrint (INT32 *fp, INT64 val); +export void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +export void OPM_FPrintReal (INT32 *fp, REAL val); +export void OPM_FPrintSet (INT32 *fp, UINT64 val); +static void OPM_FindInstallDir (void); +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos); +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len); +export void OPM_Get (CHAR *ch); +export void OPM_GetComment (CHAR *text, ADDRESS text__len); +export void OPM_Init (BOOLEAN *done); +export void OPM_InitOptions (void); +export INT16 OPM_Integer (INT64 n); +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len); +export void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +static void OPM_LogErrMsg (INT16 n); +export void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +export void OPM_LogW (CHAR ch); +export void OPM_LogWLn (void); +export void OPM_LogWNum (INT64 i, INT64 len); +export void OPM_LogWStr (CHAR *s, ADDRESS s__len); +export INT32 OPM_Longint (INT64 n); +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len); +export void OPM_Mark (INT16 n, INT32 pos); +export void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +export void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +export void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +export BOOLEAN OPM_OpenPar (void); +export void OPM_RegisterNewSym (void); +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len); +static void OPM_ShowLine (INT64 pos); +export INT64 OPM_SignedMaximum (INT32 bytecount); +export INT64 OPM_SignedMinimum (INT32 bytecount); +export void OPM_StoreComment (CHAR *text, ADDRESS text__len); +export void OPM_SymRCh (CHAR *ch); +export INT32 OPM_SymRInt (void); +export INT64 OPM_SymRInt64 (void); +export void OPM_SymRLReal (LONGREAL *lr); +export void OPM_SymRReal (REAL *r); +export void OPM_SymRSet (UINT64 *s); +export void OPM_SymWCh (CHAR ch); +export void OPM_SymWInt (INT64 i); +export void OPM_SymWLReal (LONGREAL lr); +export void OPM_SymWReal (REAL r); +export void OPM_SymWSet (UINT64 s); +export void OPM_Write (CHAR ch); +export void OPM_WriteHex (INT64 i); +export void OPM_WriteInt (INT64 i); +export void OPM_WriteLn (void); +export void OPM_WriteReal (LONGREAL r, CHAR suffx); +export void OPM_WriteString (CHAR *s, ADDRESS s__len); +export void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +export BOOLEAN OPM_eofSF (void); +export void OPM_err (INT16 n); + +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s + +void OPM_LogW (CHAR ch) +{ + Out_Char(ch); +} + +void OPM_LogWStr (CHAR *s, ADDRESS s__len) +{ + __DUP(s, s__len, CHAR); + Out_String(s, s__len); + __DEL(s); +} + +void OPM_LogWNum (INT64 i, INT64 len) +{ + Out_Int(i, len); +} + +void OPM_LogWLn (void) +{ + Out_Ln(); +} + +void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len) +{ + __DUP(vt100code, vt100code__len, CHAR); + if ((Out_IsConsole && !__IN(16, OPM_Options, 32))) { + VT100_SetAttr(vt100code, vt100code__len); + } + __DEL(vt100code); +} + +void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len) +{ + __DUP(modname, modname__len, CHAR); + OPM_LogWStr((CHAR*)"Compiling ", 11); + OPM_LogWStr(modname, modname__len); + if (__IN(18, OPM_Options, 32)) { + OPM_LogWStr((CHAR*)", s:", 5); + OPM_LogWNum(__ASHL(OPM_ShortintSize, 3), 1); + OPM_LogWStr((CHAR*)" i:", 4); + OPM_LogWNum(__ASHL(OPM_IntegerSize, 3), 1); + OPM_LogWStr((CHAR*)" l:", 4); + OPM_LogWNum(__ASHL(OPM_LongintSize, 3), 1); + OPM_LogWStr((CHAR*)" adr:", 6); + OPM_LogWNum(__ASHL(OPM_AddressSize, 3), 1); + OPM_LogWStr((CHAR*)" algn:", 7); + OPM_LogWNum(__ASHL(OPM_Alignment, 3), 1); + } + OPM_LogW('.'); + __DEL(modname); +} + +void OPM_StoreComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_currentComment[__X(i, 256)] = text[__X(i, text__len)]; + i += 1; + } + OPM_currentComment[__X(i, 256)] = 0x00; + OPM_hasComment = 1; + __DEL(text); +} + +void OPM_GetComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + if (OPM_hasComment) { + i = 0; + while ((((i < text__len && i < 256)) && OPM_currentComment[__X(i, 256)] != 0x00)) { + text[__X(i, text__len)] = OPM_currentComment[__X(i, 256)]; + i += 1; + } + text[__X(i, text__len)] = 0x00; + OPM_hasComment = 0; + } else { + text[0] = 0x00; + } +} + +INT64 OPM_SignedMaximum (INT32 bytecount) +{ + INT64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + return result - 1; +} + +INT64 OPM_SignedMinimum (INT32 bytecount) +{ + return -OPM_SignedMaximum(bytecount) - 1; +} + +INT32 OPM_Longint (INT64 n) +{ + return __VAL(INT32, n); +} + +INT16 OPM_Integer (INT64 n) +{ + return __VAL(INT16, n); +} + +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 1; + while (s[__X(i, s__len)] != 0x00) { + switch (s[__X(i, s__len)]) { + case 'p': + OPM_Options = OPM_Options ^ 0x20; + break; + case 'a': + OPM_Options = OPM_Options ^ 0x80; + break; + case 'r': + OPM_Options = OPM_Options ^ 0x04; + break; + case 't': + OPM_Options = OPM_Options ^ 0x08; + break; + case 'x': + OPM_Options = OPM_Options ^ 0x01; + break; + case 'e': + OPM_Options = OPM_Options ^ 0x0200; + break; + case 's': + OPM_Options = OPM_Options ^ 0x10; + break; + case 'F': + OPM_Options = OPM_Options ^ 0x020000; + break; + case 'm': + OPM_Options = OPM_Options ^ 0x0400; + break; + case 'M': + OPM_Options = OPM_Options ^ 0x8000; + break; + case 'S': + OPM_Options = OPM_Options ^ 0x2000; + break; + case 'c': + OPM_Options = OPM_Options ^ 0x4000; + break; + case 'f': + OPM_Options = OPM_Options ^ 0x010000; + break; + case 'V': + OPM_Options = OPM_Options ^ 0x040000; + break; + case 'O': + if (i + 1 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); + OPM_LogWLn(); + } else { + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); + } + i += 1; + } + break; + case 'A': + if (i + 2 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-M option requires two following digits.", 41); + OPM_LogWLn(); + } else { + OPM_AddressSize = (INT16)s[__X(i + 1, s__len)] - 48; + OPM_Alignment = (INT16)s[__X(i + 2, s__len)] - 48; + i += 2; + } + break; + default: + OPM_LogWStr((CHAR*)" warning: option ", 19); + OPM_LogW('-'); + OPM_LogW(s[__X(i, s__len)]); + OPM_LogWStr((CHAR*)" ignored", 9); + OPM_LogWLn(); + break; + } + i += 1; + } + __DEL(s); +} + +BOOLEAN OPM_OpenPar (void) +{ + CHAR s[256]; + if (Modules_ArgCount == 1) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Oberon-2 compiler v", 20); + OPM_LogWStr(Configuration_versionLong, 76); + OPM_LogW('.'); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Based on Ofront by J. Templ and Software Templ OEG.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Further development by Norayr Chilingarian, David Brown and others.", 68); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Loaded from ", 13); + OPM_LogWStr(Modules_BinaryDir, 1024); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Usage:", 7); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWStr((CHAR*)"voc", 4); + OPM_LogWStr((CHAR*)" options {files {options}}.", 28); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options:", 9); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Run time safety", 18); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -p Initialise pointers to NIL. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -a Halt on assertion failures. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -r Halt on range check failures.", 39); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -t Halt on type guard failure. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -x Halt on index out of range. On by default.", 52); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Symbol file management", 25); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -e Allow extension of old symbol file.", 45); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -s Allow generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -F Force generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" C compiler and linker control", 32); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -m This module is main. Link dynamically.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -M This module is main. Link statically.", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -S Don't call C compiler", 31); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -c Don't link.", 21); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Miscellaneous", 16); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -f Disable VT100 control characters in status output.", 60); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -V Display compiler debugging messages.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Size model for elementary types (default O2)", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Target machine address size and alignment (default is that of the running compiler binary)", 93); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86).", 79); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm).", 97); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms).", 71); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"All options are off by default, except where noted above.", 58); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Initial options specify defaults for all files.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options following a filename are specific to that file.", 56); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Repeating an option toggles its value.", 39); + OPM_LogWLn(); + return 0; + } else { + OPM_AddressSize = 8; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; + OPM_S = 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __MOVE(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; + return 1; + } + __RETCHK; +} + +void OPM_InitOptions (void) +{ + CHAR s[256]; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __MOVE(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); + } + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 4; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + __MOVE(OPM_InstallDir, OPM_ResourceDir, 1024); + if (OPM_ResourceDir[0] != 0x00) { + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + } + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); +} + +void OPM_Init (BOOLEAN *done) +{ + Texts_Text T = NIL; + INT32 beg, end, time; + CHAR s[256]; + *done = 0; + OPM_curpos = 0; + if (OPM_S >= Modules_ArgCount) { + return; + } + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + __NEW(T, Texts_TextDesc); + Texts_Open(T, s, 256); + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" ", 3); + __COPY(s, OPM_SourceFileName, 256); + if (T->len == 0) { + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" not found.", 12); + OPM_LogWLn(); + } else { + Texts_OpenReader(&OPM_inR, Texts_Reader__typ, T, 0); + *done = 1; + } + OPM_S += 1; + OPM_level = 0; + OPM_noerr = 1; + OPM_errpos = OPM_curpos; + OPM_lasterrpos = OPM_curpos - 10; + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; +} + +void OPM_Get (CHAR *ch) +{ + OPM_curpos = Texts_Pos(&OPM_inR, Texts_Reader__typ); + Texts_Read(&OPM_inR, Texts_Reader__typ, &*ch); + if ((*ch < 0x09 && !OPM_inR.eot)) { + *ch = ' '; + } +} + +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len) +{ + INT16 i, j; + CHAR ch; + __DUP(ext, ext__len, CHAR); + i = 0; + for (;;) { + ch = name[__X(i, name__len)]; + if (ch == 0x00) { + break; + } + FName[__X(i, FName__len)] = ch; + i += 1; + } + j = 0; + do { + ch = ext[__X(j, ext__len)]; + FName[__X(i, FName__len)] = ch; + i += 1; + j += 1; + } while (!(ch == 0x00)); + __DEL(ext); +} + +static void OPM_LogErrMsg (INT16 n) +{ + INT16 l; + Texts_Scanner S; + CHAR c; + if (n >= 0) { + OPM_LogVT100((CHAR*)"31m", 4); + OPM_LogWStr((CHAR*)" err ", 7); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + OPM_LogVT100((CHAR*)"35m", 4); + OPM_LogWStr((CHAR*)" warning ", 11); + n = -n; + OPM_LogVT100((CHAR*)"0m", 3); + } + OPM_LogWNum(n, 1); + OPM_LogWStr((CHAR*)" ", 3); + if (OPM_Errors == NIL) { + __NEW(OPM_Errors, Texts_TextDesc); + Texts_Open(OPM_Errors, (CHAR*)"Errors.Txt", 11); + } + Texts_OpenScanner(&S, Texts_Scanner__typ, OPM_Errors, 0); + do { + l = S.line; + Texts_Scan(&S, Texts_Scanner__typ); + } while (!((((l != S.line && S.class == 3)) && S.i == n) || S.eot)); + if (!S.eot) { + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + while ((!S.eot && c >= ' ')) { + Out_Char(c); + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + } + } +} + +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos) +{ + CHAR ch, cheol; + if (pos < (INT64)OPM_ErrorLineStartPos) { + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; + } + if (pos < (INT64)OPM_ErrorLineLimitPos) { + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); + return; + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineLimitPos); + Files_Read(&*r, r__typ, (void*)&ch); + while (((INT64)OPM_ErrorLineLimitPos < pos && !(*r).eof)) { + OPM_ErrorLineStartPos = OPM_ErrorLineLimitPos; + OPM_ErrorLineNumber += 1; + while ((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) { + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + } + cheol = ch; + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + if ((cheol == 0x0d && ch == 0x0a)) { + OPM_ErrorLineLimitPos += 1; + Files_Read(&*r, r__typ, (void*)&ch); + } + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); +} + +static void OPM_ShowLine (INT64 pos) +{ + Files_File f = NIL; + Files_Rider r; + CHAR line[1023]; + INT16 i; + CHAR ch; + f = Files_Old(OPM_SourceFileName, 256); + OPM_FindLine(f, &r, Files_Rider__typ, pos); + i = 0; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + while ((((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) && i < 1022)) { + line[__X(i, 1023)] = ch; + i += 1; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + } + line[__X(i, 1023)] = 0x00; + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWNum(OPM_ErrorLineNumber, 4); + OPM_LogWStr((CHAR*)": ", 3); + OPM_LogWStr(line, 1023); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 7); + if (pos >= (INT64)OPM_ErrorLineLimitPos) { + pos = OPM_ErrorLineLimitPos - 1; + } + i = __SHORTF(OPM_Longint(pos - (INT64)OPM_ErrorLineStartPos), 32768); + while (i > 0) { + OPM_LogW(' '); + i -= 1; + } + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogW('^'); + OPM_LogVT100((CHAR*)"0m", 3); +} + +void OPM_Mark (INT16 n, INT32 pos) +{ + if (pos == -1) { + pos = 0; + } + if (n >= 0) { + OPM_noerr = 0; + if (pos < OPM_lasterrpos || OPM_lasterrpos + 9 < pos) { + OPM_lasterrpos = pos; + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + if (n < 249) { + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + OPM_LogErrMsg(n); + } else if (n == 255) { + OPM_LogWStr((CHAR*)"pos", 4); + OPM_LogWNum(pos, 6); + OPM_LogWStr((CHAR*)" pc ", 6); + OPM_LogWNum(OPM_breakpc, 1); + } else if (n == 254) { + OPM_LogWStr((CHAR*)"pc not found", 13); + } else { + OPM_LogWStr(OPM_objname, 64); + if (n == 253) { + OPM_LogWStr((CHAR*)" is new, compile with option e", 31); + } else if (n == 252) { + OPM_LogWStr((CHAR*)" is redefined, compile with option s", 37); + } else if (n == 251) { + OPM_LogWStr((CHAR*)" is redefined (private part only), compile with option s", 57); + } else if (n == 250) { + OPM_LogWStr((CHAR*)" is no longer visible, compile with option s", 45); + } else if (n == 249) { + OPM_LogWStr((CHAR*)" is not consistently imported, recompile imports", 49); + } + } + } + } else { + if (pos >= 0) { + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + } + OPM_LogErrMsg(n); + if (pos < 0) { + OPM_LogWLn(); + } + } +} + +void OPM_err (INT16 n) +{ + OPM_Mark(n, OPM_errpos); +} + +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len) +{ + INT16 i; + INT32 l; + __ASSERT(__MASK(bytes__len, -4) == 0, 0); + i = 0; + while (i < bytes__len) { + __GET((ADDRESS)&bytes[__X(i, bytes__len)], l, INT32); + *fp = __ROTL((INT32)((UINT32)*fp ^ (UINT32)l), 1, 32); + i += 4; + } +} + +void OPM_FPrint (INT32 *fp, INT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintSet (INT32 *fp, UINT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintReal (INT32 *fp, REAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 4); +} + +void OPM_FPrintLReal (INT32 *fp, LONGREAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_SymRCh (CHAR *ch) +{ + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); +} + +INT32 OPM_SymRInt (void) +{ + INT32 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 4); + return k; +} + +INT64 OPM_SymRInt64 (void) +{ + INT64 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 8); + return k; +} + +void OPM_SymRSet (UINT64 *s) +{ + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&*s, 8); +} + +void OPM_SymRReal (REAL *r) +{ + Files_ReadReal(&OPM_oldSF, Files_Rider__typ, &*r); +} + +void OPM_SymRLReal (LONGREAL *lr) +{ + Files_ReadLReal(&OPM_oldSF, Files_Rider__typ, &*lr); +} + +void OPM_CloseOldSym (void) +{ + Files_Close(Files_Base(&OPM_oldSF, Files_Rider__typ)); +} + +void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done) +{ + CHAR tag, ver; + OPM_FileName fileName; + INT16 res; + OPM_oldSFile = NIL; + *done = 0; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_oldSFile = Files_Old(fileName, 32); + *done = OPM_oldSFile != NIL; + if (*done) { + Files_Set(&OPM_oldSF, Files_Rider__typ, OPM_oldSFile, 0); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&tag); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&ver); + if (tag != 0xf7 || ver != 0x84) { + if (!__IN(4, OPM_Options, 32)) { + OPM_err(-306); + } + OPM_CloseOldSym(); + *done = 0; + } + } +} + +BOOLEAN OPM_eofSF (void) +{ + return OPM_oldSF.eof; +} + +void OPM_SymWCh (CHAR ch) +{ + Files_Write(&OPM_newSF, Files_Rider__typ, ch); +} + +void OPM_SymWInt (INT64 i) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, i); +} + +void OPM_SymWSet (UINT64 s) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, (INT64)s); +} + +void OPM_SymWReal (REAL r) +{ + Files_WriteReal(&OPM_newSF, Files_Rider__typ, r); +} + +void OPM_SymWLReal (LONGREAL lr) +{ + Files_WriteLReal(&OPM_newSF, Files_Rider__typ, lr); +} + +void OPM_RegisterNewSym (void) +{ + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { + Files_Register(OPM_newSFile); + } +} + +void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".sym", 5); + Files_Delete(fn, 32, &res); +} + +void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".o", 3); + Files_Delete(fn, 32, &res); +} + +void OPM_NewSym (CHAR *modName, ADDRESS modName__len) +{ + OPM_FileName fileName; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_newSFile = Files_New(fileName, 32); + if (OPM_newSFile != NIL) { + Files_Set(&OPM_newSF, Files_Rider__typ, OPM_newSFile, 0); + Files_Write(&OPM_newSF, Files_Rider__typ, 0xf7); + Files_Write(&OPM_newSF, Files_Rider__typ, 0x84); + } else { + OPM_err(153); + } +} + +void OPM_Write (CHAR ch) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, ch); +} + +void OPM_WriteString (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteStringVar (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteHex (INT64 i) +{ + CHAR s[3]; + INT32 digit; + digit = __ASHR(__SHORT(i, 2147483648LL), 4); + if (digit < 10) { + s[0] = __CHR(48 + digit); + } else { + s[0] = __CHR(87 + digit); + } + digit = __MASK(__SHORT(i, 2147483648LL), -16); + if (digit < 10) { + s[1] = __CHR(48 + digit); + } else { + s[1] = __CHR(87 + digit); + } + s[2] = 0x00; + OPM_WriteString(s, 3); +} + +void OPM_WriteInt (INT64 i) +{ + CHAR s[26]; + INT64 i1, k; + if ((i == OPM_SignedMinimum(2) || i == OPM_SignedMinimum(4)) || i == OPM_SignedMinimum(8)) { + OPM_Write('('); + OPM_WriteInt(i + 1); + OPM_WriteString((CHAR*)"-1)", 4); + } else { + i1 = __ABS(i); + if (i1 <= 2147483647) { + k = 0; + } else { + __MOVE("LL", s, 3); + k = 2; + } + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + while (i1 > 0) { + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + } + if (i < 0) { + s[__X(k, 26)] = '-'; + k += 1; + } + while (k > 0) { + k -= 1; + OPM_Write(s[__X(k, 26)]); + } + } +} + +void OPM_WriteReal (LONGREAL r, CHAR suffx) +{ + Texts_Writer W; + Texts_Text T = NIL; + Texts_Reader R; + CHAR s[32]; + CHAR ch; + INT16 i; + if ((((r < OPM_SignedMaximum(OPM_LongintSize) && r > OPM_SignedMinimum(OPM_LongintSize))) && r == (__SHORT(__ENTIER(r), 2147483648LL)))) { + if (suffx == 'f') { + OPM_WriteString((CHAR*)"(REAL)", 7); + } else { + OPM_WriteString((CHAR*)"(LONGREAL)", 11); + } + OPM_WriteInt(__SHORT(__ENTIER(r), 2147483648LL)); + } else { + Texts_OpenWriter(&W, Texts_Writer__typ); + if (suffx == 'f') { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 16); + } else { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 23); + } + __NEW(T, Texts_TextDesc); + Texts_Open(T, (CHAR*)"", 1); + Texts_Append(T, W.buf); + Texts_OpenReader(&R, Texts_Reader__typ, T, 0); + i = 0; + Texts_Read(&R, Texts_Reader__typ, &ch); + while (ch != 0x00) { + s[__X(i, 32)] = ch; + i += 1; + Texts_Read(&R, Texts_Reader__typ, &ch); + } + s[__X(i, 32)] = 0x00; + i = 0; + ch = s[0]; + while ((ch != 'D' && ch != 0x00)) { + i += 1; + ch = s[__X(i, 32)]; + } + if (ch == 'D') { + s[__X(i, 32)] = 'e'; + } + OPM_WriteString(s, 32); + } +} + +void OPM_WriteLn (void) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, 0x0a); +} + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F) +{ + Files_Rider R1; + CHAR buffer[4096]; + if (F != NIL) { + Files_Set(&R1, Files_Rider__typ, F, 0); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + while (4096 - R1.res > 0) { + Files_WriteBytes(&*R, R__typ, (void*)buffer, 4096, 4096 - R1.res); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + } + } +} + +void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len) +{ + OPM_FileName FName; + __COPY(moduleName, OPM_modName, 32); + OPM_HFile = Files_New((CHAR*)"", 1); + if (OPM_HFile != NIL) { + Files_Set(&OPM_R[0], Files_Rider__typ, OPM_HFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".c", 3); + OPM_BFile = Files_New(FName, 32); + if (OPM_BFile != NIL) { + Files_Set(&OPM_R[1], Files_Rider__typ, OPM_BFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".h", 3); + OPM_HIFile = Files_New(FName, 32); + if (OPM_HIFile != NIL) { + Files_Set(&OPM_R[2], Files_Rider__typ, OPM_HIFile, 0); + } else { + OPM_err(153); + } +} + +void OPM_CloseFiles (void) +{ + OPM_FileName FName; + INT16 res; + if (OPM_noerr) { + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWNum(Files_Pos(&OPM_R[1], Files_Rider__typ), 0); + OPM_LogWStr((CHAR*)" chars.", 8); + } + if (OPM_noerr) { + if (__STRCMP(OPM_modName, "SYSTEM") == 0) { + if (!__IN(10, OPM_Options, 32)) { + Files_Register(OPM_BFile); + } + } else if (!__IN(10, OPM_Options, 32)) { + OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); + Files_Register(OPM_HIFile); + Files_Register(OPM_BFile); + } else { + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".h", 3); + Files_Delete(FName, 32, &res); + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".sym", 5); + Files_Delete(FName, 32, &res); + Files_Register(OPM_BFile); + } + } + OPM_HFile = NIL; + OPM_BFile = NIL; + OPM_HIFile = NIL; + OPM_newSFile = NIL; + OPM_oldSFile = NIL; + Files_Set(&OPM_R[0], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[1], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[2], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_newSF, Files_Rider__typ, NIL, 0); + Files_Set(&OPM_oldSF, Files_Rider__typ, NIL, 0); +} + +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len) +{ + CHAR testpath[4096]; + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/lib/lib", 9, (void*)testpath, 4096); + Strings_Append((CHAR*)"voc", 4, (void*)testpath, 4096); + Strings_Append((CHAR*)"-O2.a", 6, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/include/Oberon.h", 20, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/sym/Files.sym", 17, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __DEL(s); + return 1; +} + +static void OPM_FindInstallDir (void) +{ + INT16 i; + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + Strings_Append((CHAR*)"/", 2, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)"voc", 4, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)".d", 3, (void*)OPM_InstallDir, 1024); + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + i = Strings_Length(OPM_InstallDir, 1024); + while ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] != '/')) { + i -= 1; + } + if ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] == '/')) { + OPM_InstallDir[__X(i - 1, 1024)] = 0x00; + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + } + __COPY("", OPM_InstallDir, 1024); +} + +static void EnumPtrs(void (*P)(void*)) +{ + __ENUMR(&OPM_inR, Texts_Reader__typ, 72, 1, P); + P(OPM_Log); + P(OPM_Errors); + __ENUMR(&OPM_oldSF, Files_Rider__typ, 24, 1, P); + __ENUMR(&OPM_newSF, Files_Rider__typ, 24, 1, P); + __ENUMR(OPM_R, Files_Rider__typ, 24, 3, P); + P(OPM_oldSFile); + P(OPM_newSFile); + P(OPM_HFile); + P(OPM_BFile); + P(OPM_HIFile); +} + + +export void *OPM__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(Texts); + __MODULE_IMPORT(VT100); + __REGMOD("OPM", EnumPtrs); + __REGCMD("CloseFiles", OPM_CloseFiles); + __REGCMD("CloseOldSym", OPM_CloseOldSym); + __REGCMD("InitOptions", OPM_InitOptions); + __REGCMD("LogWLn", OPM_LogWLn); + __REGCMD("RegisterNewSym", OPM_RegisterNewSym); + __REGCMD("WriteLn", OPM_WriteLn); +/* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; + OPM_FindInstallDir(); + OPM_hasComment = 0; + OPM_currentComment[0] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPM.h b/bootstrap/unix-88/OPM.h new file mode 100644 index 00000000..64c15a28 --- /dev/null +++ b/bootstrap/unix-88/OPM.h @@ -0,0 +1,76 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPM__h +#define OPM__h + +#include "SYSTEM.h" + + +import CHAR OPM_Model[10]; +import INT16 OPM_AddressSize, OPM_Alignment; +import UINT32 OPM_GlobalOptions, OPM_Options; +import INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +import INT64 OPM_MaxIndex; +import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +import BOOLEAN OPM_noerr; +import INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +import INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +import CHAR OPM_modName[32]; +import CHAR OPM_objname[64]; +import CHAR OPM_InstallDir[1024]; +import CHAR OPM_ResourceDir[1024]; + + +import void OPM_CloseFiles (void); +import void OPM_CloseOldSym (void); +import void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +import void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +import void OPM_FPrint (INT32 *fp, INT64 val); +import void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +import void OPM_FPrintReal (INT32 *fp, REAL val); +import void OPM_FPrintSet (INT32 *fp, UINT64 val); +import void OPM_Get (CHAR *ch); +import void OPM_GetComment (CHAR *text, ADDRESS text__len); +import void OPM_Init (BOOLEAN *done); +import void OPM_InitOptions (void); +import INT16 OPM_Integer (INT64 n); +import void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +import void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +import void OPM_LogW (CHAR ch); +import void OPM_LogWLn (void); +import void OPM_LogWNum (INT64 i, INT64 len); +import void OPM_LogWStr (CHAR *s, ADDRESS s__len); +import INT32 OPM_Longint (INT64 n); +import void OPM_Mark (INT16 n, INT32 pos); +import void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +import void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +import void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +import BOOLEAN OPM_OpenPar (void); +import void OPM_RegisterNewSym (void); +import INT64 OPM_SignedMaximum (INT32 bytecount); +import INT64 OPM_SignedMinimum (INT32 bytecount); +import void OPM_StoreComment (CHAR *text, ADDRESS text__len); +import void OPM_SymRCh (CHAR *ch); +import INT32 OPM_SymRInt (void); +import INT64 OPM_SymRInt64 (void); +import void OPM_SymRLReal (LONGREAL *lr); +import void OPM_SymRReal (REAL *r); +import void OPM_SymRSet (UINT64 *s); +import void OPM_SymWCh (CHAR ch); +import void OPM_SymWInt (INT64 i); +import void OPM_SymWLReal (LONGREAL lr); +import void OPM_SymWReal (REAL r); +import void OPM_SymWSet (UINT64 s); +import void OPM_Write (CHAR ch); +import void OPM_WriteHex (INT64 i); +import void OPM_WriteInt (INT64 i); +import void OPM_WriteLn (void); +import void OPM_WriteReal (LONGREAL r, CHAR suffx); +import void OPM_WriteString (CHAR *s, ADDRESS s__len); +import void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +import BOOLEAN OPM_eofSF (void); +import void OPM_err (INT16 n); +import void *OPM__init(void); + + +#endif // OPM diff --git a/bootstrap/unix-88/OPP.c b/bootstrap/unix-88/OPP.c new file mode 100644 index 00000000..3fed2e31 --- /dev/null +++ b/bootstrap/unix-88/OPP.c @@ -0,0 +1,1881 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPB.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +struct OPP__1 { + INT32 low, high; +}; + +typedef + struct OPP__1 OPP_CaseTable[128]; + + +static INT8 OPP_sym, OPP_level; +static INT16 OPP_LoopLevel; +static OPT_Node OPP_TDinit, OPP_lastTDinit; +static INT16 OPP_nofFwdPtr; +static OPT_Struct OPP_FwdPtr[64]; + +export ADDRESS *OPP__1__typ; + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar); +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq); +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab); +static void OPP_CheckMark (INT8 *vis); +static void OPP_CheckSym (INT16 s); +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_); +static void OPP_ConstExpression (OPT_Node *x); +static void OPP_Element (OPT_Node *x); +static void OPP_Expression (OPT_Node *x); +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b); +static void OPP_Factor (OPT_Node *x); +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp); +export void OPP_Module (OPT_Node *prog, UINT32 opt); +static void OPP_PointerType (OPT_Struct *typ); +static void OPP_ProcedureDeclaration (OPT_Node *x); +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec); +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Sets (OPT_Node *x); +static void OPP_SimpleExpression (OPT_Node *x); +static void OPP_StandProcCall (OPT_Node *x); +static void OPP_StatSeq (OPT_Node *stat); +static void OPP_Term (OPT_Node *x); +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_err (INT16 n); +static void OPP_qualident (OPT_Object *id); +static void OPP_selector (OPT_Node *x); + + +static void OPP_err (INT16 n) +{ + OPM_err(n); +} + +static void OPP_CheckSym (INT16 s) +{ + if ((INT16)OPP_sym == s) { + OPS_Get(&OPP_sym); + } else { + OPM_err(s); + } +} + +static void OPP_qualident (OPT_Object *id) +{ + OPT_Object obj = NIL; + INT8 lev; + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if ((((OPP_sym == 18 && obj != NIL)) && obj->mode == 11)) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPT_FindImport(obj, &obj); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + obj = NIL; + } + } + if (obj == NIL) { + OPP_err(0); + obj = OPT_NewObj(); + obj->mode = 1; + obj->typ = OPT_undftyp; + obj->adr = 0; + } else { + lev = obj->mnolev; + if ((__IN(obj->mode, 0x06, 32) && lev != OPP_level)) { + obj->leaf = 0; + if (lev > 0) { + OPB_StaticLink(OPP_level - lev); + } + } + } + *id = obj; +} + +static void OPP_ConstExpression (OPT_Node *x) +{ + OPP_Expression(&*x); + if ((*x)->class != 7) { + OPP_err(50); + *x = OPB_NewIntConst(1); + } +} + +static void OPP_CheckMark (INT8 *vis) +{ + OPS_Get(&OPP_sym); + if (OPP_sym == 1 || OPP_sym == 7) { + if (OPP_level > 0) { + OPP_err(47); + } + if (OPP_sym == 1) { + *vis = 1; + } else { + *vis = 2; + } + OPS_Get(&OPP_sym); + } else { + *vis = 0; + } +} + +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_) +{ + OPT_Node x = NIL; + INT64 sf; + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + if (!OPT_SYSimported) { + OPP_err(135); + } + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + sf = x->conval->intval; + if (sf < 0 || sf > 1) { + OPP_err(220); + sf = 0; + } + } else { + OPP_err(51); + sf = 0; + } + *sysflag = OPM_Integer(sf); + OPP_CheckSym(23); + } else { + *sysflag = default_; + } +} + +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object fld = NIL, first = NIL, last = NIL, base = NIL; + OPT_Struct ftyp = NIL; + INT16 sysflag; + *typ = OPT_NewStr(13, 4); + (*typ)->BaseTyp = NIL; + OPP_CheckSysFlag(&sysflag, -1); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&base); + if ((base->mode == 5 && base->typ->comp == 4)) { + if (base->typ == *banned) { + OPP_err(58); + } else { + base->typ->pvused = 1; + (*typ)->BaseTyp = base->typ; + (*typ)->extlev = base->typ->extlev + 1; + (*typ)->sysflag = base->typ->sysflag; + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } + if (sysflag >= 0) { + (*typ)->sysflag = sysflag; + } + OPT_OpenScope(0, NIL); + first = NIL; + last = NIL; + for (;;) { + if (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + if ((*typ)->BaseTyp != NIL) { + OPT_FindField(OPS_name, (*typ)->BaseTyp, &fld); + if (fld != NIL) { + OPP_err(1); + } + } + OPT_Insert(OPS_name, &fld); + OPP_CheckMark(&fld->vis); + fld->mode = 4; + fld->link = NIL; + fld->typ = OPT_undftyp; + if (first == NIL) { + first = fld; + } + if (last == NIL) { + (*typ)->link = fld; + } else { + last->link = fld; + } + last = fld; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&ftyp, &*banned); + ftyp->pvused = 1; + if (ftyp->comp == 3) { + ftyp = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = ftyp; + first = first->link; + } + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + OPT_CloseScope(); +} + +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Node x = NIL; + INT64 n; + INT16 sysflag; + OPP_CheckSysFlag(&sysflag, 0); + if (OPP_sym == 25) { + *typ = OPT_NewStr(13, 3); + (*typ)->mno = 0; + (*typ)->sysflag = sysflag; + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + } else { + *typ = OPT_NewStr(13, 2); + (*typ)->sysflag = sysflag; + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + n = x->conval->intval; + if (n <= 0 || n > OPM_MaxIndex) { + OPP_err(63); + n = 1; + } + } else { + OPP_err(51); + n = 1; + } + (*typ)->n = OPM_Longint(n); + if (OPP_sym == 25) { + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + } else if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + if (OPP_sym != 25) { + OPP_ArrayType(&(*typ)->BaseTyp, &*banned); + } + } else { + OPP_err(35); + } + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(88); + } + } +} + +static void OPP_PointerType (OPT_Struct *typ) +{ + OPT_Object id = NIL; + *typ = OPT_NewStr(11, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + OPP_CheckSym(28); + if (OPP_sym == 38) { + OPT_Find(&id); + if (id == NIL) { + if (OPP_nofFwdPtr < 64) { + OPP_FwdPtr[__X(OPP_nofFwdPtr, 64)] = *typ; + OPP_nofFwdPtr += 1; + } else { + OPP_err(224); + } + (*typ)->link = OPT_NewObj(); + __COPY(OPS_name, (*typ)->link->name, 256); + (*typ)->BaseTyp = OPT_undftyp; + OPS_Get(&OPP_sym); + } else { + OPP_qualident(&id); + if (id->mode == 5) { + if (__IN(id->typ->comp, 0x1c, 32)) { + (*typ)->BaseTyp = id->typ; + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(52); + } + } + } else { + OPP_Type(&(*typ)->BaseTyp, &OPT_notyp); + if (!__IN((*typ)->BaseTyp->comp, 0x1c, 32)) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } +} + +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp) +{ + INT8 mode; + OPT_Object par = NIL, first = NIL, last = NIL, res = NIL; + OPT_Struct typ = NIL; + first = NIL; + last = *firstPar; + if (OPP_sym == 38 || OPP_sym == 60) { + for (;;) { + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + mode = 2; + } else { + mode = 1; + } + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &par); + OPS_Get(&OPP_sym); + par->mode = mode; + par->link = NIL; + if (first == NIL) { + first = par; + } + if (*firstPar == NIL) { + *firstPar = par; + } else { + last->link = par; + } + last = par; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else if (OPP_sym == 60) { + OPP_err(19); + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + if (((typ->comp == 2 || typ->comp == 4) && typ->strobj == NIL)) { + OPP_err(-309); + } + if (mode == 1) { + typ->pvused = 1; + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + } + OPP_CheckSym(22); + if (OPP_sym == 20) { + OPS_Get(&OPP_sym); + *resTyp = OPT_undftyp; + if (OPP_sym == 38) { + OPP_qualident(&res); + if (res->mode == 5) { + if (res->typ->form < 13) { + *resTyp = res->typ; + } else { + OPP_err(54); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + *resTyp = OPT_notyp; + } +} + +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object id = NIL; + *typ = OPT_undftyp; + if (OPP_sym < 30) { + OPP_err(12); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + if (id->mode == 5) { + if (id->typ == *banned) { + OPP_err(58); + } else { + *typ = id->typ; + } + } else { + OPP_err(52); + } + } else if (OPP_sym == 54) { + OPS_Get(&OPP_sym); + OPP_ArrayType(&*typ, &*banned); + } else if (OPP_sym == 55) { + OPS_Get(&OPP_sym); + OPP_RecordType(&*typ, &*banned); + OPB_Inittd(&OPP_TDinit, &OPP_lastTDinit, *typ); + OPP_CheckSym(41); + } else if (OPP_sym == 56) { + OPS_Get(&OPP_sym); + OPP_PointerType(&*typ); + } else if (OPP_sym == 61) { + OPS_Get(&OPP_sym); + *typ = OPT_NewStr(12, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPT_OpenScope(OPP_level, NIL); + OPP_FormalParameters(&(*typ)->link, &(*typ)->BaseTyp); + OPT_CloseScope(); + } else { + (*typ)->BaseTyp = OPT_notyp; + (*typ)->link = NIL; + } + } else { + OPP_err(12); + } + for (;;) { + if (((OPP_sym >= 39 && OPP_sym <= 42) || OPP_sym == 22) || OPP_sym == 64) { + break; + } + OPP_err(15); + if (OPP_sym == 38) { + break; + } + OPS_Get(&OPP_sym); + } +} + +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned) +{ + OPP_TypeDecl(&*typ, &*banned); + if (((((*typ)->form == 11 && (*typ)->BaseTyp == OPT_undftyp)) && (*typ)->strobj == NIL)) { + OPP_err(0); + } +} + +static void OPP_selector (OPT_Node *x) +{ + OPT_Object obj = NIL, proc = NIL; + OPT_Node y = NIL; + OPT_Struct typ = NIL; + OPS_Name name; + for (;;) { + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + for (;;) { + if (((*x)->typ != NIL && (*x)->typ->form == 11)) { + OPB_DeRef(&*x); + } + OPP_Expression(&y); + OPB_Index(&*x, y); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(23); + } else if (OPP_sym == 18) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __MOVE(OPS_name, name, 256); + OPS_Get(&OPP_sym); + if ((*x)->typ != NIL) { + if ((*x)->typ->form == 11) { + OPB_DeRef(&*x); + } + if ((*x)->typ->comp == 4) { + OPT_FindField(name, (*x)->typ, &obj); + OPB_Field(&*x, obj); + if ((obj != NIL && obj->mode == 13)) { + if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + y = (*x)->left; + if (y->class == 3) { + y = y->left; + } + if (y->obj != NIL) { + proc = OPT_topScope; + while ((proc->link != NIL && proc->link->mode != 13)) { + proc = proc->left; + } + if (proc->link == NIL || proc->link->link != y->obj) { + OPP_err(75); + } + typ = y->obj->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField((*x)->obj->name, typ->BaseTyp, &proc); + if (proc != NIL) { + (*x)->subcl = 1; + } else { + OPP_err(74); + } + } else { + OPP_err(75); + } + } + if ((obj->typ != OPT_notyp && OPP_sym != 30)) { + OPP_err(30); + } + } + } else { + OPP_err(53); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + OPB_DeRef(&*x); + } else if ((((((OPP_sym == 30 && (*x)->class < 7)) && (*x)->typ->form != 12)) && ((*x)->obj == NIL || (*x)->obj->mode != 13))) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 1); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } else { + break; + } + } +} + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar) +{ + OPT_Node apar = NIL, last = NIL; + *aparlist = NIL; + last = NIL; + if (OPP_sym != 22) { + for (;;) { + OPP_Expression(&apar); + if (fpar != NIL) { + OPB_Param(apar, fpar); + OPB_Link(&*aparlist, &last, apar); + fpar = fpar->link; + } else { + OPP_err(64); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + } + if (fpar != NIL) { + OPP_err(65); + } +} + +static void OPP_StandProcCall (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 m; + INT16 n; + m = __SHORT(__SHORT((*x)->obj->adr, 32768), 128); + n = 0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym != 22) { + for (;;) { + if (n == 0) { + OPP_Expression(&*x); + OPB_StPar0(&*x, m); + n = 1; + } else if (n == 1) { + OPP_Expression(&y); + OPB_StPar1(&*x, y, m); + n = 2; + } else { + OPP_Expression(&y); + OPB_StParN(&*x, y, m, n); + n += 1; + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(22); + } else { + OPS_Get(&OPP_sym); + } + OPB_StFct(&*x, m, n); + } else { + OPP_err(30); + } + if ((OPP_level > 0 && (m == 1 || m == 30))) { + OPT_topScope->link->leaf = 0; + } +} + +static void OPP_Element (OPT_Node *x) +{ + OPT_Node y = NIL; + OPP_Expression(&*x); + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_SetRange(&*x, y); + } else { + OPB_SetElem(&*x); + } +} + +static void OPP_Sets (OPT_Node *x) +{ + OPT_Node y = NIL; + if (OPP_sym != 24) { + OPP_Element(&*x); + for (;;) { + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + OPP_Element(&y); + OPB_Op(6, &*x, y); + } + } else { + *x = OPB_EmptySet(); + } + OPP_CheckSym(24); +} + +static void OPP_Factor (OPT_Node *x) +{ + OPT_Object fpar = NIL, id = NIL; + OPT_Node apar = NIL; + if (OPP_sym < 30) { + OPP_err(13); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + *x = OPB_NewLeaf(id); + OPP_selector(&*x); + if (((*x)->class == 9 && (*x)->obj->mode == 8)) { + OPP_StandProcCall(&*x); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPB_PrepCall(&*x, &fpar); + OPP_ActualParameters(&apar, fpar); + OPB_Call(&*x, apar, fpar); + OPP_CheckSym(22); + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + } else if (OPP_sym == 35) { + switch (OPS_numtyp) { + case 1: + *x = OPB_NewIntConst(OPS_intval); + (*x)->typ = OPT_chartyp; + break; + case 2: + *x = OPB_NewIntConst(OPS_intval); + break; + case 3: + *x = OPB_NewRealConst(OPS_realval, OPT_realtyp); + break; + case 4: + *x = OPB_NewRealConst(OPS_lrlval, OPT_lrltyp); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPP.Factor, OPS.numtyp = ", 44); + OPM_LogWNum(OPS_numtyp, 0); + OPM_LogWLn(); + break; + } + OPS_Get(&OPP_sym); + } else if (OPP_sym == 37) { + *x = OPB_NewString(OPS_str, OPS_intval); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 36) { + *x = OPB_Nil(); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + OPP_err(30); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 32) { + OPS_Get(&OPP_sym); + OPP_Sets(&*x); + } else if (OPP_sym == 33) { + OPS_Get(&OPP_sym); + OPP_Factor(&*x); + OPB_MOp(33, &*x); + } else { + OPP_err(13); + OPS_Get(&OPP_sym); + *x = NIL; + } + if (*x == NIL) { + *x = OPB_NewIntConst(1); + (*x)->typ = OPT_undftyp; + } +} + +static void OPP_Term (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 mulop; + OPP_Factor(&*x); + while ((1 <= OPP_sym && OPP_sym <= 5)) { + mulop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Factor(&y); + OPB_Op(mulop, &*x, y); + } +} + +static void OPP_SimpleExpression (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 addop; + if (OPP_sym == 7) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(7, &*x); + } else if (OPP_sym == 6) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(6, &*x); + } else { + OPP_Term(&*x); + } + while ((6 <= OPP_sym && OPP_sym <= 8)) { + addop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Term(&y); + OPB_Op(addop, &*x, y); + } +} + +static void OPP_Expression (OPT_Node *x) +{ + OPT_Node y = NIL; + OPT_Object obj = NIL; + INT8 relation; + OPP_SimpleExpression(&*x); + if ((9 <= OPP_sym && OPP_sym <= 14)) { + relation = OPP_sym; + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_Op(relation, &*x, y); + } else if (OPP_sym == 15) { + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_In(&*x, y); + } else if (OPP_sym == 16) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 0); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } +} + +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec) +{ + OPT_Object obj = NIL; + *typ = OPT_undftyp; + *rec = NIL; + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + *mode = 2; + } else { + *mode = 1; + } + __MOVE(OPS_name, name, 256); + OPP_CheckSym(38); + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if (obj == NIL) { + OPP_err(0); + } else if (obj->mode != 5) { + OPP_err(72); + } else { + *typ = obj->typ; + *rec = *typ; + if ((*rec)->form == 11) { + *rec = (*rec)->BaseTyp; + } + if (!((((*mode == 1 && (*typ)->form == 11)) && (*rec)->comp == 4) || (*mode == 2 && (*typ)->comp == 4))) { + OPP_err(70); + *rec = NIL; + } + if ((*rec != NIL && (*rec)->mno != OPP_level)) { + OPP_err(72); + *rec = NIL; + } + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + if (*rec == NIL) { + *rec = OPT_NewStr(13, 4); + (*rec)->BaseTyp = NIL; + } +} + +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b) +{ + if ((b->form == 11 && x->form == 11)) { + b = b->BaseTyp; + x = x->BaseTyp; + } + if ((b->comp == 4 && x->comp == 4)) { + do { + x = x->BaseTyp; + } while (!(x == NIL || x == b)); + } + return x == b; +} + +static struct ProcedureDeclaration__16 { + OPT_Node *x; + OPT_Object *proc, *fwd; + OPS_Name *name; + INT8 *mode, *vis; + BOOLEAN *forward; + struct ProcedureDeclaration__16 *lnk; +} *ProcedureDeclaration__16_s; + +static void Body__17 (void); +static void GetCode__19 (void); +static void GetParams__21 (void); +static void TProcDecl__23 (void); + +static void GetCode__19 (void) +{ + OPT_ConstExt ext = NIL; + INT16 n; + INT64 c; + ext = OPT_NewExt(); + (*ProcedureDeclaration__16_s->proc)->conval->ext = ext; + n = 0; + if (OPP_sym == 37) { + while (OPS_str[__X(n, 256)] != 0x00) { + (*ext)[__X(n + 1, 256)] = OPS_str[__X(n, 256)]; + n += 1; + } + (*ext)[0] = __CHR(n); + OPS_Get(&OPP_sym); + } else { + for (;;) { + if (OPP_sym == 35) { + c = OPS_intval; + n += 1; + if ((c < 0 || c > 255) || n == 256) { + OPP_err(64); + c = 1; + n = 1; + } + OPS_Get(&OPP_sym); + (*ext)[__X(n, 256)] = __CHR(c); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35) { + OPP_err(19); + } else { + (*ext)[0] = __CHR(n); + break; + } + } + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); +} + +static void GetParams__21 (void) +{ + (*ProcedureDeclaration__16_s->proc)->vis = *ProcedureDeclaration__16_s->vis; + (*ProcedureDeclaration__16_s->proc)->mode = *ProcedureDeclaration__16_s->mode; + (*ProcedureDeclaration__16_s->proc)->typ = OPT_notyp; + (*ProcedureDeclaration__16_s->proc)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->proc)->conval->setval = 0x0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_FormalParameters(&(*ProcedureDeclaration__16_s->proc)->link, &(*ProcedureDeclaration__16_s->proc)->typ); + } + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link, (*ProcedureDeclaration__16_s->fwd)->link, 1); + if ((*ProcedureDeclaration__16_s->proc)->typ != (*ProcedureDeclaration__16_s->fwd)->typ) { + OPP_err(117); + } + *ProcedureDeclaration__16_s->proc = *ProcedureDeclaration__16_s->fwd; + OPT_topScope = (*ProcedureDeclaration__16_s->proc)->scope; + if (*ProcedureDeclaration__16_s->mode == 10) { + (*ProcedureDeclaration__16_s->proc)->mode = 10; + } + } +} + +static void Body__17 (void) +{ + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + c = OPM_errpos; + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); + OPP_CheckSym(39); + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, *ProcedureDeclaration__16_s->proc); + *ProcedureDeclaration__16_s->x = procdec; + (*ProcedureDeclaration__16_s->x)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->x)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, (*ProcedureDeclaration__16_s->proc)->name) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } +} + +static void TProcDecl__23 (void) +{ + OPT_Object baseProc = NIL; + OPT_Struct objTyp = NIL, recTyp = NIL; + INT8 objMode; + OPS_Name objName; + OPS_Get(&OPP_sym); + *ProcedureDeclaration__16_s->mode = 13; + if (OPP_level > 0) { + OPP_err(73); + } + OPP_Receiver(&objMode, objName, &objTyp, &recTyp); + if (OPP_sym == 38) { + __MOVE(OPS_name, *ProcedureDeclaration__16_s->name, 256); + OPP_CheckMark(&*ProcedureDeclaration__16_s->vis); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp, &*ProcedureDeclaration__16_s->fwd); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp->BaseTyp, &baseProc); + if ((baseProc != NIL && baseProc->mode != 13)) { + baseProc = NIL; + } + if (*ProcedureDeclaration__16_s->fwd == baseProc) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mnolev != OPP_level)) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mode == 13)) && !__IN(1, (*ProcedureDeclaration__16_s->fwd)->conval->setval, 64))) { + *ProcedureDeclaration__16_s->proc = OPT_NewObj(); + (*ProcedureDeclaration__16_s->proc)->leaf = 1; + if ((*ProcedureDeclaration__16_s->fwd)->vis != *ProcedureDeclaration__16_s->vis) { + OPP_err(118); + } + } else { + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPP_err(1); + *ProcedureDeclaration__16_s->fwd = NIL; + } + OPT_OpenScope(0, NIL); + OPT_topScope->right = recTyp->link; + OPT_Insert(*ProcedureDeclaration__16_s->name, &*ProcedureDeclaration__16_s->proc); + recTyp->link = OPT_topScope->right; + OPT_CloseScope(); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, *ProcedureDeclaration__16_s->proc); + OPT_Insert(objName, &(*ProcedureDeclaration__16_s->proc)->link); + (*ProcedureDeclaration__16_s->proc)->link->mode = objMode; + (*ProcedureDeclaration__16_s->proc)->link->typ = objTyp; + GetParams__21(); + if (baseProc != NIL) { + if (objMode != baseProc->link->mode || !OPP_Extends(objTyp, baseProc->link->typ)) { + OPP_err(115); + } + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link->link, baseProc->link->link, 0); + if ((*ProcedureDeclaration__16_s->proc)->typ != baseProc->typ) { + OPP_err(117); + } + if ((((((baseProc->vis == 1 && (*ProcedureDeclaration__16_s->proc)->vis == 0)) && recTyp->strobj != NIL)) && recTyp->strobj->vis == 1)) { + OPP_err(109); + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(2,64); + } + if (!*ProcedureDeclaration__16_s->forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } +} + +static void OPP_ProcedureDeclaration (OPT_Node *x) +{ + OPT_Object proc = NIL, fwd = NIL; + OPS_Name name; + INT8 mode, vis; + BOOLEAN forward; + struct ProcedureDeclaration__16 _s; + _s.x = x; + _s.proc = &proc; + _s.fwd = &fwd; + _s.name = (void*)name; + _s.mode = &mode; + _s.vis = &vis; + _s.forward = &forward; + _s.lnk = ProcedureDeclaration__16_s; + ProcedureDeclaration__16_s = &_s; + proc = NIL; + forward = 0; + *x = NIL; + mode = 6; + if ((OPP_sym != 38 && OPP_sym != 30)) { + if (OPP_sym == 1) { + } else if (OPP_sym == 17) { + forward = 1; + } else if (OPP_sym == 6) { + mode = 10; + } else if (OPP_sym == 7) { + mode = 9; + } else { + OPP_err(38); + } + if ((__IN(mode, 0x0600, 32) && !OPT_SYSimported)) { + OPP_err(135); + } + OPS_Get(&OPP_sym); + } + if (OPP_sym == 30) { + TProcDecl__23(); + } else if (OPP_sym == 38) { + OPT_Find(&fwd); + __MOVE(OPS_name, name, 256); + OPP_CheckMark(&vis); + if ((vis != 0 && mode == 6)) { + mode = 7; + } + if ((fwd != NIL && (fwd->mnolev != OPP_level || fwd->mode == 8))) { + fwd = NIL; + } + if ((((fwd != NIL && __IN(fwd->mode, 0xc0, 32))) && !__IN(1, fwd->conval->setval, 64))) { + proc = OPT_NewObj(); + proc->leaf = 1; + if (fwd->vis != vis) { + OPP_err(118); + } + } else { + if (fwd != NIL) { + OPP_err(1); + fwd = NIL; + } + OPT_Insert(name, &proc); + } + if ((mode != 6 && OPP_level > 0)) { + OPP_err(73); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, proc); + proc->link = NIL; + GetParams__21(); + if (mode == 9) { + GetCode__19(); + } else if (!forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } + ProcedureDeclaration__16_s = _s.lnk; +} + +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab) +{ + OPT_Node x = NIL, y = NIL, lastlab = NIL; + INT16 i, f; + INT32 xval, yval; + *lab = NIL; + lastlab = NIL; + for (;;) { + OPP_ConstExpression(&x); + f = x->typ->form; + if (__IN(f, 0x18, 32)) { + xval = OPM_Longint(x->conval->intval); + } else { + OPP_err(61); + xval = 1; + } + if (f == 4) { + if (!(LabelTyp->form == 4) || LabelTyp->size < x->typ->size) { + OPP_err(60); + } + } else if ((INT16)LabelTyp->form != f) { + OPP_err(60); + } + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&y); + yval = OPM_Longint(y->conval->intval); + if (((INT16)y->typ->form != f && !((f == 4 && y->typ->form == 4)))) { + OPP_err(60); + } + if (yval < xval) { + OPP_err(63); + yval = xval; + } + } else { + yval = xval; + } + x->conval->intval2 = yval; + i = *n; + if (i < 128) { + for (;;) { + if (i == 0) { + break; + } + if (tab[__X(i - 1, 128)].low <= yval) { + if (tab[__X(i - 1, 128)].high >= xval) { + OPP_err(62); + } + break; + } + tab[__X(i, 128)] = tab[__X(i - 1, 128)]; + i -= 1; + } + tab[__X(i, 128)].low = xval; + tab[__X(i, 128)].high = yval; + *n += 1; + } else { + OPP_err(213); + } + OPB_Link(&*lab, &lastlab, x); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35 || OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } +} + +static struct StatSeq__30 { + INT32 *pos; + struct StatSeq__30 *lnk; +} *StatSeq__30_s; + +static void CasePart__31 (OPT_Node *x); +static void CheckBool__33 (OPT_Node *x); +static void SetPos__35 (OPT_Node x); + +static void CasePart__31 (OPT_Node *x) +{ + INT16 n; + INT32 low, high; + BOOLEAN e; + OPP_CaseTable tab; + OPT_Node cases = NIL, lab = NIL, y = NIL, lastcase = NIL; + OPP_Expression(&*x); + *StatSeq__30_s->pos = OPM_errpos; + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + } else if (!__IN((*x)->typ->form, 0x18, 32)) { + OPP_err(125); + } + OPP_CheckSym(25); + cases = NIL; + lastcase = NIL; + n = 0; + for (;;) { + if (OPP_sym < 40) { + OPP_CaseLabelList(&lab, (*x)->typ, &n, tab); + OPP_CheckSym(20); + OPP_StatSeq(&y); + OPB_Construct(17, &lab, y); + OPB_Link(&cases, &lastcase, lab); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + if (n > 0) { + low = tab[0].low; + high = tab[__X(n - 1, 128)].high; + if (high - low > 512) { + OPP_err(209); + } + } else { + low = 1; + high = 0; + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + OPM_Mark(-307, OPM_curpos); + } + OPB_Construct(16, &cases, y); + OPB_Construct(21, &*x, cases); + cases->conval = OPT_NewConst(); + cases->conval->intval = low; + cases->conval->intval2 = high; + if (e) { + cases->conval->setval = 0x02; + } else { + cases->conval->setval = 0x0; + } +} + +static void SetPos__35 (OPT_Node x) +{ + x->conval = OPT_NewConst(); + x->conval->intval = *StatSeq__30_s->pos; +} + +static void CheckBool__33 (OPT_Node *x) +{ + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + *x = OPB_NewBoolConst(0); + } else if ((*x)->typ->form != 2) { + OPP_err(120); + *x = OPB_NewBoolConst(0); + } + *StatSeq__30_s->pos = OPM_errpos; +} + +static void OPP_StatSeq (OPT_Node *stat) +{ + OPT_Object fpar = NIL, id = NIL, t = NIL, obj = NIL; + OPT_Struct idtyp = NIL; + BOOLEAN e; + OPT_Node s = NIL, x = NIL, y = NIL, z = NIL, apar = NIL, last = NIL, lastif = NIL; + INT32 pos; + OPS_Name name; + struct StatSeq__30 _s; + _s.pos = &pos; + _s.lnk = StatSeq__30_s; + StatSeq__30_s = &_s; + *stat = NIL; + last = NIL; + for (;;) { + x = NIL; + if (OPP_sym < 38) { + OPP_err(14); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 38)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + x = OPB_NewLeaf(id); + OPP_selector(&x); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if (OPP_sym == 9) { + OPP_err(34); + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if ((x->class == 9 && x->obj->mode == 8)) { + OPP_StandProcCall(&x); + if ((x != NIL && x->typ != OPT_notyp)) { + OPP_err(55); + } + } else { + OPB_PrepCall(&x, &fpar); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_ActualParameters(&apar, fpar); + OPP_CheckSym(22); + } else { + apar = NIL; + if (fpar != NIL) { + OPP_err(65); + } + } + OPB_Call(&x, apar, fpar); + if (x->typ != OPT_notyp) { + OPP_err(55); + } + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + pos = OPM_errpos; + } else if (OPP_sym == 45) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(26); + OPP_StatSeq(&y); + OPB_Construct(15, &x, y); + SetPos__35(x); + lastif = x; + while (OPP_sym == 43) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + OPP_CheckSym(26); + OPP_StatSeq(&z); + OPB_Construct(15, &y, z); + SetPos__35(y); + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 42) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + } + OPB_Construct(20, &x, y); + OPP_CheckSym(41); + OPB_OptIf(&x); + pos = OPM_errpos; + } else if (OPP_sym == 46) { + OPS_Get(&OPP_sym); + CasePart__31(&x); + OPP_CheckSym(41); + } else if (OPP_sym == 47) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(27); + OPP_StatSeq(&y); + OPB_Construct(22, &x, y); + OPP_CheckSym(41); + } else if (OPP_sym == 48) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&x); + if (OPP_sym == 44) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + } else { + OPP_err(44); + } + OPB_Construct(23, &x, y); + } else if (OPP_sym == 49) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&id); + if (!(id->typ->form == 4)) { + OPP_err(68); + } + OPP_CheckSym(34); + OPP_Expression(&y); + pos = OPM_errpos; + x = OPB_NewLeaf(id); + OPB_Assign(&x, y); + SetPos__35(x); + OPP_CheckSym(28); + OPP_Expression(&y); + pos = OPM_errpos; + if (y->class != 7) { + __MOVE("@@", name, 3); + OPT_Insert(name, &t); + __MOVE("@for", t->name, 5); + t->mode = 1; + t->typ = x->left->typ; + obj = OPT_topScope->scope; + if (obj == NIL) { + OPT_topScope->scope = t; + } else { + while (obj->link != NIL) { + obj = obj->link; + } + obj->link = t; + } + z = OPB_NewLeaf(t); + OPB_Assign(&z, y); + SetPos__35(z); + OPB_Link(&*stat, &last, z); + y = OPB_NewLeaf(t); + } else if (!(y->typ->form == 4) || y->typ->size > x->left->typ->size) { + OPP_err(113); + } + OPB_Link(&*stat, &last, x); + if (OPP_sym == 29) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&z); + } else { + z = OPB_NewIntConst(1); + } + pos = OPM_errpos; + x = OPB_NewLeaf(id); + if (z->conval->intval > 0) { + OPB_Op(12, &x, y); + } else if (z->conval->intval < 0) { + OPB_Op(14, &x, y); + } else { + OPP_err(63); + OPB_Op(14, &x, y); + } + OPP_CheckSym(27); + OPP_StatSeq(&s); + y = OPB_NewLeaf(id); + OPB_StPar1(&y, z, 13); + SetPos__35(y); + if (s == NIL) { + s = y; + } else { + z = s; + while (z->link != NIL) { + z = z->link; + } + z->link = y; + } + OPP_CheckSym(41); + OPB_Construct(22, &x, s); + } else { + OPP_err(38); + } + } else if (OPP_sym == 50) { + OPS_Get(&OPP_sym); + OPP_LoopLevel += 1; + OPP_StatSeq(&x); + OPP_LoopLevel -= 1; + OPB_Construct(24, &x, NIL); + OPP_CheckSym(41); + pos = OPM_errpos; + } else if (OPP_sym == 51) { + OPS_Get(&OPP_sym); + idtyp = NIL; + x = NIL; + for (;;) { + if (OPP_sym == 38) { + OPP_qualident(&id); + y = OPB_NewLeaf(id); + if ((((id != NIL && id->typ->form == 11)) && (id->mode == 2 || !id->leaf))) { + OPP_err(245); + } + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPP_qualident(&t); + if (t->mode == 5) { + if (id != NIL) { + idtyp = id->typ; + OPB_TypTest(&y, t, 0); + id->typ = t->typ; + } else { + OPP_err(130); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + OPP_err(38); + } + pos = OPM_errpos; + OPP_CheckSym(27); + OPP_StatSeq(&s); + OPB_Construct(15, &y, s); + SetPos__35(y); + if (idtyp != NIL) { + id->typ = idtyp; + idtyp = NIL; + } + if (x == NIL) { + x = y; + lastif = x; + } else { + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&s); + } else { + s = NIL; + } + OPB_Construct(27, &x, s); + OPP_CheckSym(41); + if (e) { + x->subcl = 1; + } + } else if (OPP_sym == 52) { + OPS_Get(&OPP_sym); + if (OPP_LoopLevel == 0) { + OPP_err(46); + } + OPB_Construct(25, &x, NIL); + pos = OPM_errpos; + } else if (OPP_sym == 53) { + OPS_Get(&OPP_sym); + if (OPP_sym < 39) { + OPP_Expression(&x); + } + if (OPP_level > 0) { + OPB_Return(&x, OPT_topScope->link); + } else { + OPB_Return(&x, NIL); + } + pos = OPM_errpos; + } + if (x != NIL) { + SetPos__35(x); + OPB_Link(&*stat, &last, x); + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym <= 38 || (45 <= OPP_sym && OPP_sym <= 53)) { + OPP_err(39); + } else { + break; + } + } + StatSeq__30_s = _s.lnk; +} + +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq) +{ + OPT_Struct typ = NIL; + OPT_Object obj = NIL, first = NIL, last = NIL; + OPT_Node x = NIL, lastdec = NIL; + INT16 i; + first = NIL; + last = NIL; + OPP_nofFwdPtr = 0; + for (;;) { + if (OPP_sym == 58) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->typ = OPT_sinttyp; + obj->mode = 1; + if (OPP_sym == 9) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else if (OPP_sym == 34) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else { + OPP_err(9); + x = OPB_NewIntConst(1); + } + obj->mode = 3; + obj->typ = x->typ; + obj->conval = x->conval; + OPP_CheckSym(39); + } + } + if (OPP_sym == 59) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + obj->mode = 5; + obj->typ = OPT_undftyp; + OPP_CheckMark(&obj->vis); + if (OPP_sym == 9) { + if (((((((((__STRCMP(obj->name, "SHORTINT") == 0 || __STRCMP(obj->name, "INTEGER") == 0) || __STRCMP(obj->name, "LONGINT") == 0) || __STRCMP(obj->name, "HUGEINT") == 0) || __STRCMP(obj->name, "REAL") == 0) || __STRCMP(obj->name, "LONGREAL") == 0) || __STRCMP(obj->name, "SET") == 0) || __STRCMP(obj->name, "CHAR") == 0) || __STRCMP(obj->name, "TRUE") == 0) || __STRCMP(obj->name, "FALSE") == 0) { + OPM_Mark(-310, OPM_curpos); + } + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else if (OPP_sym == 34 || OPP_sym == 20) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else { + OPP_err(9); + } + if (obj->typ->strobj == NIL) { + obj->typ->strobj = obj; + } + if (__IN(obj->typ->comp, 0x1c, 32)) { + i = 0; + while (i < OPP_nofFwdPtr) { + typ = OPP_FwdPtr[__X(i, 64)]; + i += 1; + if (__STRCMP(typ->link->name, obj->name) == 0) { + typ->BaseTyp = obj->typ; + typ->link->name[0] = 0x00; + } + } + } + OPP_CheckSym(39); + } + } + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->mode = 1; + obj->link = NIL; + obj->leaf = obj->vis == 0; + obj->typ = OPT_undftyp; + if (first == NIL) { + first = obj; + } + if (last == NIL) { + OPT_topScope->scope = obj; + } else { + last->link = obj; + } + last = obj; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + typ->pvused = 1; + if (typ->comp == 3) { + typ = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + OPP_CheckSym(39); + } + } + if (OPP_sym < 58 || OPP_sym > 60) { + break; + } + } + i = 0; + while (i < OPP_nofFwdPtr) { + if (OPP_FwdPtr[__X(i, 64)]->link->name[0] != 0x00) { + OPP_err(128); + } + OPP_FwdPtr[__X(i, 64)] = NIL; + i += 1; + } + OPT_topScope->adr = OPM_errpos; + *procdec = NIL; + lastdec = NIL; + while (OPP_sym == 61) { + OPS_Get(&OPP_sym); + OPP_ProcedureDeclaration(&x); + if (x != NIL) { + if (lastdec == NIL) { + *procdec = x; + } else { + lastdec->link = x; + } + lastdec = x; + } + OPP_CheckSym(39); + } + if (OPP_sym == 57) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&*statseq); + } else { + *statseq = NIL; + } + if ((OPP_level == 0 && OPP_TDinit != NIL)) { + OPP_lastTDinit->link = *statseq; + *statseq = OPP_TDinit; + } + OPP_CheckSym(41); +} + +void OPP_Module (OPT_Node *prog, UINT32 opt) +{ + OPS_Name impName, aliasName; + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + BOOLEAN done; + OPS_Init(); + OPP_LoopLevel = 0; + OPP_level = 0; + OPS_Get(&OPP_sym); + if (OPP_sym == 63) { + OPS_Get(&OPP_sym); + } else { + OPP_err(16); + } + if (OPP_sym == 38) { + OPM_LogCompiling(OPS_name, 256); + OPT_Init(OPS_name, opt); + OPS_Get(&OPP_sym); + OPP_CheckSym(39); + if (OPP_sym == 62) { + OPS_Get(&OPP_sym); + for (;;) { + if (OPP_sym == 38) { + __COPY(OPS_name, aliasName, 256); + __COPY(aliasName, impName, 256); + OPS_Get(&OPP_sym); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __COPY(OPS_name, impName, 256); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + } + OPT_Import(aliasName, impName, &done); + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(39); + } + if (OPM_noerr) { + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; + c = OPM_errpos; + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, NIL); + *prog = procdec; + (*prog)->conval = OPT_NewConst(); + (*prog)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, OPT_SelfName) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + if (OPP_sym != 18) { + OPP_err(18); + } + } + } else { + OPP_err(38); + } + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPP_TDinit); + P(OPP_lastTDinit); + __ENUMP(OPP_FwdPtr, 64, P); +} + +__TDESC(OPP__1, 1, 0) = {__TDFLDS("", 8), {-8}}; + +export void *OPP__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPP", EnumPtrs); + __INITYP(OPP__1, OPP__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPP.h b/bootstrap/unix-88/OPP.h new file mode 100644 index 00000000..3d8cefe8 --- /dev/null +++ b/bootstrap/unix-88/OPP.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPP__h +#define OPP__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPP_Module (OPT_Node *prog, UINT32 opt); +import void *OPP__init(void); + + +#endif // OPP diff --git a/bootstrap/unix-88/OPS.c b/bootstrap/unix-88/OPS.c new file mode 100644 index 00000000..a25a2c12 --- /dev/null +++ b/bootstrap/unix-88/OPS.c @@ -0,0 +1,666 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +export OPS_Name OPS_name; +export OPS_String OPS_str; +export INT16 OPS_numtyp; +export INT64 OPS_intval; +export REAL OPS_realval; +export LONGREAL OPS_lrlval; +static CHAR OPS_ch; + + +export void OPS_Get (INT8 *sym); +static void OPS_Identifier (INT8 *sym); +export void OPS_Init (void); +static void OPS_Number (void); +static void OPS_Str (INT8 *sym); +static void OPS_err (INT16 n); + + +static void OPS_err (INT16 n) +{ + OPM_err(n); +} + +static void OPS_Str (INT8 *sym) +{ + INT16 i; + CHAR och; + i = 0; + och = OPS_ch; + for (;;) { + OPM_Get(&OPS_ch); + if (OPS_ch == och) { + break; + } + if (OPS_ch < ' ') { + OPS_err(3); + break; + } + if (i == 255) { + OPS_err(241); + break; + } + OPS_str[__X(i, 256)] = OPS_ch; + i += 1; + } + OPM_Get(&OPS_ch); + OPS_str[__X(i, 256)] = 0x00; + OPS_intval = i + 1; + if (OPS_intval == 2) { + *sym = 35; + OPS_numtyp = 1; + OPS_intval = (INT16)OPS_str[0]; + } else { + *sym = 37; + } +} + +static void OPS_Identifier (INT8 *sym) +{ + INT16 i; + i = 0; + do { + OPS_name[__X(i, 256)] = OPS_ch; + i += 1; + OPM_Get(&OPS_ch); + } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256)); + if (i == 256) { + OPS_err(240); + i -= 1; + } + OPS_name[__X(i, 256)] = 0x00; + *sym = 38; +} + +static struct Number__6 { + struct Number__6 *lnk; +} *Number__6_s; + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex); +static LONGREAL Ten__9 (INT16 e); + +static LONGREAL Ten__9 (INT16 e) +{ + LONGREAL x, p; + x = (LONGREAL)1; + p = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + x = x * p; + } + e = __ASHR(e, 1); + if (e > 0) { + p = p * p; + } + } + return x; +} + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex) +{ + if (ch <= '9') { + return (INT16)ch - 48; + } else if (hex) { + return ((INT16)ch - 65) + 10; + } else { + OPS_err(2); + return 0; + } + __RETCHK; +} + +static void OPS_Number (void) +{ + INT16 i, m, n, d, e; + CHAR dig[24]; + LONGREAL f; + CHAR expCh; + BOOLEAN neg; + struct Number__6 _s; + _s.lnk = Number__6_s; + Number__6_s = &_s; + i = 0; + m = 0; + n = 0; + d = 0; + for (;;) { + if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) { + if (m > 0 || OPS_ch != '0') { + if (n < 24) { + dig[__X(n, 24)] = OPS_ch; + n += 1; + } + m += 1; + } + OPM_Get(&OPS_ch); + i += 1; + } else if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPS_ch = 0x7f; + break; + } else if (d == 0) { + d = i; + } else { + OPS_err(2); + } + } else { + break; + } + } + if (d == 0) { + if (n == m) { + OPS_intval = 0; + i = 0; + if (OPS_ch == 'X') { + OPM_Get(&OPS_ch); + OPS_numtyp = 1; + if (n <= 2) { + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else if (OPS_ch == 'H') { + OPM_Get(&OPS_ch); + OPS_numtyp = 2; + if (n <= 16) { + if ((n == 16 && dig[0] > '7')) { + OPS_intval = -1; + } + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 2; + while (i < n) { + d = Ord__7(dig[__X(i, 24)], 0); + i += 1; + if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (INT64)d; + } else { + OPS_err(203); + } + } + } + } else { + OPS_err(203); + } + } else { + f = (LONGREAL)0; + e = 0; + expCh = 'E'; + while (n > 0) { + n -= 1; + f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10; + } + if (OPS_ch == 'E' || OPS_ch == 'D') { + expCh = OPS_ch; + OPM_Get(&OPS_ch); + neg = 0; + if (OPS_ch == '-') { + neg = 1; + OPM_Get(&OPS_ch); + } else if (OPS_ch == '+') { + OPM_Get(&OPS_ch); + } + if (('0' <= OPS_ch && OPS_ch <= '9')) { + do { + n = Ord__7(OPS_ch, 0); + OPM_Get(&OPS_ch); + if (e <= __DIV(32767 - n, 10)) { + e = e * 10 + n; + } else { + OPS_err(203); + } + } while (!(OPS_ch < '0' || '9' < OPS_ch)); + if (neg) { + e = -e; + } + } else { + OPS_err(2); + } + } + e -= (i - d) - m; + if (expCh == 'E') { + OPS_numtyp = 3; + if ((-37 < e && e <= 38)) { + if (e < 0) { + OPS_realval = (f / (LONGREAL)Ten__9(-e)); + } else { + OPS_realval = (f * Ten__9(e)); + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 4; + if ((-307 < e && e <= 308)) { + if (e < 0) { + OPS_lrlval = f / (LONGREAL)Ten__9(-e); + } else { + OPS_lrlval = f * Ten__9(e); + } + } else { + OPS_err(203); + } + } + } + Number__6_s = _s.lnk; +} + +static struct Get__1 { + struct Get__1 *lnk; +} *Get__1_s; + +static void Comment__2 (void); + +static void Comment__2 (void) +{ + BOOLEAN isExported; + CHAR commentText[256]; + INT16 i, nestLevel; + CHAR prevCh, nextCh; + i = 0; + while (i <= 255) { + commentText[__X(i, 256)] = 0x00; + i += 1; + } + isExported = 0; + i = 0; + nestLevel = 1; + prevCh = 0x00; + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + isExported = 1; + OPM_Get(&OPS_ch); + if (OPS_ch == ')') { + commentText[0] = 0x00; + OPM_StoreComment(commentText, 256); + OPM_Get(&OPS_ch); + return; + } + } + while ((nestLevel > 0 && OPS_ch != 0x00)) { + if ((prevCh == '(' && OPS_ch == '*')) { + nestLevel += 1; + prevCh = 0x00; + } else if ((prevCh == '*' && OPS_ch == ')')) { + nestLevel -= 1; + if (nestLevel == 0) { + OPM_Get(&OPS_ch); + } else { + prevCh = 0x00; + } + } else { + if ((((isExported && nestLevel == 1)) && prevCh != 0x00)) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } + } + prevCh = OPS_ch; + } + if (nestLevel > 0) { + OPM_Get(&OPS_ch); + } + } + if (OPS_ch == 0x00) { + OPS_err(5); + } + if ((((((isExported && nestLevel == 0)) && prevCh != 0x00)) && prevCh != '*')) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } else { + OPM_LogWStr((CHAR*)"Truncating final comment character", 35); + OPM_LogWLn(); + } + } + if (isExported) { + if (i >= 256) { + OPM_LogWStr((CHAR*)"Warning: commentText overflow", 30); + OPM_LogWLn(); + i = 255; + } + commentText[__X(i, 256)] = 0x00; + OPM_StoreComment(commentText, 256); + } +} + +void OPS_Get (INT8 *sym) +{ + INT8 s; + struct Get__1 _s; + _s.lnk = Get__1_s; + Get__1_s = &_s; + OPM_errpos = OPM_curpos - 1; + while (OPS_ch <= ' ') { + if (OPS_ch == 0x00) { + *sym = 64; + Get__1_s = _s.lnk; + return; + } else { + OPM_Get(&OPS_ch); + } + } + switch (OPS_ch) { + case '"': case '\'': + OPS_Str(&s); + break; + case '#': + s = 10; + OPM_Get(&OPS_ch); + break; + case '&': + s = 5; + OPM_Get(&OPS_ch); + break; + case '(': + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + Comment__2(); + OPS_Get(&s); + } else { + s = 30; + } + break; + case ')': + s = 22; + OPM_Get(&OPS_ch); + break; + case '*': + s = 1; + OPM_Get(&OPS_ch); + break; + case '+': + s = 6; + OPM_Get(&OPS_ch); + break; + case ',': + s = 19; + OPM_Get(&OPS_ch); + break; + case '-': + s = 7; + OPM_Get(&OPS_ch); + break; + case '.': + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + s = 21; + } else { + s = 18; + } + break; + case '/': + s = 2; + OPM_Get(&OPS_ch); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + OPS_Number(); + s = 35; + break; + case ':': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 34; + } else { + s = 20; + } + break; + case ';': + s = 39; + OPM_Get(&OPS_ch); + break; + case '<': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 12; + } else { + s = 11; + } + break; + case '=': + s = 9; + OPM_Get(&OPS_ch); + break; + case '>': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 14; + } else { + s = 13; + } + break; + case 'A': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "ARRAY") == 0) { + s = 54; + } + break; + case 'B': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "BEGIN") == 0) { + s = 57; + } else if (__STRCMP(OPS_name, "BY") == 0) { + s = 29; + } + break; + case 'C': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "CASE") == 0) { + s = 46; + } else if (__STRCMP(OPS_name, "CONST") == 0) { + s = 58; + } + break; + case 'D': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "DO") == 0) { + s = 27; + } else if (__STRCMP(OPS_name, "DIV") == 0) { + s = 3; + } + break; + case 'E': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "END") == 0) { + s = 41; + } else if (__STRCMP(OPS_name, "ELSE") == 0) { + s = 42; + } else if (__STRCMP(OPS_name, "ELSIF") == 0) { + s = 43; + } else if (__STRCMP(OPS_name, "EXIT") == 0) { + s = 52; + } + break; + case 'F': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "FOR") == 0) { + s = 49; + } + break; + case 'I': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "IF") == 0) { + s = 45; + } else if (__STRCMP(OPS_name, "IN") == 0) { + s = 15; + } else if (__STRCMP(OPS_name, "IS") == 0) { + s = 16; + } else if (__STRCMP(OPS_name, "IMPORT") == 0) { + s = 62; + } + break; + case 'L': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "LOOP") == 0) { + s = 50; + } + break; + case 'M': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "MOD") == 0) { + s = 4; + } else if (__STRCMP(OPS_name, "MODULE") == 0) { + s = 63; + } + break; + case 'N': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "NIL") == 0) { + s = 36; + } + break; + case 'O': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "OR") == 0) { + s = 8; + } else if (__STRCMP(OPS_name, "OF") == 0) { + s = 25; + } + break; + case 'P': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "PROCEDURE") == 0) { + s = 61; + } else if (__STRCMP(OPS_name, "POINTER") == 0) { + s = 56; + } + break; + case 'R': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "RECORD") == 0) { + s = 55; + } else if (__STRCMP(OPS_name, "REPEAT") == 0) { + s = 48; + } else if (__STRCMP(OPS_name, "RETURN") == 0) { + s = 53; + } + break; + case 'T': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "THEN") == 0) { + s = 26; + } else if (__STRCMP(OPS_name, "TO") == 0) { + s = 28; + } else if (__STRCMP(OPS_name, "TYPE") == 0) { + s = 59; + } + break; + case 'U': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "UNTIL") == 0) { + s = 44; + } + break; + case 'V': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "VAR") == 0) { + s = 60; + } + break; + case 'W': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "WHILE") == 0) { + s = 47; + } else if (__STRCMP(OPS_name, "WITH") == 0) { + s = 51; + } + break; + case 'G': case 'H': case 'J': case 'K': case 'Q': + case 'S': case 'X': case 'Y': case 'Z': + OPS_Identifier(&s); + break; + case '[': + s = 31; + OPM_Get(&OPS_ch); + break; + case ']': + s = 23; + OPM_Get(&OPS_ch); + break; + case '^': + s = 17; + OPM_Get(&OPS_ch); + break; + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + OPS_Identifier(&s); + break; + case '{': + s = 32; + OPM_Get(&OPS_ch); + break; + case '|': + s = 40; + OPM_Get(&OPS_ch); + break; + case '}': + s = 24; + OPM_Get(&OPS_ch); + break; + case '~': + s = 33; + OPM_Get(&OPS_ch); + break; + case 0x7f: + s = 21; + OPM_Get(&OPS_ch); + break; + default: + s = 0; + OPM_Get(&OPS_ch); + break; + } + *sym = s; + Get__1_s = _s.lnk; +} + +void OPS_Init (void) +{ + OPS_ch = ' '; +} + + +export void *OPS__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __REGMOD("OPS", 0); + __REGCMD("Init", OPS_Init); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPS.h b/bootstrap/unix-88/OPS.h new file mode 100644 index 00000000..19e222ac --- /dev/null +++ b/bootstrap/unix-88/OPS.h @@ -0,0 +1,28 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPS__h +#define OPS__h + +#include "SYSTEM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +import OPS_Name OPS_name; +import OPS_String OPS_str; +import INT16 OPS_numtyp; +import INT64 OPS_intval; +import REAL OPS_realval; +import LONGREAL OPS_lrlval; + + +import void OPS_Get (INT8 *sym); +import void OPS_Init (void); +import void *OPS__init(void); + + +#endif // OPS diff --git a/bootstrap/unix-88/OPT.c b/bootstrap/unix-88/OPT.c new file mode 100644 index 00000000..c3999981 --- /dev/null +++ b/bootstrap/unix-88/OPT.c @@ -0,0 +1,2261 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_ExpCtxt { + INT32 reffp; + INT16 ref; + INT8 nofm; + INT8 locmno[64]; + } OPT_ExpCtxt; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_ImpCtxt { + INT32 nextTag, reffp; + INT16 nofr, minr, nofm; + BOOLEAN self; + OPT_Struct ref[255]; + OPT_Object old[255]; + INT32 pvfp[255]; + INT8 glbmno[64]; + } OPT_ImpCtxt; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused, fpdone, idfpdone; + INT32 idfp, pbfp, pvfp; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +export OPT_Object OPT_topScope; +export OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +export OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +export INT8 OPT_nofGmod; +export OPT_Object OPT_GlbMod[64]; +export OPS_Name OPT_SelfName; +export BOOLEAN OPT_SYSimported; +static OPT_Object OPT_universe, OPT_syslink; +static OPT_ImpCtxt OPT_impCtxt; +static OPT_ExpCtxt OPT_expCtxt; +static INT32 OPT_nofhdfld; +static BOOLEAN OPT_newsf, OPT_findpc, OPT_extsf, OPT_sfpresent, OPT_symExtended, OPT_symNew; +static INT32 OPT_recno; +export OPT_Link OPT_Links; + +export ADDRESS *OPT_ConstDesc__typ; +export ADDRESS *OPT_ObjDesc__typ; +export ADDRESS *OPT_StrDesc__typ; +export ADDRESS *OPT_NodeDesc__typ; +export ADDRESS *OPT_ImpCtxt__typ; +export ADDRESS *OPT_ExpCtxt__typ; +export ADDRESS *OPT_LinkDesc__typ; + +export void OPT_Align (INT32 *adr, INT32 base); +export INT32 OPT_BaseAlignment (OPT_Struct typ); +export void OPT_Close (void); +export void OPT_CloseScope (void); +static void OPT_DebugStruct (OPT_Struct btyp); +static void OPT_EnterBoolConst (OPS_Name name, INT32 value); +static void OPT_EnterProc (OPS_Name name, INT16 num); +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res); +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res); +export void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +export void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len); +export void OPT_FPrintObj (OPT_Object obj); +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par); +export void OPT_FPrintStr (OPT_Struct typ); +export void OPT_Find (OPT_Object *res); +export void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +export void OPT_FindImport (OPT_Object mod, OPT_Object *res); +export void OPT_IdFPrint (OPT_Struct typ); +export void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +static void OPT_InConstant (INT32 f, OPT_Const conval); +static OPT_Object OPT_InFld (void); +static void OPT_InLinks (void); +static void OPT_InMod (INT8 *mno); +static void OPT_InName (CHAR *name, ADDRESS name__len); +static OPT_Object OPT_InObj (INT8 mno); +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par); +static void OPT_InStruct (OPT_Struct *typ); +static OPT_Object OPT_InTProc (INT8 mno); +static OPT_Struct OPT_InTyp (INT32 tag); +export void OPT_Init (OPS_Name name, UINT32 opt); +export void OPT_InitRecno (void); +static void OPT_InitStruct (OPT_Struct *typ, INT8 form); +export void OPT_Insert (OPS_Name name, OPT_Object *obj); +export void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +export INT16 OPT_IntSize (INT64 n); +export OPT_Struct OPT_IntType (INT32 size); +export OPT_Const OPT_NewConst (void); +export OPT_ConstExt OPT_NewExt (void); +export OPT_Node OPT_NewNode (INT8 class); +export OPT_Object OPT_NewObj (void); +export OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +export void OPT_OpenScope (INT8 level, OPT_Object owner); +static void OPT_OutConstant (OPT_Object obj); +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void OPT_OutLinks (void); +static void OPT_OutMod (INT16 mno); +static void OPT_OutName (CHAR *name, ADDRESS name__len); +static void OPT_OutObj (OPT_Object obj); +static void OPT_OutSign (OPT_Struct result, OPT_Object par); +static void OPT_OutStr (OPT_Struct typ); +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj); +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len); +export OPT_Struct OPT_SetType (INT32 size); +export OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +export INT32 OPT_SizeAlignment (INT32 size); +export void OPT_TypSize (OPT_Struct typ); +static void OPT_err (INT16 n); + + +void OPT_InitRecno (void) +{ + OPT_recno = 0; +} + +static void OPT_err (INT16 n) +{ + OPM_err(n); +} + +INT16 OPT_IntSize (INT64 n) +{ + INT16 bytes; + if (n < 0) { + n = -(n + 1); + } + bytes = 1; + while ((bytes < 8 && __ASH(n, -(__ASHL(bytes, 3) - 1)) != 0)) { + bytes += 1; + } + return bytes; +} + +OPT_Struct OPT_IntType (INT32 size) +{ + if (size <= OPT_int8typ->size) { + return OPT_int8typ; + } + if (size <= OPT_int16typ->size) { + return OPT_int16typ; + } + if (size <= OPT_int32typ->size) { + return OPT_int32typ; + } + return OPT_int64typ; +} + +OPT_Struct OPT_SetType (INT32 size) +{ + if (size == OPT_set32typ->size) { + return OPT_set32typ; + } + return OPT_set64typ; +} + +OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir) +{ + INT16 i; + __ASSERT(x->form == 4, 0); + __ASSERT(x->BaseTyp == OPT_undftyp, 0); + __ASSERT(dir == 1 || dir == -1, 0); + if (dir > 0) { + if (x->size < OPT_sinttyp->size) { + return OPT_sinttyp; + } + if (x->size < OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size < OPT_linttyp->size) { + return OPT_linttyp; + } + return OPT_int64typ; + } else { + if (x->size > OPT_linttyp->size) { + return OPT_linttyp; + } + if (x->size > OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size > OPT_sinttyp->size) { + return OPT_sinttyp; + } + return OPT_int8typ; + } + __RETCHK; +} + +void OPT_Align (INT32 *adr, INT32 base) +{ + switch (base) { + case 2: + *adr += __MASK(*adr, -2); + break; + case 4: + *adr += __MASK(-*adr, -4); + break; + case 8: + *adr += __MASK(-*adr, -8); + break; + case 16: + *adr += __MASK(-*adr, -16); + break; + default: + break; + } +} + +INT32 OPT_SizeAlignment (INT32 size) +{ + INT32 alignment; + if (size < OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; + } + return alignment; +} + +INT32 OPT_BaseAlignment (OPT_Struct typ) +{ + INT32 alignment; + if (typ->form == 13) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPT_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPT_SizeAlignment(typ->size); + } + return alignment; +} + +void OPT_TypSize (OPT_Struct typ) +{ + INT16 f, c; + INT32 offset, size, base, fbase, off0; + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + if (typ == OPT_undftyp) { + OPM_err(58); + } else if (typ->size == -1) { + f = typ->form; + c = typ->comp; + if (c == 4) { + btyp = typ->BaseTyp; + if (btyp == NIL) { + offset = 0; + base = 1; + } else { + OPT_TypSize(btyp); + offset = btyp->size - __ASHR(btyp->sysflag, 8); + base = btyp->align; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + btyp = fld->typ; + OPT_TypSize(btyp); + size = btyp->size; + fbase = OPT_BaseAlignment(btyp); + OPT_Align(&offset, fbase); + fld->adr = offset; + offset += size; + if (fbase > base) { + base = fbase; + } + fld = fld->link; + } + off0 = offset; + if (offset == 0) { + offset = 1; + } + OPT_Align(&offset, base); + if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { + OPT_recno += 1; + base += __ASHL(OPT_recno, 16); + } + typ->size = offset; + typ->align = base; + typ->sysflag = __MASK(typ->sysflag, -256) + __SHORT(__ASHL(offset - off0, 8), 32768); + } else if (c == 2) { + OPT_TypSize(typ->BaseTyp); + typ->size = typ->n * typ->BaseTyp->size; + } else if (f == 11) { + typ->size = OPM_AddressSize; + if (typ->BaseTyp == OPT_undftyp) { + OPM_Mark(128, typ->n); + } else { + OPT_TypSize(typ->BaseTyp); + } + } else if (f == 12) { + typ->size = OPM_AddressSize; + } else if (c == 3) { + btyp = typ->BaseTyp; + OPT_TypSize(btyp); + if (btyp->comp == 3) { + typ->size = btyp->size + 4; + } else { + typ->size = 8; + } + } + } +} + +OPT_Const OPT_NewConst (void) +{ + OPT_Const const_ = NIL; + __NEW(const_, OPT_ConstDesc); + return const_; +} + +OPT_Object OPT_NewObj (void) +{ + OPT_Object obj = NIL; + __NEW(obj, OPT_ObjDesc); + obj->typ = NIL; + obj->conval = NIL; + obj->comment = NIL; + obj->name[0] = 0x00; + return obj; +} + +OPT_Struct OPT_NewStr (INT8 form, INT8 comp) +{ + OPT_Struct typ = NIL; + __NEW(typ, OPT_StrDesc); + typ->form = form; + typ->comp = comp; + typ->ref = 255; + if (form != 0) { + typ->txtpos = OPM_errpos; + } + typ->size = -1; + typ->BaseTyp = OPT_undftyp; + return typ; +} + +OPT_Node OPT_NewNode (INT8 class) +{ + OPT_Node node = NIL; + __NEW(node, OPT_NodeDesc); + node->class = class; + return node; +} + +OPT_ConstExt OPT_NewExt (void) +{ + OPT_ConstExt ext = NIL; + ext = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + return ext; +} + +void OPT_OpenScope (INT8 level, OPT_Object owner) +{ + OPT_Object head = NIL; + head = OPT_NewObj(); + head->mode = 12; + head->mnolev = level; + head->link = owner; + if (owner != NIL) { + owner->scope = head; + } + head->left = OPT_topScope; + head->right = NIL; + head->scope = NIL; + OPT_topScope = head; +} + +void OPT_CloseScope (void) +{ + OPT_topScope = OPT_topScope->left; +} + +void OPT_Init (OPS_Name name, UINT32 opt) +{ + OPT_topScope = OPT_universe; + OPT_OpenScope(0, NIL); + OPT_SYSimported = 0; + __MOVE(name, OPT_SelfName, 256); + __MOVE(name, OPT_topScope->name, 256); + OPT_GlbMod[0] = OPT_topScope; + OPT_nofGmod = 1; + OPT_newsf = __IN(4, opt, 32); + OPT_findpc = __IN(8, opt, 32); + OPT_extsf = OPT_newsf || __IN(9, opt, 32); + OPT_sfpresent = 1; + __NEW(OPT_Links, OPT_LinkDesc); + __MOVE(name, OPT_Links->name, 256); +} + +void OPT_Close (void) +{ + INT16 i; + OPT_CloseScope(); + i = 0; + while (i < 64) { + OPT_GlbMod[__X(i, 64)] = NIL; + i += 1; + } + i = 14; + while (i < 255) { + OPT_impCtxt.ref[__X(i, 255)] = NIL; + OPT_impCtxt.old[__X(i, 255)] = NIL; + i += 1; + } +} + +void OPT_FindImport (OPT_Object mod, OPT_Object *res) +{ + OPT_Object obj = NIL; + obj = mod->scope; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + if ((obj->mode == 5 && obj->vis == 0)) { + obj = NIL; + } else { + obj->used = 1; + } + break; + } + } + *res = obj; +} + +void OPT_Find (OPT_Object *res) +{ + OPT_Object obj = NIL, head = NIL; + head = OPT_topScope; + for (;;) { + obj = head->right; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + break; + } + } + if (obj != NIL) { + break; + } + head = head->left; + if (head == NIL) { + break; + } + } + *res = obj; +} + +void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res) +{ + OPT_Object obj = NIL; + while (typ != NIL) { + obj = typ->link; + while (obj != NIL) { + if (__STRCMP(name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(name, obj->name) > 0) { + obj = obj->right; + } else { + *res = obj; + return; + } + } + typ = typ->BaseTyp; + } + *res = NIL; +} + +void OPT_Insert (OPS_Name name, OPT_Object *obj) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + INT8 mnolev; + CHAR commentText[256]; + INT16 j; + ob0 = OPT_topScope; + ob1 = ob0->right; + left = 0; + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob0->right; + left = 0; + } else { + OPT_err(1); + ob0 = ob1; + ob1 = ob0->right; + } + } else { + ob1 = OPT_NewObj(); + ob1->leaf = 1; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + __COPY(name, ob1->name, 256); + mnolev = OPT_topScope->mnolev; + ob1->mnolev = mnolev; + OPM_GetComment((void*)commentText, 256); + if (commentText[0] != 0x00) { + ob1->comment = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + j = 0; + while ((j < 255 && commentText[__X(j, 256)] != 0x00)) { + (*ob1->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*ob1->comment)[__X(j, 256)] = 0x00; + } + break; + } + } + *obj = ob1; +} + +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_FPrint(&*fp, (INT16)ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_DebugStruct (OPT_Struct btyp) +{ + OPM_LogWLn(); + if (btyp == NIL) { + OPM_LogWStr((CHAR*)"btyp is nil", 12); + OPM_LogWLn(); + } + OPM_LogWStr((CHAR*)"btyp^.strobji^.name = ", 23); + OPM_LogWStr(btyp->strobj->name, 256); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.form = ", 14); + OPM_LogWNum(btyp->form, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.comp = ", 14); + OPM_LogWNum(btyp->comp, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.mno = ", 13); + OPM_LogWNum(btyp->mno, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.extlev = ", 16); + OPM_LogWNum(btyp->extlev, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.size = ", 14); + OPM_LogWNum(btyp->size, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.align = ", 15); + OPM_LogWNum(btyp->align, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.txtpos = ", 16); + OPM_LogWNum(btyp->txtpos, 0); + OPM_LogWLn(); +} + +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par) +{ + OPT_IdFPrint(result); + OPM_FPrint(&*fp, result->idfp); + while (par != NIL) { + OPM_FPrint(&*fp, par->mode); + OPT_IdFPrint(par->typ); + OPM_FPrint(&*fp, par->typ->idfp); + par = par->link; + } +} + +void OPT_IdFPrint (OPT_Struct typ) +{ + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL; + INT32 idfp; + INT16 f, c; + if (!typ->idfpdone) { + typ->idfpdone = 1; + idfp = 0; + f = typ->form; + OPM_FPrint(&idfp, f); + if (__IN(f, 0x90, 32)) { + OPM_FPrint(&idfp, typ->size); + } + c = typ->comp; + OPM_FPrint(&idfp, c); + btyp = typ->BaseTyp; + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_FPrintName(&idfp, (void*)OPT_GlbMod[__X(typ->mno, 64)]->name, 256); + OPT_FPrintName(&idfp, (void*)strobj->name, 256); + } + if ((f == 11 || (c == 4 && btyp != NIL)) || c == 3) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + } else if (c == 2) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + OPM_FPrint(&idfp, typ->n); + } else if (f == 12) { + OPT_FPrintSign(&idfp, btyp, typ->link); + } + typ->idfp = idfp; + } +} + +static struct FPrintStr__15 { + INT32 *pbfp, *pvfp; + struct FPrintStr__15 *lnk; +} *FPrintStr__15_s; + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void FPrintTProcs__20 (OPT_Object obj); + +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + FPrintFlds__16(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + FPrintHdFld__18(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + FPrintHdFld__18(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_FPrint(&*FPrintStr__15_s->pvfp, 11); + OPM_FPrint(&*FPrintStr__15_s->pvfp, adr); + OPT_nofhdfld += 1; + } +} + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->vis); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)fld->name, 256); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->adr); + OPT_FPrintStr(fld->typ); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->typ->pbfp); + OPM_FPrint(&*FPrintStr__15_s->pvfp, fld->typ->pvfp); + } else { + FPrintHdFld__18(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void FPrintTProcs__20 (OPT_Object obj) +{ + if (obj != NIL) { + FPrintTProcs__20(obj->left); + if (obj->mode == 13) { + if (obj->vis != 0) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, 13); + OPM_FPrint(&*FPrintStr__15_s->pbfp, __ASHR(obj->adr, 16)); + OPT_FPrintSign(&*FPrintStr__15_s->pbfp, obj->typ, obj->link); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)obj->name, 256); + } + } + FPrintTProcs__20(obj->right); + } +} + +void OPT_FPrintStr (OPT_Struct typ) +{ + INT16 f, c; + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL, bstrobj = NIL; + INT32 pbfp, pvfp; + struct FPrintStr__15 _s; + _s.pbfp = &pbfp; + _s.pvfp = &pvfp; + _s.lnk = FPrintStr__15_s; + FPrintStr__15_s = &_s; + if (!typ->fpdone) { + OPT_IdFPrint(typ); + pbfp = typ->idfp; + if (typ->sysflag != 0) { + OPM_FPrint(&pbfp, typ->sysflag); + } + pvfp = pbfp; + typ->pbfp = pbfp; + typ->pvfp = pvfp; + typ->fpdone = 1; + f = typ->form; + c = typ->comp; + btyp = typ->BaseTyp; + if (f == 11) { + strobj = typ->strobj; + bstrobj = btyp->strobj; + if (((strobj == NIL || strobj->name[0] == 0x00) || bstrobj == NIL) || bstrobj->name[0] == 0x00) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + pvfp = pbfp; + } + } else if (f == 12) { + } else if (__IN(c, 0x0c, 32)) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pvfp); + pvfp = pbfp; + } else { + if (btyp != NIL) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + OPM_FPrint(&pvfp, btyp->pvfp); + } + OPM_FPrint(&pvfp, typ->size); + OPM_FPrint(&pvfp, typ->align); + OPM_FPrint(&pvfp, typ->n); + OPT_nofhdfld = 0; + FPrintFlds__16(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(225, typ->txtpos); + } + FPrintTProcs__20(typ->link); + OPM_FPrint(&pvfp, pbfp); + strobj = typ->strobj; + if (strobj == NIL || strobj->name[0] == 0x00) { + pbfp = pvfp; + } + } + typ->pbfp = pbfp; + typ->pvfp = pvfp; + } + FPrintStr__15_s = _s.lnk; +} + +void OPT_FPrintObj (OPT_Object obj) +{ + INT32 fprint; + INT16 f, m; + REAL rval; + OPT_ConstExt ext = NIL; + if (!obj->fpdone) { + fprint = 0; + obj->fpdone = 1; + OPM_FPrint(&fprint, obj->mode); + if (obj->mode == 3) { + f = obj->typ->form; + OPM_FPrint(&fprint, f); + switch (f) { + case 2: case 3: case 4: + OPM_FPrint(&fprint, obj->conval->intval); + break; + case 7: + OPM_FPrintSet(&fprint, obj->conval->setval); + break; + case 5: + rval = obj->conval->realval; + OPM_FPrintReal(&fprint, rval); + break; + case 6: + OPM_FPrintLReal(&fprint, obj->conval->realval); + break; + case 8: + OPT_FPrintName(&fprint, (void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } + } else if (obj->mode == 1) { + OPM_FPrint(&fprint, obj->vis); + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } else if (__IN(obj->mode, 0x0480, 32)) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + } else if (obj->mode == 9) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + ext = obj->conval->ext; + m = (INT16)(*ext)[0]; + f = 1; + OPM_FPrint(&fprint, m); + while (f <= m) { + OPM_FPrint(&fprint, (INT16)(*ext)[__X(f, 256)]); + f += 1; + } + } else if (obj->mode == 5) { + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } + obj->fprint = fprint; + } +} + +void OPT_FPrintErr (OPT_Object obj, INT16 errcode) +{ + INT16 i, j; + CHAR ch; + if (obj->mnolev != 0) { + __COPY(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, OPM_objname, 64); + i = 0; + while (OPM_objname[__X(i, 64)] != 0x00) { + i += 1; + } + OPM_objname[__X(i, 64)] = '.'; + j = 0; + i += 1; + do { + ch = obj->name[__X(j, 256)]; + OPM_objname[__X(i, 64)] = ch; + j += 1; + i += 1; + } while (!(ch == 0x00)); + } else { + __COPY(obj->name, OPM_objname, 64); + } + if (errcode == 249) { + if (OPM_noerr) { + OPT_err(errcode); + } + } else if (errcode == 253) { + if ((((!OPT_symNew && !OPT_symExtended)) && !OPT_extsf)) { + OPT_err(errcode); + } + OPT_symExtended = 1; + } else { + if ((!OPT_symNew && !OPT_newsf)) { + OPT_err(errcode); + } + OPT_symNew = 1; + } +} + +void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + if (*root == NIL) { + *root = obj; + *old = NIL; + } else { + ob0 = *root; + ob1 = ob0->right; + left = 0; + if (__STRCMP(obj->name, ob0->name) < 0) { + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(obj->name, ob0->name) > 0) { + ob1 = ob0->right; + left = 0; + } else { + *old = ob0; + return; + } + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(obj->name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob1->left; + left = 1; + } else if (__STRCMP(obj->name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob1->right; + left = 0; + } else { + *old = ob1; + break; + } + } else { + ob1 = obj; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + *old = NIL; + break; + } + } + } +} + +static void OPT_InName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + OPM_SymRCh(&ch); + name[__X(i, name__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_InMod (INT8 *mno) +{ + OPT_Object head = NIL; + OPS_Name name; + INT32 mn; + INT8 i; + mn = OPM_SymRInt(); + if (mn == 0) { + *mno = OPT_impCtxt.glbmno[0]; + } else { + if (mn == 16) { + OPT_InName((void*)name, 256); + if ((__STRCMP(name, OPT_SelfName) == 0 && !OPT_impCtxt.self)) { + OPT_err(154); + } + i = 0; + while ((i < OPT_nofGmod && __STRCMP(name, OPT_GlbMod[__X(i, 64)]->name) != 0)) { + i += 1; + } + if (i < OPT_nofGmod) { + *mno = i; + } else { + head = OPT_NewObj(); + head->mode = 12; + __COPY(name, head->name, 256); + *mno = OPT_nofGmod; + head->mnolev = -*mno; + if (OPT_nofGmod < 64) { + OPT_GlbMod[__X(*mno, 64)] = head; + OPT_nofGmod += 1; + } else { + OPT_err(227); + } + } + OPT_impCtxt.glbmno[__X(OPT_impCtxt.nofm, 64)] = *mno; + OPT_impCtxt.nofm += 1; + } else { + *mno = OPT_impCtxt.glbmno[__X(-mn, 64)]; + } + } +} + +static void OPT_InLinks (void) +{ + OPS_Name linkname; + OPT_Link l = NIL; + OPT_InName((void*)linkname, 256); + while (linkname[0] != 0x00) { + l = OPT_Links; + while ((l != NIL && __STRCMP(l->name, linkname) != 0)) { + l = l->next; + } + if (l == NIL) { + l = OPT_Links; + __NEW(OPT_Links, OPT_LinkDesc); + OPT_Links->next = l; + __MOVE(linkname, OPT_Links->name, 256); + } + OPT_InName((void*)linkname, 256); + } +} + +static void OPT_InConstant (INT32 f, OPT_Const conval) +{ + CHAR ch; + INT16 i; + OPT_ConstExt ext = NIL; + REAL rval; + switch (f) { + case 1: case 3: case 2: + OPM_SymRCh(&ch); + conval->intval = (INT16)ch; + break; + case 4: + conval->intval = OPM_SymRInt(); + break; + case 7: + OPM_SymRSet(&conval->setval); + break; + case 5: + OPM_SymRReal(&rval); + conval->realval = rval; + conval->intval = -1; + break; + case 6: + OPM_SymRLReal(&conval->realval); + conval->intval = -1; + break; + case 8: + ext = OPT_NewExt(); + conval->ext = ext; + i = 0; + do { + OPM_SymRCh(&ch); + (*ext)[__X(i, 256)] = ch; + i += 1; + } while (!(ch == 0x00)); + conval->intval2 = i; + conval->intval = -1; + break; + case 9: + conval->intval = 0; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", 37); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } +} + +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par) +{ + OPT_Object last = NIL, new = NIL; + INT32 tag; + OPT_InStruct(&*res); + tag = OPM_SymRInt(); + last = NIL; + while (tag != 18) { + if (tag < 0 || tag > 100) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag value in InSign: ", 37); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return; + } + new = OPT_NewObj(); + new->mnolev = -mno; + if (last == NIL) { + *par = new; + } else { + last->link = new; + } + if (tag == 23) { + new->mode = 1; + } else { + new->mode = 2; + } + OPT_InStruct(&new->typ); + new->adr = OPM_SymRInt(); + OPT_InName((void*)new->name, 256); + last = new; + tag = OPM_SymRInt(); + } +} + +static OPT_Object OPT_InFld (void) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + if (tag <= 26) { + obj->mode = 4; + if (tag == 26) { + obj->vis = 2; + } else { + obj->vis = 1; + } + OPT_InStruct(&obj->typ); + OPT_InName((void*)obj->name, 256); + obj->adr = OPM_SymRInt(); + } else { + obj->mode = 4; + if (tag == 27) { + __MOVE("@ptr", obj->name, 5); + } else { + __MOVE("@proc", obj->name, 6); + } + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = OPM_SymRInt(); + } + return obj; +} + +static OPT_Object OPT_InTProc (INT8 mno) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + obj->mnolev = -mno; + if (tag == 29) { + obj->mode = 13; + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + obj->vis = 1; + OPT_InName((void*)obj->name, 256); + obj->adr = __ASHL(OPM_SymRInt(), 16); + } else { + obj->mode = 13; + __MOVE("@tproc", obj->name, 7); + obj->link = OPT_NewObj(); + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = __ASHL(OPM_SymRInt(), 16); + } + return obj; +} + +static OPT_Struct OPT_InTyp (INT32 tag) +{ + if (tag == 4) { + return OPT_IntType(OPM_SymRInt()); + } else if (tag == 7) { + return OPT_SetType(OPM_SymRInt()); + } else { + return OPT_impCtxt.ref[__X(tag, 255)]; + } + __RETCHK; +} + +static void OPT_InStruct (OPT_Struct *typ) +{ + INT8 mno; + INT16 ref; + INT32 tag; + OPS_Name name; + OPT_Struct t = NIL; + OPT_Object obj = NIL, last = NIL, fld = NIL, old = NIL, dummy = NIL; + tag = OPM_SymRInt(); + if (tag != 34) { + *typ = OPT_InTyp(-tag); + } else { + ref = OPT_impCtxt.nofr; + OPT_impCtxt.nofr += 1; + if (ref < OPT_impCtxt.minr) { + OPT_impCtxt.minr = ref; + } + OPT_InMod(&mno); + OPT_InName((void*)name, 256); + obj = OPT_NewObj(); + if (name[0] == 0x00) { + if (OPT_impCtxt.self) { + old = NIL; + } else { + __MOVE("@", obj->name, 2); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + obj->name[0] = 0x00; + } + *typ = OPT_NewStr(0, 1); + } else { + __MOVE(name, obj->name, 256); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (old != NIL) { + OPT_FPrintObj(old); + OPT_impCtxt.pvfp[__X(ref, 255)] = old->typ->pvfp; + if (OPT_impCtxt.self) { + *typ = OPT_NewStr(0, 1); + } else { + *typ = old->typ; + (*typ)->link = NIL; + (*typ)->sysflag = 0; + (*typ)->fpdone = 0; + (*typ)->idfpdone = 0; + } + } else { + *typ = OPT_NewStr(0, 1); + } + } + OPT_impCtxt.ref[__X(ref, 255)] = *typ; + OPT_impCtxt.old[__X(ref, 255)] = old; + (*typ)->ref = ref + 255; + (*typ)->mno = mno; + (*typ)->allocated = 1; + (*typ)->strobj = obj; + obj->mode = 5; + obj->typ = *typ; + obj->mnolev = -mno; + obj->vis = 0; + tag = OPM_SymRInt(); + if (tag == 35) { + (*typ)->sysflag = __SHORTF(OPM_SymRInt(), 32768); + tag = OPM_SymRInt(); + } + switch (tag) { + case 36: + (*typ)->form = 11; + (*typ)->size = OPM_AddressSize; + (*typ)->n = 0; + OPT_InStruct(&(*typ)->BaseTyp); + break; + case 37: + (*typ)->form = 13; + (*typ)->comp = 2; + OPT_InStruct(&(*typ)->BaseTyp); + (*typ)->n = OPM_SymRInt(); + OPT_TypSize(*typ); + break; + case 38: + (*typ)->form = 13; + (*typ)->comp = 3; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + OPT_TypSize(*typ); + break; + case 39: + (*typ)->form = 13; + (*typ)->comp = 4; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp == OPT_notyp) { + (*typ)->BaseTyp = NIL; + } + (*typ)->extlev = 0; + t = (*typ)->BaseTyp; + while (t != NIL) { + (*typ)->extlev += 1; + t = t->BaseTyp; + } + (*typ)->size = OPM_SymRInt(); + (*typ)->align = OPM_SymRInt(); + (*typ)->n = OPM_SymRInt(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + last = NIL; + while ((OPT_impCtxt.nextTag >= 25 && OPT_impCtxt.nextTag <= 28)) { + fld = OPT_InFld(); + fld->mnolev = -mno; + if (last != NIL) { + last->link = fld; + } + last = fld; + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + while (OPT_impCtxt.nextTag != 18) { + fld = OPT_InTProc(mno); + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + break; + case 40: + (*typ)->form = 12; + (*typ)->size = OPM_AddressSize; + OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", 35); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + break; + } + if (ref == OPT_impCtxt.minr) { + while (ref < OPT_impCtxt.nofr) { + t = OPT_InTyp(ref); + OPT_FPrintStr(t); + obj = t->strobj; + if (obj->name[0] != 0x00) { + OPT_FPrintObj(obj); + } + old = OPT_impCtxt.old[__X(ref, 255)]; + if (old != NIL) { + t->strobj = old; + if (OPT_impCtxt.self) { + if (old->mnolev < 0) { + if (old->history != 5) { + if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } + } + } else if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } else if (old->vis == 0) { + old->history = 1; + } else { + old->history = 0; + } + } else { + if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 5; + } + if (old->fprint != obj->fprint) { + OPT_FPrintErr(old, 249); + } + } + } else if (OPT_impCtxt.self) { + obj->history = 4; + } else { + obj->history = 1; + } + ref += 1; + } + OPT_impCtxt.minr = 255; + } + } +} + +static OPT_Object OPT_InObj (INT8 mno) +{ + INT16 i, s; + CHAR ch; + OPT_Object obj = NIL, old = NIL; + OPT_Struct typ = NIL; + INT32 tag; + OPT_ConstExt ext = NIL; + OPS_Name commentText; + BOOLEAN hasComment; + INT16 j; + INT32 len; + tag = OPT_impCtxt.nextTag; + hasComment = 0; + while (tag == 41) { + len = OPM_SymRInt(); + if (len < 0) { + len = 0; + } + if (len > 255) { + len = 255; + } + i = 0; + while (i < len) { + OPM_SymRCh(&commentText[__X(i, 256)]); + i += 1; + } + commentText[__X(i, 256)] = 0x00; + hasComment = 1; + tag = OPM_SymRInt(); + } + OPT_impCtxt.nextTag = tag; + if (tag < 0 || tag > 50) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag in InObj: ", 30); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + if (tag == 19) { + OPT_InStruct(&typ); + obj = typ->strobj; + if (!OPT_impCtxt.self) { + obj->vis = 1; + } + } else { + obj = OPT_NewObj(); + obj->mnolev = -mno; + obj->vis = 1; + if (tag <= 11) { + obj->mode = 3; + obj->conval = OPT_NewConst(); + OPT_InConstant(tag, obj->conval); + obj->typ = OPT_InTyp(tag); + } else if ((tag >= 31 && tag <= 33)) { + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + switch (tag) { + case 31: + obj->mode = 7; + break; + case 32: + obj->mode = 10; + break; + case 33: + obj->mode = 9; + ext = OPT_NewExt(); + obj->conval->ext = ext; + s = __SHORTF(OPM_SymRInt(), 32768); + (*ext)[0] = __CHR(s); + i = 1; + while (i <= s) { + OPM_SymRCh(&(*ext)[__X(i, 256)]); + i += 1; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", 32); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + break; + } + } else if (tag == 20) { + obj->mode = 5; + OPT_InStruct(&obj->typ); + } else if (tag == 21 || tag == 22) { + obj->mode = 1; + if (tag == 22) { + obj->vis = 2; + } + OPT_InStruct(&obj->typ); + } else { + OPM_LogWStr((CHAR*)"ERROR: Unexpected tag in InObj: ", 33); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + OPT_InName((void*)obj->name, 256); + } + if ((hasComment && obj != NIL)) { + obj->comment = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + j = 0; + while ((((j < 255 && j < len)) && commentText[__X(j, 256)] != 0x00)) { + (*obj->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*obj->comment)[__X(j, 256)] = 0x00; + } + OPT_FPrintObj(obj); + if ((obj->mode == 1 && (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00))) { + OPM_FPrint(&OPT_impCtxt.reffp, obj->typ->ref - 255); + } + if (tag != 19) { + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (OPT_impCtxt.self) { + if (old != NIL) { + if (old->vis == 0) { + old->history = 4; + } else { + OPT_FPrintObj(old); + if (obj->fprint != old->fprint) { + old->history = 2; + } else if (obj->typ->pvfp != old->typ->pvfp) { + old->history = 3; + } else { + old->history = 1; + } + } + } else { + obj->history = 4; + } + } + } else { + if (OPT_impCtxt.self) { + if (obj->vis == 0) { + obj->history = 4; + } else if (obj->history == 0) { + obj->history = 1; + } + } + } + return obj; +} + +void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done) +{ + OPT_Object obj = NIL; + INT8 mno; + OPS_Name aliasName__copy; + __DUPARR(aliasName, OPS_Name); + if (__STRCMP(name, "SYSTEM") == 0) { + OPT_SYSimported = 1; + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->mnolev = 0; + obj->scope = OPT_syslink; + obj->typ = OPT_notyp; + } else { + OPT_impCtxt.nofr = 14; + OPT_impCtxt.minr = 255; + OPT_impCtxt.nofm = 0; + OPT_impCtxt.self = __STRCMP(aliasName, "@self") == 0; + OPT_impCtxt.reffp = 0; + if ((OPT_impCtxt.self && __IN(17, OPM_Options, 32))) { + OPM_DeleteSym((void*)name, 256); + *done = 0; + } else { + OPM_OldSym((void*)name, 256, &*done); + } + if (*done) { + OPT_InMod(&mno); + OPT_InLinks(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + while (!OPM_eofSF()) { + obj = OPT_InObj(mno); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->scope = OPT_GlbMod[__X(mno, 64)]->right; + OPT_GlbMod[__X(mno, 64)]->link = obj; + obj->mnolev = -mno; + obj->typ = OPT_notyp; + OPM_CloseOldSym(); + } else if (OPT_impCtxt.self) { + OPT_newsf = 1; + OPT_extsf = 1; + OPT_sfpresent = 0; + } else { + OPT_err(152); + } + } +} + +static void OPT_OutName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_SymWCh(ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_OutMod (INT16 mno) +{ + if (OPT_expCtxt.locmno[__X(mno, 64)] < 0) { + OPM_SymWInt(16); + OPT_expCtxt.locmno[__X(mno, 64)] = OPT_expCtxt.nofm; + OPT_expCtxt.nofm += 1; + OPT_OutName((void*)OPT_GlbMod[__X(mno, 64)]->name, 256); + } else { + OPM_SymWInt(-OPT_expCtxt.locmno[__X(mno, 64)]); + } +} + +static void OPT_OutLinks (void) +{ + OPT_Link l = NIL; + l = OPT_Links; + while (l != NIL) { + OPT_OutName((void*)l->name, 256); + l = l->next; + } + OPM_SymWCh(0x00); +} + +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + OPT_OutFlds(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + OPT_OutHdFld(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + OPT_OutHdFld(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_SymWInt(27); + OPM_SymWInt(adr); + OPT_nofhdfld += 1; + } +} + +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + if (fld->vis == 2) { + OPM_SymWInt(26); + } else { + OPM_SymWInt(25); + } + OPT_OutStr(fld->typ); + OPT_OutName((void*)fld->name, 256); + OPM_SymWInt(fld->adr); + } else { + OPT_OutHdFld(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void OPT_OutSign (OPT_Struct result, OPT_Object par) +{ + OPT_OutStr(result); + while (par != NIL) { + if (par->mode == 1) { + OPM_SymWInt(23); + } else { + OPM_SymWInt(24); + } + OPT_OutStr(par->typ); + OPM_SymWInt(par->adr); + OPT_OutName((void*)par->name, 256); + par = par->link; + } + OPM_SymWInt(18); +} + +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj) +{ + if (obj != NIL) { + OPT_OutTProcs(typ, obj->left); + if (obj->mode == 13) { + if ((((typ->BaseTyp != NIL && __ASHR(obj->adr, 16) < typ->BaseTyp->n)) && obj->vis == 0)) { + OPM_Mark(109, typ->txtpos); + } + if (obj->vis != 0) { + if (obj->vis != 0) { + OPM_SymWInt(29); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } else { + OPM_SymWInt(30); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } + } + } + OPT_OutTProcs(typ, obj->right); + } +} + +static void OPT_OutStr (OPT_Struct typ) +{ + OPT_Object strobj = NIL; + if (typ->ref < OPT_expCtxt.ref) { + OPM_SymWInt(-typ->ref); + if (__IN(typ->ref, 0x90, 32)) { + OPM_SymWInt(typ->size); + } + } else { + OPM_SymWInt(34); + typ->ref = OPT_expCtxt.ref; + OPT_expCtxt.ref += 1; + if (OPT_expCtxt.ref >= 255) { + OPT_err(228); + } + OPT_OutMod(typ->mno); + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_OutName((void*)strobj->name, 256); + switch (strobj->history) { + case 2: + OPT_FPrintErr(strobj, 252); + break; + case 3: + OPT_FPrintErr(strobj, 251); + break; + case 5: + OPT_FPrintErr(strobj, 249); + break; + default: + break; + } + } else { + OPM_SymWCh(0x00); + } + if (typ->sysflag != 0) { + OPM_SymWInt(35); + OPM_SymWInt(typ->sysflag); + } + switch (typ->form) { + case 11: + OPM_SymWInt(36); + OPT_OutStr(typ->BaseTyp); + break; + case 12: + OPM_SymWInt(40); + OPT_OutSign(typ->BaseTyp, typ->link); + break; + case 13: + switch (typ->comp) { + case 2: + OPM_SymWInt(37); + OPT_OutStr(typ->BaseTyp); + OPM_SymWInt(typ->n); + break; + case 3: + OPM_SymWInt(38); + OPT_OutStr(typ->BaseTyp); + break; + case 4: + OPM_SymWInt(39); + if (typ->BaseTyp == NIL) { + OPT_OutStr(OPT_notyp); + } else { + OPT_OutStr(typ->BaseTyp); + } + OPM_SymWInt(typ->size); + OPM_SymWInt(typ->align); + OPM_SymWInt(typ->n); + OPT_nofhdfld = 0; + OPT_OutFlds(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(223, typ->txtpos); + } + OPT_OutTProcs(typ, typ->link); + OPM_SymWInt(18); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", 39); + OPM_LogWNum(typ->comp, 0); + OPM_LogWLn(); + break; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", 39); + OPM_LogWNum(typ->form, 0); + OPM_LogWLn(); + break; + } + } +} + +static void OPT_OutConstant (OPT_Object obj) +{ + INT16 f; + REAL rval; + f = obj->typ->form; + OPM_SymWInt(f); + switch (f) { + case 2: case 3: + OPM_SymWCh(__CHR(obj->conval->intval)); + break; + case 4: + OPM_SymWInt(obj->conval->intval); + OPM_SymWInt(obj->typ->size); + break; + case 7: + OPM_SymWSet(obj->conval->setval); + OPM_SymWInt(obj->typ->size); + break; + case 5: + rval = obj->conval->realval; + OPM_SymWReal(rval); + break; + case 6: + OPM_SymWLReal(obj->conval->realval); + break; + case 8: + OPT_OutName((void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } +} + +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_SymWCh(text[__X(i, text__len)]); + i += 1; + } + OPM_SymWCh(0x00); + __DEL(text); +} + +static void OPT_OutObj (OPT_Object obj) +{ + INT16 i, j; + OPT_ConstExt ext = NIL; + INT16 k, l; + if (obj != NIL) { + OPT_OutObj(obj->left); + if (__IN(obj->mode, 0x06ea, 32)) { + if (obj->comment != NIL) { + OPM_SymWInt(41); + k = 0; + while ((k < 255 && (*obj->comment)[__X(k, 256)] != 0x00)) { + k += 1; + } + OPM_SymWInt(k); + l = 0; + while (l < k) { + OPM_SymWCh((*obj->comment)[__X(l, 256)]); + l += 1; + } + } + if (obj->history == 4) { + OPT_FPrintErr(obj, 250); + } else if (obj->vis != 0) { + switch (obj->history) { + case 0: + OPT_FPrintErr(obj, 253); + break; + case 1: + break; + case 2: + OPT_FPrintErr(obj, 252); + break; + case 3: + OPT_FPrintErr(obj, 251); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", 42); + OPM_LogWNum(obj->history, 0); + OPM_LogWLn(); + break; + } + switch (obj->mode) { + case 3: + OPT_OutConstant(obj); + OPT_OutName((void*)obj->name, 256); + break; + case 5: + if (obj->typ->strobj == obj) { + OPM_SymWInt(19); + OPT_OutStr(obj->typ); + } else { + OPM_SymWInt(20); + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + } + break; + case 1: + if (obj->vis == 2) { + OPM_SymWInt(22); + } else { + OPM_SymWInt(21); + } + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + if (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00) { + OPM_FPrint(&OPT_expCtxt.reffp, obj->typ->ref); + } + break; + case 7: + OPM_SymWInt(31); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 10: + OPM_SymWInt(32); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 9: + OPM_SymWInt(33); + OPT_OutSign(obj->typ, obj->link); + ext = obj->conval->ext; + j = (INT16)(*ext)[0]; + i = 1; + OPM_SymWInt(j); + while (i <= j) { + OPM_SymWCh((*ext)[__X(i, 256)]); + i += 1; + } + OPT_OutName((void*)obj->name, 256); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", 38); + OPM_LogWNum(obj->mode, 0); + OPM_LogWLn(); + break; + } + } + } + OPT_OutObj(obj->right); + } +} + +void OPT_Export (BOOLEAN *ext, BOOLEAN *new) +{ + INT16 i; + INT8 nofmod; + BOOLEAN done; + OPT_symExtended = 0; + OPT_symNew = 0; + nofmod = OPT_nofGmod; + OPT_Import((CHAR*)"@self", OPT_SelfName, &done); + OPT_nofGmod = nofmod; + if (OPM_noerr) { + OPM_NewSym((void*)OPT_SelfName, 256); + if (OPM_noerr) { + OPM_SymWInt(16); + OPT_OutName((void*)OPT_SelfName, 256); + OPT_OutLinks(); + OPT_expCtxt.reffp = 0; + OPT_expCtxt.ref = 14; + OPT_expCtxt.nofm = 1; + OPT_expCtxt.locmno[0] = 0; + i = 1; + while (i < 64) { + OPT_expCtxt.locmno[__X(i, 64)] = -1; + i += 1; + } + OPT_OutObj(OPT_topScope->right); + *ext = (OPT_sfpresent && OPT_symExtended); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); + if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { + *new = 1; + if (!OPT_extsf) { + OPT_err(155); + } + } + OPT_newsf = 0; + OPT_symNew = 0; + if (!OPM_noerr || OPT_findpc) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } +} + +static void OPT_InitStruct (OPT_Struct *typ, INT8 form) +{ + *typ = OPT_NewStr(form, 1); + (*typ)->ref = form; + (*typ)->size = 1; + (*typ)->allocated = 1; + (*typ)->strobj = OPT_NewObj(); + (*typ)->pbfp = form; + (*typ)->pvfp = form; + (*typ)->fpdone = 1; + (*typ)->idfp = form; + (*typ)->idfpdone = 1; +} + +static void OPT_EnterBoolConst (OPS_Name name, INT32 value) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->conval = OPT_NewConst(); + obj->mode = 3; + obj->typ = OPT_booltyp; + obj->conval->intval = value; +} + +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + typ = OPT_NewStr(form, 1); + obj->mode = 5; + obj->typ = typ; + obj->vis = 1; + typ->strobj = obj; + typ->size = size; + typ->ref = form; + typ->allocated = 1; + typ->pbfp = form; + typ->pvfp = form; + typ->fpdone = 1; + typ->idfp = form; + typ->idfpdone = 1; + if (__IN(form, 0x90, 32)) { + OPM_FPrint(&typ->idfp, typ->size); + } + *res = typ; +} + +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 5; + obj->typ = NIL; + obj->vis = 1; + *res = obj; +} + +static void OPT_EnterProc (OPS_Name name, INT16 num) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 8; + obj->typ = OPT_notyp; + obj->adr = num; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPT_topScope); + P(OPT_undftyp); + P(OPT_niltyp); + P(OPT_notyp); + P(OPT_bytetyp); + P(OPT_cpbytetyp); + P(OPT_booltyp); + P(OPT_chartyp); + P(OPT_sinttyp); + P(OPT_inttyp); + P(OPT_linttyp); + P(OPT_hinttyp); + P(OPT_int8typ); + P(OPT_int16typ); + P(OPT_int32typ); + P(OPT_int64typ); + P(OPT_settyp); + P(OPT_set32typ); + P(OPT_set64typ); + P(OPT_realtyp); + P(OPT_lrltyp); + P(OPT_stringtyp); + P(OPT_adrtyp); + P(OPT_sysptrtyp); + P(OPT_sintobj); + P(OPT_intobj); + P(OPT_lintobj); + P(OPT_setobj); + __ENUMP(OPT_GlbMod, 64, P); + P(OPT_universe); + P(OPT_syslink); + __ENUMR(&OPT_impCtxt, OPT_ImpCtxt__typ, 5184, 1, P); + P(OPT_Links); +} + +__TDESC(OPT_ConstDesc, 1, 1) = {__TDFLDS("ConstDesc", 40), {0, -16}}; +__TDESC(OPT_ObjDesc, 1, 7) = {__TDFLDS("ObjDesc", 344), {0, 8, 16, 24, 304, 312, 336, -64}}; +__TDESC(OPT_StrDesc, 1, 3) = {__TDFLDS("StrDesc", 72), {48, 56, 64, -32}}; +__TDESC(OPT_NodeDesc, 1, 6) = {__TDFLDS("NodeDesc", 56), {0, 8, 16, 32, 40, 48, -56}}; +__TDESC(OPT_ImpCtxt, 1, 510) = {__TDFLDS("ImpCtxt", 5184), {16, 24, 32, 40, 48, 56, 64, 72, 80, 88, 96, 104, 112, 120, 128, 136, + 144, 152, 160, 168, 176, 184, 192, 200, 208, 216, 224, 232, 240, 248, 256, 264, + 272, 280, 288, 296, 304, 312, 320, 328, 336, 344, 352, 360, 368, 376, 384, 392, + 400, 408, 416, 424, 432, 440, 448, 456, 464, 472, 480, 488, 496, 504, 512, 520, + 528, 536, 544, 552, 560, 568, 576, 584, 592, 600, 608, 616, 624, 632, 640, 648, + 656, 664, 672, 680, 688, 696, 704, 712, 720, 728, 736, 744, 752, 760, 768, 776, + 784, 792, 800, 808, 816, 824, 832, 840, 848, 856, 864, 872, 880, 888, 896, 904, + 912, 920, 928, 936, 944, 952, 960, 968, 976, 984, 992, 1000, 1008, 1016, 1024, 1032, + 1040, 1048, 1056, 1064, 1072, 1080, 1088, 1096, 1104, 1112, 1120, 1128, 1136, 1144, 1152, 1160, + 1168, 1176, 1184, 1192, 1200, 1208, 1216, 1224, 1232, 1240, 1248, 1256, 1264, 1272, 1280, 1288, + 1296, 1304, 1312, 1320, 1328, 1336, 1344, 1352, 1360, 1368, 1376, 1384, 1392, 1400, 1408, 1416, + 1424, 1432, 1440, 1448, 1456, 1464, 1472, 1480, 1488, 1496, 1504, 1512, 1520, 1528, 1536, 1544, + 1552, 1560, 1568, 1576, 1584, 1592, 1600, 1608, 1616, 1624, 1632, 1640, 1648, 1656, 1664, 1672, + 1680, 1688, 1696, 1704, 1712, 1720, 1728, 1736, 1744, 1752, 1760, 1768, 1776, 1784, 1792, 1800, + 1808, 1816, 1824, 1832, 1840, 1848, 1856, 1864, 1872, 1880, 1888, 1896, 1904, 1912, 1920, 1928, + 1936, 1944, 1952, 1960, 1968, 1976, 1984, 1992, 2000, 2008, 2016, 2024, 2032, 2040, 2048, 2056, + 2064, 2072, 2080, 2088, 2096, 2104, 2112, 2120, 2128, 2136, 2144, 2152, 2160, 2168, 2176, 2184, + 2192, 2200, 2208, 2216, 2224, 2232, 2240, 2248, 2256, 2264, 2272, 2280, 2288, 2296, 2304, 2312, + 2320, 2328, 2336, 2344, 2352, 2360, 2368, 2376, 2384, 2392, 2400, 2408, 2416, 2424, 2432, 2440, + 2448, 2456, 2464, 2472, 2480, 2488, 2496, 2504, 2512, 2520, 2528, 2536, 2544, 2552, 2560, 2568, + 2576, 2584, 2592, 2600, 2608, 2616, 2624, 2632, 2640, 2648, 2656, 2664, 2672, 2680, 2688, 2696, + 2704, 2712, 2720, 2728, 2736, 2744, 2752, 2760, 2768, 2776, 2784, 2792, 2800, 2808, 2816, 2824, + 2832, 2840, 2848, 2856, 2864, 2872, 2880, 2888, 2896, 2904, 2912, 2920, 2928, 2936, 2944, 2952, + 2960, 2968, 2976, 2984, 2992, 3000, 3008, 3016, 3024, 3032, 3040, 3048, 3056, 3064, 3072, 3080, + 3088, 3096, 3104, 3112, 3120, 3128, 3136, 3144, 3152, 3160, 3168, 3176, 3184, 3192, 3200, 3208, + 3216, 3224, 3232, 3240, 3248, 3256, 3264, 3272, 3280, 3288, 3296, 3304, 3312, 3320, 3328, 3336, + 3344, 3352, 3360, 3368, 3376, 3384, 3392, 3400, 3408, 3416, 3424, 3432, 3440, 3448, 3456, 3464, + 3472, 3480, 3488, 3496, 3504, 3512, 3520, 3528, 3536, 3544, 3552, 3560, 3568, 3576, 3584, 3592, + 3600, 3608, 3616, 3624, 3632, 3640, 3648, 3656, 3664, 3672, 3680, 3688, 3696, 3704, 3712, 3720, + 3728, 3736, 3744, 3752, 3760, 3768, 3776, 3784, 3792, 3800, 3808, 3816, 3824, 3832, 3840, 3848, + 3856, 3864, 3872, 3880, 3888, 3896, 3904, 3912, 3920, 3928, 3936, 3944, 3952, 3960, 3968, 3976, + 3984, 3992, 4000, 4008, 4016, 4024, 4032, 4040, 4048, 4056, 4064, 4072, 4080, 4088, -4088}}; +__TDESC(OPT_ExpCtxt, 1, 0) = {__TDFLDS("ExpCtxt", 72), {-8}}; +__TDESC(OPT_LinkDesc, 1, 1) = {__TDFLDS("LinkDesc", 264), {256, -16}}; + +export void *OPT__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __REGMOD("OPT", EnumPtrs); + __REGCMD("Close", OPT_Close); + __REGCMD("CloseScope", OPT_CloseScope); + __REGCMD("InitRecno", OPT_InitRecno); + __INITYP(OPT_ConstDesc, OPT_ConstDesc, 0); + __INITYP(OPT_ObjDesc, OPT_ObjDesc, 0); + __INITYP(OPT_StrDesc, OPT_StrDesc, 0); + __INITYP(OPT_NodeDesc, OPT_NodeDesc, 0); + __INITYP(OPT_ImpCtxt, OPT_ImpCtxt, 0); + __INITYP(OPT_ExpCtxt, OPT_ExpCtxt, 0); + __INITYP(OPT_LinkDesc, OPT_LinkDesc, 0); +/* BEGIN */ + OPT_topScope = NIL; + OPT_OpenScope(0, NIL); + OPM_errpos = 0; + OPT_InitStruct(&OPT_undftyp, 0); + OPT_undftyp->BaseTyp = OPT_undftyp; + OPT_InitStruct(&OPT_notyp, 10); + OPT_InitStruct(&OPT_stringtyp, 8); + OPT_InitStruct(&OPT_niltyp, 9); + OPT_EnterTyp((CHAR*)"BYTE", 1, 1, &OPT_bytetyp); + OPT_EnterTyp((CHAR*)"PTR", 11, -1, &OPT_sysptrtyp); + OPT_EnterTyp((CHAR*)"ADDRESS", 4, -1, &OPT_adrtyp); + OPT_EnterTyp((CHAR*)"INT8", 4, 1, &OPT_int8typ); + OPT_EnterTyp((CHAR*)"INT16", 4, 2, &OPT_int16typ); + OPT_EnterTyp((CHAR*)"INT32", 4, 4, &OPT_int32typ); + OPT_EnterTyp((CHAR*)"INT64", 4, 8, &OPT_int64typ); + OPT_EnterTyp((CHAR*)"SET32", 7, 4, &OPT_set32typ); + OPT_EnterTyp((CHAR*)"SET64", 7, 8, &OPT_set64typ); + OPT_EnterProc((CHAR*)"ADR", 20); + OPT_EnterProc((CHAR*)"CC", 21); + OPT_EnterProc((CHAR*)"LSH", 22); + OPT_EnterProc((CHAR*)"ROT", 23); + OPT_EnterProc((CHAR*)"GET", 24); + OPT_EnterProc((CHAR*)"PUT", 25); + OPT_EnterProc((CHAR*)"GETREG", 26); + OPT_EnterProc((CHAR*)"PUTREG", 27); + OPT_EnterProc((CHAR*)"BIT", 28); + OPT_EnterProc((CHAR*)"VAL", 29); + OPT_EnterProc((CHAR*)"NEW", 30); + OPT_EnterProc((CHAR*)"MOVE", 31); + OPT_syslink = OPT_topScope->right; + OPT_universe = OPT_topScope; + OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, 1, &OPT_booltyp); + OPT_EnterTyp((CHAR*)"CHAR", 3, 1, &OPT_chartyp); + OPT_EnterTyp((CHAR*)"REAL", 5, 4, &OPT_realtyp); + OPT_EnterTyp((CHAR*)"LONGREAL", 6, 8, &OPT_lrltyp); + OPT_EnterTyp((CHAR*)"HUGEINT", 4, 8, &OPT_hinttyp); + OPT_EnterTyp((CHAR*)"BYTE@", 4, 1, &OPT_cpbytetyp); + OPT_EnterTypeAlias((CHAR*)"SHORTINT", &OPT_sintobj); + OPT_EnterTypeAlias((CHAR*)"INTEGER", &OPT_intobj); + OPT_EnterTypeAlias((CHAR*)"LONGINT", &OPT_lintobj); + OPT_EnterTypeAlias((CHAR*)"SET", &OPT_setobj); + OPT_EnterBoolConst((CHAR*)"FALSE", 0); + OPT_EnterBoolConst((CHAR*)"TRUE", 1); + OPT_EnterProc((CHAR*)"HALT", 0); + OPT_EnterProc((CHAR*)"NEW", 1); + OPT_EnterProc((CHAR*)"ABS", 2); + OPT_EnterProc((CHAR*)"CAP", 3); + OPT_EnterProc((CHAR*)"ORD", 4); + OPT_EnterProc((CHAR*)"ENTIER", 5); + OPT_EnterProc((CHAR*)"ODD", 6); + OPT_EnterProc((CHAR*)"MIN", 7); + OPT_EnterProc((CHAR*)"MAX", 8); + OPT_EnterProc((CHAR*)"CHR", 9); + OPT_EnterProc((CHAR*)"SHORT", 10); + OPT_EnterProc((CHAR*)"LONG", 11); + OPT_EnterProc((CHAR*)"SIZE", 12); + OPT_EnterProc((CHAR*)"INC", 13); + OPT_EnterProc((CHAR*)"DEC", 14); + OPT_EnterProc((CHAR*)"INCL", 15); + OPT_EnterProc((CHAR*)"EXCL", 16); + OPT_EnterProc((CHAR*)"LEN", 17); + OPT_EnterProc((CHAR*)"COPY", 18); + OPT_EnterProc((CHAR*)"ASH", 19); + OPT_EnterProc((CHAR*)"ASSERT", 32); + OPT_impCtxt.ref[0] = OPT_undftyp; + OPT_impCtxt.ref[1] = OPT_bytetyp; + OPT_impCtxt.ref[2] = OPT_booltyp; + OPT_impCtxt.ref[3] = OPT_chartyp; + OPT_impCtxt.ref[4] = OPT_int32typ; + OPT_impCtxt.ref[5] = OPT_realtyp; + OPT_impCtxt.ref[6] = OPT_lrltyp; + OPT_impCtxt.ref[7] = OPT_settyp; + OPT_impCtxt.ref[8] = OPT_stringtyp; + OPT_impCtxt.ref[9] = OPT_niltyp; + OPT_impCtxt.ref[10] = OPT_notyp; + OPT_impCtxt.ref[11] = OPT_sysptrtyp; + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPT.h b/bootstrap/unix-88/OPT.h new file mode 100644 index 00000000..cf456af5 --- /dev/null +++ b/bootstrap/unix-88/OPT.h @@ -0,0 +1,128 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPT__h +#define OPT__h + +#include "SYSTEM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused; + char _prvt0[4]; + INT32 idfp; + char _prvt1[8]; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +import OPT_Object OPT_topScope; +import OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +import OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +import INT8 OPT_nofGmod; +import OPT_Object OPT_GlbMod[64]; +import OPS_Name OPT_SelfName; +import BOOLEAN OPT_SYSimported; +import OPT_Link OPT_Links; + +import ADDRESS *OPT_ConstDesc__typ; +import ADDRESS *OPT_ObjDesc__typ; +import ADDRESS *OPT_StrDesc__typ; +import ADDRESS *OPT_NodeDesc__typ; +import ADDRESS *OPT_LinkDesc__typ; + +import void OPT_Align (INT32 *adr, INT32 base); +import INT32 OPT_BaseAlignment (OPT_Struct typ); +import void OPT_Close (void); +import void OPT_CloseScope (void); +import void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +import void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +import void OPT_FPrintObj (OPT_Object obj); +import void OPT_FPrintStr (OPT_Struct typ); +import void OPT_Find (OPT_Object *res); +import void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +import void OPT_FindImport (OPT_Object mod, OPT_Object *res); +import void OPT_IdFPrint (OPT_Struct typ); +import void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +import void OPT_Init (OPS_Name name, UINT32 opt); +import void OPT_InitRecno (void); +import void OPT_Insert (OPS_Name name, OPT_Object *obj); +import void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +import INT16 OPT_IntSize (INT64 n); +import OPT_Struct OPT_IntType (INT32 size); +import OPT_Const OPT_NewConst (void); +import OPT_ConstExt OPT_NewExt (void); +import OPT_Node OPT_NewNode (INT8 class); +import OPT_Object OPT_NewObj (void); +import OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +import void OPT_OpenScope (INT8 level, OPT_Object owner); +import OPT_Struct OPT_SetType (INT32 size); +import OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +import INT32 OPT_SizeAlignment (INT32 size); +import void OPT_TypSize (OPT_Struct typ); +import void *OPT__init(void); + + +#endif // OPT diff --git a/bootstrap/unix-88/OPV.c b/bootstrap/unix-88/OPV.c new file mode 100644 index 00000000..26c1c715 --- /dev/null +++ b/bootstrap/unix-88/OPV.c @@ -0,0 +1,1585 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPC.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +typedef + struct OPV_ExitInfo { + INT16 level, label; + } OPV_ExitInfo; + + +static INT16 OPV_stamp; +static OPV_ExitInfo OPV_exit; +static INT16 OPV_nofExitLabels; + +export ADDRESS *OPV_ExitInfo__typ; + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp); +export void OPV_AdrAndSize (OPT_Object topScope); +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec); +static void OPV_DefineTDescs (OPT_Node n); +static void OPV_Entier (OPT_Node n, INT16 prec); +static void OPV_GetTProcNum (OPT_Object obj); +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc); +static BOOLEAN OPV_ImplicitReturn (OPT_Node n); +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim); +export void OPV_Init (void); +static void OPV_InitTDescs (OPT_Node n); +static void OPV_Len (OPT_Node n, INT64 dim); +export void OPV_Module (OPT_Node prog); +static void OPV_NewArr (OPT_Node d, OPT_Node x); +static void OPV_ParIntLiteral (INT64 n, INT32 size); +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp); +static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (OPT_Node n, INT32 to); +static void OPV_Stamp (OPS_Name s); +static OPT_Object OPV_SuperProc (OPT_Node n); +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); +static void OPV_TraverseRecord (OPT_Struct typ); +static void OPV_TypeOf (OPT_Node n); +static void OPV_design (OPT_Node n, INT16 prec); +static void OPV_expr (OPT_Node n, INT16 prec); +static void OPV_stat (OPT_Node n, OPT_Object outerProc); + + +void OPV_Init (void) +{ + OPV_stamp = 0; + OPV_nofExitLabels = 0; +} + +static void OPV_GetTProcNum (OPT_Object obj) +{ + INT32 oldPos; + OPT_Struct typ = NIL; + OPT_Object redef = NIL; + oldPos = OPM_errpos; + OPM_errpos = obj->scope->adr; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(obj->name, typ->BaseTyp, &redef); + if (redef != NIL) { + obj->adr = __ASHL(__ASHR(redef->adr, 16), 16); + if (!__IN(2, obj->conval->setval, 64)) { + OPM_err(119); + } + } else { + obj->adr += __ASHL(typ->n, 16); + typ->n += 1; + } + OPM_errpos = oldPos; +} + +static void OPV_TraverseRecord (OPT_Struct typ) +{ + if (!typ->allocated) { + if (typ->BaseTyp != NIL) { + OPV_TraverseRecord(typ->BaseTyp); + typ->n = typ->BaseTyp->n; + } + typ->allocated = 1; + OPV_Traverse(typ->link, typ->strobj, 0); + } +} + +static void OPV_Stamp (OPS_Name s) +{ + INT16 i, j, k; + CHAR n[10]; + OPV_stamp += 1; + i = 0; + j = OPV_stamp; + while (s[__X(i, 256)] != 0x00) { + i += 1; + } + if (i > 25) { + i = 25; + } + s[__X(i, 256)] = '_'; + s[__X(i + 1, 256)] = '_'; + i += 2; + k = 0; + do { + n[__X(k, 10)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } while (!(j == 0)); + do { + k -= 1; + s[__X(i, 256)] = n[__X(k, 10)]; + i += 1; + } while (!(k == 0)); + s[__X(i, 256)] = 0x00; +} + +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported) +{ + INT16 mode; + OPT_Object scope = NIL; + OPT_Struct typ = NIL; + if (obj != NIL) { + OPV_Traverse(obj->left, outerScope, exported); + if (obj->name[0] == '@') { + obj->name[0] = '_'; + OPV_Stamp(obj->name); + } + obj->linkadr = 0; + mode = obj->mode; + if ((mode == 5 && (obj->vis != 0) == exported)) { + typ = obj->typ; + OPT_TypSize(obj->typ); + if (typ->form == 11) { + typ = typ->BaseTyp; + } + if (typ->comp == 4) { + OPV_TraverseRecord(typ); + } + } else if (mode == 13) { + OPV_GetTProcNum(obj); + } else if (mode == 1) { + OPT_TypSize(obj->typ); + } + if (!exported) { + if ((__IN(mode, 0x60, 32) && obj->mnolev > 0)) { + OPV_Stamp(obj->name); + } + if (__IN(mode, 0x26, 32)) { + obj->scope = outerScope; + } else if (__IN(mode, 0x26c0, 32)) { + if (obj->conval->setval == 0x0) { + OPM_err(129); + } + scope = obj->scope; + scope->leaf = 1; + __MOVE(obj->name, scope->name, 256); + OPV_Stamp(scope->name); + if (mode == 9) { + obj->adr = 1; + } + if (scope->mnolev > 1) { + outerScope->leaf = 0; + } + OPV_Traverse(obj->scope->right, obj->scope, 0); + } + } + OPV_Traverse(obj->right, outerScope, exported); + } +} + +void OPV_AdrAndSize (OPT_Object topScope) +{ + __ASSERT(OPT_sinttyp != NIL, 0); + __ASSERT(OPT_inttyp != NIL, 0); + __ASSERT(OPT_linttyp != NIL, 0); + OPM_errpos = topScope->adr; + topScope->leaf = 1; + OPV_Traverse(topScope->right, topScope, 1); + OPV_Traverse(topScope->right, topScope, 0); + OPT_chartyp->strobj->linkadr = 2; + OPT_cpbytetyp->strobj->linkadr = 2; + OPT_settyp->strobj->linkadr = 2; + OPT_realtyp->strobj->linkadr = 2; + OPT_adrtyp->strobj->linkadr = 2; + OPT_int8typ->strobj->linkadr = 2; + OPT_int16typ->strobj->linkadr = 2; + OPT_int32typ->strobj->linkadr = 2; + OPT_int64typ->strobj->linkadr = 2; + OPT_set32typ->strobj->linkadr = 2; + OPT_set64typ->strobj->linkadr = 2; + OPT_hinttyp->strobj->linkadr = 2; + OPT_lrltyp->strobj->linkadr = 2; + OPT_booltyp->strobj->linkadr = 2; + OPT_bytetyp->strobj->linkadr = 2; + OPT_sysptrtyp->strobj->linkadr = 2; +} + +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp) +{ + switch (class) { + case 7: case 0: case 2: case 4: case 9: + case 13: + return 10; + break; + case 5: + if (__IN(3, OPM_Options, 32)) { + return 10; + } else { + return 9; + } + break; + case 1: + if (__IN(comp, 0x0c, 32)) { + return 10; + } else { + return 9; + } + break; + case 3: + return 9; + break; + case 11: + switch (subclass) { + case 33: case 7: case 24: case 29: case 20: + return 9; + break; + case 16: case 21: case 22: case 23: case 25: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 12: + switch (subclass) { + case 1: + if (form == 7) { + return 4; + } else { + return 8; + } + break; + case 2: + if (form == 7) { + return 3; + } else { + return 8; + } + break; + case 3: case 4: + return 10; + break; + case 6: + if (form == 7) { + return 2; + } else { + return 7; + } + break; + case 7: + if (form == 7) { + return 4; + } else { + return 7; + } + break; + case 11: case 12: case 13: case 14: + return 6; + break; + case 9: case 10: + return 5; + break; + case 5: + return 1; + break; + case 8: + return 0; + break; + case 19: case 15: case 17: case 18: case 26: + case 27: case 28: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 10: + return 10; + break; + case 8: case 6: + return 12; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence, class = ", 43); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + __RETCHK; +} + +static void OPV_Len (OPT_Node n, INT64 dim) +{ + INT64 d; + OPT_Struct array = NIL; + while ((n->class == 4 && n->typ->comp == 3)) { + dim += 1; + n = n->left; + } + if ((n->class == 3 && n->typ->comp == 3)) { + d = dim; + array = n->typ; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->len[", 7); + OPM_WriteInt(dim); + OPM_Write(']'); + } else { + OPM_WriteInt(array->n); + } + } else { + OPC_Len(n->obj, n->typ, dim); + } +} + +static BOOLEAN OPV_SideEffects (OPT_Node n) +{ + if (n != NIL) { + return (n->class == 13 || OPV_SideEffects(n->left)) || OPV_SideEffects(n->right); + } else { + return 0; + } + __RETCHK; +} + +static void OPV_Entier (OPT_Node n, INT16 prec) +{ + if (__IN(n->typ->form, 0x60, 32)) { + OPM_WriteString((CHAR*)"__ENTIER(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else { + OPV_expr(n, prec); + } +} + +static void OPV_SizeCast (OPT_Node n, INT32 to) +{ + if ((to < n->typ->size && __IN(2, OPM_Options, 32))) { + OPM_WriteString((CHAR*)"__SHORT", 8); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPM_SignedMaximum(to) + 1); + OPM_Write(')'); + } else { + if ((n->typ->size != to && (n->typ->size > 4 || to != 4))) { + OPM_WriteString((CHAR*)"(INT", 5); + OPM_WriteInt(__ASHL(to, 3)); + OPM_WriteString((CHAR*)")", 2); + } + OPV_Entier(n, 9); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec) +{ + INT16 from, to; + from = n->typ->form; + to = newtype->form; + if (to == 7) { + if (from == 7) { + OPV_SizeCast(n, newtype->size); + } else { + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(newtype->size, 3)); + OPM_Write(')'); + } + } else if (to == 4) { + OPV_SizeCast(n, newtype->size); + } else if (to == 3) { + if (__IN(2, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__CHR", 6); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_Write(')'); + } else { + OPM_WriteString((CHAR*)"(CHAR)", 7); + OPV_Entier(n, 9); + } + } else { + OPV_expr(n, prec); + } +} + +static void OPV_TypeOf (OPT_Node n) +{ + if (n->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else if (__IN(n->class, 0x15, 32)) { + OPC_Andent(n->typ); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (n->class == 3) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n->left, -1); + OPM_Write(')'); + } else if (n->class == 5) { + OPV_TypeOf(n->left); + } else if ((n->class == 11 && n->subcl == 29)) { + OPC_TypeOf(n->left->obj); + } else { + OPC_TypeOf(n->obj); + } +} + +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim) +{ + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + OPV_expr(n->right, prec); + } else { + if (OPV_SideEffects(n->right)) { + OPM_WriteString((CHAR*)"__XF(", 6); + } else { + OPM_WriteString((CHAR*)"__X(", 5); + } + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(d, dim); + OPM_Write(')'); + } +} + +static void OPV_design (OPT_Node n, INT16 prec) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT16 class, designPrec, comp; + OPT_Node d = NIL, x = NIL; + INT16 dims, i, _for__26; + comp = n->typ->comp; + obj = n->obj; + class = n->class; + designPrec = OPV_Precedence(class, n->subcl, n->typ->form, comp); + if ((((((class == 0 && obj->mnolev > 0)) && (INT16)obj->mnolev != OPM_level)) && prec == 10)) { + designPrec = 9; + } + if (prec > designPrec) { + OPM_Write('('); + } + if (prec == 11) { + OPM_Write('*'); + } + switch (class) { + case 9: + OPC_Ident(n->obj); + break; + case 0: + OPC_CompleteIdent(n->obj); + break; + case 1: + if (!__IN(comp, 0x0c, 32)) { + OPM_Write('*'); + } + OPC_CompleteIdent(n->obj); + break; + case 2: + if (n->left->class == 3) { + OPV_design(n->left->left, designPrec); + OPM_WriteString((CHAR*)"->", 3); + } else { + OPV_design(n->left, designPrec); + OPM_Write('.'); + } + OPC_Ident(n->obj); + break; + case 3: + if (n->typ->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->data", 7); + } else { + OPM_Write('*'); + OPV_design(n->left, designPrec); + } + break; + case 4: + d = n->left; + if (d->typ->comp == 3) { + dims = 0; + while (d->class == 4) { + d = d->left; + dims += 1; + } + if (n->typ->comp == 3) { + OPM_Write('&'); + } + OPV_design(d, designPrec); + OPM_Write('['); + if (n->typ->comp == 3) { + OPM_Write('('); + } + i = dims; + x = n; + while (x != d) { + if (x->left != d) { + OPV_Index(x, d, 7, i); + OPM_WriteString((CHAR*)" + ", 4); + OPV_Len(d, i); + OPM_WriteString((CHAR*)" * (", 5); + i -= 1; + } else { + OPV_Index(x, d, -1, i); + } + x = x->left; + } + _for__26 = dims; + i = 1; + while (i <= _for__26) { + OPM_Write(')'); + i += 1; + } + if (n->typ->comp == 3) { + OPM_Write(')'); + while (i < __ASHR(d->typ->size - 4, 2)) { + OPM_WriteString((CHAR*)" * ", 4); + OPV_Len(d, i); + i += 1; + } + } + OPM_Write(']'); + } else { + OPV_design(n->left, designPrec); + OPM_Write('['); + OPV_Index(n, n->left, -1, 0); + OPM_Write(']'); + } + break; + case 5: + typ = n->typ; + obj = n->left->obj; + if (__IN(3, OPM_Options, 32)) { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__GUARDR(", 10); + if ((INT16)obj->mnolev != OPM_level) { + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"__curr->", 9); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } + } else { + if (typ->BaseTyp->strobj == NIL) { + OPM_WriteString((CHAR*)"__GUARDA(", 10); + } else { + OPM_WriteString((CHAR*)"__GUARDP(", 10); + } + OPV_expr(n->left, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + } else { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + OPC_CompleteIdent(obj); + } else { + OPM_Write('('); + OPC_Ident(typ->strobj); + OPM_Write(')'); + OPV_expr(n->left, designPrec); + } + } + break; + case 6: + if (__IN(3, OPM_Options, 32)) { + if (n->left->class == 1) { + OPM_WriteString((CHAR*)"__GUARDEQR(", 12); + OPC_CompleteIdent(n->left->obj); + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n->left); + } else { + OPM_WriteString((CHAR*)"__GUARDEQP(", 12); + OPV_expr(n->left->left, -1); + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + } else { + OPV_expr(n->left, -1); + } + break; + case 11: + if (n->subcl == 29) { + OPV_design(n->left, prec); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.design, class = ", 39); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + if (prec > designPrec) { + OPM_Write(')'); + } +} + +static void OPV_ParIntLiteral (INT64 n, INT32 size) +{ + OPM_WriteInt(n); +} + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp) +{ + OPT_Struct typ = NIL, aptyp = NIL; + INT16 comp, form, mode, prec, dim; + OPM_Write('('); + while (n != NIL) { + typ = fp->typ; + comp = typ->comp; + form = typ->form; + mode = fp->mode; + prec = -1; + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + prec = 10; + } + if (!__IN(n->typ->comp, 0x0c, 32)) { + if (mode == 2) { + if (typ != n->typ) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPM_Write('&'); + prec = 9; + } else { + if ((__IN(comp, 0x0c, 32) && n->class == 7)) { + OPM_WriteString((CHAR*)"(CHAR*)", 8); + } else if ((((form == 11 && typ != n->typ)) && n->typ != OPT_niltyp)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + } else { + if ((((mode == 2 && typ != n->typ)) && prec == -1)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPV_expr(n->left, prec); + } else if ((form == 4 && n->class == 7)) { + OPV_ParIntLiteral(n->conval->intval, n->typ->size); + } else { + OPV_expr(n, prec); + } + if ((comp == 4 && mode == 2)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n); + } else if (comp == 3) { + if (n->class == 7) { + OPM_WriteString((CHAR*)", ", 3); + OPV_ParIntLiteral(n->conval->intval2, OPM_AddressSize); + } else { + aptyp = n->typ; + dim = 0; + while ((typ->comp == 3 && typ->BaseTyp->form != 1)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n, dim); + typ = typ->BaseTyp; + aptyp = aptyp->BaseTyp; + dim += 1; + } + if ((typ->comp == 3 && typ->BaseTyp->form == 1)) { + OPM_WriteString((CHAR*)", ", 3); + while (aptyp->comp == 3) { + OPV_Len(n, dim); + OPM_WriteString((CHAR*)" * ", 4); + dim += 1; + aptyp = aptyp->BaseTyp; + } + OPV_ParIntLiteral(aptyp->size, OPM_AddressSize); + } + } + } + n = n->link; + fp = fp->link; + if (n != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static OPT_Object OPV_SuperProc (OPT_Node n) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + typ = n->right->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(n->left->obj->name, typ->BaseTyp, &obj); + return obj; +} + +static void OPV_expr (OPT_Node n, INT16 prec) +{ + INT16 class, subclass, form, exprPrec; + OPT_Struct typ = NIL; + OPT_Node l = NIL, r = NIL; + OPT_Object proc = NIL; + class = n->class; + subclass = n->subcl; + form = n->typ->form; + l = n->left; + r = n->right; + exprPrec = OPV_Precedence(class, subclass, form, n->typ->comp); + if ((exprPrec <= prec && __IN(class, 0x3ce0, 32))) { + OPM_Write('('); + } + switch (class) { + case 7: + OPC_Constant(n->conval, form); + break; + case 10: + OPM_WriteString((CHAR*)"__SETRNG(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(__ASHL(n->typ->size, 3)); + OPM_Write(')'); + break; + case 11: + switch (subclass) { + case 33: + OPM_Write('!'); + OPV_expr(l, exprPrec); + break; + case 7: + if (form == 7) { + OPM_Write('~'); + } else { + OPM_Write('-'); + } + OPV_expr(l, exprPrec); + break; + case 16: + typ = n->obj->typ; + if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"__IS(", 6); + OPC_TypeOf(l->obj); + } else { + OPM_WriteString((CHAR*)"__ISP(", 7); + OPV_expr(l, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + break; + case 20: + OPV_Convert(l, n->typ, exprPrec); + break; + case 21: + if (OPV_SideEffects(l)) { + if (l->typ->form < 5) { + if (l->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__ABSF(", 8); + } else { + OPM_WriteString((CHAR*)"__ABSFD(", 9); + } + } else { + OPM_WriteString((CHAR*)"__ABS(", 7); + } + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 22: + OPM_WriteString((CHAR*)"__CAP(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 23: + OPM_WriteString((CHAR*)"__ODD(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + if (l->class == 1) { + OPC_CompleteIdent(l->obj); + } else { + if ((l->typ->form != 8 && !__IN(l->typ->comp, 0x0c, 32))) { + OPM_Write('&'); + } + OPV_expr(l, exprPrec); + } + break; + case 29: + if (!__IN(l->class, 0x17, 32) || (((__IN(n->typ->form, 0x1890, 32) && __IN(l->typ->form, 0x1890, 32))) && n->typ->size == l->typ->size)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + if (__IN(n->typ->form, 0x1800, 32) || __IN(l->typ->form, 0x1800, 32)) { + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + } + OPV_expr(l, exprPrec); + } else { + OPM_WriteString((CHAR*)"__VAL(", 7); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_Write(')'); + } + break; + default: + OPM_err(200); + break; + } + break; + case 12: + switch (subclass) { + case 19: + OPV_Len(l, r->conval->intval); + break; + case 15: case 17: case 18: case 26: case 27: + case 28: case 3: case 4: + switch (subclass) { + case 15: + OPM_WriteString((CHAR*)"__IN(", 6); + break; + case 17: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ASHL(", 8); + } else { + OPM_WriteString((CHAR*)"__ASHR(", 8); + } + } else if (OPV_SideEffects(r)) { + OPM_WriteString((CHAR*)"__ASHF(", 8); + } else { + OPM_WriteString((CHAR*)"__ASH(", 7); + } + break; + case 18: + OPM_WriteString((CHAR*)"__MASK(", 8); + break; + case 26: + OPM_WriteString((CHAR*)"__BIT(", 7); + break; + case 27: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__LSHL(", 8); + } else { + OPM_WriteString((CHAR*)"__LSHR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__LSH(", 7); + } + break; + case 28: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ROTL(", 8); + } else { + OPM_WriteString((CHAR*)"__ROTR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__ROT(", 7); + } + break; + case 3: + if (OPV_SideEffects(n)) { + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__DIVF(", 8); + } else { + OPM_WriteString((CHAR*)"__DIV(", 7); + } + break; + case 4: + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + if (OPV_SideEffects(n)) { + OPM_WriteString((CHAR*)"__MODF(", 8); + } else { + OPM_WriteString((CHAR*)"__MOD(", 7); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if ((((__IN(subclass, 0x18020000, 32) && r->class == 7)) && r->conval->intval < 0)) { + OPM_WriteInt(-r->conval->intval); + } else { + OPV_expr(r, -1); + } + if (__IN(subclass, 0x18008000, 32)) { + OPM_WriteString((CHAR*)", ", 3); + if (subclass == 15) { + OPM_WriteInt(__ASHL(r->typ->size, 3)); + } else { + OPM_WriteInt(__ASHL(l->typ->size, 3)); + } + } + OPM_Write(')'); + break; + case 9: case 10: case 11: case 12: case 13: + case 14: + if (__IN(l->typ->form, 0x2100, 32)) { + OPM_WriteString((CHAR*)"__STRCMP(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_Write(')'); + OPC_Cmp(subclass); + OPM_Write('0'); + } else { + OPV_expr(l, exprPrec); + OPC_Cmp(subclass); + typ = l->typ; + if ((((((typ->form == 11 && r->typ->form != 9)) && r->typ != typ)) && r->typ != OPT_sysptrtyp)) { + OPM_WriteString((CHAR*)"(void *) ", 10); + } + OPV_expr(r, exprPrec); + } + break; + default: + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write('('); + } + OPV_expr(l, exprPrec); + switch (subclass) { + case 1: + if (form == 7) { + OPM_WriteString((CHAR*)" & ", 4); + } else { + OPM_WriteString((CHAR*)" * ", 4); + } + break; + case 2: + if (form == 7) { + OPM_WriteString((CHAR*)" ^ ", 4); + } else { + OPM_WriteString((CHAR*)" / ", 4); + if (r->obj == NIL || r->obj->typ->form == 4) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + } + } + break; + case 5: + OPM_WriteString((CHAR*)" && ", 5); + break; + case 6: + if (form == 7) { + OPM_WriteString((CHAR*)" | ", 4); + } else { + OPM_WriteString((CHAR*)" + ", 4); + } + break; + case 7: + if (form == 7) { + OPM_WriteString((CHAR*)" & ~", 5); + } else { + OPM_WriteString((CHAR*)" - ", 4); + } + break; + case 8: + OPM_WriteString((CHAR*)" || ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(r, exprPrec); + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write(')'); + } + break; + } + break; + case 13: + if ((l->obj != NIL && l->obj->mode == 13)) { + if (l->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(l->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (l->class == 9) { + OPV_design(l, 10); + } else { + OPV_design(l, 11); + } + OPV_ActualPar(r, n->obj); + break; + default: + OPV_design(n, prec); + break; + } + if ((exprPrec <= prec && __IN(class, 0x3ca0, 32))) { + OPM_Write(')'); + } +} + +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc) +{ + OPT_Node if_ = NIL; + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT32 adr; + if_ = n->left; + while (if_ != NIL) { + OPM_WriteString((CHAR*)"if ", 4); + OPV_expr(if_->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + if ((n->class == 27 && if_->left->left != NIL)) { + obj = if_->left->left->obj; + typ = obj->typ; + adr = obj->adr; + if (typ->comp == 4) { + OPC_BegStat(); + OPC_Ident(if_->left->obj); + OPM_WriteString((CHAR*)" *", 3); + OPM_WriteString(obj->name, 256); + OPM_WriteString((CHAR*)"__ = (void*)", 13); + obj->adr = 0; + OPC_CompleteIdent(obj); + OPC_EndStat(); + } + obj->adr = 1; + obj->typ = if_->left->obj->typ; + OPV_stat(if_->right, outerProc); + obj->typ = typ; + obj->adr = adr; + } else { + OPV_stat(if_->right, outerProc); + } + if_ = if_->link; + if ((if_ != NIL || n->right != NIL) || withtrap) { + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" else ", 7); + } else { + OPC_EndBlk(); + } + } + if (withtrap) { + OPM_WriteString((CHAR*)"__WITHCHK", 10); + OPC_EndStat(); + } else if (n->right != NIL) { + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + } +} + +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Node switchCase = NIL, label = NIL; + INT64 low, high; + INT16 form, i; + OPM_WriteString((CHAR*)"switch ", 8); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + form = n->left->typ->form; + switchCase = n->right->left; + while (switchCase != NIL) { + label = switchCase->left; + i = 0; + while (label != NIL) { + low = label->conval->intval; + high = label->conval->intval2; + while (low <= high) { + if (i == 0) { + OPC_BegStat(); + } + OPC_Case(low, form); + low += 1; + i += 1; + if (i == 5) { + OPM_WriteLn(); + i = 0; + } + } + label = label->link; + } + if (i > 0) { + OPM_WriteLn(); + } + OPC_Indent(1); + OPV_stat(switchCase->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_EndStat(); + OPC_Indent(-1); + switchCase = switchCase->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"default: ", 10); + if (n->right->conval->setval != 0x0) { + OPC_Indent(1); + OPM_WriteLn(); + OPV_stat(n->right->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_Indent(-1); + } else { + OPM_WriteString((CHAR*)"__CASECHK", 10); + } + OPC_EndStat(); + OPC_EndBlk(); +} + +static BOOLEAN OPV_ImplicitReturn (OPT_Node n) +{ + while ((n != NIL && n->class != 26)) { + n = n->link; + } + return n == NIL; +} + +static void OPV_NewArr (OPT_Node d, OPT_Node x) +{ + OPT_Struct typ = NIL, base = NIL; + INT16 nofdim, nofdyn; + typ = d->typ->BaseTyp; + base = typ; + nofdim = 0; + nofdyn = 0; + while (base->comp == 3) { + nofdim += 1; + nofdyn += 1; + base = base->BaseTyp; + } + OPV_design(d, -1); + OPM_WriteString((CHAR*)" = __NEWARR(", 13); + while (base->comp == 2) { + nofdim += 1; + base = base->BaseTyp; + } + if ((base->comp == 4 && OPC_NofPtrs(base) != 0)) { + OPC_Andent(base); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (base->form == 11) { + OPM_WriteString((CHAR*)"POINTER__typ", 13); + } else { + OPM_WriteString((CHAR*)"NIL", 4); + } + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(base->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPT_BaseAlignment(base)); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdim); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdyn); + while (typ != base) { + OPM_WriteString((CHAR*)", ", 3); + if (typ->comp == 3) { + if (x->class == 7) { + OPC_IntLiteral(x->conval->intval, OPM_AddressSize); + } else { + OPM_WriteString((CHAR*)"((ADDRESS)(", 12); + OPV_expr(x, 10); + OPM_WriteString((CHAR*)"))", 3); + } + x = x->link; + } else { + OPC_IntLiteral(typ->n, OPM_AddressSize); + } + typ = typ->BaseTyp; + } + OPM_Write(')'); +} + +static void OPV_DefineTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_TDescDecl(n->typ); + n = n->link; + } +} + +static void OPV_InitTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_InitTDesc(n->typ); + n = n->link; + } +} + +static void OPV_stat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Object proc = NIL; + OPV_ExitInfo saved; + OPT_Node l = NIL, r = NIL; + while ((n != NIL && OPM_noerr)) { + OPM_errpos = OPM_Longint(n->conval->intval); + if (n->class != 14) { + OPC_BegStat(); + } + switch (n->class) { + case 18: + if (n->obj == NIL) { + OPM_level += 1; + OPV_stat(n->left, outerProc); + OPM_level -= 1; + OPC_GenEnumPtrs(OPT_topScope->scope); + OPV_DefineTDescs(n->right); + OPC_EnterBody(); + OPV_InitTDescs(n->right); + OPM_WriteString((CHAR*)"/* BEGIN */", 12); + OPM_WriteLn(); + OPV_stat(n->right, outerProc); + OPC_ExitBody(); + } else { + proc = n->obj; + OPC_TypeDefs(proc->scope->right, 0); + if (!proc->scope->leaf) { + OPC_DefineInter(proc); + } + OPM_level += 1; + OPV_stat(n->left, proc); + OPM_level -= 1; + OPC_EnterProc(proc); + OPV_stat(n->right, proc); + OPC_ExitProc(proc, 1, OPV_ImplicitReturn(n->right)); + } + break; + case 14: + break; + case 19: + switch (n->subcl) { + case 0: + l = n->left; + r = n->right; + if (l->typ->comp == 2) { + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if (r->typ == OPT_stringtyp) { + OPM_WriteInt(r->conval->intval2); + } else if (r->typ->comp == 3) { + OPM_WriteString((CHAR*)"__X(", 5); + OPC_Len(r->obj, r->typ, 0); + OPM_WriteString((CHAR*)" * ", 4); + OPM_WriteInt(r->typ->BaseTyp->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(l->typ->size + 1); + OPM_Write(')'); + } else { + __ASSERT(r->typ->comp == 2, 0); + __ASSERT(r->typ->size <= l->typ->size, 0); + OPM_WriteInt(r->typ->size); + } + OPM_Write(')'); + } else { + if ((((((l->typ->form == 11 && l->obj != NIL)) && l->obj->adr == 1)) && l->obj->mode == 1)) { + l->obj->adr = 0; + OPV_design(l, -1); + l->obj->adr = 1; + if (r->typ->form != 9) { + OPM_WriteString((CHAR*)" = (void*)", 11); + } else { + OPM_WriteString((CHAR*)" = ", 4); + } + } else { + OPV_design(l, -1); + OPM_WriteString((CHAR*)" = ", 4); + } + if (l->typ == r->typ) { + OPV_expr(r, -1); + } else if ((((l->typ->form == 11 && r->typ->form != 9)) && l->typ->strobj != NIL)) { + OPM_Write('('); + OPC_Ident(l->typ->strobj); + OPM_Write(')'); + OPV_expr(r, -1); + } else if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Andent(l->typ); + OPM_WriteString((CHAR*)"*)&", 4); + OPV_expr(r, 9); + } else { + OPV_expr(r, -1); + } + } + break; + case 1: + if (n->left->typ->BaseTyp->comp == 4) { + OPM_WriteString((CHAR*)"__NEW(", 7); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(n->left->typ->BaseTyp); + OPM_WriteString((CHAR*)")", 2); + } else if (__IN(n->left->typ->BaseTyp->comp, 0x0c, 32)) { + OPV_NewArr(n->left, n->right); + } + break; + case 13: case 14: + OPV_expr(n->left, -1); + OPC_Increment(n->subcl == 14); + OPV_expr(n->right, -1); + break; + case 15: case 16: + OPV_expr(n->left, -1); + OPC_SetInclude(n->subcl == 16); + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(n->left->typ->size, 3)); + OPM_Write(')'); + break; + case 18: + OPM_WriteString((CHAR*)"__COPY(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n->left, 0); + OPM_Write(')'); + break; + case 31: + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right->link, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"__GET(", 7); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + break; + case 25: + OPM_WriteString((CHAR*)"__PUT(", 7); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->right->typ->strobj); + OPM_Write(')'); + break; + case 26: case 27: + OPM_err(200); + break; + case 30: + OPM_WriteString((CHAR*)"__SYSNEW(", 10); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_Write(')'); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.subcl = ", 40); + OPM_LogWNum(n->subcl, 0); + OPM_LogWLn(); + break; + } + break; + case 13: + if ((n->left->obj != NIL && n->left->obj->mode == 13)) { + if (n->left->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(n->left->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (n->left->class == 9) { + OPV_design(n->left, 10); + } else { + OPV_design(n->left, 11); + } + OPV_ActualPar(n->right, n->obj); + break; + case 20: + if (n->subcl != 32) { + OPV_IfStat(n, 0, outerProc); + } else if (__IN(7, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__ASSERT(", 10); + OPV_expr(n->left->left->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(n->left->right->right->conval->intval); + OPM_Write(')'); + OPC_EndStat(); + } + break; + case 21: + OPV_exit.level += 1; + OPV_CaseStat(n, outerProc); + OPV_exit.level -= 1; + break; + case 22: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"while ", 7); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + OPV_exit.level -= 1; + break; + case 23: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"do ", 4); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" while (!", 10); + OPV_expr(n->right, 9); + OPM_Write(')'); + OPV_exit.level -= 1; + break; + case 24: + saved = OPV_exit; + OPV_exit.level = 0; + OPV_exit.label = -1; + OPM_WriteString((CHAR*)"for (;;) ", 10); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk(); + if (OPV_exit.label != -1) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"exit__", 7); + OPM_WriteInt(OPV_exit.label); + OPM_Write(':'); + OPC_EndStat(); + } + OPV_exit = saved; + break; + case 25: + if (OPV_exit.level == 0) { + OPM_WriteString((CHAR*)"break", 6); + } else { + if (OPV_exit.label == -1) { + OPV_exit.label = OPV_nofExitLabels; + OPV_nofExitLabels += 1; + } + OPM_WriteString((CHAR*)"goto exit__", 12); + OPM_WriteInt(OPV_exit.label); + } + break; + case 26: + if (OPM_level == 0) { + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI", 7); + } else { + OPM_WriteString((CHAR*)"__ENDMOD", 9); + } + } else if (OPC_NeedsRetval(outerProc)) { + OPM_WriteString((CHAR*)"__retval = ", 12); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + OPC_EndStat(); + OPC_BegStat(); + OPC_ExitProc(outerProc, 0, 0); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"return __retval", 16); + } else { + OPC_ExitProc(outerProc, 0, 0); + OPM_WriteString((CHAR*)"return", 7); + if (n->left != NIL) { + OPM_Write(' '); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + } + } + break; + case 27: + OPV_IfStat(n, n->subcl == 0, outerProc); + break; + case 28: + OPC_Halt(OPM_Longint(n->right->conval->intval)); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.class = ", 40); + OPM_LogWNum(n->class, 0); + OPM_LogWLn(); + break; + } + if (!__IN(n->class, 0x09744000, 32)) { + OPC_EndStat(); + } + n = n->link; + } +} + +void OPV_Module (OPT_Node prog) +{ + if (!__IN(10, OPM_Options, 32)) { + OPC_GenHdr(prog->right); + OPC_GenHdrIncludes(); + } + OPC_GenBdy(prog->right); + OPV_stat(prog, NIL); +} + +__TDESC(OPV_ExitInfo, 1, 0) = {__TDFLDS("ExitInfo", 4), {-8}}; + +export void *OPV__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPV", 0); + __REGCMD("Init", OPV_Init); + __INITYP(OPV_ExitInfo, OPV_ExitInfo, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/OPV.h b/bootstrap/unix-88/OPV.h new file mode 100644 index 00000000..fbabd8f4 --- /dev/null +++ b/bootstrap/unix-88/OPV.h @@ -0,0 +1,18 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPV__h +#define OPV__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPV_AdrAndSize (OPT_Object topScope); +import void OPV_Init (void); +import void OPV_Module (OPT_Node prog); +import void *OPV__init(void); + + +#endif // OPV diff --git a/bootstrap/unix-88/Out.c b/bootstrap/unix-88/Out.c new file mode 100644 index 00000000..ce936589 --- /dev/null +++ b/bootstrap/unix-88/Out.c @@ -0,0 +1,345 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export BOOLEAN Out_IsConsole; +static CHAR Out_buf[128]; +static INT16 Out_in; + + +export void Out_Char (CHAR ch); +export void Out_Flush (void); +export void Out_Hex (INT64 x, INT64 n); +export void Out_Int (INT64 x, INT64 n); +static INT32 Out_Length (CHAR *s, ADDRESS s__len); +export void Out_Ln (void); +export void Out_LongReal (LONGREAL x, INT16 n); +export void Out_Open (void); +export void Out_Real (REAL x, INT16 n); +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_); +export void Out_String (CHAR *str, ADDRESS str__len); +export LONGREAL Out_Ten (INT16 e); +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i); +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i); + +#define Out_Entier64(x) (INT64)(x) + +void Out_Flush (void) +{ + INT16 error; + if (Out_in > 0) { + error = Platform_Write(1, (ADDRESS)Out_buf, Out_in); + } + Out_in = 0; +} + +void Out_Open (void) +{ +} + +void Out_Char (CHAR ch) +{ + if (Out_in >= 128) { + Out_Flush(); + } + Out_buf[__X(Out_in, 128)] = ch; + Out_in += 1; + if (ch == 0x0a) { + Out_Flush(); + } +} + +static INT32 Out_Length (CHAR *s, ADDRESS s__len) +{ + INT32 l; + l = 0; + while ((l < s__len && s[__X(l, s__len)] != 0x00)) { + l += 1; + } + return l; +} + +void Out_String (CHAR *str, ADDRESS str__len) +{ + INT32 l; + INT16 error; + __DUP(str, str__len, CHAR); + l = Out_Length((void*)str, str__len); + if (Out_in + l > 128) { + Out_Flush(); + } + if (l > 128) { + error = Platform_Write(1, (ADDRESS)str, l); + } else { + __MOVE((ADDRESS)str, (ADDRESS)&Out_buf[__X(Out_in, 128)], l); + Out_in += __SHORT(l, 32768); + } + __DEL(str); +} + +void Out_Int (INT64 x, INT64 n) +{ + CHAR s[22]; + INT16 i; + BOOLEAN negative; + negative = x < 0; + if (x == (-9223372036854775807LL-1)) { + __MOVE("8085774586302733229", s, 20); + i = 19; + } else { + if (x < 0) { + x = -x; + } + s[0] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i = 1; + while (x != 0) { + s[__X(i, 22)] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i += 1; + } + } + if (negative) { + s[__X(i, 22)] = '-'; + i += 1; + } + while (n > (INT64)i) { + Out_Char(' '); + n -= 1; + } + while (i > 0) { + i -= 1; + Out_Char(s[__X(i, 22)]); + } +} + +void Out_Hex (INT64 x, INT64 n) +{ + if (n < 1) { + n = 1; + } else if (n > 16) { + n = 16; + } + if (x >= 0) { + while ((n < 16 && __LSH(x, -__ASHL(n, 2), 64) != 0)) { + n += 1; + } + } + x = __ROT(x, __ASHL(16 - n, 2), 64); + while (n > 0) { + x = __ROTL(x, 4, 64); + n -= 1; + if (__MASK(x, -16) < 10) { + Out_Char(__CHR(__MASK(x, -16) + 48)); + } else { + Out_Char(__CHR((__MASK(x, -16) - 10) + 65)); + } + } +} + +void Out_Ln (void) +{ + Out_String(Platform_NL, 3); + Out_Flush(); +} + +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i) +{ + *i -= 1; + s[__X(*i, s__len)] = __CHR(__MOD(n, 10) + 48); +} + +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i) +{ + INT16 j; + INT32 l; + __DUP(t, t__len, CHAR); + l = Out_Length((void*)t, t__len); + if (l > *i) { + l = *i; + } + *i -= __SHORT(l, 32768); + j = 0; + while (j < l) { + s[__X(*i + j, s__len)] = t[__X(j, t__len)]; + j += 1; + } + __DEL(t); +} + +LONGREAL Out_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_) +{ + INT16 e; + INT64 f; + CHAR s[30]; + INT16 i, el; + LONGREAL x0; + BOOLEAN nn, en; + INT64 m; + INT16 d, dr; + e = (INT16)__MASK(__ASHR((__VAL(INT64, x)), 52), -2048); + f = __MASK((__VAL(INT64, x)), -4503599627370496LL); + nn = (__VAL(INT64, x) < 0 && !((e == 2047 && f != 0))); + if (nn) { + n -= 1; + } + i = 30; + if (e == 2047) { + if (f == 0) { + Out_prepend((CHAR*)"Infinity", 9, (void*)s, 30, &i); + } else { + Out_prepend((CHAR*)"NaN", 4, (void*)s, 30, &i); + } + } else { + if (long_) { + el = 3; + dr = n - 6; + if (dr > 17) { + dr = 17; + } + d = dr; + if (d < 15) { + d = 15; + } + } else { + el = 2; + dr = n - 5; + if (dr > 9) { + dr = 9; + } + d = dr; + if (d < 6) { + d = 6; + } + } + if (e == 0) { + while (el > 0) { + i -= 1; + s[__X(i, 30)] = '0'; + el -= 1; + } + i -= 1; + s[__X(i, 30)] = '+'; + m = 0; + } else { + if (nn) { + x = -x; + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Out_Ten(e); + } else { + x = Out_Ten(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + en = e < 0; + if (en) { + e = -e; + } + while (el > 0) { + Out_digit(e, (void*)s, 30, &i); + e = __DIV(e, 10); + el -= 1; + } + i -= 1; + if (en) { + s[__X(i, 30)] = '-'; + } else { + s[__X(i, 30)] = '+'; + } + x0 = Out_Ten(d - 1); + x = x0 * x; + x = x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + m = Out_Entier64(x); + } + i -= 1; + if (long_) { + s[__X(i, 30)] = 'D'; + } else { + s[__X(i, 30)] = 'E'; + } + if (dr < 2) { + dr = 2; + } + while ((d > dr && __MOD(m, 10) == 0)) { + m = __DIV(m, 10); + d -= 1; + } + while (d > 1) { + Out_digit(m, (void*)s, 30, &i); + m = __DIV(m, 10); + d -= 1; + } + i -= 1; + s[__X(i, 30)] = '.'; + Out_digit(m, (void*)s, 30, &i); + } + n -= 30 - i; + while (n > 0) { + Out_Char(' '); + n -= 1; + } + if (nn) { + Out_Char('-'); + } + while (i < 30) { + Out_Char(s[__X(i, 30)]); + i += 1; + } +} + +void Out_Real (REAL x, INT16 n) +{ + Out_RealP(x, n, 0); +} + +void Out_LongReal (LONGREAL x, INT16 n) +{ + Out_RealP(x, n, 1); +} + + +export void *Out__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Out", 0); + __REGCMD("Flush", Out_Flush); + __REGCMD("Ln", Out_Ln); + __REGCMD("Open", Out_Open); +/* BEGIN */ + Out_IsConsole = Platform_IsConsole(1); + Out_in = 0; + __ENDMOD; +} diff --git a/bootstrap/unix-88/Out.h b/bootstrap/unix-88/Out.h new file mode 100644 index 00000000..a72547f4 --- /dev/null +++ b/bootstrap/unix-88/Out.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Out__h +#define Out__h + +#include "SYSTEM.h" + + +import BOOLEAN Out_IsConsole; + + +import void Out_Char (CHAR ch); +import void Out_Flush (void); +import void Out_Hex (INT64 x, INT64 n); +import void Out_Int (INT64 x, INT64 n); +import void Out_Ln (void); +import void Out_LongReal (LONGREAL x, INT16 n); +import void Out_Open (void); +import void Out_Real (REAL x, INT16 n); +import void Out_String (CHAR *str, ADDRESS str__len); +import LONGREAL Out_Ten (INT16 e); +import void *Out__init(void); + + +#endif // Out diff --git a/bootstrap/unix-88/Platform.c b/bootstrap/unix-88/Platform.c new file mode 100644 index 00000000..139181a0 --- /dev/null +++ b/bootstrap/unix-88/Platform.c @@ -0,0 +1,535 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 volume, index, mtime; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +export BOOLEAN Platform_LittleEndian; +export INT16 Platform_PID; +export CHAR Platform_CWD[256]; +static INT32 Platform_TimeStart; +export INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +export CHAR Platform_NL[3]; + +export ADDRESS *Platform_FileIdentity__typ; + +export BOOLEAN Platform_Absent (INT16 e); +export INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +export INT16 Platform_Close (INT32 h); +export BOOLEAN Platform_ConnectionFailed (INT16 e); +export void Platform_Delay (INT32 ms); +export BOOLEAN Platform_DifferentFilesystems (INT16 e); +export INT16 Platform_Error (void); +export void Platform_Exit (INT32 code); +export void Platform_GetClock (INT32 *t, INT32 *d); +export void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +export void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +export INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export BOOLEAN Platform_Inaccessible (INT16 e); +export BOOLEAN Platform_Interrupted (INT16 e); +export BOOLEAN Platform_IsConsole (INT32 h); +export void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +export INT16 Platform_MaxNameLength (void); +export INT16 Platform_MaxPathLength (void); +export INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +export BOOLEAN Platform_NoSuchDirectory (INT16 e); +export INT64 Platform_OSAllocate (INT64 size); +export void Platform_OSFree (INT64 address); +export INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_Read (INT32 h, INT64 p, INT32 l, INT32 *n); +export INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +export INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +export BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +export BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +export INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +export void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +export void Platform_SetInterruptHandler (Platform_SignalHandler handler); +export void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +export void Platform_SetQuitHandler (Platform_SignalHandler handler); +export INT16 Platform_Size (INT32 h, INT32 *l); +export INT16 Platform_Sync (INT32 h); +export INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +static void Platform_TestLittleEndian (void); +export INT32 Platform_Time (void); +export BOOLEAN Platform_TimedOut (INT16 e); +export BOOLEAN Platform_TooManyFiles (INT16 e); +export INT16 Platform_Truncate (INT32 h, INT32 l); +export INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +export INT16 Platform_Write (INT32 h, INT64 p, INT32 l); +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d); +export BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#define Platform_EACCES() EACCES +#define Platform_EAGAIN() EAGAIN +#define Platform_ECONNABORTED() ECONNABORTED +#define Platform_ECONNREFUSED() ECONNREFUSED +#define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR +#define Platform_EMFILE() EMFILE +#define Platform_ENETUNREACH() ENETUNREACH +#define Platform_ENFILE() ENFILE +#define Platform_ENOENT() ENOENT +#define Platform_EROFS() EROFS +#define Platform_ETIMEDOUT() ETIMEDOUT +#define Platform_EXDEV() EXDEV +#define Platform_NAMEMAX() NAME_MAX +#define Platform_PATHMAX() PATH_MAX +#define Platform_allocate(size) (ADDRESS)((void*)malloc((size_t)size)) +#define Platform_chdir(n, n__len) chdir((char*)n) +#define Platform_closefile(fd) close(fd) +#define Platform_err() errno +#define Platform_exit(code) exit((int)code) +#define Platform_free(address) free((void*)address) +#define Platform_fstat(fd) fstat(fd, &s) +#define Platform_fsync(fd) fsync(fd) +#define Platform_ftruncate(fd, l) ftruncate(fd, l) +#define Platform_getcwd(cwd, cwd__len) getcwd((char*)cwd, cwd__len) +#define Platform_getenv(var, var__len) getenv((char*)var) +#define Platform_getpid() (INTEGER)getpid() +#define Platform_gettimeval() struct timeval tv; gettimeofday(&tv,0) +#define Platform_isatty(fd) isatty(fd) +#define Platform_lseek(fd, o, w) lseek(fd, o, w) +#define Platform_nanosleep(s, ns) struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem) +#define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) +#define Platform_openro(n, n__len) open((char*)n, O_RDONLY) +#define Platform_openrw(n, n__len) open((char*)n, O_RDWR) +#define Platform_readfile(fd, p, l) (LONGINT)read(fd, (void*)(ADDRESS)(p), l) +#define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) +#define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) +#define Platform_seekcur() SEEK_CUR +#define Platform_seekend() SEEK_END +#define Platform_seekset() SEEK_SET +#define Platform_sethandler(s, h) SystemSetHandler(s, (ADDRESS)h) +#define Platform_stat(n, n__len) stat((char*)n, &s) +#define Platform_statdev() (LONGINT)s.st_dev +#define Platform_statino() (LONGINT)s.st_ino +#define Platform_statmtime() (LONGINT)s.st_mtime +#define Platform_statsize() (ADDRESS)s.st_size +#define Platform_structstats() struct stat s +#define Platform_system(str, str__len) system((char*)str) +#define Platform_tmhour() (LONGINT)time->tm_hour +#define Platform_tmmday() (LONGINT)time->tm_mday +#define Platform_tmmin() (LONGINT)time->tm_min +#define Platform_tmmon() (LONGINT)time->tm_mon +#define Platform_tmsec() (LONGINT)time->tm_sec +#define Platform_tmyear() (LONGINT)time->tm_year +#define Platform_tvsec() tv.tv_sec +#define Platform_tvusec() tv.tv_usec +#define Platform_unlink(n, n__len) unlink((char*)n) +#define Platform_writefile(fd, p, l) write(fd, (void*)(ADDRESS)(p), l) + +BOOLEAN Platform_TooManyFiles (INT16 e) +{ + return e == Platform_EMFILE() || e == Platform_ENFILE(); +} + +BOOLEAN Platform_NoSuchDirectory (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_DifferentFilesystems (INT16 e) +{ + return e == Platform_EXDEV(); +} + +BOOLEAN Platform_Inaccessible (INT16 e) +{ + return (e == Platform_EACCES() || e == Platform_EROFS()) || e == Platform_EAGAIN(); +} + +BOOLEAN Platform_Absent (INT16 e) +{ + return e == Platform_ENOENT(); +} + +BOOLEAN Platform_TimedOut (INT16 e) +{ + return e == Platform_ETIMEDOUT(); +} + +BOOLEAN Platform_ConnectionFailed (INT16 e) +{ + return ((e == Platform_ECONNREFUSED() || e == Platform_ECONNABORTED()) || e == Platform_ENETUNREACH()) || e == Platform_EHOSTUNREACH(); +} + +BOOLEAN Platform_Interrupted (INT16 e) +{ + return e == Platform_EINTR(); +} + +INT16 Platform_MaxNameLength (void) +{ + return Platform_NAMEMAX(); +} + +INT16 Platform_MaxPathLength (void) +{ + return Platform_PATHMAX(); +} + +INT64 Platform_OSAllocate (INT64 size) +{ + return Platform_allocate(size); +} + +void Platform_OSFree (INT64 address) +{ + Platform_free(address); +} + +typedef + CHAR (*EnvPtr__83)[1024]; + +BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + EnvPtr__83 p = NIL; + __DUP(var, var__len, CHAR); + p = (EnvPtr__83)(ADDRESS)Platform_getenv(var, var__len); + if (p != NIL) { + __COPY(*p, val, val__len); + } + __DEL(var); + return p != NIL; +} + +void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + __DUP(var, var__len, CHAR); + if (!Platform_getEnv(var, var__len, (void*)val, val__len)) { + val[0] = 0x00; + } + __DEL(var); +} + +void Platform_SetInterruptHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(2, handler); +} + +void Platform_SetQuitHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(3, handler); +} + +void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) +{ + Platform_sethandler(4, handler); +} + +static void Platform_YMDHMStoClock (INT32 ye, INT32 mo, INT32 da, INT32 ho, INT32 mi, INT32 se, INT32 *t, INT32 *d) +{ + *d = (__ASHL((int)__MOD(ye, 100), 9) + __ASHL(mo + 1, 5)) + da; + *t = (__ASHL(ho, 12) + __ASHL(mi, 6)) + se; +} + +void Platform_GetClock (INT32 *t, INT32 *d) +{ + Platform_gettimeval(); + Platform_sectotm(Platform_tvsec()); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec) +{ + Platform_gettimeval(); + *sec = Platform_tvsec(); + *usec = Platform_tvusec(); +} + +INT32 Platform_Time (void) +{ + INT32 ms; + Platform_gettimeval(); + ms = (int)__DIVF(Platform_tvusec(), 1000) + Platform_tvsec() * 1000; + return (int)__MOD(ms - Platform_TimeStart, 2147483647); +} + +void Platform_Delay (INT32 ms) +{ + INT32 s, ns; + s = __DIV(ms, 1000); + ns = (int)__MOD(ms, 1000) * 1000000; + Platform_nanosleep(s, ns); +} + +INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len) +{ + __DUP(cmd, cmd__len, CHAR); + __DEL(cmd); + return Platform_system(cmd, cmd__len); +} + +INT16 Platform_Error (void) +{ + return Platform_err(); +} + +INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openro(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_openrw(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT16 fd; + fd = Platform_opennew(n, n__len); + if (fd < 0) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_Close (INT32 h) +{ + if (Platform_closefile(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +BOOLEAN Platform_IsConsole (INT32 h) +{ + return Platform_isatty(h) != 0; +} + +INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + return 0; +} + +INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + __DUP(n, n__len, CHAR); + Platform_structstats(); + if (Platform_stat(n, n__len) < 0) { + __DEL(n); + return Platform_err(); + } + (*identity).volume = Platform_statdev(); + (*identity).index = Platform_statino(); + (*identity).mtime = Platform_statmtime(); + __DEL(n); + return 0; +} + +BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (i1.index == i2.index && i1.volume == i2.volume); +} + +BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return i1.mtime == i2.mtime; +} + +void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source) +{ + (*target).mtime = source.mtime; +} + +void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d) +{ + Platform_sectotm(i.mtime); + Platform_YMDHMStoClock(Platform_tmyear(), Platform_tmmon(), Platform_tmmday(), Platform_tmhour(), Platform_tmmin(), Platform_tmsec(), &*t, &*d); +} + +INT16 Platform_Size (INT32 h, INT32 *l) +{ + Platform_structstats(); + if (Platform_fstat(h) < 0) { + return Platform_err(); + } + *l = Platform_statsize(); + return 0; +} + +INT16 Platform_Read (INT32 h, INT64 p, INT32 l, INT32 *n) +{ + *n = Platform_readfile(h, p, l); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n) +{ + *n = Platform_readfile(h, (ADDRESS)b, b__len); + if (*n < 0) { + *n = 0; + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Write (INT32 h, INT64 p, INT32 l) +{ + INT64 written; + written = Platform_writefile(h, p, l); + if (written < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Sync (INT32 h) +{ + if (Platform_fsync(h) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence) +{ + if (Platform_lseek(h, offset, whence) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Truncate (INT32 h, INT32 l) +{ + if (Platform_ftruncate(h, l) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Unlink (CHAR *n, ADDRESS n__len) +{ + if (Platform_unlink(n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Chdir (CHAR *n, ADDRESS n__len) +{ + INT16 r; + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + return 0; + } else { + return Platform_err(); + } + __RETCHK; +} + +INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len) +{ + if (Platform_rename(o, o__len, n, n__len) < 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +void Platform_Exit (INT32 code) +{ + Platform_exit(code); +} + +static void Platform_TestLittleEndian (void) +{ + INT16 i; + i = 1; + __GET((ADDRESS)&i, Platform_LittleEndian, BOOLEAN); +} + +__TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 12), {-8}}; + +export void *Platform__init(void) +{ + __DEFMOD; + __REGMOD("Platform", 0); + __INITYP(Platform_FileIdentity, Platform_FileIdentity, 0); +/* BEGIN */ + Platform_TestLittleEndian(); + Platform_TimeStart = 0; + Platform_TimeStart = Platform_Time(); + Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } + Platform_SeekSet = Platform_seekset(); + Platform_SeekCur = Platform_seekcur(); + Platform_SeekEnd = Platform_seekend(); + Platform_NL[0] = 0x0a; + Platform_NL[1] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/unix-88/Platform.h b/bootstrap/unix-88/Platform.h new file mode 100644 index 00000000..e827b641 --- /dev/null +++ b/bootstrap/unix-88/Platform.h @@ -0,0 +1,74 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Platform__h +#define Platform__h + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 _prvt0; + char _prvt1[8]; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +import BOOLEAN Platform_LittleEndian; +import INT16 Platform_PID; +import CHAR Platform_CWD[256]; +import INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +import CHAR Platform_NL[3]; + +import ADDRESS *Platform_FileIdentity__typ; + +import BOOLEAN Platform_Absent (INT16 e); +import INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +import INT16 Platform_Close (INT32 h); +import BOOLEAN Platform_ConnectionFailed (INT16 e); +import void Platform_Delay (INT32 ms); +import BOOLEAN Platform_DifferentFilesystems (INT16 e); +import INT16 Platform_Error (void); +import void Platform_Exit (INT32 code); +import void Platform_GetClock (INT32 *t, INT32 *d); +import void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +import INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import BOOLEAN Platform_Inaccessible (INT16 e); +import BOOLEAN Platform_Interrupted (INT16 e); +import BOOLEAN Platform_IsConsole (INT32 h); +import void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +import INT16 Platform_MaxNameLength (void); +import INT16 Platform_MaxPathLength (void); +import INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +import BOOLEAN Platform_NoSuchDirectory (INT16 e); +import INT64 Platform_OSAllocate (INT64 size); +import void Platform_OSFree (INT64 address); +import INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_Read (INT32 h, INT64 p, INT32 l, INT32 *n); +import INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +import INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +import BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +import BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +import INT16 Platform_Seek (INT32 h, INT32 offset, INT16 whence); +import void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +import void Platform_SetInterruptHandler (Platform_SignalHandler handler); +import void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +import void Platform_SetQuitHandler (Platform_SignalHandler handler); +import INT16 Platform_Size (INT32 h, INT32 *l); +import INT16 Platform_Sync (INT32 h); +import INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +import INT32 Platform_Time (void); +import BOOLEAN Platform_TimedOut (INT16 e); +import BOOLEAN Platform_TooManyFiles (INT16 e); +import INT16 Platform_Truncate (INT32 h, INT32 l); +import INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +import INT16 Platform_Write (INT32 h, INT64 p, INT32 l); +import BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void *Platform__init(void); + + +#endif // Platform diff --git a/bootstrap/unix-88/Reals.c b/bootstrap/unix-88/Reals.c new file mode 100644 index 00000000..512ec2c4 --- /dev/null +++ b/bootstrap/unix-88/Reals.c @@ -0,0 +1,157 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + + + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len); +export void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +export void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +export void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +export void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +export INT16 Reals_Expo (REAL x); +export INT16 Reals_ExpoL (LONGREAL x); +export void Reals_SetExpo (REAL *x, INT16 ex); +export REAL Reals_Ten (INT16 e); +export LONGREAL Reals_TenL (INT16 e); +static CHAR Reals_ToHex (INT16 i); + + +REAL Reals_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +LONGREAL Reals_TenL (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + for (;;) { + if (__ODD(e)) { + r = r * power; + } + e = __ASHR(e, 1); + if (e <= 0) { + return r; + } + power = power * power; + } + __RETCHK; +} + +INT16 Reals_Expo (REAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 2, i, INT16); + return __MASK(__ASHR(i, 7), -256); +} + +void Reals_SetExpo (REAL *x, INT16 ex) +{ + CHAR c; + __GET((ADDRESS)x + 3, c, CHAR); + __PUT((ADDRESS)x + 3, __CHR(__ASHL(__ASHR((INT16)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((ADDRESS)x + 2, c, CHAR); + __PUT((ADDRESS)x + 2, __CHR(__MASK((INT16)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); +} + +INT16 Reals_ExpoL (LONGREAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 6, i, INT16); + return __MASK(__ASHR(i, 4), -2048); +} + +void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + INT32 i, j, k; + if (x < (LONGREAL)0) { + x = -x; + } + k = 0; + if (n > 9) { + i = __SHORT(__ENTIER(x / (LONGREAL)(LONGREAL)1000000000), 2147483648LL); + j = __SHORT(__ENTIER(x - i * (LONGREAL)1000000000), 2147483648LL); + if (j < 0) { + j = 0; + } + while (k < 9) { + d[__X(k, d__len)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } + } else { + i = __SHORT(__ENTIER(x), 2147483648LL); + } + while (k < n) { + d[__X(k, d__len)] = __CHR((int)__MOD(i, 10) + 48); + i = __DIV(i, 10); + k += 1; + } +} + +void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + Reals_ConvertL(x, n, (void*)d, d__len); +} + +static CHAR Reals_ToHex (INT16 i) +{ + if (i < 10) { + return __CHR(i + 48); + } else { + return __CHR(i + 55); + } + __RETCHK; +} + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len) +{ + INT16 i; + INT32 l; + CHAR by; + i = 0; + l = b__len; + while (i < l) { + by = __VAL(CHAR, b[__X(i, b__len)]); + d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((INT16)by, 4)); + d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((INT16)by, -16)); + i += 1; + } +} + +void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&y, 4, (void*)d, d__len * 1); +} + +void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&x, 8, (void*)d, d__len * 1); +} + + +export void *Reals__init(void) +{ + __DEFMOD; + __REGMOD("Reals", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/Reals.h b/bootstrap/unix-88/Reals.h new file mode 100644 index 00000000..93e7fa75 --- /dev/null +++ b/bootstrap/unix-88/Reals.h @@ -0,0 +1,23 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Reals__h +#define Reals__h + +#include "SYSTEM.h" + + + + +import void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +import void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +import void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +import void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +import INT16 Reals_Expo (REAL x); +import INT16 Reals_ExpoL (LONGREAL x); +import void Reals_SetExpo (REAL *x, INT16 ex); +import REAL Reals_Ten (INT16 e); +import LONGREAL Reals_TenL (INT16 e); +import void *Reals__init(void); + + +#endif // Reals diff --git a/bootstrap/unix-88/Strings.c b/bootstrap/unix-88/Strings.c new file mode 100644 index 00000000..4b18812f --- /dev/null +++ b/bootstrap/unix-88/Strings.c @@ -0,0 +1,374 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Reals.h" + + + + +export void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +export void Strings_Cap (CHAR *s, ADDRESS s__len); +export void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +export void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +export void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export INT16 Strings_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +export INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +export void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +export void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); + + +INT16 Strings_Length (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + if (i <= 32767) { + __DEL(s); + return __SHORT(i, 32768); + } else { + __DEL(s); + return 32767; + } + __RETCHK; +} + +void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(extra, extra__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(extra, extra__len); + i = 0; + while ((i < n2 && (i + n1) < dest__len)) { + dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; + i += 1; + } + if ((i + n1) < dest__len) { + dest[__X(i + n1, dest__len)] = 0x00; + } + __DEL(extra); +} + +void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(source, source__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(source, source__len); + if (pos < 0) { + pos = 0; + } + if (pos > n1) { + Strings_Append(dest, dest__len, (void*)source, source__len); + __DEL(source); + return; + } + if ((pos + n2) < dest__len) { + i = n1; + while (i >= pos) { + if ((i + n2) < dest__len) { + dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; + } + i -= 1; + } + } + i = 0; + while (i < n2) { + dest[__X(pos + i, dest__len)] = source[__X(i, source__len)]; + i += 1; + } + __DEL(source); +} + +void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n) +{ + INT16 len, i; + len = Strings_Length(s, s__len); + if (pos < 0) { + pos = 0; + } else if (pos >= len) { + return; + } + if (pos + n < len) { + i = pos + n; + while (i < len) { + s[__X(i - n, s__len)] = s[__X(i, s__len)]; + i += 1; + } + if ((i - n) < s__len) { + s[__X(i - n, s__len)] = 0x00; + } + } else { + s[__X(pos, s__len)] = 0x00; + } +} + +void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + __DUP(source, source__len, CHAR); + Strings_Delete((void*)dest, dest__len, pos, pos + Strings_Length(source, source__len)); + Strings_Insert(source, source__len, pos, (void*)dest, dest__len); + __DEL(source); +} + +void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len) +{ + INT16 len, destLen, i; + __DUP(source, source__len, CHAR); + len = Strings_Length(source, source__len); + destLen = __SHORT(dest__len, 32768) - 1; + if (pos < 0) { + pos = 0; + } + if (pos >= len) { + dest[0] = 0x00; + __DEL(source); + return; + } + i = 0; + while (((((pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + if (i < destLen) { + dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; + } + i += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(source); +} + +INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos) +{ + INT16 n1, n2, i, j; + __DUP(pattern, pattern__len, CHAR); + __DUP(s, s__len, CHAR); + n1 = Strings_Length(s, s__len); + n2 = Strings_Length(pattern, pattern__len); + if (n2 == 0) { + __DEL(pattern); + __DEL(s); + return 0; + } + i = pos; + while (i <= n1 - n2) { + if (s[__X(i, s__len)] == pattern[0]) { + j = 1; + while ((j < n2 && s[__X(i + j, s__len)] == pattern[__X(j, pattern__len)])) { + j += 1; + } + if (j == n2) { + __DEL(pattern); + __DEL(s); + return i; + } + } + i += 1; + } + __DEL(pattern); + __DEL(s); + return -1; +} + +void Strings_Cap (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + if (('a' <= s[__X(i, s__len)] && s[__X(i, s__len)] <= 'z')) { + s[__X(i, s__len)] = __CAP(s[__X(i, s__len)]); + } + i += 1; + } +} + +static struct Match__7 { + struct Match__7 *lnk; +} *Match__7_s; + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m); + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m) +{ + while ((((n >= 0 && m >= 0)) && mask[__X(m, mask__len)] != '*')) { + if (name[__X(n, name__len)] != mask[__X(m, mask__len)]) { + return 0; + } + n -= 1; + m -= 1; + } + if (m < 0) { + return n < 0; + } + while ((m >= 0 && mask[__X(m, mask__len)] == '*')) { + m -= 1; + } + if (m < 0) { + return 1; + } + while (n >= 0) { + if (M__8(name, name__len, mask, mask__len, n, m)) { + return 1; + } + n -= 1; + } + return 0; +} + +BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len) +{ + struct Match__7 _s; + BOOLEAN __retval; + __DUP(string, string__len, CHAR); + __DUP(pattern, pattern__len, CHAR); + _s.lnk = Match__7_s; + Match__7_s = &_s; + __retval = M__8((void*)string, string__len, (void*)pattern, pattern__len, Strings_Length(string, string__len) - 1, Strings_Length(pattern, pattern__len) - 1); + Match__7_s = _s.lnk; + __DEL(string); + __DEL(pattern); + ; + return __retval; +} + +void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r) +{ + INT16 p, e; + REAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (REAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (REAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (REAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (REAL)(REAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (REAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + +void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r) +{ + INT16 p, e; + LONGREAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (LONGREAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (LONGREAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (LONGREAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (LONGREAL)(LONGREAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (LONGREAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + + +export void *Strings__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Reals); + __REGMOD("Strings", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/Strings.h b/bootstrap/unix-88/Strings.h new file mode 100644 index 00000000..f0e3ae34 --- /dev/null +++ b/bootstrap/unix-88/Strings.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Strings__h +#define Strings__h + +#include "SYSTEM.h" + + + + +import void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +import void Strings_Cap (CHAR *s, ADDRESS s__len); +import void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +import void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +import void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import INT16 Strings_Length (CHAR *s, ADDRESS s__len); +import BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +import INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +import void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +import void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); +import void *Strings__init(void); + + +#endif // Strings diff --git a/bootstrap/unix-88/Texts.c b/bootstrap/unix-88/Texts.c new file mode 100644 index 00000000..77dc1bac --- /dev/null +++ b/bootstrap/unix-88/Texts.c @@ -0,0 +1,1833 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Files.h" +#include "Modules.h" +#include "Reals.h" + +typedef + struct Texts_RunDesc *Texts_Run; + +typedef + struct Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_RunDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + } Texts_RunDesc; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + struct Texts_ElemDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + } Texts_ElemDesc; + +struct Texts__1 { /* Texts_ElemDesc */ + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + Files_File file; + INT32 org, span; + CHAR mod[32], proc[32]; +}; + +typedef + struct Texts__1 *Texts_Alien; + +typedef + struct Texts_BufDesc { + INT32 len; + Texts_Run head; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + CHAR name[32]; + } Texts_FontDesc; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_PieceDesc *Texts_Piece; + +typedef + struct Texts_PieceDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + Files_File file; + INT32 org; + } Texts_PieceDesc; + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + Texts_Run head, cache; + INT32 corg; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + Files_Rider rider; + Files_File file; + } Texts_Writer; + + +export Texts_Elem Texts_new; +static Texts_Buffer Texts_del; +static Texts_FontsFont Texts_FontsDefault; + +export ADDRESS *Texts_FontDesc__typ; +export ADDRESS *Texts_RunDesc__typ; +export ADDRESS *Texts_PieceDesc__typ; +export ADDRESS *Texts_ElemMsg__typ; +export ADDRESS *Texts_ElemDesc__typ; +export ADDRESS *Texts_FileMsg__typ; +export ADDRESS *Texts_CopyMsg__typ; +export ADDRESS *Texts_IdentifyMsg__typ; +export ADDRESS *Texts_BufDesc__typ; +export ADDRESS *Texts_TextDesc__typ; +export ADDRESS *Texts_Reader__typ; +export ADDRESS *Texts_Scanner__typ; +export ADDRESS *Texts_Writer__typ; +export ADDRESS *Texts__1__typ; + +export void Texts_Append (Texts_Text T, Texts_Buffer B); +export void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +static Texts_Elem Texts_CloneElem (Texts_Elem e); +static Texts_Piece Texts_ClonePiece (Texts_Piece p); +export void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +export void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +export void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +export Texts_Text Texts_ElemBase (Texts_Elem E); +export INT32 Texts_ElemPos (Texts_Elem E); +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off); +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len); +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ); +export void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +export void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v); +export void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_OpenBuf (Texts_Buffer B); +export void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +export void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +export void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +export INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +export void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Recall (Texts_Buffer *B); +export void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +export void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +export void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +export void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +export void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base); +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un); +export void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +export void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +export void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +export void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +export void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +export void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +export void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +export void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +export void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +export void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +export void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +export void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +export void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); + + +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len) +{ + Texts_FontsFont F = NIL; + __NEW(F, Texts_FontDesc); + __COPY(name, F->name, 32); + return F; +} + +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off) +{ + Texts_Run v = NIL; + INT32 m; + if (*pos >= T->len) { + *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) { + while (m >= v->len) { + m -= v->len; + v = v->next; + } + } else { + while (m < 0) { + v = v->prev; + m += v->len; + } + } + *u = v; + *org = *pos - m; + *off = m; + T->cache = v->prev; + T->corg = *org; + } +} + +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un) +{ + Texts_Piece p = NIL, U = NIL; + if (off == 0) { + *un = *u; + *u = (*un)->prev; + } else if (off >= (*u)->len) { + *un = (*u)->next; + } else { + __NEW(p, Texts_PieceDesc); + *un = (Texts_Run)p; + U = __GUARDP(*u, Texts_PieceDesc, 1); + __GUARDEQP(p, Texts_PieceDesc) = *U; + p->org += off; + p->len -= off; + U->len -= p->len; + p->ascii = (*u)->ascii; + p->prev = (Texts_Run)U; + p->next = U->next; + p->next->prev = (Texts_Run)p; + U->next = (Texts_Run)p; + } +} + +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v) +{ + Texts_Piece p = NIL, q = NIL; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __ISP(*v, Texts_PieceDesc, 1))) && __STRCMP(u->fnt->name, (*v)->fnt->name) == 0)) && u->col == (*v)->col)) && u->voff == (*v)->voff)) && __GUARDP(u, Texts_PieceDesc, 1)->ascii == __GUARDP(*v, Texts_PieceDesc, 1)->ascii)) { + p = __GUARDP(u, Texts_PieceDesc, 1); + q = __GUARDP(*v, Texts_PieceDesc, 1); + if ((p->file == q->file && p->org + p->len == q->org)) { + if (T->cache == u) { + T->corg += q->len; + } else if (T->cache == *v) { + T->cache = T->head; + T->corg = 0; + } + p->len += q->len; + *v = (*v)->next; + } + } +} + +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base) +{ + Texts_Run u = NIL; + if (v != w->next) { + u = un->prev; + u->next = v; + v->prev = u; + un->prev = w; + w->next = un; + do { + if (__ISP(v, Texts_ElemDesc, 1)) { + __GUARDP(v, Texts_ElemDesc, 1)->base = base; + } + v = v->next; + } while (!(v == un)); + } +} + +static Texts_Piece Texts_ClonePiece (Texts_Piece p) +{ + Texts_Piece q = NIL; + __NEW(q, Texts_PieceDesc); + __GUARDEQP(q, Texts_PieceDesc) = *p; + return q; +} + +static Texts_Elem Texts_CloneElem (Texts_Elem e) +{ + Texts_CopyMsg msg; + msg.e = NIL; + (*e->handle)(e, (void*)&msg, Texts_CopyMsg__typ); + return msg.e; +} + +void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE) +{ + 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; +} + +Texts_Text Texts_ElemBase (Texts_Elem E) +{ + return E->base; +} + +INT32 Texts_ElemPos (Texts_Elem E) +{ + Texts_Run u = NIL; + INT32 pos; + u = E->base->head->next; + pos = 0; + while (u != (void *) E) { + pos = pos + u->len; + u = u->next; + } + return pos; +} + +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ) +{ + Texts_Alien e = NIL; + Files_Rider r; + INT32 i; + CHAR ch; + if (__ISP(E, Texts__1, 2)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + Texts_CopyMsg *msg__ = (void*)msg; + __NEW(e, Texts__1); + Texts_CopyElem((void*)(*(Texts_Alien*)&E), (void*)e); + e->file = (*(Texts_Alien*)&E)->file; + e->org = (*(Texts_Alien*)&E)->org; + e->span = (*(Texts_Alien*)&E)->span; + __MOVE((*(Texts_Alien*)&E)->mod, e->mod, 32); + __MOVE((*(Texts_Alien*)&E)->proc, e->proc, 32); + (*msg__).e = (Texts_Elem)e; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + Texts_IdentifyMsg *msg__ = (void*)msg; + __COPY((*(Texts_Alien*)&E)->mod, (*msg__).mod, 32); + __COPY((*(Texts_Alien*)&E)->proc, (*msg__).proc, 32); + (*msg__).mod[31] = 0x01; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_FileMsg, 1)) { + if (__IS(msg__typ, Texts_FileMsg, 1)) { + Texts_FileMsg *msg__ = (void*)msg; + if ((*msg__).id == 1) { + Files_Set(&r, Files_Rider__typ, (*(Texts_Alien*)&E)->file, (*(Texts_Alien*)&E)->org); + i = (*(Texts_Alien*)&E)->span; + while (i > 0) { + Files_Read(&r, Files_Rider__typ, (void*)&ch); + Files_Write(&(*msg__).r, Files_Rider__typ, ch); + i -= 1; + } + } + } else __WITHCHK; + } + } else __WITHCHK; +} + +void Texts_OpenBuf (Texts_Buffer B) +{ + Texts_Run u = NIL; + __NEW(u, Texts_RunDesc); + u->next = u; + u->prev = u; + B->head = u; + B->len = 0; +} + +void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB) +{ + Texts_Run u = NIL, v = NIL, vn = NIL; + u = SB->head->next; + v = DB->head->prev; + while (u != SB->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + vn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + } else { + vn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + v->next = vn; + vn->prev = v; + v = vn; + u = u->next; + } + v->next = DB->head; + DB->head->prev = v; + DB->len += SB->len; +} + +void Texts_Recall (Texts_Buffer *B) +{ + *B = Texts_del; + Texts_del = NIL; +} + +void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B) +{ + Texts_Run u = NIL, v = NIL, w = NIL, wn = NIL; + INT32 uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Find(T, &end, &v, &vo, &vd); + w = B->head->prev; + while (u != v) { + if (__ISP(u, Texts_PieceDesc, 1)) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + wn->len -= ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + } else { + wn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + w->next = wn; + wn->prev = w; + w = wn; + u = u->next; + ud = 0; + } + if (vd > 0) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(v, Texts_PieceDesc, 1)); + wn->len = vd - ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + w->next = wn; + wn->prev = w; + w = wn; + } + w->next = B->head; + B->head->prev = w; + B->len += end - beg; +} + +void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B) +{ + Texts_Run u = NIL, un = NIL, v = NIL; + Texts_Piece p = NIL, q = NIL; + INT32 uo, ud, len; + Texts_Find(T, &pos, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + len = B->len; + v = B->head->next; + Texts_Merge(T, u, &v); + Texts_Splice(un, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Append (Texts_Text T, Texts_Buffer B) +{ + Texts_Run v = NIL; + INT32 pos, len; + pos = T->len; + len = B->len; + v = B->head->next; + Texts_Merge(T, T->head->prev, &v); + Texts_Splice(T->head, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Delete (Texts_Text T, INT32 beg, INT32 end) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + __NEW(Texts_del, Texts_BufDesc); + Texts_OpenBuf(Texts_del); + Texts_del->len = end - beg; + Texts_Splice(Texts_del->head, un, v, NIL); + Texts_Merge(T, u, &vn); + u->next = vn; + vn->prev = u; + T->len -= end - beg; + if (T->notify != NIL) { + (*T->notify)(T, 2, beg, end); + } +} + +void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + while (un != vn) { + if ((__IN(0, sel, 32) && fnt != NIL)) { + un->fnt = fnt; + } + if (__IN(1, sel, 32)) { + un->col = col; + } + if (__IN(2, sel, 32)) { + un->voff = voff; + } + Texts_Merge(T, u, &un); + if (u->next == un) { + u = un; + un = un->next; + } else { + u->next = un; + un->prev = u; + } + } + Texts_Merge(T, u, &un); + u->next = un; + un->prev = u; + if (T->notify != NIL) { + (*T->notify)(T, 0, beg, end); + } +} + +void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos) +{ + Texts_Run u = NIL; + if (pos >= T->len) { + pos = T->len; + } + Texts_Find(T, &pos, &u, &(*R).org, &(*R).off); + (*R).run = u; + (*R).eot = 0; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, __GUARDP(u, Texts_PieceDesc, 1)->org + (*R).off); + } +} + +void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch) +{ + Texts_Run u = NIL; + INT32 pos; + CHAR nextch; + u = (*R).run; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).off += 1; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&*ch); + (*R).elem = NIL; + if ((*ch == 0x0a && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + *ch = 0x0d; + } else if ((*ch == 0x0d && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + pos = Files_Pos(&(*R).rider, Files_Rider__typ); + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&nextch); + if (nextch == 0x0a) { + (*R).off += 1; + } else { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, pos); + } + } + } else if (__ISP(u, Texts_ElemDesc, 1)) { + *ch = 0x1c; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + *ch = 0x00; + (*R).elem = NIL; + (*R).eot = 1; + } + if ((*R).off == u->len) { + (*R).org += u->len; + u = u->next; + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + } else __WITHCHK; + } + (*R).run = u; + (*R).off = 0; + } +} + +void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL, un = NIL; + u = (*R).run; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org += u->len; + u = u->next; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + un = u->next; + (*R).run = un; + (*R).org += 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + if (__ISP(un, Texts_PieceDesc, 1)) { + if (__ISP(un, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&un)->file, (*(Texts_Piece*)&un)->org); + } else __WITHCHK; + } + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL; + u = (*R).run->prev; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org -= u->len; + u = u->prev; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + (*R).run = u; + (*R).org -= 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ) +{ + return (*R).org + (*R).off; +} + +void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos) +{ + Texts_OpenReader((void*)&*S, S__typ, T, pos); + (*S).line = 0; + (*S).nextCh = ' '; +} + +static struct Scan__31 { + Texts_Scanner *S; + ADDRESS *S__typ; + CHAR *ch; + BOOLEAN *negE; + INT16 *e; + struct Scan__31 *lnk; +} *Scan__31_s; + +static void ReadScaleFactor__32 (void); + +static void ReadScaleFactor__32 (void) +{ + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + if (*Scan__31_s->ch == '-') { + *Scan__31_s->negE = 1; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } else { + *Scan__31_s->negE = 0; + if (*Scan__31_s->ch == '+') { + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } + } + while (('0' <= *Scan__31_s->ch && *Scan__31_s->ch <= '9')) { + *Scan__31_s->e = (*Scan__31_s->e * 10 + (INT16)*Scan__31_s->ch) - 48; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } +} + +void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ) +{ + CHAR ch, term; + BOOLEAN neg, negE, hex; + INT8 i, j, h; + INT16 e; + INT32 k; + REAL x, f; + LONGREAL y, g; + CHAR d[32]; + struct Scan__31 _s; + _s.S = S; _s.S__typ = S__typ; + _s.ch = &ch; + _s.negE = &negE; + _s.e = &e; + _s.lnk = Scan__31_s; + Scan__31_s = &_s; + ch = (*S).nextCh; + i = 0; + for (;;) { + if (ch == 0x0d) { + (*S).line += 1; + } else if ((ch != ' ' && ch != 0x09)) { + break; + } + Texts_Read((void*)&*S, S__typ, &ch); + } + if ((('A' <= __CAP(ch) && __CAP(ch) <= 'Z') || ch == '/') || ch == '.') { + do { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } while (!((((__CAP(ch) > 'Z' && ch != '_') || ('A' > __CAP(ch) && ch > '9')) || ((('0' > ch && ch != '.')) && ch != '/')) || i == 63)); + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i; + (*S).class = 1; + } else if (ch == '"') { + Texts_Read((void*)&*S, S__typ, &ch); + while ((((ch != '"' && ch >= ' ')) && i != 63)) { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i + 1; + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 2; + } else { + if (ch == '-') { + neg = 1; + Texts_Read((void*)&*S, S__typ, &ch); + } else { + neg = 0; + } + if (('0' <= ch && ch <= '9')) { + hex = 0; + j = 0; + for (;;) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + if (ch < '0') { + break; + } + if ('9' < ch) { + if (('A' <= ch && ch <= 'F')) { + hex = 1; + ch = __CHR((INT16)ch - 7); + } else if (('a' <= ch && ch <= 'f')) { + hex = 1; + ch = __CHR((INT16)ch - 39); + } else { + break; + } + } + } + if (ch == 'H') { + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 3; + if (i - j > 8) { + j = i - 8; + } + k = (INT16)d[__X(j, 32)] - 48; + j += 1; + if ((i - j == 7 && k >= 8)) { + k -= 16; + } + while (j < i) { + k = __ASHL(k, 4) + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + } else if (ch == '.') { + Texts_Read((void*)&*S, S__typ, &ch); + h = i; + while (('0' <= ch && ch <= '9')) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + if (ch == 'D') { + e = 0; + y = (LONGREAL)0; + g = (LONGREAL)1; + do { + y = y * (LONGREAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + g = g / (LONGREAL)(LONGREAL)10; + y = ((INT16)d[__X(j, 32)] - 48) * g + y; + j += 1; + } + ReadScaleFactor__32(); + if (negE) { + if (e <= 308) { + y = y / (LONGREAL)Reals_TenL(e); + } else { + y = (LONGREAL)0; + } + } else if (e > 0) { + if (e <= 308) { + y = Reals_TenL(e) * y; + } else { + __HALT(40); + } + } + if (neg) { + y = -y; + } + (*S).class = 5; + (*S).y = y; + } else { + e = 0; + x = (REAL)0; + f = (REAL)1; + do { + x = x * (REAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + f = f / (REAL)(REAL)10; + x = ((INT16)d[__X(j, 32)] - 48) * f + x; + j += 1; + } + if (ch == 'E') { + ReadScaleFactor__32(); + } + if (negE) { + if (e <= 38) { + x = x / (REAL)Reals_Ten(e); + } else { + x = (REAL)0; + } + } else if (e > 0) { + if (e <= 38) { + x = Reals_Ten(e) * x; + } else { + __HALT(40); + } + } + if (neg) { + x = -x; + } + (*S).class = 4; + (*S).x = x; + } + if (hex) { + (*S).class = 0; + } + } else { + (*S).class = 3; + k = 0; + do { + k = k * 10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == i)); + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + if (hex) { + (*S).class = 0; + } else { + (*S).class = 3; + } + } + } else { + (*S).class = 6; + if (neg) { + (*S).c = '-'; + } else { + (*S).c = ch; + Texts_Read((void*)&*S, S__typ, &ch); + } + } + } + (*S).nextCh = ch; + Scan__31_s = _s.lnk; +} + +void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ) +{ + __NEW((*W).buf, Texts_BufDesc); + Texts_OpenBuf((*W).buf); + (*W).fnt = Texts_FontsDefault; + (*W).col = 15; + (*W).voff = 0; + (*W).file = Files_New((CHAR*)"", 1); + Files_Set(&(*W).rider, Files_Rider__typ, (*W).file, 0); +} + +void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt) +{ + (*W).fnt = fnt; +} + +void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col) +{ + (*W).col = col; +} + +void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff) +{ + (*W).voff = voff; +} + +void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Files_Write(&(*W).rider, Files_Rider__typ, ch); + (*W).buf->len += 1; + un = (*W).buf->head; + u = un->prev; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __GUARDP(u, Texts_PieceDesc, 1)->file == (*W).file)) && __STRCMP(u->fnt->name, (*W).fnt->name) == 0)) && u->col == (*W).col)) && u->voff == (*W).voff)) && !__GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + u->len += 1; + } else { + __NEW(p, Texts_PieceDesc); + u->next = (Texts_Run)p; + p->prev = u; + p->next = un; + un->prev = (Texts_Run)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 = 0; + } +} + +void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e) +{ + Texts_Run u = NIL, un = NIL; + if (e->base != NIL) { + __HALT(99); + } + (*W).buf->len += 1; + e->len = 1; + e->fnt = (*W).fnt; + e->col = (*W).col; + e->voff = (*W).voff; + un = (*W).buf->head; + u = un->prev; + u->next = (Texts_Run)e; + e->prev = u; + e->next = un; + un->prev = (Texts_Run)e; +} + +void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ) +{ + Texts_Write(&*W, W__typ, 0x0d); +} + +void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while (s[__X(i, s__len)] >= ' ') { + Texts_Write(&*W, W__typ, s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n) +{ + INT16 i; + INT64 x0; + CHAR a[24]; + i = 0; + if (x < 0) { + if (x == (-9223372036854775807LL-1)) { + Texts_WriteString(&*W, W__typ, (CHAR*)" -9223372036854775808", 22); + return; + } else { + n -= 1; + x0 = -x; + } + } else { + x0 = x; + } + do { + a[__X(i, 24)] = __CHR(__MOD(x0, 10) + 48); + x0 = __DIV(x0, 10); + i += 1; + } while (!(x0 == 0)); + while (n > (INT64)i) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + if (x < 0) { + Texts_Write(&*W, W__typ, '-'); + } + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 24)]); + } while (!(i == 0)); +} + +void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x) +{ + INT16 i; + INT32 y; + CHAR a[20]; + i = 0; + Texts_Write(&*W, W__typ, ' '); + do { + y = __MASK(x, -16); + if (y < 10) { + a[__X(i, 20)] = __CHR(y + 48); + } else { + a[__X(i, 20)] = __CHR(y + 55); + } + x = __ASHR(x, 4); + i += 1; + } while (!(i == 8)); + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 20)]); + } while (!(i == 0)); +} + +void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n) +{ + INT16 e; + REAL x0; + CHAR d[9]; + e = Reals_Expo(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 9) { + n = 3; + } else { + n -= 6; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 8)); + if (x < (REAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __ASHR((e - 127) * 77, 8); + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + x0 = Reals_Ten(n - 1); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + x = x * 1.0000000e-001; + e += 1; + } + Reals_Convert(x, n, (void*)d, 9); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'E'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +static struct WriteRealFix__53 { + Texts_Writer *W; + ADDRESS *W__typ; + INT16 *i; + CHAR (*d)[9]; + struct WriteRealFix__53 *lnk; +} *WriteRealFix__53_s; + +static void dig__54 (INT16 n); +static void seq__56 (CHAR ch, INT16 n); + +static void seq__56 (CHAR ch, INT16 n) +{ + while (n > 0) { + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, ch); + n -= 1; + } +} + +static void dig__54 (INT16 n) +{ + while (n > 0) { + *WriteRealFix__53_s->i -= 1; + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, (*WriteRealFix__53_s->d)[__X(*WriteRealFix__53_s->i, 9)]); + n -= 1; + } +} + +void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k) +{ + INT16 e, i; + CHAR sign; + REAL x0; + CHAR d[9]; + struct WriteRealFix__53 _s; + _s.W = W; _s.W__typ = W__typ; + _s.i = &i; + _s.d = (void*)d; + _s.lnk = WriteRealFix__53_s; + WriteRealFix__53_s = &_s; + e = Reals_Expo(x); + if (k < 0) { + k = 0; + } + if (e == 0) { + seq__56(' ', (n - k) - 2); + Texts_Write(&*W, W__typ, '0'); + seq__56(' ', k + 1); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + seq__56(' ', n - 4); + } else { + e = __ASHR((e - 127) * 77, 8); + if (x < (REAL)0) { + sign = '-'; + x = -x; + } else { + sign = ' '; + } + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + if (k + e >= 8) { + k = 8 - e; + } else if (k + e < 0) { + k = -e; + x = (REAL)0; + } + x0 = Reals_Ten(k + e); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + e += 1; + } + e += 1; + i = k + e; + Reals_Convert(x, i, (void*)d, 9); + if (e > 0) { + seq__56(' ', ((n - e) - k) - 2); + Texts_Write(&*W, W__typ, sign); + dig__54(e); + Texts_Write(&*W, W__typ, '.'); + dig__54(k); + } else { + seq__56(' ', (n - k) - 3); + Texts_Write(&*W, W__typ, sign); + Texts_Write(&*W, W__typ, '0'); + Texts_Write(&*W, W__typ, '.'); + seq__56('0', -e); + dig__54(k + e); + } + } + WriteRealFix__53_s = _s.lnk; +} + +void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x) +{ + INT16 i; + CHAR d[8]; + Reals_ConvertH(x, (void*)d, 8); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 8)]); + i += 1; + } while (!(i == 8)); +} + +void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n) +{ + INT16 e; + LONGREAL x0; + CHAR d[16]; + e = Reals_ExpoL(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 2047) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 10) { + n = 3; + } else { + n -= 7; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 16)); + if (x < (LONGREAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Reals_TenL(e); + } else { + x = Reals_TenL(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + x0 = Reals_TenL(n - 1); + x = x0 * x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + Reals_ConvertL(x, n, (void*)d, 16); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'D'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 100) + 48)); + e = (int)__MOD(e, 100); + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x) +{ + INT16 i; + CHAR d[16]; + Reals_ConvertHL(x, (void*)d, 16); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 16)]); + i += 1; + } while (!(i == 16)); +} + +static struct WriteDate__43 { + Texts_Writer *W; + ADDRESS *W__typ; + struct WriteDate__43 *lnk; +} *WriteDate__43_s; + +static void WritePair__44 (CHAR ch, INT32 x); + +static void WritePair__44 (CHAR ch, INT32 x) +{ + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, ch); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR(__DIV(x, 10) + 48)); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR((int)__MOD(x, 10) + 48)); +} + +void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d) +{ + struct WriteDate__43 _s; + _s.W = W; _s.W__typ = W__typ; + _s.lnk = WriteDate__43_s; + WriteDate__43_s = &_s; + WritePair__44(' ', __MASK(d, -32)); + WritePair__44('.', __MASK(__ASHR(d, 5), -16)); + WritePair__44('.', __MASK(__ASHR(d, 9), -128)); + WritePair__44(' ', __MASK(__ASHR(t, 12), -32)); + WritePair__44(':', __MASK(__ASHR(t, 6), -64)); + WritePair__44(':', __MASK(t, -64)); + WriteDate__43_s = _s.lnk; +} + +static struct Load0__16 { + Texts_Text *T; + INT8 *ecnt; + Files_File *f; + Texts_FileMsg *msg; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Load0__16 *lnk; +} *Load0__16_s; + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e); + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e) +{ + Heap_Module M = NIL; + Heap_Command Cmd; + Texts_Alien a = NIL; + INT32 org, ew, eh; + INT8 eno; + Texts_new = NIL; + Files_ReadLInt(&*r, r__typ, &ew); + Files_ReadLInt(&*r, r__typ, &eh); + Files_Read(&*r, r__typ, (void*)&eno); + if (eno > *Load0__16_s->ecnt) { + *Load0__16_s->ecnt = eno; + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->mods)[__X(eno, 64)], 32); + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->procs)[__X(eno, 64)], 32); + } + org = Files_Pos(&*r, r__typ); + M = Modules_ThisMod((*Load0__16_s->mods)[__X(eno, 64)], 32); + if (M != NIL) { + Cmd = Modules_ThisCommand(M, (*Load0__16_s->procs)[__X(eno, 64)], 32); + if (Cmd != NIL) { + (*Cmd)(); + } + } + *e = Texts_new; + if (*e != NIL) { + (*e)->W = ew; + (*e)->H = eh; + (*e)->base = *Load0__16_s->T; + (*Load0__16_s->msg).pos = pos; + (*(*e)->handle)(*e, (void*)&*Load0__16_s->msg, Texts_FileMsg__typ); + if (Files_Pos(&*r, r__typ) != org + span) { + *e = NIL; + } + } + if (*e == NIL) { + Files_Set(&*r, r__typ, *Load0__16_s->f, org + span); + __NEW(a, Texts__1); + a->W = ew; + a->H = eh; + a->handle = Texts_HandleAlien; + a->base = *Load0__16_s->T; + a->file = *Load0__16_s->f; + a->org = org; + a->span = span; + __COPY((*Load0__16_s->mods)[__X(eno, 64)], a->mod, 32); + __COPY((*Load0__16_s->procs)[__X(eno, 64)], a->proc, 32); + *e = (Texts_Elem)a; + } +} + +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Texts_Elem e = NIL; + INT32 org, pos, hlen, plen; + INT8 ecnt, fcnt, fno, col, voff; + Files_File f = NIL; + Texts_FileMsg msg; + CHAR mods[64][32], procs[64][32]; + CHAR name[32]; + Texts_FontsFont fnts[32]; + struct Load0__16 _s; + _s.T = &T; + _s.ecnt = &ecnt; + _s.f = &f; + _s.msg = &msg; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Load0__16_s; + Load0__16_s = &_s; + pos = Files_Pos(&*r, r__typ); + f = Files_Base(&*r, r__typ); + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + T->head = u; + ecnt = 0; + fcnt = 0; + msg.id = 0; + msg.r = *r; + Files_ReadLInt(&msg.r, Files_Rider__typ, &hlen); + org = (pos - 2) + hlen; + pos = org; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + while (fno != 0) { + if (fno > fcnt) { + fcnt = fno; + Files_ReadString(&msg.r, Files_Rider__typ, (void*)name, 32); + fnts[__X(fno, 32)] = Texts_FontsThis((void*)name, 32); + } + Files_Read(&msg.r, Files_Rider__typ, (void*)&col); + Files_Read(&msg.r, Files_Rider__typ, (void*)&voff); + Files_ReadLInt(&msg.r, Files_Rider__typ, &plen); + if (plen > 0) { + __NEW(p, Texts_PieceDesc); + p->file = f; + p->org = pos; + p->ascii = 0; + un = (Texts_Run)p; + un->len = plen; + } else { + LoadElem__17(&msg.r, Files_Rider__typ, pos - org, -plen, &e); + un = (Texts_Run)e; + un->len = 1; + } + un->col = col; + un->voff = voff; + pos += un->len; + u->next = un; + un->prev = u; + u = un; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + } + u->next = T->head; + T->head->prev = u; + T->cache = T->head; + T->corg = 0; + Files_ReadLInt(&msg.r, Files_Rider__typ, &T->len); + Files_Set(&*r, r__typ, f, Files_Pos(&msg.r, Files_Rider__typ) + T->len); + Load0__16_s = _s.lnk; +} + +void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + INT16 tag; + Files_ReadInt(&*r, r__typ, &tag); + if (tag != -4095) { + Files_Set(&*r, r__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ) - 2); + } + Texts_Load0(&*r, r__typ, T); +} + +void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + Texts_Run u = NIL; + Texts_Piece p = NIL; + CHAR tag, version; + INT32 hlen; + __DUP(name, name__len, CHAR); + f = Files_Old(name, name__len); + if (f == NIL) { + f = Files_New((CHAR*)"", 1); + } + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Read(&r, Files_Rider__typ, (void*)&tag); + Files_Read(&r, Files_Rider__typ, (void*)&version); + if (tag == 0xf0 || (tag == 0x01 && version == 0xf0)) { + Texts_Load0(&r, Files_Rider__typ, T); + } else { + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + __NEW(p, Texts_PieceDesc); + if ((tag == 0xf7 && version == 0x07)) { + Files_Set(&r, Files_Rider__typ, f, 28); + Files_ReadLInt(&r, Files_Rider__typ, &hlen); + Files_Set(&r, Files_Rider__typ, f, 22 + hlen); + Files_ReadLInt(&r, Files_Rider__typ, &T->len); + p->org = 26 + hlen; + } else { + T->len = Files_Length(f); + p->org = 0; + } + if (T->len > 0) { + p->len = T->len; + p->fnt = Texts_FontsDefault; + p->col = 15; + p->voff = 0; + p->file = f; + p->ascii = 1; + u->next = (Texts_Run)p; + u->prev = (Texts_Run)p; + p->next = u; + p->prev = u; + } else { + u->next = u; + u->prev = u; + } + T->head = u; + T->cache = T->head; + T->corg = 0; + } + __DEL(name); +} + +static struct Store__39 { + INT8 *ecnt; + Texts_FileMsg *msg; + Texts_IdentifyMsg *iden; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Store__39 *lnk; +} *Store__39_s; + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e); + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e) +{ + Files_Rider r1; + INT32 org, span; + INT8 eno; + __COPY((*Store__39_s->iden).mod, (*Store__39_s->mods)[__X(*Store__39_s->ecnt, 64)], 32); + __COPY((*Store__39_s->iden).proc, (*Store__39_s->procs)[__X(*Store__39_s->ecnt, 64)], 32); + eno = 1; + while (__STRCMP((*Store__39_s->mods)[__X(eno, 64)], (*Store__39_s->iden).mod) != 0 || __STRCMP((*Store__39_s->procs)[__X(eno, 64)], (*Store__39_s->iden).proc) != 0) { + eno += 1; + } + Files_Set(&r1, Files_Rider__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ)); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_Write(&*r, r__typ, eno); + if (eno == *Store__39_s->ecnt) { + *Store__39_s->ecnt += 1; + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).mod, 32); + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).proc, 32); + } + (*Store__39_s->msg).pos = pos; + org = Files_Pos(&*r, r__typ); + (*e->handle)(e, (void*)&*Store__39_s->msg, Texts_FileMsg__typ); + span = Files_Pos(&*r, r__typ) - org; + Files_WriteLInt(&r1, Files_Rider__typ, -span); + Files_WriteLInt(&r1, Files_Rider__typ, e->W); + Files_WriteLInt(&r1, Files_Rider__typ, e->H); +} + +void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Files_Rider r1; + Texts_Run u = NIL, un = NIL; + Texts_Elem e = NIL; + INT32 org, pos, delta, hlen, rlen; + INT8 ecnt, fcnt; + CHAR ch; + INT8 fno; + Texts_FileMsg msg; + Texts_IdentifyMsg iden; + CHAR mods[64][32], procs[64][32]; + Texts_FontsFont fnts[32]; + CHAR block[1024]; + struct Store__39 _s; + _s.ecnt = &ecnt; + _s.msg = &msg; + _s.iden = &iden; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Store__39_s; + Store__39_s = &_s; + org = Files_Pos(&*r, r__typ); + msg.id = 1; + msg.r = *r; + Files_WriteLInt(&msg.r, Files_Rider__typ, 0); + u = T->head->next; + pos = 0; + delta = 0; + fcnt = 1; + ecnt = 1; + while (u != T->head) { + if (__ISP(u, Texts_ElemDesc, 1)) { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + } else { + iden.mod[0] = 0x01; + } + if (iden.mod[0] != 0x00) { + fnts[__X(fcnt, 32)] = u->fnt; + fno = 1; + while (__STRCMP(fnts[__X(fno, 32)]->name, u->fnt->name) != 0) { + fno += 1; + } + Files_Write(&msg.r, Files_Rider__typ, fno); + if (fno == fcnt) { + fcnt += 1; + Files_WriteString(&msg.r, Files_Rider__typ, u->fnt->name, 32); + } + Files_Write(&msg.r, Files_Rider__typ, u->col); + Files_Write(&msg.r, Files_Rider__typ, u->voff); + } + if (__ISP(u, Texts_PieceDesc, 1)) { + rlen = u->len; + un = u->next; + while ((((((__ISP(un, Texts_PieceDesc, 1) && un->fnt == u->fnt)) && un->col == u->col)) && un->voff == u->voff)) { + rlen += un->len; + un = un->next; + } + Files_WriteLInt(&msg.r, Files_Rider__typ, rlen); + pos += rlen; + u = un; + } else if (iden.mod[0] != 0x00) { + StoreElem__40(&msg.r, Files_Rider__typ, pos, __GUARDP(u, Texts_ElemDesc, 1)); + pos += 1; + u = u->next; + } else { + delta += 1; + u = u->next; + } + } + Files_Write(&msg.r, Files_Rider__typ, 0); + Files_WriteLInt(&msg.r, Files_Rider__typ, T->len - delta); + hlen = (Files_Pos(&msg.r, Files_Rider__typ) - org) + 2; + Files_Set(&r1, Files_Rider__typ, Files_Base(&msg.r, Files_Rider__typ), org); + Files_WriteLInt(&r1, Files_Rider__typ, hlen); + u = T->head->next; + while (u != T->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if ((*(Texts_Piece*)&u)->ascii) { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 0) { + Files_Read(&r1, Files_Rider__typ, (void*)&ch); + delta -= 1; + if (ch == 0x0a) { + Files_Write(&msg.r, Files_Rider__typ, 0x0d); + } else { + Files_Write(&msg.r, Files_Rider__typ, ch); + } + } + } else { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 1024) { + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, 1024); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, 1024); + delta -= 1024; + } + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, delta); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, delta); + } + } else __WITHCHK; + } else { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + if (iden.mod[0] != 0x00) { + Files_Write(&msg.r, Files_Rider__typ, 0x1c); + } + } + u = u->next; + } + __GUARDEQR(r, r__typ, Files_Rider) = msg.r; + if (T->notify != NIL) { + (*T->notify)(T, 3, 0, 0); + } + Store__39_s = _s.lnk; +} + +void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + INT16 i, res; + CHAR bak[64]; + __DUP(name, name__len, CHAR); + f = Files_New(name, name__len); + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Write(&r, Files_Rider__typ, 0xf0); + Files_Write(&r, Files_Rider__typ, 0x01); + Texts_Store(&r, Files_Rider__typ, T); + i = 0; + while (name[__X(i, name__len)] != 0x00) { + i += 1; + } + __COPY(name, bak, 64); + bak[__X(i, 64)] = '.'; + bak[__X(i + 1, 64)] = 'B'; + bak[__X(i + 2, 64)] = 'a'; + bak[__X(i + 3, 64)] = 'k'; + bak[__X(i + 4, 64)] = 0x00; + Files_Rename(name, name__len, bak, 64, &res); + Files_Register(f); + __DEL(name); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Texts_new); + P(Texts_del); + P(Texts_FontsDefault); +} + +__TDESC(Texts_FontDesc, 1, 0) = {__TDFLDS("FontDesc", 32), {-8}}; +__TDESC(Texts_RunDesc, 1, 3) = {__TDFLDS("RunDesc", 40), {0, 8, 24, -32}}; +__TDESC(Texts_PieceDesc, 1, 4) = {__TDFLDS("PieceDesc", 56), {0, 8, 24, 40, -40}}; +__TDESC(Texts_ElemMsg, 1, 0) = {__TDFLDS("ElemMsg", 1), {-8}}; +__TDESC(Texts_ElemDesc, 1, 4) = {__TDFLDS("ElemDesc", 64), {0, 8, 24, 56, -40}}; +__TDESC(Texts_FileMsg, 1, 1) = {__TDFLDS("FileMsg", 32), {16, -16}}; +__TDESC(Texts_CopyMsg, 1, 1) = {__TDFLDS("CopyMsg", 8), {0, -16}}; +__TDESC(Texts_IdentifyMsg, 1, 0) = {__TDFLDS("IdentifyMsg", 64), {-8}}; +__TDESC(Texts_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 16), {8, -16}}; +__TDESC(Texts_TextDesc, 1, 2) = {__TDFLDS("TextDesc", 40), {16, 24, -24}}; +__TDESC(Texts_Reader, 1, 4) = {__TDFLDS("Reader", 72), {8, 24, 40, 56, -40}}; +__TDESC(Texts_Scanner, 1, 4) = {__TDFLDS("Scanner", 168), {8, 24, 40, 56, -40}}; +__TDESC(Texts_Writer, 1, 4) = {__TDFLDS("Writer", 56), {0, 8, 32, 48, -40}}; +__TDESC(Texts__1, 1, 5) = {__TDFLDS("", 144), {0, 8, 24, 56, 64, -48}}; + +export void *Texts__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Reals); + __REGMOD("Texts", EnumPtrs); + __INITYP(Texts_FontDesc, Texts_FontDesc, 0); + __INITYP(Texts_RunDesc, Texts_RunDesc, 0); + __INITYP(Texts_PieceDesc, Texts_RunDesc, 1); + __INITYP(Texts_ElemMsg, Texts_ElemMsg, 0); + __INITYP(Texts_ElemDesc, Texts_RunDesc, 1); + __INITYP(Texts_FileMsg, Texts_ElemMsg, 1); + __INITYP(Texts_CopyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_IdentifyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_BufDesc, Texts_BufDesc, 0); + __INITYP(Texts_TextDesc, Texts_TextDesc, 0); + __INITYP(Texts_Reader, Texts_Reader, 0); + __INITYP(Texts_Scanner, Texts_Reader, 1); + __INITYP(Texts_Writer, Texts_Writer, 0); + __INITYP(Texts__1, Texts_ElemDesc, 2); +/* BEGIN */ + Texts_del = NIL; + __NEW(Texts_FontsDefault, Texts_FontDesc); + __MOVE("Syntax10.Scn.Fnt", Texts_FontsDefault->name, 17); + __ENDMOD; +} diff --git a/bootstrap/unix-88/Texts.h b/bootstrap/unix-88/Texts.h new file mode 100644 index 00000000..081eec2c --- /dev/null +++ b/bootstrap/unix-88/Texts.h @@ -0,0 +1,173 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Texts__h +#define Texts__h + +#include "SYSTEM.h" +#include "Files.h" + +typedef + struct Texts_BufDesc { + INT32 len; + INT64 _prvt0; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_RunDesc { + INT64 _prvt0; + char _prvt1[27]; + } Texts_RunDesc; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_ElemDesc { + INT64 _prvt0; + char _prvt1[28]; + INT32 W, H; + Texts_Handler handle; + char _prvt2[8]; + } Texts_ElemDesc; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + char _prvt0[32]; + } Texts_FontDesc; + +typedef + Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[40]; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[40]; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + char _prvt0[20]; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + char _prvt0[38]; + } Texts_Writer; + + +import Texts_Elem Texts_new; + +import ADDRESS *Texts_FontDesc__typ; +import ADDRESS *Texts_RunDesc__typ; +import ADDRESS *Texts_ElemMsg__typ; +import ADDRESS *Texts_ElemDesc__typ; +import ADDRESS *Texts_FileMsg__typ; +import ADDRESS *Texts_CopyMsg__typ; +import ADDRESS *Texts_IdentifyMsg__typ; +import ADDRESS *Texts_BufDesc__typ; +import ADDRESS *Texts_TextDesc__typ; +import ADDRESS *Texts_Reader__typ; +import ADDRESS *Texts_Scanner__typ; +import ADDRESS *Texts_Writer__typ; + +import void Texts_Append (Texts_Text T, Texts_Buffer B); +import void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +import void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +import void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +import void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +import Texts_Text Texts_ElemBase (Texts_Elem E); +import INT32 Texts_ElemPos (Texts_Elem E); +import void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +import void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_OpenBuf (Texts_Buffer B); +import void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +import void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +import void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +import INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +import void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Recall (Texts_Buffer *B); +import void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +import void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +import void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +import void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +import void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +import void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +import void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +import void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +import void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +import void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +import void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +import void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +import void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +import void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +import void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +import void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +import void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); +import void *Texts__init(void); + + +#endif // Texts diff --git a/bootstrap/unix-88/VT100.c b/bootstrap/unix-88/VT100.c new file mode 100644 index 00000000..346fb37b --- /dev/null +++ b/bootstrap/unix-88/VT100.c @@ -0,0 +1,275 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Out.h" +#include "Strings.h" + + +export CHAR VT100_CSI[5]; +static CHAR VT100_tmpstr[32]; + + +export void VT100_CHA (INT16 n); +export void VT100_CNL (INT16 n); +export void VT100_CPL (INT16 n); +export void VT100_CUB (INT16 n); +export void VT100_CUD (INT16 n); +export void VT100_CUF (INT16 n); +export void VT100_CUP (INT16 n, INT16 m); +export void VT100_CUU (INT16 n); +export void VT100_DECTCEMh (void); +export void VT100_DECTCEMl (void); +export void VT100_DSR (INT16 n); +export void VT100_ED (INT16 n); +export void VT100_EL (INT16 n); +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len); +export void VT100_HVP (INT16 n, INT16 m); +export void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +export void VT100_RCP (void); +export void VT100_Reset (void); +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end); +export void VT100_SCP (void); +export void VT100_SD (INT16 n); +export void VT100_SGR (INT16 n); +export void VT100_SGR2 (INT16 n, INT16 m); +export void VT100_SU (INT16 n); +export void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); + + +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end) +{ + CHAR h; + while (start < end) { + h = str[__X(start, str__len)]; + str[__X(start, str__len)] = str[__X(end, str__len)]; + str[__X(end, str__len)] = h; + start += 1; + end -= 1; + } +} + +void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len) +{ + CHAR b[21]; + INT16 s, e; + INT8 maxLength; + maxLength = 11; + if (int_ == (-2147483647-1)) { + __MOVE("-2147483648", b, 12); + e = 11; + } else { + if (int_ < 0) { + b[0] = '-'; + int_ = -int_; + s = 1; + } else { + s = 0; + } + e = s; + do { + b[__X(e, 21)] = __CHR((int)__MOD(int_, 10) + 48); + int_ = __DIV(int_, 10); + e += 1; + } while (!(int_ == 0)); + b[__X(e, 21)] = 0x00; + VT100_Reverse0((void*)b, 21, s, e - 1); + } + __COPY(b, str, str__len); +} + +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len) +{ + CHAR cmd[9]; + __DUP(letter, letter__len, CHAR); + __COPY(VT100_CSI, cmd, 9); + Strings_Append(letter, letter__len, (void*)cmd, 9); + Out_String(cmd, 9); + __DEL(letter); +} + +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[5], mstr[5]; + CHAR cmd[12]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 5); + VT100_IntToStr(m, (void*)mstr, 5); + __COPY(VT100_CSI, cmd, 12); + Strings_Append(nstr, 5, (void*)cmd, 12); + Strings_Append((CHAR*)";", 2, (void*)cmd, 12); + Strings_Append(mstr, 5, (void*)cmd, 12); + Strings_Append(letter, letter__len, (void*)cmd, 12); + Out_String(cmd, 12); + __DEL(letter); +} + +void VT100_Reset (void) +{ + CHAR cmd[6]; + __COPY("\033", cmd, 6); + Strings_Append((CHAR*)"c", 2, (void*)cmd, 6); + Out_String(cmd, 6); + Out_Ln(); +} + +void VT100_CUU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"A", 2); +} + +void VT100_CUD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"B", 2); +} + +void VT100_CUF (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"C", 2); +} + +void VT100_CUB (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"D", 2); +} + +void VT100_CNL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"E", 2); +} + +void VT100_CPL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"F", 2); +} + +void VT100_CHA (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"G", 2); +} + +void VT100_CUP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"H", 2); +} + +void VT100_ED (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"J", 2); +} + +void VT100_EL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"K", 2); +} + +void VT100_SU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"S", 2); +} + +void VT100_SD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"T", 2); +} + +void VT100_HVP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"f", 2); +} + +void VT100_SGR (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"m", 2); +} + +void VT100_SGR2 (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"m", 2); +} + +void VT100_DSR (INT16 n) +{ + VT100_EscSeq(6, (CHAR*)"n", 2); +} + +void VT100_SCP (void) +{ + VT100_EscSeq0((CHAR*)"s", 2); +} + +void VT100_RCP (void) +{ + VT100_EscSeq0((CHAR*)"u", 2); +} + +void VT100_DECTCEMl (void) +{ + VT100_EscSeq0((CHAR*)"\?25l", 5); +} + +void VT100_DECTCEMh (void) +{ + VT100_EscSeq0((CHAR*)"\?25h", 5); +} + +void VT100_SetAttr (CHAR *attr, ADDRESS attr__len) +{ + CHAR tmpstr[16]; + __DUP(attr, attr__len, CHAR); + __COPY(VT100_CSI, tmpstr, 16); + Strings_Append(attr, attr__len, (void*)tmpstr, 16); + Out_String(tmpstr, 16); + __DEL(attr); +} + + +export void *VT100__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Strings); + __REGMOD("VT100", 0); + __REGCMD("DECTCEMh", VT100_DECTCEMh); + __REGCMD("DECTCEMl", VT100_DECTCEMl); + __REGCMD("RCP", VT100_RCP); + __REGCMD("Reset", VT100_Reset); + __REGCMD("SCP", VT100_SCP); +/* BEGIN */ + __COPY("\033", VT100_CSI, 5); + Strings_Append((CHAR*)"[", 2, (void*)VT100_CSI, 5); + __ENDMOD; +} diff --git a/bootstrap/unix-88/VT100.h b/bootstrap/unix-88/VT100.h new file mode 100644 index 00000000..4e708647 --- /dev/null +++ b/bootstrap/unix-88/VT100.h @@ -0,0 +1,38 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef VT100__h +#define VT100__h + +#include "SYSTEM.h" + + +import CHAR VT100_CSI[5]; + + +import void VT100_CHA (INT16 n); +import void VT100_CNL (INT16 n); +import void VT100_CPL (INT16 n); +import void VT100_CUB (INT16 n); +import void VT100_CUD (INT16 n); +import void VT100_CUF (INT16 n); +import void VT100_CUP (INT16 n, INT16 m); +import void VT100_CUU (INT16 n); +import void VT100_DECTCEMh (void); +import void VT100_DECTCEMl (void); +import void VT100_DSR (INT16 n); +import void VT100_ED (INT16 n); +import void VT100_EL (INT16 n); +import void VT100_HVP (INT16 n, INT16 m); +import void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +import void VT100_RCP (void); +import void VT100_Reset (void); +import void VT100_SCP (void); +import void VT100_SD (INT16 n); +import void VT100_SGR (INT16 n); +import void VT100_SGR2 (INT16 n, INT16 m); +import void VT100_SU (INT16 n); +import void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); +import void *VT100__init(void); + + +#endif // VT100 diff --git a/bootstrap/unix-88/extTools.c b/bootstrap/unix-88/extTools.c new file mode 100644 index 00000000..ce2fc413 --- /dev/null +++ b/bootstrap/unix-88/extTools.c @@ -0,0 +1,139 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "Modules.h" +#include "OPM.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + CHAR extTools_CommandString[4096]; + + +static extTools_CommandString extTools_CFLAGS; + + +export void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len); +export void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len); + + +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len) +{ + INT16 r, status, exitcode; + extTools_CommandString fullcmd; + __DUP(title, title__len, CHAR); + __DUP(cmd, cmd__len, CHAR); + if (__IN(18, OPM_Options, 32)) { + Out_String((CHAR*)" ", 3); + Out_String(cmd, cmd__len); + Out_Ln(); + } + __COPY(cmd, fullcmd, 4096); + Heap_GC(0); + r = Platform_System(fullcmd, 4096); + status = __MASK(r, -128); + exitcode = __ASHR(r, 8); + if (exitcode > 127) { + exitcode = exitcode - 256; + } + if (r != 0) { + Out_String(title, title__len); + Out_String(cmd, cmd__len); + Out_Ln(); + Out_String((CHAR*)"-- failed: status ", 19); + Out_Int(status, 1); + Out_String((CHAR*)", exitcode ", 12); + Out_Int(exitcode, 1); + Out_String((CHAR*)".", 2); + Out_Ln(); + if ((status == 0 && exitcode == 127)) { + Out_String((CHAR*)"Is the C compiler in the current command path\?", 47); + Out_Ln(); + } + if (status != 0) { + Modules_Halt(status); + } else { + Modules_Halt(exitcode); + } + } + __DEL(title); + __DEL(cmd); +} + +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + __DUP(additionalopts, additionalopts__len, CHAR); + __COPY("gcc -fPIC -g -Wno-stringop-overflow", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Strings_Append(additionalopts, additionalopts__len, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 4096); + Strings_Append(extTools_CFLAGS, 4096, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + __DEL(additionalopts); +} + +void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len) +{ + extTools_CommandString cmd; + __DUP(moduleName, moduleName__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, (CHAR*)"", 1); + Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c", 3, (void*)cmd, 4096); + extTools_execute((CHAR*)"C compile: ", 12, cmd, 4096); + __DEL(moduleName); +} + +void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + extTools_CommandString cmd; + __DUP(additionalopts, additionalopts__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, additionalopts, additionalopts__len); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c ", 4, (void*)cmd, 4096); + if (statically) { + Strings_Append((CHAR*)" -static", 9, (void*)cmd, 4096); + } + Strings_Append((CHAR*)" -o ", 5, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + if (!statically || 1) { + Strings_Append((CHAR*)" -L\"", 5, (void*)cmd, 4096); + Strings_Append(OPM_InstallDir, 1024, (void*)cmd, 4096); + Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 4096); + Strings_Append((CHAR*)" -lvoc", 7, (void*)cmd, 4096); + Strings_Append((CHAR*)"-O", 3, (void*)cmd, 4096); + Strings_Append(OPM_Model, 10, (void*)cmd, 4096); + Strings_Append((CHAR*)"", 1, (void*)cmd, 4096); + } + extTools_execute((CHAR*)"C compile and link: ", 21, cmd, 4096); + __DEL(additionalopts); +} + + +export void *extTools__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("extTools", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/unix-88/extTools.h b/bootstrap/unix-88/extTools.h new file mode 100644 index 00000000..686f0b4e --- /dev/null +++ b/bootstrap/unix-88/extTools.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef extTools__h +#define extTools__h + +#include "SYSTEM.h" + + + + +import void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +import void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +import void *extTools__init(void); + + +#endif // extTools diff --git a/bootstrap/windows-48/Compiler.c b/bootstrap/windows-48/Compiler.c new file mode 100644 index 00000000..4460479d --- /dev/null +++ b/bootstrap/windows-48/Compiler.c @@ -0,0 +1,213 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspamS */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "OPB.h" +#include "OPC.h" +#include "OPM.h" +#include "OPP.h" +#include "OPT.h" +#include "OPV.h" +#include "Platform.h" +#include "Strings.h" +#include "VT100.h" +#include "extTools.h" + + + + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len); +export void Compiler_Module (BOOLEAN *done); +static void Compiler_PropagateElementaryTypeSizes (void); +export void Compiler_Translate (void); +static void Compiler_Trap (INT32 sig); + + +void Compiler_Module (BOOLEAN *done) +{ + BOOLEAN ext, new; + OPT_Node p = NIL; + OPP_Module(&p, OPM_Options); + if (OPM_noerr) { + OPV_Init(); + OPT_InitRecno(); + OPV_AdrAndSize(OPT_topScope); + OPT_Export(&ext, &new); + if (OPM_noerr) { + OPM_OpenFiles((void*)OPT_SelfName, 256); + OPM_DeleteObj((void*)OPT_SelfName, 256); + OPC_Init(); + OPV_Module(p); + if (OPM_noerr) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" Main program.", 16); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + if (new) { + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" New symbol file.", 19); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_RegisterNewSym(); + } else if (ext) { + OPM_LogWStr((CHAR*)" Extended symbol file.", 24); + OPM_RegisterNewSym(); + } + } + } else { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } + OPM_CloseFiles(); + OPT_Close(); + OPM_LogWLn(); + *done = OPM_noerr; +} + +static void Compiler_PropagateElementaryTypeSizes (void) +{ + OPT_Struct adrinttyp = NIL; + OPT_sysptrtyp->size = OPM_AddressSize; + OPT_sysptrtyp->idfp = OPT_sysptrtyp->form; + OPM_FPrint(&OPT_sysptrtyp->idfp, OPT_sysptrtyp->size); + OPT_adrtyp->size = OPM_AddressSize; + OPT_adrtyp->idfp = OPT_adrtyp->form; + OPM_FPrint(&OPT_adrtyp->idfp, OPT_adrtyp->size); + adrinttyp = OPT_IntType(OPM_AddressSize); + OPT_adrtyp->strobj = adrinttyp->strobj; + OPT_sinttyp = OPT_IntType(OPM_ShortintSize); + OPT_inttyp = OPT_IntType(OPM_IntegerSize); + OPT_linttyp = OPT_IntType(OPM_LongintSize); + OPT_sintobj->typ = OPT_sinttyp; + OPT_intobj->typ = OPT_inttyp; + OPT_lintobj->typ = OPT_linttyp; + switch (OPM_SetSize) { + case 4: + OPT_settyp = OPT_set32typ; + break; + default: + OPT_settyp = OPT_set64typ; + break; + } + OPT_setobj->typ = OPT_settyp; + if (__STRCMP(OPM_Model, "C") == 0) { + OPT_cpbytetyp->strobj->name[4] = 0x00; + } else { + OPT_cpbytetyp->strobj->name[4] = '@'; + } +} + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len) +{ + OPT_Link l = NIL; + CHAR fn[64]; + Platform_FileIdentity id; + objectnames[0] = 0x00; + l = OPT_Links; + while (l != NIL) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".sym", 5, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".o", 3, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + Strings_Append((CHAR*)" ", 2, (void*)objectnames, objectnames__len); + Strings_Append(fn, 64, (void*)objectnames, objectnames__len); + } else { + OPM_LogVT100((CHAR*)"91m", 4); + OPM_LogWStr((CHAR*)"Link warning: a local symbol file is present for module ", 57); + OPM_LogWStr(l->name, 256); + OPM_LogWStr((CHAR*)", but local object file '", 26); + OPM_LogWStr(fn, 64); + OPM_LogWStr((CHAR*)"' is missing.", 14); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_LogWLn(); + } + } + l = l->next; + } +} + +void Compiler_Translate (void) +{ + BOOLEAN done; + CHAR linkfiles[2048]; + if (OPM_OpenPar()) { + for (;;) { + OPM_Init(&done); + if (!done) { + return; + } + OPM_InitOptions(); + Compiler_PropagateElementaryTypeSizes(); + Heap_GC(0); + Compiler_Module(&done); + if (!done) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Module compilation failed.", 27); + OPM_LogWLn(); + Platform_Exit(1); + } + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + if (!__IN(10, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + Compiler_FindLocalObjectFiles((void*)linkfiles, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), linkfiles, 2048); + } + } + } + } + } +} + +static void Compiler_Trap (INT32 sig) +{ + Heap_FINALL(); + if (sig == 3) { + Platform_Exit(0); + } else { + if (sig == 4) { + OPM_LogWStr((CHAR*)" --- Oberon compiler internal error", 36); + OPM_LogWLn(); + } + Platform_Exit(2); + } +} + + +export int main(int argc, char **argv) +{ + __INIT(argc, argv); + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPP); + __MODULE_IMPORT(OPT); + __MODULE_IMPORT(OPV); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(VT100); + __MODULE_IMPORT(extTools); + __REGMAIN("Compiler", 0); + __REGCMD("Translate", Compiler_Translate); +/* BEGIN */ + Platform_SetInterruptHandler(Compiler_Trap); + Platform_SetQuitHandler(Compiler_Trap); + Platform_SetBadInstructionHandler(Compiler_Trap); + Compiler_Translate(); + __FINI; +} diff --git a/bootstrap/windows-48/Configuration.c b/bootstrap/windows-48/Configuration.c new file mode 100644 index 00000000..fa87c9de --- /dev/null +++ b/bootstrap/windows-48/Configuration.c @@ -0,0 +1,24 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + +export CHAR Configuration_versionLong[76]; + + + + + +export void *Configuration__init(void) +{ + __DEFMOD; + __REGMOD("Configuration", 0); +/* BEGIN */ + __MOVE("2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 76); + __ENDMOD; +} diff --git a/bootstrap/windows-48/Configuration.h b/bootstrap/windows-48/Configuration.h new file mode 100644 index 00000000..c3c54eed --- /dev/null +++ b/bootstrap/windows-48/Configuration.h @@ -0,0 +1,15 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Configuration__h +#define Configuration__h + +#include "SYSTEM.h" + + +import CHAR Configuration_versionLong[76]; + + +import void *Configuration__init(void); + + +#endif // Configuration diff --git a/bootstrap/windows-48/Files.c b/bootstrap/windows-48/Files.c new file mode 100644 index 00000000..553bb49a --- /dev/null +++ b/bootstrap/windows-48/Files.c @@ -0,0 +1,1097 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_BufDesc { + Files_File f; + BOOLEAN chg; + INT32 org, size; + SYSTEM_BYTE data[4096]; + } Files_BufDesc; + +typedef + Files_BufDesc *Files_Buffer; + +typedef + CHAR Files_FileName[256]; + +typedef + struct Files_FileDesc { + Files_FileName workName, registerName; + BOOLEAN tempFile; + Platform_FileIdentity identity; + INT32 fd, len, pos; + Files_Buffer bufs[4]; + INT16 swapper, state; + struct Files_FileDesc *next; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + Files_Buffer buf; + INT32 org, offset; + } Files_Rider; + + +export INT16 Files_MaxPathLength, Files_MaxNameLength; +static Files_FileDesc *Files_files; +static INT16 Files_tempno; +static CHAR Files_HOME[1024]; +static struct { + ADDRESS len[1]; + CHAR data[1]; +} *Files_SearchPath; + +export ADDRESS *Files_FileDesc__typ; +export ADDRESS *Files_BufDesc__typ; +export ADDRESS *Files_Rider__typ; + +static void Files_Assert (BOOLEAN truth); +export Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +static Files_File Files_CacheEntry (Platform_FileIdentity identity); +export void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +export void Files_Close (Files_File f); +static void Files_CloseOSFile (Files_File f); +static void Files_Create (Files_File f); +export void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +static void Files_Deregister (CHAR *name, ADDRESS name__len); +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode); +static void Files_Finalize (SYSTEM_PTR o); +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len); +static void Files_Flush (Files_Buffer buf); +export void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +export void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len); +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len); +export INT32 Files_Length (Files_File f); +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len); +export Files_File Files_New (CHAR *name, ADDRESS name__len); +export Files_File Files_Old (CHAR *name, ADDRESS name__len); +export INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +export void Files_Purge (Files_File f); +export void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +export void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +export void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +export void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +export void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +export void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +export void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +export void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_Register (Files_File f); +export void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len); +export void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +export void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +export void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +export void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +export void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +export void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +export void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +export void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +export void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +export void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +export void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); + +#define Files_IdxTrap() __HALT(-1) + +static void Files_Assert (BOOLEAN truth) +{ + if (!truth) { + Out_Ln(); + __ASSERT(truth, 0); + } +} + +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode) +{ + __DUP(s, s__len, CHAR); + Out_Ln(); + Out_String((CHAR*)"-- ", 4); + Out_String(s, s__len); + Out_String((CHAR*)": ", 3); + if (f != NIL) { + if (f->registerName[0] != 0x00) { + Out_String(f->registerName, 256); + } else { + Out_String(f->workName, 256); + } + if (f->fd != 0) { + Out_String((CHAR*)", f.fd = ", 10); + Out_Int(f->fd, 1); + } + } + if (errcode != 0) { + Out_String((CHAR*)", errcode = ", 13); + Out_Int(errcode, 1); + } + Out_Ln(); + __HALT(99); + __DEL(s); +} + +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 i, j, ld, ln; + __DUP(dir, dir__len, CHAR); + __DUP(name, name__len, CHAR); + ld = Strings_Length(dir, dir__len); + ln = Strings_Length(name, name__len); + while ((ld > 0 && dir[__X(ld - 1, dir__len)] == '/')) { + ld -= 1; + } + if (((ld + ln) + 2) > dest__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + i = 0; + while (i < ld) { + dest[__X(i, dest__len)] = dir[__X(i, dir__len)]; + i += 1; + } + if (i > 0) { + dest[__X(i, dest__len)] = '/'; + i += 1; + } + j = 0; + while (j < ln) { + dest[__X(i, dest__len)] = name[__X(j, name__len)]; + i += 1; + j += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(dir); + __DEL(name); +} + +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len) +{ + INT16 i, n; + __DUP(finalName, finalName__len, CHAR); + if (finalName[0] == '/') { + __COPY(finalName, name, name__len); + } else { + Files_MakeFileName(Platform_CWD, 4096, finalName, finalName__len, (void*)name, name__len); + } + i = Strings_Length(name, name__len) - 1; + while ((i > 0 && name[__X(i, name__len)] != '/')) { + i -= 1; + } + if ((i + 16) >= name__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + Files_tempno += 1; + n = Files_tempno; + name[__X(i + 1, name__len)] = '.'; + name[__X(i + 2, name__len)] = 't'; + name[__X(i + 3, name__len)] = 'm'; + name[__X(i + 4, name__len)] = 'p'; + name[__X(i + 5, name__len)] = '.'; + i += 6; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = '.'; + i += 1; + n = Platform_PID; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = 0x00; + __DEL(finalName); +} + +static void Files_Deregister (CHAR *name, ADDRESS name__len) +{ + Platform_FileIdentity identity; + Files_File osfile = NIL; + INT16 error; + __DUP(name, name__len, CHAR); + if (Platform_IdentifyByName(name, name__len, &identity, Platform_FileIdentity__typ) == 0) { + osfile = (Files_File)Files_files; + while ((osfile != NIL && !Platform_SameFile(osfile->identity, identity))) { + osfile = (Files_File)osfile->next; + } + if (osfile != NIL) { + __ASSERT(!osfile->tempFile, 0); + __ASSERT(osfile->fd >= 0, 0); + __MOVE(osfile->workName, osfile->registerName, 256); + Files_GetTempName(osfile->registerName, 256, (void*)osfile->workName, 256); + osfile->tempFile = 1; + osfile->state = 0; + error = Platform_Rename((void*)osfile->registerName, 256, (void*)osfile->workName, 256); + if (error != 0) { + Files_Err((CHAR*)"Couldn't rename previous version of file being registered", 58, osfile, error); + } + } + } + __DEL(name); +} + +static void Files_Create (Files_File f) +{ + BOOLEAN done; + INT16 error; + CHAR err[32]; + if (f->fd == -1) { + if (f->state == 1) { + Files_GetTempName(f->registerName, 256, (void*)f->workName, 256); + f->tempFile = 1; + } else { + __ASSERT(f->state == 2, 0); + Files_Deregister(f->registerName, 256); + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } + error = Platform_Unlink((void*)f->workName, 256); + error = Platform_New((void*)f->workName, 256, &f->fd); + done = error == 0; + if (done) { + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->state = 0; + f->pos = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + } else { + if (Platform_NoSuchDirectory(error)) { + __MOVE("no such directory", err, 18); + } else if (Platform_TooManyFiles(error)) { + __MOVE("too many files open", err, 20); + } else { + __MOVE("file not created", err, 17); + } + Files_Err(err, 32, f, error); + } + } +} + +static void Files_Flush (Files_Buffer buf) +{ + INT16 error; + Files_File f = NIL; + if (buf->chg) { + f = buf->f; + Files_Create(f); + if (buf->org != f->pos) { + error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); + } + error = Platform_Write(f->fd, (ADDRESS)buf->data, buf->size); + if (error != 0) { + Files_Err((CHAR*)"error writing file", 19, f, error); + } + f->pos = buf->org + buf->size; + buf->chg = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + if (error != 0) { + Files_Err((CHAR*)"error identifying file", 23, f, error); + } + } +} + +void Files_Close (Files_File f) +{ + INT32 i; + INT16 error; + if (f->state != 1 || f->registerName[0] != 0x00) { + Files_Create(f); + i = 0; + while ((i < 4 && f->bufs[__X(i, 4)] != NIL)) { + Files_Flush(f->bufs[__X(i, 4)]); + i += 1; + } + } +} + +INT32 Files_Length (Files_File f) +{ + return f->len; +} + +Files_File Files_New (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + __DUP(name, name__len, CHAR); + __NEW(f, Files_FileDesc); + f->workName[0] = 0x00; + __COPY(name, f->registerName, 256); + f->fd = -1; + f->state = 1; + f->len = 0; + f->pos = 0; + f->swapper = -1; + __DEL(name); + return f; +} + +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len) +{ + INT16 i; + CHAR ch; + i = 0; + if (Files_SearchPath == NIL) { + if (*pos == 0) { + dir[0] = '.'; + i = 1; + *pos += 1; + } + } else { + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (ch == ' ' || ch == ';') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + if (ch == '~') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (Files_HOME[__X(i, 1024)] != 0x00) { + dir[__X(i, dir__len)] = Files_HOME[__X(i, 1024)]; + i += 1; + } + if ((((((ch != '/' && ch != 0x00)) && ch != ';')) && ch != ' ')) { + while ((i > 0 && dir[__X(i - 1, dir__len)] != '/')) { + i -= 1; + } + } + } + while ((ch != 0x00 && ch != ';')) { + dir[__X(i, dir__len)] = ch; + i += 1; + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + while ((i > 0 && dir[__X(i - 1, dir__len)] == ' ')) { + i -= 1; + } + } + dir[__X(i, dir__len)] = 0x00; +} + +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + ch = name[0]; + while ((ch != 0x00 && ch != '/')) { + i += 1; + ch = name[__X(i, name__len)]; + } + return ch == '/'; +} + +static Files_File Files_CacheEntry (Platform_FileIdentity identity) +{ + Files_File f = NIL; + INT16 i, error; + f = (Files_File)Files_files; + while (f != NIL) { + if (Platform_SameFile(identity, f->identity)) { + if (!Platform_SameFileTime(identity, f->identity)) { + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + f->swapper = -1; + f->identity = identity; + error = Platform_Size(f->fd, &f->len); + } + return f; + } + f = (Files_File)f->next; + } + return NIL; +} + +Files_File Files_Old (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + INT32 fd; + INT16 pos; + BOOLEAN done; + CHAR dir[256], path[256]; + INT16 error; + Platform_FileIdentity identity; + __DUP(name, name__len, CHAR); + if (name[0] != 0x00) { + if (Files_HasDir((void*)name, name__len)) { + dir[0] = 0x00; + __COPY(name, path, 256); + } else { + pos = 0; + Files_ScanPath(&pos, (void*)dir, 256); + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + for (;;) { + error = Platform_OldRW((void*)path, 256, &fd); + done = error == 0; + if ((!done && Platform_TooManyFiles(error))) { + Files_Err((CHAR*)"too many files open", 20, f, error); + } + if ((!done && Platform_Inaccessible(error))) { + error = Platform_OldRO((void*)path, 256, &fd); + done = error == 0; + } + if ((!done && !Platform_Absent(error))) { + Out_String((CHAR*)"Warning: Files.Old ", 20); + Out_String(name, name__len); + Out_String((CHAR*)" error = ", 10); + Out_Int(error, 0); + Out_Ln(); + } + if (done) { + error = Platform_Identify(fd, &identity, Platform_FileIdentity__typ); + f = Files_CacheEntry(identity); + if (f != NIL) { + error = Platform_Close(fd); + __DEL(name); + return f; + } else { + __NEW(f, Files_FileDesc); + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->fd = fd; + f->state = 0; + f->pos = 0; + f->swapper = -1; + error = Platform_Size(fd, &f->len); + __COPY(name, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + f->identity = identity; + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + __DEL(name); + return f; + } + } else if (dir[0] == 0x00) { + __DEL(name); + return NIL; + } else { + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + } + } else { + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Files_Purge (Files_File f) +{ + INT16 i; + Platform_FileIdentity identity; + INT16 error; + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + if (f->fd != -1) { + error = Platform_Truncate(f->fd, 0); + error = Platform_Seek(f->fd, 0, Platform_SeekSet); + } + f->pos = 0; + f->len = 0; + f->swapper = -1; + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_SetMTime(&f->identity, Platform_FileIdentity__typ, identity); +} + +void Files_GetDate (Files_File f, INT32 *t, INT32 *d) +{ + Platform_FileIdentity identity; + INT16 error; + Files_Create(f); + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_MTimeAsClock(identity, &*t, &*d); +} + +INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ) +{ + Files_Assert((*r).offset <= 4096); + return (*r).org + (*r).offset; +} + +void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos) +{ + INT32 org, offset, i, n; + Files_Buffer buf = NIL; + INT16 error; + if (f != NIL) { + if (pos > f->len) { + pos = f->len; + } else if (pos < 0) { + pos = 0; + } + offset = __MASK(pos, -4096); + org = pos - offset; + i = 0; + while ((((i < 4 && f->bufs[__X(i, 4)] != NIL)) && org != f->bufs[__X(i, 4)]->org)) { + i += 1; + } + if (i < 4) { + if (f->bufs[__X(i, 4)] == NIL) { + __NEW(buf, Files_BufDesc); + buf->chg = 0; + buf->org = -1; + buf->f = f; + f->bufs[__X(i, 4)] = buf; + } else { + buf = f->bufs[__X(i, 4)]; + } + } else { + f->swapper = __MASK(f->swapper + 1, -4); + buf = f->bufs[__X(f->swapper, 4)]; + Files_Flush(buf); + } + if (buf->org != org) { + if (org == f->len) { + buf->size = 0; + } else { + Files_Create(f); + if (f->pos != org) { + error = Platform_Seek(f->fd, org, Platform_SeekSet); + } + error = Platform_ReadBuf(f->fd, (void*)buf->data, 4096, &n); + if (error != 0) { + Files_Err((CHAR*)"read from file not done", 24, f, error); + } + f->pos = org + n; + buf->size = n; + } + buf->org = org; + buf->chg = 0; + } + } else { + buf = NIL; + org = 0; + offset = 0; + } + Files_Assert(offset <= 4096); + (*r).buf = buf; + (*r).org = org; + (*r).offset = offset; + (*r).eof = 0; + (*r).res = 0; +} + +void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + INT32 offset; + Files_Buffer buf = NIL; + buf = (*r).buf; + offset = (*r).offset; + if ((*r).org != buf->org) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= buf->size); + if (offset < buf->size) { + *x = buf->data[__X(offset, 4096)]; + (*r).offset = offset + 1; + } else if ((*r).org + offset < buf->f->len) { + Files_Set(&*r, r__typ, (*r).buf->f, (*r).org + offset); + *x = (*r).buf->data[0]; + (*r).offset = 1; + } else { + *x = 0x00; + (*r).eof = 1; + } +} + +void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + Files_Read(&*r, r__typ, &*x); +} + +void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + restInBuf = buf->size - offset; + if (restInBuf == 0) { + (*r).res = n; + (*r).eof = 1; + return; + } else if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&buf->data[__X(offset, 4096)], (ADDRESS)&x[__X(xpos, x__len)], min); + offset += min; + (*r).offset = offset; + xpos += min; + n -= min; + Files_Assert(offset <= 4096); + } + (*r).res = 0; + (*r).eof = 0; +} + +Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ) +{ + return (*r).buf->f; +} + +void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x) +{ + Files_Buffer buf = NIL; + INT32 offset; + buf = (*r).buf; + offset = (*r).offset; + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset < 4096); + buf->data[__X(offset, 4096)] = x; + buf->chg = 1; + if (offset == buf->size) { + buf->size += 1; + buf->f->len += 1; + } + (*r).offset = offset + 1; + (*r).res = 0; +} + +void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= 4096); + restInBuf = 4096 - offset; + if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&x[__X(xpos, x__len)], (ADDRESS)&buf->data[__X(offset, 4096)], min); + offset += min; + (*r).offset = offset; + Files_Assert(offset <= 4096); + if (offset > buf->size) { + buf->f->len += offset - buf->size; + buf->size = offset; + } + xpos += min; + n -= min; + buf->chg = 1; + } + (*r).res = 0; +} + +void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res) +{ + __DUP(name, name__len, CHAR); + Files_Deregister(name, name__len); + *res = Platform_Unlink((void*)name, name__len); + __DEL(name); +} + +void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res) +{ + INT32 fdold, fdnew, n; + INT16 error, ignore; + Platform_FileIdentity oldidentity, newidentity; + CHAR buf[4096]; + __DUP(old, old__len, CHAR); + __DUP(new, new__len, CHAR); + error = Platform_IdentifyByName(old, old__len, &oldidentity, Platform_FileIdentity__typ); + if (error == 0) { + error = Platform_IdentifyByName(new, new__len, &newidentity, Platform_FileIdentity__typ); + if ((error != 0 && !Platform_SameFile(oldidentity, newidentity))) { + Files_Delete(new, new__len, &error); + } + error = Platform_Rename((void*)old, old__len, (void*)new, new__len); + if (!Platform_DifferentFilesystems(error)) { + *res = error; + __DEL(old); + __DEL(new); + return; + } else { + error = Platform_OldRO((void*)old, old__len, &fdold); + if (error != 0) { + *res = 2; + __DEL(old); + __DEL(new); + return; + } + error = Platform_New((void*)new, new__len, &fdnew); + if (error != 0) { + error = Platform_Close(fdold); + *res = 3; + __DEL(old); + __DEL(new); + return; + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + while (n > 0) { + error = Platform_Write(fdnew, (ADDRESS)buf, n); + if (error != 0) { + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + } + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + if (n == 0) { + error = Platform_Unlink((void*)old, old__len); + *res = 0; + } else { + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + } + } else { + *res = 2; + } + __DEL(old); + __DEL(new); +} + +void Files_Register (Files_File f) +{ + INT16 idx, errcode; + Files_File f1 = NIL; + if ((f->state == 1 && f->registerName[0] != 0x00)) { + f->state = 2; + } + Files_Close(f); + if (f->registerName[0] != 0x00) { + Files_Deregister(f->registerName, 256); + Files_Rename(f->workName, 256, f->registerName, 256, &errcode); + if (errcode != 0) { + Files_Err((CHAR*)"Couldn't rename temp name as register name", 43, f, errcode); + } + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } +} + +void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res) +{ + __DUP(path, path__len, CHAR); + *res = Platform_Chdir((void*)path, path__len); + __DEL(path); +} + +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len) +{ + INT32 i, j; + if (!Platform_LittleEndian) { + i = src__len; + j = 0; + while (i > 0) { + i -= 1; + dest[__X(j, dest__len)] = src[__X(i, src__len)]; + j += 1; + } + } else { + __MOVE((ADDRESS)src, (ADDRESS)dest, src__len); + } +} + +void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x) +{ + Files_Read(&*R, R__typ, (CHAR*)(void*)&*x); +} + +void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x) +{ + CHAR b[2]; + Files_ReadBytes(&*R, R__typ, (void*)b, 2, 2); + *x = (INT16)b[0] + __ASHL((INT16)b[1], 8); +} + +void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + *x = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); +} + +void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x) +{ + CHAR b[4]; + INT32 l; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + l = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); + *x = (UINT32)l; +} + +void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + Files_FlipBytes((void*)b, 4, (void*)&*x, 4); +} + +void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x) +{ + CHAR b[8]; + Files_ReadBytes(&*R, R__typ, (void*)b, 8, 8); + Files_FlipBytes((void*)b, 8, (void*)&*x, 8); +} + +void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&ch); + x[__X(i, x__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&x[__X(i, x__len)]); + i += 1; + } while (!(x[__X(i - 1, x__len)] == 0x00 || x[__X(i - 1, x__len)] == 0x0a)); + if (x[__X(i - 1, x__len)] == 0x0a) { + i -= 1; + } + if ((i > 0 && x[__X(i - 1, x__len)] == 0x0d)) { + i -= 1; + } + x[__X(i, x__len)] = 0x00; +} + +void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len) +{ + INT8 s, b; + INT64 q; + s = 0; + q = 0; + Files_Read(&*R, R__typ, (void*)&b); + while (b < 0) { + q += (INT64)__ASH(((INT16)b + 128), s); + s += 7; + Files_Read(&*R, R__typ, (void*)&b); + } + q += (INT64)__ASH((__MASK(b, -64) - __ASHL(__ASHR(b, 6), 6)), s); + Files_Assert(x__len <= 8); + __MOVE((ADDRESS)&q, (ADDRESS)x, x__len); +} + +void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x) +{ + Files_Write(&*R, R__typ, __VAL(CHAR, x)); +} + +void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x) +{ + CHAR b[2]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + Files_WriteBytes(&*R, R__typ, (void*)b, 2, 2); +} + +void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x) +{ + CHAR b[4]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + b[2] = __CHR(__ASHR(x, 16)); + b[3] = __CHR(__ASHR(x, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x) +{ + CHAR b[4]; + INT32 i; + UINT64 y; + y = x; + i = __VAL(INT32, y); + b[0] = __CHR(i); + b[1] = __CHR(__ASHR(i, 8)); + b[2] = __CHR(__ASHR(i, 16)); + b[3] = __CHR(__ASHR(i, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x) +{ + CHAR b[4]; + Files_FlipBytes((void*)&x, 4, (void*)b, 4); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x) +{ + CHAR b[8]; + Files_FlipBytes((void*)&x, 8, (void*)b, 8); + Files_WriteBytes(&*R, R__typ, (void*)b, 8, 8); +} + +void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + while (x[__X(i, x__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&*R, R__typ, (void*)x, x__len * 1, i + 1); +} + +void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x) +{ + while (x < -64 || x > 63) { + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128) + 128)); + x = __ASHR(x, 7); + } + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128))); +} + +void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len) +{ + __COPY(f->workName, name, name__len); +} + +static void Files_CloseOSFile (Files_File f) +{ + Files_File prev = NIL; + INT16 error; + if (Files_files == (void *) f) { + Files_files = f->next; + } else { + prev = (Files_File)Files_files; + while ((prev != NIL && prev->next != (void *) f)) { + prev = (Files_File)prev->next; + } + if (prev->next != NIL) { + prev->next = f->next; + } + } + error = Platform_Close(f->fd); + f->fd = -1; + f->state = 1; + Heap_FileCount -= 1; +} + +static void Files_Finalize (SYSTEM_PTR o) +{ + Files_File f = NIL; + INT32 res; + f = (Files_File)(ADDRESS)o; + if (f->fd >= 0) { + Files_CloseOSFile(f); + if (f->tempFile) { + res = Platform_Unlink((void*)f->workName, 256); + } + } +} + +void Files_SetSearchPath (CHAR *path, ADDRESS path__len) +{ + __DUP(path, path__len, CHAR); + if (Strings_Length(path, path__len) != 0) { + Files_SearchPath = __NEWARR(NIL, 1, 1, 1, 1, ((ADDRESS)((Strings_Length(path, path__len) + 1)))); + __COPY(path, Files_SearchPath->data, Files_SearchPath->len[0]); + } else { + Files_SearchPath = NIL; + } + __DEL(path); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Files_SearchPath); +} + +__TDESC(Files_FileDesc, 1, 4) = {__TDFLDS("FileDesc", 572), {548, 552, 556, 560, -20}}; +__TDESC(Files_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 4112), {0, -8}}; +__TDESC(Files_Rider, 1, 1) = {__TDFLDS("Rider", 20), {8, -8}}; + +export void *Files__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("Files", EnumPtrs); + __INITYP(Files_FileDesc, Files_FileDesc, 0); + __INITYP(Files_BufDesc, Files_BufDesc, 0); + __INITYP(Files_Rider, Files_Rider, 0); +/* BEGIN */ + Files_tempno = -1; + Heap_FileCount = 0; + Files_HOME[0] = 0x00; + Platform_GetEnv((CHAR*)"HOME", 5, (void*)Files_HOME, 1024); + Files_MaxPathLength = Platform_MaxPathLength(); + Files_MaxNameLength = Platform_MaxNameLength(); + __ENDMOD; +} diff --git a/bootstrap/windows-48/Files.h b/bootstrap/windows-48/Files.h new file mode 100644 index 00000000..dadf1ace --- /dev/null +++ b/bootstrap/windows-48/Files.h @@ -0,0 +1,70 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Files__h +#define Files__h + +#include "SYSTEM.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_FileDesc { + INT32 _prvt0; + char _prvt1[568]; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + char _prvt0[15]; + } Files_Rider; + + +import INT16 Files_MaxPathLength, Files_MaxNameLength; + +import ADDRESS *Files_FileDesc__typ; +import ADDRESS *Files_Rider__typ; + +import Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +import void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +import void Files_Close (Files_File f); +import void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +import void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +import void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +import INT32 Files_Length (Files_File f); +import Files_File Files_New (CHAR *name, ADDRESS name__len); +import Files_File Files_Old (CHAR *name, ADDRESS name__len); +import INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +import void Files_Purge (Files_File f); +import void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +import void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +import void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +import void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +import void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +import void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +import void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +import void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_Register (Files_File f); +import void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +import void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +import void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +import void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +import void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +import void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +import void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +import void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +import void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +import void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +import void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +import void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void *Files__init(void); + + +#endif // Files diff --git a/bootstrap/windows-48/Heap.c b/bootstrap/windows-48/Heap.c new file mode 100644 index 00000000..42552415 --- /dev/null +++ b/bootstrap/windows-48/Heap.c @@ -0,0 +1,799 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +struct Heap__1 { + CHAR ch; + SYSTEM_PTR p; +}; + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + struct Heap_FinDesc *Heap_FinNode; + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_FinDesc { + Heap_FinNode next; + INT32 obj; + BOOLEAN marked; + Heap_Finalizer finalize; + } Heap_FinDesc; + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + INT32 reserved1, reserved2; + } Heap_ModuleDesc; + + +export SYSTEM_PTR Heap_modules; +static INT32 Heap_freeList[10]; +static INT32 Heap_bigBlocks; +export INT32 Heap_allocated; +static BOOLEAN Heap_firstTry; +static INT16 Heap_ldUnit; +export INT32 Heap_heap; +static INT32 Heap_heapMin, Heap_heapMax; +export INT32 Heap_heapsize, Heap_heapMinExpand; +static Heap_FinNode Heap_fin; +static INT16 Heap_lockdepth; +static BOOLEAN Heap_interrupted; +export INT16 Heap_FileCount; + +export ADDRESS *Heap_ModuleDesc__typ; +export ADDRESS *Heap_CmdDesc__typ; +export ADDRESS *Heap_FinDesc__typ; +export ADDRESS *Heap__1__typ; + +static void Heap_CheckFin (void); +static void Heap_ExtendHeap (INT32 blksz); +export void Heap_FINALL (void); +static void Heap_Finalize (void); +export INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +export void Heap_GC (BOOLEAN markStack); +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len); +export void Heap_INCREF (Heap_Module m); +export void Heap_InitHeap (void); +export void Heap_Lock (void); +static void Heap_Mark (INT32 q); +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len); +static void Heap_MarkP (SYSTEM_PTR p); +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len); +export SYSTEM_PTR Heap_NEWBLK (INT32 size); +export SYSTEM_PTR Heap_NEWREC (INT32 tag); +static INT32 Heap_NewChunk (INT32 blksz); +export void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +export SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +export void Heap_REGTYP (Heap_Module m, INT32 typ); +export void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +static void Heap_Scan (void); +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len); +export void Heap_Unlock (void); + +extern void *Heap__init(); +extern ADDRESS Modules_MainStackFrame; +extern ADDRESS Platform_OSAllocate(ADDRESS size); +#define Heap_HeapModuleInit() Heap__init() +#define Heap_ModulesHalt(code) Modules_Halt(code) +#define Heap_ModulesMainStackFrame() Modules_MainStackFrame +#define Heap_OSAllocate(size) Platform_OSAllocate(size) +#define Heap_uLE(x, y) ((size_t)x <= (size_t)y) +#define Heap_uLT(x, y) ((size_t)x < (size_t)y) + +void Heap_Lock (void) +{ + Heap_lockdepth += 1; +} + +void Heap_Unlock (void) +{ + Heap_lockdepth -= 1; + if ((Heap_interrupted && Heap_lockdepth == 0)) { + Heap_ModulesHalt(-9); + } +} + +SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) +{ + Heap_Module m; + if (__STRCMP(name, "Heap") == 0) { + __SYSNEW(m, 48); + } else { + __NEW(m, Heap_ModuleDesc); + } + m->types = 0; + m->cmds = NIL; + __COPY(name, m->name, 20); + m->refcnt = 0; + m->enumPtrs = enumPtrs; + m->next = (Heap_Module)(ADDRESS)Heap_modules; + Heap_modules = (SYSTEM_PTR)m; + return (void*)m; +} + +INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len) +{ + Heap_Module m, p; + __DUP(name, name__len, CHAR); + m = (Heap_Module)(ADDRESS)Heap_modules; + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + p = m; + m = m->next; + } + if ((m != NIL && m->refcnt == 0)) { + if (m == (Heap_Module)(ADDRESS)Heap_modules) { + Heap_modules = (SYSTEM_PTR)m->next; + } else { + p->next = m->next; + } + __DEL(name); + return 0; + } else { + if (m == NIL) { + __DEL(name); + return -1; + } else { + __DEL(name); + return m->refcnt; + } + } + __RETCHK; +} + +void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd) +{ + Heap_Cmd c; + if (__STRCMP(m->name, "Heap") == 0) { + __SYSNEW(c, 32); + } else { + __NEW(c, Heap_CmdDesc); + } + __COPY(name, c->name, 24); + c->cmd = cmd; + c->next = m->cmds; + m->cmds = c; +} + +void Heap_REGTYP (Heap_Module m, INT32 typ) +{ + __PUT(typ, m->types, INT32); + m->types = typ; +} + +void Heap_INCREF (Heap_Module m) +{ + m->refcnt += 1; +} + +static INT32 Heap_NewChunk (INT32 blksz) +{ + INT32 chnk, blk, end; + chnk = Heap_OSAllocate(blksz + 12); + if (chnk != 0) { + blk = chnk + 12; + end = blk + blksz; + __PUT(chnk + 4, end, INT32); + __PUT(blk, blk + 4, INT32); + __PUT(blk + 4, blksz, INT32); + __PUT(blk + 8, -4, INT32); + __PUT(blk + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = blk; + Heap_heapsize += blksz; + if (Heap_uLT(blk + 4, Heap_heapMin)) { + Heap_heapMin = blk + 4; + } + if (Heap_uLT(Heap_heapMax, end)) { + Heap_heapMax = end; + } + } + return chnk; +} + +static void Heap_ExtendHeap (INT32 blksz) +{ + INT32 size, chnk, j, next; + if (Heap_uLT(Heap_heapMinExpand, blksz)) { + size = blksz; + } else { + size = Heap_heapMinExpand; + } + chnk = Heap_NewChunk(size); + if (chnk != 0) { + if (Heap_uLT(chnk, Heap_heap)) { + __PUT(chnk, Heap_heap, INT32); + Heap_heap = chnk; + } else { + j = Heap_heap; + __GET(j, next, INT32); + while ((next != 0 && Heap_uLT(next, chnk))) { + j = next; + __GET(j, next, INT32); + } + __PUT(chnk, next, INT32); + __PUT(j, chnk, INT32); + } + } else if (!Heap_firstTry) { + Heap_heapMinExpand = 16; + } +} + +SYSTEM_PTR Heap_NEWREC (INT32 tag) +{ + INT32 i, i0, di, blksz, restsize, t, adr, end, next, prev; + SYSTEM_PTR new; + Heap_Lock(); + __GET(tag, blksz, INT32); + i0 = __LSH(blksz, -Heap_ldUnit, 32); + i = i0; + if (i < 9) { + adr = Heap_freeList[i]; + while (adr == 0) { + i += 1; + adr = Heap_freeList[i]; + } + } + if (i < 9) { + __GET(adr + 12, next, INT32); + Heap_freeList[i] = next; + if (i != i0) { + di = i - i0; + restsize = __ASHL(di, 4); + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + adr += restsize; + } + } else { + adr = Heap_bigBlocks; + prev = 0; + for (;;) { + if (adr == 0) { + if (Heap_firstTry) { + Heap_GC(1); + blksz += 16; + t = __LSH(Heap_allocated + blksz, -(2 + Heap_ldUnit), 32) * 80; + if (Heap_uLT(Heap_heapsize, t)) { + Heap_ExtendHeap(t - Heap_heapsize); + } + Heap_firstTry = 0; + new = Heap_NEWREC(tag); + if (new == NIL) { + Heap_ExtendHeap(blksz); + new = Heap_NEWREC(tag); + } + Heap_firstTry = 1; + Heap_Unlock(); + return new; + } else { + Heap_Unlock(); + return NIL; + } + } + __GET(adr + 4, t, INT32); + if (Heap_uLE(blksz, t)) { + break; + } + prev = adr; + __GET(adr + 12, adr, INT32); + } + restsize = t - blksz; + end = adr + restsize; + __PUT(end + 4, blksz, INT32); + __PUT(end + 8, -4, INT32); + __PUT(end, end + 4, INT32); + if (Heap_uLT(144, restsize)) { + __PUT(adr + 4, restsize, INT32); + } else { + __GET(adr + 12, next, INT32); + if (prev == 0) { + Heap_bigBlocks = next; + } else { + __PUT(prev + 12, next, INT32); + } + if (restsize != 0) { + di = __ASHR(restsize, 4); + __PUT(adr + 4, restsize, INT32); + __PUT(adr + 12, Heap_freeList[di], INT32); + Heap_freeList[di] = adr; + } + } + adr += restsize; + } + i = adr + 16; + end = adr + blksz; + while (Heap_uLT(i, end)) { + __PUT(i, 0, INT32); + __PUT(i + 4, 0, INT32); + __PUT(i + 8, 0, INT32); + __PUT(i + 12, 0, INT32); + i += 16; + } + __PUT(adr + 12, 0, INT32); + __PUT(adr, tag, INT32); + __PUT(adr + 4, 0, INT32); + __PUT(adr + 8, 0, INT32); + Heap_allocated += blksz; + Heap_Unlock(); + return (SYSTEM_PTR)(ADDRESS)(adr + 4); +} + +SYSTEM_PTR Heap_NEWBLK (INT32 size) +{ + INT32 blksz, tag; + SYSTEM_PTR new; + Heap_Lock(); + blksz = __ASHL(__ASHR(size + 31, 4), 4); + new = Heap_NEWREC((ADDRESS)&blksz); + tag = ((INT32)(ADDRESS)new + blksz) - 12; + __PUT(tag - 4, 0, INT32); + __PUT(tag, blksz, INT32); + __PUT(tag + 4, -4, INT32); + __PUT((INT32)(ADDRESS)new - 4, tag, INT32); + Heap_Unlock(); + return new; +} + +static void Heap_Mark (INT32 q) +{ + INT32 p, tag, offset, fld, n, tagbits; + if (q != 0) { + __GET(q - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(q - 4, tagbits + 1, INT32); + p = 0; + tag = tagbits + 4; + for (;;) { + __GET(tag, offset, INT32); + if (offset < 0) { + __PUT(q - 4, (tag + offset) + 1, INT32); + if (p == 0) { + break; + } + n = q; + q = p; + __GET(q - 4, tag, INT32); + tag -= 1; + __GET(tag, offset, INT32); + fld = q + offset; + __GET(fld, p, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)n, SYSTEM_PTR); + } else { + fld = q + offset; + __GET(fld, n, INT32); + if (n != 0) { + __GET(n - 4, tagbits, INT32); + if (!__ODD(tagbits)) { + __PUT(n - 4, tagbits + 1, INT32); + __PUT(q - 4, tag + 1, INT32); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)p, SYSTEM_PTR); + p = q; + q = n; + tag = tagbits; + } + } + } + tag += 4; + } + } + } +} + +static void Heap_MarkP (SYSTEM_PTR p) +{ + Heap_Mark((INT32)(ADDRESS)p); +} + +static void Heap_Scan (void) +{ + INT32 chnk, adr, end, start, tag, i, size, freesize; + Heap_bigBlocks = 0; + i = 1; + while (i < 9) { + Heap_freeList[i] = 0; + i += 1; + } + freesize = 0; + Heap_allocated = 0; + chnk = Heap_heap; + while (chnk != 0) { + adr = chnk + 12; + __GET(chnk + 4, end, INT32); + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + tag -= 1; + __PUT(adr, tag, INT32); + __GET(tag, size, INT32); + Heap_allocated += size; + adr += size; + } else { + __GET(tag, size, INT32); + freesize += size; + adr += size; + } + } + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 4, INT32); + __PUT(start + 4, freesize, INT32); + __PUT(start + 8, -4, INT32); + i = __LSH(freesize, -Heap_ldUnit, 32); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 12, Heap_freeList[i], INT32); + Heap_freeList[i] = start; + } else { + __PUT(start + 12, Heap_bigBlocks, INT32); + Heap_bigBlocks = start; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_Sift (INT32 l, INT32 r, INT32 *a, ADDRESS a__len) +{ + INT32 i, j; + INT32 x; + j = l; + x = a[j]; + for (;;) { + i = j; + j = __ASHL(j, 1) + 1; + if ((j < r && Heap_uLT(a[j], a[j + 1]))) { + j += 1; + } + if (j > r || Heap_uLE(a[j], x)) { + break; + } + a[i] = a[j]; + } + a[i] = x; +} + +static void Heap_HeapSort (INT32 n, INT32 *a, ADDRESS a__len) +{ + INT32 l, r; + INT32 x; + l = __ASHR(n, 1); + r = n - 1; + while (l > 0) { + l -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } + while (r > 0) { + x = a[0]; + a[0] = a[r]; + a[r] = x; + r -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } +} + +static void Heap_MarkCandidates (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + INT32 chnk, end, adr, tag, next, i, ptr, size; + chnk = Heap_heap; + i = 0; + while (chnk != 0) { + __GET(chnk + 4, end, INT32); + adr = chnk + 12; + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT32); + if (__ODD(tag)) { + __GET(tag - 1, size, INT32); + adr += size; + ptr = adr + 4; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + } else { + __GET(tag, size, INT32); + ptr = adr + 4; + adr += size; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == n) { + return; + } + } + if (Heap_uLT(cand[i], adr)) { + Heap_Mark(ptr); + } + } + if (Heap_uLE(end, cand[i])) { + adr = end; + } + } + __GET(chnk, chnk, INT32); + } +} + +static void Heap_CheckFin (void) +{ + Heap_FinNode n; + INT32 tag; + n = Heap_fin; + while (n != NIL) { + __GET(n->obj - 4, tag, INT32); + if (!__ODD(tag)) { + n->marked = 0; + Heap_Mark(n->obj); + } else { + n->marked = 1; + } + n = n->next; + } +} + +static void Heap_Finalize (void) +{ + Heap_FinNode n, prev; + n = Heap_fin; + prev = NIL; + while (n != NIL) { + if (!n->marked) { + if (n == Heap_fin) { + Heap_fin = Heap_fin->next; + } else { + prev->next = n->next; + } + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + if (prev == NIL) { + n = Heap_fin; + } else { + n = n->next; + } + } else { + prev = n; + n = n->next; + } + } +} + +void Heap_FINALL (void) +{ + Heap_FinNode n; + while (Heap_fin != NIL) { + n = Heap_fin; + Heap_fin = Heap_fin->next; + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + } +} + +static void Heap_MarkStack (INT32 n, INT32 *cand, ADDRESS cand__len) +{ + SYSTEM_PTR frame; + INT32 nofcand; + INT32 inc, sp, p, stack0; + struct Heap__1 align; + if (n > 0) { + Heap_MarkStack(n - 1, cand, cand__len); + if (n > 100) { + return; + } + } + if (n == 0) { + nofcand = 0; + sp = (ADDRESS)&frame; + stack0 = Heap_ModulesMainStackFrame(); + inc = (ADDRESS)&align.p - (ADDRESS)&align; + if (Heap_uLT(stack0, sp)) { + inc = -inc; + } + while (sp != stack0) { + __GET(sp, p, INT32); + if ((Heap_uLE(Heap_heapMin, p) && Heap_uLT(p, Heap_heapMax))) { + if (nofcand == cand__len) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + nofcand = 0; + } + cand[nofcand] = p; + nofcand += 1; + } + sp += inc; + } + if (nofcand > 0) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + } + } +} + +void Heap_GC (BOOLEAN markStack) +{ + Heap_Module m; + INT32 i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23; + INT32 cand[10000]; + Heap_Lock(); + m = (Heap_Module)(ADDRESS)Heap_modules; + while (m != NIL) { + if (m->enumPtrs != NIL) { + (*m->enumPtrs)(Heap_MarkP); + } + m = m->next; + } + if (markStack) { + 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; + for (;;) { + i0 += 1; + i1 += 2; + i2 += 3; + i3 += 4; + i4 += 5; + i5 += 6; + i6 += 7; + i7 += 8; + i8 += 9; + i9 += 10; + i10 += 11; + i11 += 12; + i12 += 13; + i13 += 14; + i14 += 15; + i15 += 16; + i16 += 17; + i17 += 18; + i18 += 19; + i19 += 20; + i20 += 21; + i21 += 22; + i22 += 23; + i23 += 24; + if ((i0 == -99 && i15 == 24)) { + Heap_MarkStack(32, (void*)cand, 10000); + break; + } + } + 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) { + return; + } + } + Heap_CheckFin(); + Heap_Scan(); + Heap_Finalize(); + Heap_Unlock(); +} + +void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) +{ + Heap_FinNode f; + __NEW(f, Heap_FinDesc); + f->obj = (INT32)(ADDRESS)obj; + f->finalize = finalize; + f->marked = 1; + f->next = Heap_fin; + Heap_fin = f; +} + +void Heap_InitHeap (void) +{ + Heap_heap = 0; + Heap_heapsize = 0; + Heap_allocated = 0; + Heap_lockdepth = 0; + Heap_heapMin = -1; + Heap_heapMax = 0; + Heap_bigBlocks = 0; + Heap_heapMinExpand = 128000; + Heap_ldUnit = 4; + Heap_heap = Heap_NewChunk(128000); + __PUT(Heap_heap, 0, INT32); + Heap_firstTry = 1; + Heap_freeList[9] = 1; + Heap_FileCount = 0; + Heap_modules = NIL; + Heap_fin = NIL; + Heap_interrupted = 0; + Heap_HeapModuleInit(); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Heap_modules); + P(Heap_fin); +} + +__TDESC(Heap_ModuleDesc, 1, 2) = {__TDFLDS("ModuleDesc", 48), {0, 28, -12}}; +__TDESC(Heap_CmdDesc, 1, 1) = {__TDFLDS("CmdDesc", 32), {0, -8}}; +__TDESC(Heap_FinDesc, 1, 1) = {__TDFLDS("FinDesc", 16), {0, -8}}; +__TDESC(Heap__1, 1, 1) = {__TDFLDS("", 8), {4, -8}}; + +export void *Heap__init(void) +{ + __DEFMOD; + __REGMOD("Heap", EnumPtrs); + __REGCMD("FINALL", Heap_FINALL); + __REGCMD("InitHeap", Heap_InitHeap); + __REGCMD("Lock", Heap_Lock); + __REGCMD("Unlock", Heap_Unlock); + __INITYP(Heap_ModuleDesc, Heap_ModuleDesc, 0); + __INITYP(Heap_CmdDesc, Heap_CmdDesc, 0); + __INITYP(Heap_FinDesc, Heap_FinDesc, 0); + __INITYP(Heap__1, Heap__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/Heap.h b/bootstrap/windows-48/Heap.h new file mode 100644 index 00000000..3cde1c3b --- /dev/null +++ b/bootstrap/windows-48/Heap.h @@ -0,0 +1,73 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#ifndef Heap__h +#define Heap__h + +#include "SYSTEM.h" + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT32 types; + Heap_EnumProc enumPtrs; + char _prvt0[8]; + } Heap_ModuleDesc; + + +import SYSTEM_PTR Heap_modules; +import INT32 Heap_allocated; +import INT32 Heap_heap; +import INT32 Heap_heapsize, Heap_heapMinExpand; +import INT16 Heap_FileCount; + +import ADDRESS *Heap_ModuleDesc__typ; +import ADDRESS *Heap_CmdDesc__typ; + +import void Heap_FINALL (void); +import INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +import void Heap_GC (BOOLEAN markStack); +import void Heap_INCREF (Heap_Module m); +import void Heap_InitHeap (void); +import void Heap_Lock (void); +import SYSTEM_PTR Heap_NEWBLK (INT32 size); +import SYSTEM_PTR Heap_NEWREC (INT32 tag); +import void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +import SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +import void Heap_REGTYP (Heap_Module m, INT32 typ); +import void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +import void Heap_Unlock (void); +import void *Heap__init(void); + + +#endif // Heap diff --git a/bootstrap/windows-48/Modules.c b/bootstrap/windows-48/Modules.c new file mode 100644 index 00000000..bdad4713 --- /dev/null +++ b/bootstrap/windows-48/Modules.c @@ -0,0 +1,506 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export INT16 Modules_res; +export CHAR Modules_resMsg[256]; +export Heap_ModuleName Modules_imported, Modules_importing; +export INT32 Modules_MainStackFrame; +export INT16 Modules_ArgCount; +export INT32 Modules_ArgVector; +export CHAR Modules_BinaryDir[1024]; + + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +export void Modules_AssertFail (INT32 code); +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len); +static void Modules_DisplayHaltCode (INT32 code); +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len); +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len); +export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +export void Modules_GetIntArg (INT16 n, INT32 *val); +export void Modules_Halt (INT32 code); +export void Modules_Init (INT32 argc, INT32 argvadr); +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len); +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len); +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len); +export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_errch (CHAR c); +static void Modules_errint (INT32 l); +static void Modules_errstring (CHAR *s, ADDRESS s__len); + +extern void Heap_InitHeap(); +extern void *Modules__init(void); +#define Modules_InitHeap() Heap_InitHeap() +#define Modules_ModulesInit() Modules__init() +#define Modules_modules() (Heap_Module)Heap_modules + +void Modules_Init (INT32 argc, INT32 argvadr) +{ + Modules_MainStackFrame = argvadr; + Modules_ArgCount = __VAL(INT16, argc); + __GET(argvadr, Modules_ArgVector, INT32); + Modules_InitHeap(); + Modules_ModulesInit(); +} + +typedef + CHAR (*argptr__15)[1024]; + +void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len) +{ + argptr__15 arg = NIL; + if (n < Modules_ArgCount) { + __GET(Modules_ArgVector + __ASHL(n, 2), arg, argptr__15); + __COPY(*arg, val, val__len); + } +} + +void Modules_GetIntArg (INT16 n, INT32 *val) +{ + CHAR s[64]; + INT32 k, d, i; + s[0] = 0x00; + Modules_GetArg(n, (void*)s, 64); + i = 0; + if (s[0] == '-') { + i = 1; + } + k = 0; + d = (INT16)s[__X(i, 64)] - 48; + while ((d >= 0 && d <= 9)) { + k = k * 10 + d; + i += 1; + d = (INT16)s[__X(i, 64)] - 48; + } + if (s[0] == '-') { + k = -k; + i -= 1; + } + if (i > 0) { + *val = k; + } +} + +INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len) +{ + INT16 i; + CHAR arg[256]; + __DUP(s, s__len, CHAR); + i = 0; + Modules_GetArg(i, (void*)arg, 256); + while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) { + i += 1; + Modules_GetArg(i, (void*)arg, 256); + } + __DEL(s); + return i; +} + +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return i; +} + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + if ((j > 0 && d[__X(j - 1, d__len)] != c)) { + d[__X(j, d__len)] = c; + j += 1; + } + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + if (c == 0x00) { + __DEL(s); + return 0; + } + i = 0; + while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return s[__X(i, s__len)] == c; +} + +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len) +{ + __DUP(d, d__len, CHAR); + if (d[0] == 0x00) { + __DEL(d); + return 0; + } + if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) { + __DEL(d); + return 1; + } + if (d[__X(1, d__len)] == ':') { + __DEL(d); + return 1; + } + __DEL(d); + return 0; +} + +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + __DUP(s, s__len, CHAR); + if (Modules_IsAbsolute(s, s__len)) { + __COPY(s, d, d__len); + } else { + __COPY(Platform_CWD, d, d__len); + Modules_AppendPart('/', s, s__len, (void*)d, d__len); + } + __DEL(s); +} + +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len) +{ + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __DEL(s); + return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0; +} + +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len) +{ + INT16 j; + __DUP(s, s__len, CHAR); + __DUP(p, p__len, CHAR); + j = 0; + while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) { + d[__X(j, d__len)] = s[__X(*i, s__len)]; + *i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) { + *i += 1; + } + __DEL(s); + __DEL(p); +} + +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + CHAR part[1024]; + __DUP(s, s__len, CHAR); + i = 0; + j = 0; + while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) { + i += 1; + d[__X(j, d__len)] = '/'; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (s[__X(i, s__len)] != 0x00) { + Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024); + if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) { + Modules_AppendPart('/', part, 1024, (void*)d, d__len); + } + } + __DEL(s); +} + +typedef + CHAR pathstring__12[4096]; + +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len) +{ + pathstring__12 arg0, pathlist, pathdir, tempstr; + INT16 i, j, k; + BOOLEAN present; + if (Modules_ArgCount < 1) { + binarydir[0] = 0x00; + return; + } + Modules_GetArg(0, (void*)arg0, 4096); + i = 0; + while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) { + i += 1; + } + if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') { + Modules_Trim(arg0, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } else { + Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096); + i = 0; + present = 0; + while ((!present && pathlist[__X(i, 4096)] != 0x00)) { + Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096); + Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096); + Modules_Trim(pathdir, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } + } + if (present) { + k = Modules_CharCount(binarydir, binarydir__len); + while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) { + k -= 1; + } + if (k == 0) { + binarydir[__X(k, binarydir__len)] = 0x00; + } else { + binarydir[__X(k - 1, binarydir__len)] = 0x00; + } + } else { + binarydir[0] = 0x00; + } +} + +Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len) +{ + Heap_Module m = NIL; + CHAR bodyname[64]; + Heap_Command body; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + m = m->next; + } + if (m != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + } else { + Modules_res = 1; + __COPY(name, Modules_importing, 20); + __MOVE(" module \"", Modules_resMsg, 10); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + } + __DEL(name); + return m; +} + +Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len) +{ + Heap_Cmd c = NIL; + __DUP(name, name__len, CHAR); + c = mod->cmds; + while ((c != NIL && __STRCMP(c->name, name) != 0)) { + c = c->next; + } + if (c != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + __DEL(name); + return c->cmd; + } else { + Modules_res = 2; + __MOVE(" command \"", Modules_resMsg, 11); + __COPY(name, Modules_importing, 20); + Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all) +{ + Heap_Module m = NIL, p = NIL; + INT32 refcount; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + if (all) { + Modules_res = 1; + __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34); + } else { + refcount = Heap_FreeModule(name, name__len); + if (refcount == 0) { + Modules_res = 0; + } else { + if (refcount < 0) { + __MOVE("module not found", Modules_resMsg, 17); + } else { + __MOVE("clients of this module exist", Modules_resMsg, 29); + } + Modules_res = 1; + } + } + __DEL(name); +} + +static void Modules_errch (CHAR c) +{ + INT16 e; + e = Platform_Write(Platform_StdOut, (ADDRESS)&c, 1); +} + +static void Modules_errstring (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + Modules_errch(s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +static void Modules_errint (INT32 l) +{ + if (l < 0) { + Modules_errch('-'); + l = -l; + } + if (l >= 10) { + Modules_errint(__DIV(l, 10)); + } + Modules_errch(__CHR((int)__MOD(l, 10) + 48)); +} + +static void Modules_DisplayHaltCode (INT32 code) +{ + switch (code) { + case -1: + Modules_errstring((CHAR*)"Assertion failure.", 19); + break; + case -2: + Modules_errstring((CHAR*)"Index out of range.", 20); + break; + case -3: + Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49); + break; + case -4: + Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47); + break; + case -5: + Modules_errstring((CHAR*)"Type guard failed.", 19); + break; + case -6: + Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49); + break; + case -7: + Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32); + break; + case -8: + Modules_errstring((CHAR*)"Value out of range.", 20); + break; + case -9: + Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60); + break; + case -10: + Modules_errstring((CHAR*)"NIL access.", 12); + break; + case -11: + Modules_errstring((CHAR*)"Alignment error.", 17); + break; + case -12: + Modules_errstring((CHAR*)"Divide by zero.", 16); + break; + case -13: + Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31); + break; + case -14: + Modules_errstring((CHAR*)"Invalid function argument.", 27); + break; + case -15: + Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52); + break; + case -20: + Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60); + break; + default: + break; + } +} + +void Modules_Halt (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Terminated by Halt(", 20); + Modules_errint(code); + Modules_errstring((CHAR*)"). ", 4); + if (code < 0) { + Modules_DisplayHaltCode(code); + } + Modules_errstring(Platform_NL, 3); + Platform_Exit(code); +} + +void Modules_AssertFail (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Assertion failure.", 19); + if (code != 0) { + Modules_errstring((CHAR*)" ASSERT code ", 14); + Modules_errint(code); + Modules_errstring((CHAR*)".", 2); + } + Modules_errstring(Platform_NL, 3); + if (code > 0) { + Platform_Exit(code); + } else { + Platform_Exit(-1); + } +} + + +export void *Modules__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Modules", 0); +/* BEGIN */ + Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024); + __ENDMOD; +} diff --git a/bootstrap/windows-48/Modules.h b/bootstrap/windows-48/Modules.h new file mode 100644 index 00000000..26d86b38 --- /dev/null +++ b/bootstrap/windows-48/Modules.h @@ -0,0 +1,31 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Modules__h +#define Modules__h + +#include "SYSTEM.h" +#include "Heap.h" + + +import INT16 Modules_res; +import CHAR Modules_resMsg[256]; +import Heap_ModuleName Modules_imported, Modules_importing; +import INT32 Modules_MainStackFrame; +import INT16 Modules_ArgCount; +import INT32 Modules_ArgVector; +import CHAR Modules_BinaryDir[1024]; + + +import INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +import void Modules_AssertFail (INT32 code); +import void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +import void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +import void Modules_GetIntArg (INT16 n, INT32 *val); +import void Modules_Halt (INT32 code); +import void Modules_Init (INT32 argc, INT32 argvadr); +import Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +import Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +import void *Modules__init(void); + + +#endif // Modules diff --git a/bootstrap/windows-48/OPB.c b/bootstrap/windows-48/OPB.c new file mode 100644 index 00000000..913fbf2d --- /dev/null +++ b/bootstrap/windows-48/OPB.c @@ -0,0 +1,2592 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + + +static INT16 OPB_exp; +static INT64 OPB_maxExp; + + +export void OPB_Assign (OPT_Node *x, OPT_Node y); +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static INT16 OPB_BoolToInt (BOOLEAN b); +export void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +static void OPB_CharToString (OPT_Node n); +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode); +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo); +export void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +static void OPB_CheckProc (OPT_Struct x, OPT_Object y); +static void OPB_CheckPtr (OPT_Node x, OPT_Node y); +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x); +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp); +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y); +export void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +static void OPB_Convert (OPT_Node *x, OPT_Struct typ); +export void OPB_DeRef (OPT_Node *x); +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar); +export OPT_Node OPB_EmptySet (void); +export void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +export void OPB_Field (OPT_Node *x, OPT_Object y); +export void OPB_In (OPT_Node *x, OPT_Node y); +export void OPB_Index (OPT_Node *x, OPT_Node y); +export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +static BOOLEAN OPB_IntToBool (INT64 i); +export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +export void OPB_MOp (INT8 op, OPT_Node *x); +export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +export OPT_Node OPB_NewIntConst (INT64 intval); +export OPT_Node OPB_NewLeaf (OPT_Object obj); +export OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +export OPT_Node OPB_NewString (OPS_String str, INT64 len); +export OPT_Node OPB_Nil (void); +static BOOLEAN OPB_NotVar (OPT_Node x); +export void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +export void OPB_OptIf (OPT_Node *x); +export void OPB_Param (OPT_Node ap, OPT_Object fp); +export void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +export void OPB_Return (OPT_Node *x, OPT_Object proc); +export void OPB_SetElem (OPT_Node *x); +static void OPB_SetIntType (OPT_Node node); +export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static void OPB_SetSetType (OPT_Node node); +export void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +export void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +export void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +export void OPB_StaticLink (INT8 dlev); +export void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +static void OPB_err (INT16 n); +static INT64 OPB_log (INT64 x); + + +static void OPB_err (INT16 n) +{ + OPM_err(n); +} + +OPT_Node OPB_NewLeaf (OPT_Object obj) +{ + OPT_Node node = NIL; + switch (obj->mode) { + case 1: + node = OPT_NewNode(0); + node->readonly = (obj->vis == 2 && obj->mnolev < 0); + break; + case 2: + node = OPT_NewNode(1); + break; + case 3: + node = OPT_NewNode(7); + node->conval = OPT_NewConst(); + __GUARDEQP(node->conval, OPT_ConstDesc) = *obj->conval; + break; + case 5: + node = OPT_NewNode(8); + break; + case 6: case 7: case 8: case 9: case 10: + node = OPT_NewNode(9); + break; + default: + node = OPT_NewNode(0); + OPB_err(127); + break; + } + node->obj = obj; + node->typ = obj->typ; + return node; +} + +void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = OPT_notyp; + node->left = *x; + node->right = y; + *x = node; +} + +void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y) +{ + if (*x == NIL) { + *x = y; + } else { + (*last)->link = y; + } + while (y->link != NIL) { + y = y->link; + } + *last = y; +} + +static INT16 OPB_BoolToInt (BOOLEAN b) +{ + if (b) { + return 1; + } else { + return 0; + } + __RETCHK; +} + +static BOOLEAN OPB_IntToBool (INT64 i) +{ + return i != 0; +} + +OPT_Node OPB_NewBoolConst (BOOLEAN boolval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_booltyp; + x->conval = OPT_NewConst(); + x->conval->intval = OPB_BoolToInt(boolval); + return x; +} + +void OPB_OptIf (OPT_Node *x) +{ + OPT_Node if_ = NIL, pred = NIL; + if_ = (*x)->left; + while (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + *x = if_->right; + return; + } else if (if_->link == NIL) { + *x = (*x)->right; + return; + } else { + if_ = if_->link; + (*x)->left = if_; + } + } + pred = if_; + if_ = if_->link; + while (if_ != NIL) { + if (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + pred->link = NIL; + (*x)->right = if_->right; + return; + } else { + if_ = if_->link; + pred->link = if_; + } + } else { + pred = if_; + if_ = if_->link; + } + } +} + +OPT_Node OPB_Nil (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_niltyp; + x->conval = OPT_NewConst(); + x->conval->intval = 0; + return x; +} + +OPT_Node OPB_EmptySet (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_settyp; + x->conval = OPT_NewConst(); + x->conval->setval = 0x0; + return x; +} + +static void OPB_SetIntType (OPT_Node node) +{ + node->typ = OPT_IntType(OPT_IntSize(node->conval->intval)); +} + +static void OPB_SetSetType (OPT_Node node) +{ + INT32 i32; + __GET((ADDRESS)&node->conval->setval + 4, i32, INT32); + if (i32 == 0) { + node->typ = OPT_set32typ; + } else { + node->typ = OPT_set64typ; + } +} + +OPT_Node OPB_NewIntConst (INT64 intval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->intval = intval; + OPB_SetIntType(x); + return x; +} + +OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->realval = realval; + x->typ = typ; + x->conval->intval = -1; + return x; +} + +OPT_Node OPB_NewString (OPS_String str, INT64 len) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->typ = OPT_stringtyp; + x->conval->intval = -1; + x->conval->intval2 = OPM_Longint(len); + x->conval->ext = OPT_NewExt(); + __MOVE(str, *x->conval->ext, 256); + return x; +} + +static void OPB_CharToString (OPT_Node n) +{ + CHAR ch; + n->typ = OPT_stringtyp; + ch = __CHR(n->conval->intval); + n->conval->ext = OPT_NewExt(); + if (ch == 0x00) { + n->conval->intval2 = 1; + } else { + n->conval->intval2 = 2; + (*n->conval->ext)[1] = 0x00; + } + (*n->conval->ext)[0] = ch; + n->conval->intval = -1; + n->obj = NIL; +} + +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN OPB_NotVar (OPT_Node x) +{ + return (x->class >= 7 && ((x->class != 11 || x->subcl != 29) || x->left->class >= 7)); +} + +void OPB_DeRef (OPT_Node *x) +{ + OPT_Object strobj = NIL, bstrobj = NIL; + OPT_Struct typ = NIL, btyp = NIL; + typ = (*x)->typ; + if ((*x)->class >= 7) { + OPB_err(78); + } else if (typ->form == 11) { + if (typ == OPT_sysptrtyp) { + OPB_err(57); + } + btyp = typ->BaseTyp; + strobj = typ->strobj; + bstrobj = btyp->strobj; + if ((((((strobj != NIL && strobj->name[0] != 0x00)) && bstrobj != NIL)) && bstrobj->name[0] != 0x00)) { + btyp->pbused = 1; + } + OPB_BindNodes(3, btyp, &*x, NIL); + } else { + OPB_err(84); + } +} + +void OPB_Index (OPT_Node *x, OPT_Node y) +{ + INT16 f; + OPT_Struct typ = NIL; + f = y->typ->form; + if ((*x)->class >= 7) { + OPB_err(79); + } else if (f != 4 || __IN(y->class, 0x0300, 32)) { + OPB_err(80); + y->typ = OPT_inttyp; + } + if ((*x)->typ->comp == 2) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && (y->conval->intval < 0 || y->conval->intval >= (INT64)(*x)->typ->n))) { + OPB_err(81); + } + } else if ((*x)->typ->comp == 3) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && y->conval->intval < 0)) { + OPB_err(81); + } + } else { + OPB_err(82); + typ = OPT_undftyp; + } + OPB_BindNodes(4, typ, &*x, y); + (*x)->readonly = (*x)->left->readonly; +} + +void OPB_Field (OPT_Node *x, OPT_Object y) +{ + if ((*x)->class >= 7) { + OPB_err(77); + } + if ((y != NIL && __IN(y->mode, 0x2010, 32))) { + OPB_BindNodes(2, y->typ, &*x, NIL); + (*x)->obj = y; + (*x)->readonly = (*x)->left->readonly || (y->vis == 2 && y->mnolev < 0); + } else { + OPB_err(83); + (*x)->typ = OPT_undftyp; + } +} + +static struct TypTest__58 { + OPT_Node *x; + OPT_Object *obj; + BOOLEAN *guard; + struct TypTest__58 *lnk; +} *TypTest__58_s; + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1); + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1) +{ + OPT_Node node = NIL; + OPT_Struct t = NIL; + t = t0; + while ((((t != NIL && t != t1)) && t != OPT_undftyp)) { + t = t->BaseTyp; + } + if (t != t1) { + while ((((t1 != NIL && t1 != t0)) && t1 != OPT_undftyp)) { + t1 = t1->BaseTyp; + } + if (t1 == t0 || t0->form == 0) { + if (*TypTest__58_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__58_s->x, NIL); + (*TypTest__58_s->x)->readonly = (*TypTest__58_s->x)->left->readonly; + } else { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } + } else { + OPB_err(85); + } + } else if (t0 != t1) { + OPB_err(85); + } else if (!*TypTest__58_s->guard) { + if ((*TypTest__58_s->x)->class == 5) { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } else { + *TypTest__58_s->x = OPB_NewBoolConst(1); + } + } +} + +void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) +{ + struct TypTest__58 _s; + _s.x = x; + _s.obj = &obj; + _s.guard = &guard; + _s.lnk = TypTest__58_s; + TypTest__58_s = &_s; + if (OPB_NotVar(*x)) { + OPB_err(112); + } else if ((*x)->typ->form == 11) { + if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { + OPB_err(85); + } else if (obj->typ->form == 11) { + GTT__59((*x)->typ->BaseTyp, obj->typ->BaseTyp); + } else { + OPB_err(86); + } + } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { + GTT__59((*x)->typ, obj->typ); + } else { + OPB_err(87); + } + if (guard) { + (*x)->typ = obj->typ; + } else { + (*x)->typ = OPT_booltyp; + } + TypTest__58_s = _s.lnk; +} + +void OPB_In (OPT_Node *x, OPT_Node y) +{ + INT16 f; + INT64 k; + f = (*x)->typ->form; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((f == 4 && y->typ->form == 7)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (k < 0 || k >= (INT64)__ASHL(y->typ->size, 3)) { + OPB_err(202); + } else if (y->class == 7) { + (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval, 64)); + (*x)->obj = NIL; + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_err(92); + } + (*x)->typ = OPT_booltyp; +} + +static INT64 OPB_log (INT64 x) +{ + OPB_exp = 0; + if (x > 0) { + while (!__ODD(x)) { + x = __ASHR(x, 1); + OPB_exp += 1; + } + } + return x; +} + +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x) +{ + LONGREAL min, max, r; + if (f == 5) { + min = OPM_MinReal; + max = OPM_MaxReal; + } else { + min = OPM_MinLReal; + max = OPM_MaxLReal; + } + r = __ABS(x->realval); + if (r > max || r < min) { + OPB_err(nr); + x->realval = (LONGREAL)1; + } else if (f == 5) { + x->realval = x->realval; + } + x->intval = -1; +} + +static struct MOp__28 { + struct MOp__28 *lnk; +} *MOp__28_s; + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z); + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z) +{ + OPT_Node node = NIL; + node = OPT_NewNode(11); + node->subcl = op; + node->typ = typ; + node->left = z; + return node; +} + +void OPB_MOp (INT8 op, OPT_Node *x) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node z = NIL; + struct MOp__28 _s; + _s.lnk = MOp__28_s; + MOp__28_s = &_s; + z = *x; + if (z->class == 8 || z->class == 9) { + OPB_err(126); + } else { + typ = z->typ; + f = typ->form; + switch (op) { + case 33: + if (f == 2) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(98); + } + break; + case 6: + if (!__IN(f, 0x70, 32)) { + OPB_err(96); + } + break; + case 7: + if (__IN(f, 0xf0, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = -z->conval->intval; + OPB_SetIntType(z); + } + } else if (__IN(f, 0x60, 32)) { + z->conval->realval = -z->conval->realval; + } else { + if (z->typ->size == 8) { + z->conval->setval = ~z->conval->setval; + } else { + z->conval->setval = z->conval->setval ^ 0xffffffff; + } + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(97); + } + break; + case 21: + if (__IN(f, 0x70, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = __ABS(z->conval->intval); + OPB_SetIntType(z); + } + } else { + z->conval->realval = __ABS(z->conval->realval); + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + break; + case 22: + if (f == 3) { + if (z->class == 7) { + z->conval->intval = (INT16)__CAP(__CHR(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + z->typ = OPT_chartyp; + } + break; + case 23: + if (f == 4) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + z->typ = OPT_booltyp; + break; + case 24: + if ((((z->class == 7 && f == 3)) && z->conval->intval >= 32)) { + OPB_CharToString(z); + f = 8; + } + if (z->class < 7 || f == 8) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(127); + } + z->typ = OPT_adrtyp; + break; + case 25: + if ((f == 4 && z->class == 7)) { + if ((0 <= z->conval->intval && z->conval->intval <= -1)) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(219); + } + } else { + OPB_err(69); + } + z->typ = OPT_booltyp; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.MOp, op = ", 33); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + MOp__28_s = _s.lnk; +} + +static void OPB_CheckPtr (OPT_Node x, OPT_Node y) +{ + INT16 g; + OPT_Struct p = NIL, q = NIL, t = NIL; + g = y->typ->form; + if (g == 11) { + p = x->typ->BaseTyp; + q = y->typ->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + if (p->extlev < q->extlev) { + t = p; + p = q; + q = t; + } + while ((((p != q && p != NIL)) && p != OPT_undftyp)) { + p = p->BaseTyp; + } + if (p == NIL) { + OPB_err(100); + } + } else { + OPB_err(100); + } + } else if (g != 9) { + OPB_err(100); + } +} + +void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames) +{ + OPT_Struct ft = NIL, at = NIL; + while (fp != NIL) { + if (ap != NIL) { + ft = fp->typ; + at = ap->typ; + while ((ft->comp == 3 && at->comp == 3)) { + ft = ft->BaseTyp; + at = at->BaseTyp; + } + if (ft != at) { + if ((ft->form == 12 && at->form == 12)) { + if (ft->BaseTyp == at->BaseTyp) { + OPB_CheckParameters(ft->link, at->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(115); + } + } + if (fp->mode != ap->mode || (checkNames && __STRCMP(fp->name, ap->name) != 0)) { + OPB_err(115); + } + ap = ap->link; + } else { + OPB_err(116); + } + fp = fp->link; + } + if (ap != NIL) { + OPB_err(116); + } +} + +static void OPB_CheckProc (OPT_Struct x, OPT_Object y) +{ + if (__IN(y->mode, 0x04c0, 32)) { + if (y->mode == 6) { + if (y->mnolev == 0) { + y->mode = 7; + } else { + OPB_err(73); + } + } + if (x->BaseTyp == y->typ) { + OPB_CheckParameters(x->link, y->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(113); + } +} + +static struct ConstOp__13 { + OPT_Node *x; + INT16 *f; + OPT_Const *xval, *yval; + struct ConstOp__13 *lnk; +} *ConstOp__13_s; + +static INT16 ConstCmp__14 (void); + +static INT16 ConstCmp__14 (void) +{ + INT16 res; + switch (*ConstOp__13_s->f) { + case 0: + res = 9; + break; + case 1: case 3: case 4: + if ((*ConstOp__13_s->xval)->intval < (*ConstOp__13_s->yval)->intval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->intval > (*ConstOp__13_s->yval)->intval) { + res = 13; + } else { + res = 9; + } + break; + case 5: case 6: + if ((*ConstOp__13_s->xval)->realval < (*ConstOp__13_s->yval)->realval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->realval > (*ConstOp__13_s->yval)->realval) { + res = 13; + } else { + res = 9; + } + break; + case 2: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + case 7: + if ((*ConstOp__13_s->xval)->setval != (*ConstOp__13_s->yval)->setval) { + res = 10; + } else { + res = 9; + } + break; + case 8: + if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) < 0) { + res = 11; + } else if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) > 0) { + res = 13; + } else { + res = 9; + } + break; + case 9: case 11: case 12: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstCmp, f = ", 37); + OPM_LogWNum(*ConstOp__13_s->f, 0); + OPM_LogWLn(); + break; + } + (*ConstOp__13_s->x)->typ = OPT_booltyp; + return res; +} + +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y) +{ + INT16 f, g; + OPT_Const xval = NIL, yval = NIL; + INT64 xv, yv; + BOOLEAN temp; + struct ConstOp__13 _s; + _s.x = &x; + _s.f = &f; + _s.xval = &xval; + _s.yval = &yval; + _s.lnk = ConstOp__13_s; + ConstOp__13_s = &_s; + f = x->typ->form; + g = y->typ->form; + xval = x->conval; + yval = y->conval; + if (f != g) { + switch (f) { + case 3: + if (g == 8) { + OPB_CharToString(x); + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 4: + if (g == 4) { + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPT_IntType(x->typ->size); + } + } else if (g == 5) { + x->typ = OPT_realtyp; + xval->realval = xval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + xval->realval = xval->intval; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 5: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 6: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 5) { + y->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 8: + if (g == 3) { + OPB_CharToString(y); + g = 8; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(x, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + default: + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + break; + } + f = x->typ->form; + } + switch (op) { + case 1: + if (f == 4) { + xv = xval->intval; + yv = yval->intval; + if (((((xv == 0 || yv == 0) || (((xv > 0 && yv > 0)) && yv <= __DIV(9223372036854775807LL, xv))) || (((xv > 0 && yv < 0)) && yv >= __DIV((-9223372036854775807LL-1), xv))) || (((xv < 0 && yv > 0)) && xv >= __DIV((-9223372036854775807LL-1), yv))) || (((((((xv < 0 && yv < 0)) && xv != (-9223372036854775807LL-1))) && yv != (-9223372036854775807LL-1))) && -xv <= __DIV(9223372036854775807LL, -yv))) { + xval->intval = xv * yv; + OPB_SetIntType(x); + } else { + OPB_err(204); + } + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) <= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 / (LONGREAL)__ABS(yval->realval)) { + xval->realval = xval->realval * yval->realval; + OPB_CheckRealType(f, 204, xval); + } else { + OPB_err(204); + } + } else if (f == 7) { + xval->setval = (xval->setval & yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(101); + } + break; + case 2: + if (f == 4) { + if (yval->intval != 0) { + xval->realval = xval->intval / (REAL)yval->intval; + OPB_CheckRealType(5, 205, xval); + } else { + OPB_err(205); + xval->realval = (LONGREAL)1; + } + x->typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) >= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 * __ABS(yval->realval)) { + xval->realval = xval->realval / yval->realval; + OPB_CheckRealType(f, 205, xval); + } else { + OPB_err(205); + } + } else if (f == 7) { + xval->setval = xval->setval ^ yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(102); + } + break; + case 3: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __DIV(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(103); + } + break; + case 4: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __MOD(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(104); + } + break; + case 5: + if (f == 2) { + xval->intval = OPB_BoolToInt((OPB_IntToBool(xval->intval) && OPB_IntToBool(yval->intval))); + } else { + OPB_err(94); + } + break; + case 6: + if (f == 4) { + temp = (yval->intval >= 0 && xval->intval <= 9223372036854775807LL - yval->intval); + if (temp || (yval->intval < 0 && xval->intval >= (-9223372036854775807LL-1) - yval->intval)) { + xval->intval += yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(206); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 - yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 - yval->realval)) { + xval->realval = xval->realval + yval->realval; + OPB_CheckRealType(f, 206, xval); + } else { + OPB_err(206); + } + } else if (f == 7) { + xval->setval = xval->setval | yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(105); + } + break; + case 7: + if (f == 4) { + if ((yval->intval >= 0 && xval->intval >= (-9223372036854775807LL-1) + yval->intval) || (yval->intval < 0 && xval->intval <= 9223372036854775807LL + yval->intval)) { + xval->intval -= yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(207); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 + yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 + yval->realval)) { + xval->realval = xval->realval - yval->realval; + OPB_CheckRealType(f, 207, xval); + } else { + OPB_err(207); + } + } else if (f == 7) { + xval->setval = (xval->setval & ~yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(106); + } + break; + case 8: + if (f == 2) { + xval->intval = OPB_BoolToInt(OPB_IntToBool(xval->intval) || OPB_IntToBool(yval->intval)); + } else { + OPB_err(95); + } + break; + case 9: + xval->intval = OPB_BoolToInt(ConstCmp__14() == 9); + break; + case 10: + xval->intval = OPB_BoolToInt(ConstCmp__14() != 9); + break; + case 11: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 11); + } + break; + case 12: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 13); + } + break; + case 13: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 13); + } + break; + case 14: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 11); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstOp, op = ", 37); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + ConstOp__13_s = _s.lnk; +} + +static void OPB_Convert (OPT_Node *x, OPT_Struct typ) +{ + OPT_Node node = NIL; + INT16 f, g; + INT64 k; + LONGREAL r; + f = (*x)->typ->form; + g = typ->form; + if ((*x)->class == 7) { + if ((((f == 7 && g == 7)) && (*x)->typ->size > typ->size)) { + OPB_SetSetType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->setval = 0x0; + } + } else if (f == 4) { + if (g == 4) { + if ((*x)->typ->size > typ->size) { + OPB_SetIntType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->intval = 1; + } + } + } else if (__IN(g, 0x60, 32)) { + (*x)->conval->realval = (*x)->conval->intval; + (*x)->conval->intval = -1; + } else { + k = (*x)->conval->intval; + if (0 > k || k > 255) { + OPB_err(220); + } + } + } else if (__IN(f, 0x60, 32)) { + if (__IN(g, 0x60, 32)) { + OPB_CheckRealType(g, 203, (*x)->conval); + } else { + r = (*x)->conval->realval; + if (r < -9.22337203685478e+018 || r > 9.22337203685478e+018) { + OPB_err(203); + r = (LONGREAL)1; + } + (*x)->conval->intval = __SHORT(__ENTIER(r), 2147483648LL); + OPB_SetIntType(*x); + } + } + (*x)->obj = NIL; + } else if (((((*x)->class == 11 && (*x)->subcl == 20)) && ((INT16)(*x)->left->typ->form < f || f > g))) { + if ((*x)->left->typ == typ) { + *x = (*x)->left; + } + } else { + node = OPT_NewNode(11); + node->subcl = 20; + node->left = *x; + *x = node; + } + (*x)->typ = typ; +} + +static struct Op__38 { + INT16 *f, *g; + struct Op__38 *lnk; +} *Op__38_s; + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(12); + node->subcl = op; + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +{ + BOOLEAN ok, xCharArr, yCharArr; + xCharArr = (__IN((*x)->typ->comp, 0x0c, 32) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 8; + yCharArr = (__IN((*y)->typ->comp, 0x0c, 32) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 8; + if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + OPB_CharToString(*y); + *Op__38_s->g = 8; + yCharArr = 1; + } + if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + OPB_CharToString(*x); + *Op__38_s->f = 8; + xCharArr = 1; + } + ok = (xCharArr && yCharArr); + if (ok) { + if ((*Op__38_s->f == 8 && (*x)->conval->intval2 == 1)) { + (*x)->typ = OPT_chartyp; + (*x)->conval->intval = 0; + OPB_Index(&*y, OPB_NewIntConst(0)); + } else if ((*Op__38_s->g == 8 && (*y)->conval->intval2 == 1)) { + (*y)->typ = OPT_chartyp; + (*y)->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + } + return ok; +} + +void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y) +{ + INT16 f, g; + OPT_Node t = NIL, z = NIL; + OPT_Struct typ = NIL; + BOOLEAN do_; + INT64 val; + struct Op__38 _s; + _s.f = &f; + _s.g = &g; + _s.lnk = Op__38_s; + Op__38_s = &_s; + z = *x; + if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((z->class == 7 && y->class == 7)) { + OPB_ConstOp(op, z, y); + z->obj = NIL; + } else { + if (z->typ != y->typ) { + g = y->typ->form; + switch (z->typ->form) { + case 3: + if (z->class == 7) { + OPB_CharToString(z); + } else { + OPB_err(100); + } + break; + case 4: + if ((g == 4 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x70, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 7: + if ((g == 7 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (g == 7) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 5: + if (g == 4) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 6: + if (__IN(g, 0x70, 32)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&y, z->typ); + } else { + OPB_err(100); + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(z, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + case 8: + break; + case 13: + if (z->typ->comp == 4) { + OPB_err(100); + } + break; + default: + OPB_err(100); + break; + } + } + typ = z->typ; + f = typ->form; + g = y->typ->form; + switch (op) { + case 1: + do_ = 1; + if (f == 4) { + if (z->class == 7) { + val = z->conval->intval; + if (val == 1) { + do_ = 0; + z = y; + } else if (val == 0) { + do_ = 0; + } else if (OPB_log(val) == 1) { + t = y; + y = z; + z = t; + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } else if (y->class == 7) { + val = y->conval->intval; + if (val == 1) { + do_ = 0; + } else if (val == 0) { + do_ = 0; + z = y; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } + } else if (!__IN(f, 0xe1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 2: + if (f == 4) { + if ((y->class == 7 && y->conval->intval == 0)) { + OPB_err(205); + } + OPB_Convert(&z, OPT_realtyp); + OPB_Convert(&y, OPT_realtyp); + typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + if ((y->class == 7 && y->conval->realval == (LONGREAL)0)) { + OPB_err(205); + } + } else if ((f != 7 && f != 0)) { + OPB_err(102); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 3: + do_ = 1; + if (f == 4) { + if (y->class == 7) { + val = y->conval->intval; + if (val == 0) { + OPB_err(205); + } else if (val == 1) { + do_ = 0; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = -OPB_exp; + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(103); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 4: + if (f == 4) { + if (y->class == 7) { + if (y->conval->intval == 0) { + OPB_err(205); + } else if (OPB_log(y->conval->intval) == 1) { + op = 18; + y->conval->intval = __ASH(-1, OPB_exp); + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(104); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 5: + if (f == 2) { + if (z->class == 7) { + if (OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(94); + z->typ = OPT_undftyp; + } + break; + case 6: + if (!__IN(f, 0xf1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + do_ = 1; + if (f == 4) { + if ((z->class == 7 && z->conval->intval == 0)) { + do_ = 0; + z = y; + } + if ((y->class == 7 && y->conval->intval == 0)) { + do_ = 0; + } + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 7: + if (!__IN(f, 0xf1, 32)) { + OPB_err(106); + typ = OPT_undftyp; + } + if ((f != 4 || y->class != 7) || y->conval->intval != 0) { + NewOp__39(op, typ, &z, y); + } + break; + case 8: + if (f == 2) { + if (z->class == 7) { + if (!OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(95); + z->typ = OPT_undftyp; + } + break; + case 9: case 10: + if (__IN(f, 0x1aff, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPB_err(107); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 11: case 12: case 13: case 14: + if (__IN(f, 0x79, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ELSE in Op()", 13); + OPM_LogWLn(); + OPB_err(108); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", 32); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + Op__38_s = _s.lnk; +} + +void OPB_SetRange (OPT_Node *x, OPT_Node y) +{ + INT64 k, l; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if (((*x)->typ->form == 4 && y->typ->form == 4)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (0 > k || k > 63) { + OPB_err(202); + } + } + if (y->class == 7) { + l = y->conval->intval; + if (0 > l || l > 63) { + OPB_err(202); + } + } + if (((*x)->class == 7 && y->class == 7)) { + if (k <= l) { + (*x)->conval->setval = __SETRNG(k, l, 32); + OPB_SetSetType(*x); + } else { + OPB_err(201); + (*x)->conval->setval = __SETRNG(l, k, 32); + } + (*x)->obj = NIL; + } else { + OPB_BindNodes(10, OPT_settyp, &*x, y); + } + } else { + OPB_err(93); + } + (*x)->typ = OPT_settyp; +} + +void OPB_SetElem (OPT_Node *x) +{ + INT64 k; + if ((*x)->class == 8 || (*x)->class == 9) { + OPB_err(126); + } else if ((*x)->typ->form != 4) { + OPB_err(93); + } else if ((*x)->class == 7) { + k = (*x)->conval->intval; + if ((0 <= k && k <= 63)) { + (*x)->conval->setval = 0x0; + (*x)->conval->setval |= __SETOF(k,64); + } else { + OPB_err(202); + } + OPB_SetSetType(*x); + (*x)->obj = NIL; + } else { + OPB_Convert(&*x, OPT_settyp); + (*x)->typ = OPT_settyp; + } +} + +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) +{ + OPT_Struct y = NIL; + INT16 f, g; + OPT_Struct p = NIL, q = NIL; + y = ynode->typ; + f = x->form; + g = y->form; + if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { + OPB_err(126); + } + switch (f) { + case 0: case 8: + break; + case 1: + if (!((__IN(g, 0x1a, 32) && y->size == 1))) { + OPB_err(113); + } + break; + case 2: case 3: + if (g != f) { + OPB_err(113); + } + break; + case 4: case 7: + if (g != f || x->size < y->size) { + OPB_err(113); + } + break; + case 5: + if (!__IN(g, 0x30, 32)) { + OPB_err(113); + } + break; + case 6: + if (!__IN(g, 0x70, 32)) { + OPB_err(113); + } + break; + case 11: + if ((x == y || g == 9) || (x == OPT_sysptrtyp && g == 11)) { + } else if (g == 11) { + p = x->BaseTyp; + q = y->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + while ((((q != p && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + case 12: + if (ynode->class == 9) { + OPB_CheckProc(x, ynode->obj); + } else if (x == y || g == 9) { + } else { + OPB_err(113); + } + break; + case 10: case 9: + OPB_err(113); + break; + case 13: + x->pvused = 1; + if (x->comp == 2) { + if ((ynode->class == 7 && g == 3)) { + OPB_CharToString(ynode); + y = ynode->typ; + g = 8; + } + if (x == y) { + } else if ((((y->comp == 2 && y->BaseTyp == x->BaseTyp)) && y->n <= x->n)) { + } else if ((y->comp == 3 && y->BaseTyp == x->BaseTyp)) { + OPB_err(113); + } else if (x->BaseTyp == OPT_chartyp) { + if (g == 8) { + if (ynode->conval->intval2 > x->n) { + OPB_err(114); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else if (x->comp == 4) { + if (x == y) { + } else if (y->comp == 4) { + q = y->BaseTyp; + while ((((q != NIL && q != x)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.CheckAssign, f = ", 40); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } + if ((((((ynode->class == 7 && g < f)) && __IN(g, 0x30, 32))) && __IN(f, 0x70, 32))) { + OPB_Convert(&ynode, x); + } +} + +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo) +{ +} + +void OPB_StPar0 (OPT_Node *par0, INT16 fctno) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node x = NIL; + x = *par0; + f = x->typ->form; + switch (fctno) { + case 0: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + x->typ = OPT_notyp; + break; + case 1: + typ = OPT_notyp; + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + if (x->readonly) { + OPB_err(76); + } + f = x->typ->BaseTyp->comp; + if (__IN(f, 0x1c, 32)) { + if (f == 3) { + typ = x->typ->BaseTyp; + } + OPB_BindNodes(19, OPT_notyp, &x, NIL); + x->subcl = 1; + } else { + OPB_err(111); + } + } else { + OPB_err(111); + } + x->typ = typ; + break; + case 2: + OPB_MOp(21, &x); + break; + case 3: + OPB_MOp(22, &x); + break; + case 4: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 3) { + OPB_Convert(&x, OPT_inttyp); + } else { + OPB_err(111); + } + x->typ = OPT_inttyp; + break; + case 5: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x60, 32)) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + x->typ = OPT_linttyp; + break; + case 6: + OPB_MOp(23, &x); + break; + case 7: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(0); + break; + case 3: + x = OPB_NewIntConst(0); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(0); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MinReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MinLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 8: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(1); + break; + case 3: + x = OPB_NewIntConst(255); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(__ASHL(x->typ->size, 3) - 1); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MaxReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MaxLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 9: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x11, 32)) { + OPB_Convert(&x, OPT_chartyp); + } else { + OPB_err(111); + x->typ = OPT_chartyp; + } + break; + case 10: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, -1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 6) { + OPB_Convert(&x, OPT_realtyp); + } else { + OPB_err(111); + } + break; + case 11: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, 1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 5) { + OPB_Convert(&x, OPT_lrltyp); + } else if (f == 3) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + break; + case 13: case 14: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f != 4) { + OPB_err(111); + } else if (x->readonly) { + OPB_err(76); + } + break; + case 15: case 16: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (x->typ->form != 7) { + OPB_err(111); + x->typ = OPT_settyp; + } else if (x->readonly) { + OPB_err(76); + } + break; + case 17: + if (!__IN(x->typ->comp, 0x0c, 32)) { + OPB_err(131); + } + break; + case 18: + if ((x->class == 7 && f == 3)) { + OPB_CharToString(x); + f = 8; + } + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (((!__IN(x->typ->comp, 0x0c, 32) || x->typ->BaseTyp->form != 3) && f != 8)) { + OPB_err(111); + } + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if (x->typ->size < OPT_linttyp->size) { + OPB_Convert(&x, OPT_linttyp); + } + } else { + OPB_err(111); + x->typ = OPT_linttyp; + } + break; + case 20: + OPB_CheckLeaf(x, 0); + OPB_MOp(24, &x); + break; + case 12: + if (x->class != 8) { + OPB_err(110); + x = OPB_NewIntConst(1); + } else if (__IN(f, 0x18fe, 32) || __IN(x->typ->comp, 0x14, 32)) { + OPT_TypSize(x->typ); + x->typ->pvused = 1; + x = OPB_NewIntConst(x->typ->size); + } else { + OPB_err(111); + x = OPB_NewIntConst(1); + } + break; + case 21: + OPB_MOp(25, &x); + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (!__IN(f, 0x9a, 32)) { + OPB_err(111); + } + break; + case 24: case 25: case 28: case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + break; + case 26: case 27: + if ((f == 4 && x->class == 7)) { + if (x->conval->intval < 0 || x->conval->intval > -1) { + OPB_err(220); + } + } else { + OPB_err(69); + } + break; + case 29: + if (x->class != 8) { + OPB_err(110); + } else if (__IN(f, 0x0501, 32) || x->typ->comp == 3) { + OPB_err(111); + } + break; + case 30: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + } else { + OPB_err(111); + } + break; + case 32: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + x = OPB_NewBoolConst(0); + } else if (f != 2) { + OPB_err(120); + x = OPB_NewBoolConst(0); + } else { + OPB_MOp(33, &x); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.StPar0, fctno = ", 39); + OPM_LogWNum(fctno, 0); + OPM_LogWLn(); + break; + } + *par0 = x; +} + +static struct StPar1__53 { + struct StPar1__53 *lnk; +} *StPar1__53_s; + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right); + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->subcl = subcl; + node->left = left; + node->right = right; + return node; +} + +void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno) +{ + INT16 f, L; + OPT_Struct typ = NIL; + OPT_Node p = NIL, t = NIL; + struct StPar1__53 _s; + _s.lnk = StPar1__53_s; + StPar1__53_s = &_s; + p = *par0; + f = x->typ->form; + switch (fctno) { + case 13: case 14: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + p->typ = OPT_notyp; + } else { + if (x->typ != p->typ) { + if ((f == 4 && (x->class == 7 || (p->typ->form == 4 && x->typ->size <= p->typ->size)))) { + OPB_Convert(&x, p->typ); + } else { + OPB_err(111); + } + } + p = NewOp__54(19, fctno, p, x); + p->typ = OPT_notyp; + } + break; + case 15: case 16: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval >= (INT64)__ASHL(p->typ->size, 3)))) { + OPB_err(202); + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 17: + if (!(f == 4) || x->class != 7) { + OPB_err(69); + } else if (x->typ->size == 1) { + L = OPM_Integer(x->conval->intval); + typ = p->typ; + while ((L > 0 && __IN(typ->comp, 0x0c, 32))) { + typ = typ->BaseTyp; + L -= 1; + } + if (L != 0 || !__IN(typ->comp, 0x0c, 32)) { + OPB_err(132); + } else { + x->obj = NIL; + if (typ->comp == 3) { + while (p->class == 4) { + p = p->left; + x->conval->intval += 1; + } + p = NewOp__54(12, 19, p, x); + p->typ = OPT_linttyp; + } else { + p = x; + p->conval->intval = typ->n; + OPB_SetIntType(p); + } + } + } else { + OPB_err(132); + } + break; + case 18: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if ((__IN(x->typ->comp, 0x0c, 32) && x->typ->BaseTyp->form == 3)) { + if (x->readonly) { + OPB_err(76); + } + t = x; + x = p; + p = t; + p = NewOp__54(19, 18, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((p->class == 7 && x->class == 7)) { + if (-OPB_maxExp > x->conval->intval || x->conval->intval > OPB_maxExp) { + OPB_err(208); + p->conval->intval = 1; + } else if (x->conval->intval >= 0) { + if (__ABS(p->conval->intval) <= __DIV(9223372036854775807LL, (INT64)__ASH(1, x->conval->intval))) { + p->conval->intval = p->conval->intval * (INT64)__ASH(1, x->conval->intval); + } else { + OPB_err(208); + p->conval->intval = 1; + } + } else { + p->conval->intval = __ASH(p->conval->intval, x->conval->intval); + } + p->obj = NIL; + } else { + p = NewOp__54(12, 17, p, x); + p->typ = p->left->typ; + } + } else { + OPB_err(111); + } + break; + case 1: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp == 3) { + if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + } else { + OPB_err(111); + } + p->right = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(64); + } + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f != 4) { + OPB_err(111); + } else { + if (fctno == 22) { + p = NewOp__54(12, 27, p, x); + } else { + p = NewOp__54(12, 28, p, x); + } + p->typ = p->left->typ; + } + break; + case 24: case 25: case 26: case 27: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x18ff, 32)) { + if (fctno == 24 || fctno == 26) { + if (OPB_NotVar(x)) { + OPB_err(112); + } + t = x; + x = p; + p = t; + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 28: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(12, 26, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_booltyp; + break; + case 29: + if (((x->class == 8 || x->class == 9) || __IN(f, 0x0501, 32)) || x->typ->comp == 3) { + OPB_err(126); + } + OPT_TypSize(x->typ); + OPT_TypSize(p->typ); + if ((x->class != 7 && x->typ->size < p->typ->size)) { + OPB_err(-308); + } + if ((((x->class == 7 && x->typ->form == 4)) && p->typ->form == 4)) { + OPB_Convert(&x, p->typ); + } else { + t = OPT_NewNode(11); + t->subcl = 29; + t->left = x; + x = t; + x->typ = p->typ; + } + p = x; + break; + case 30: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(19, 30, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + p->link = x; + break; + case 32: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + break; + default: + OPB_err(64); + break; + } + *par0 = p; + StPar1__53_s = _s.lnk; +} + +void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n) +{ + OPT_Node node = NIL; + INT16 f; + OPT_Node p = NIL; + p = *par0; + f = x->typ->form; + if (fctno == 1) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp != 3) { + OPB_err(64); + } else if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + node = p->right; + while (node->link != NIL) { + node = node->link; + } + node->link = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(111); + } + } else if ((fctno == 31 && n == 2)) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + node = OPT_NewNode(19); + node->subcl = 31; + node->right = p; + node->left = p->link; + p->link = x; + p = node; + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + } else { + OPB_err(64); + } + *par0 = p; +} + +void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno) +{ + INT16 dim; + OPT_Node x = NIL, p = NIL; + p = *par0; + if (fctno <= 19) { + if ((fctno == 1 && p->typ != OPT_notyp)) { + if (p->typ->comp == 3) { + OPB_err(65); + } + p->typ = OPT_notyp; + } else if (fctno <= 12) { + if (parno < 1) { + OPB_err(65); + } + } else { + if (((fctno == 13 || fctno == 14) && parno == 1)) { + OPB_BindNodes(19, OPT_notyp, &p, OPB_NewIntConst(1)); + p->subcl = fctno; + p->right->typ = p->left->typ; + } else if ((fctno == 17 && parno == 1)) { + if (p->typ->comp == 3) { + dim = 0; + while (p->class == 4) { + p = p->left; + dim += 1; + } + OPB_BindNodes(12, OPT_linttyp, &p, OPB_NewIntConst(dim)); + p->subcl = 19; + } else { + p = OPB_NewIntConst(p->typ->n); + } + } else if (parno < 2) { + OPB_err(65); + } + } + } else if (fctno == 32) { + if (parno == 1) { + x = NIL; + OPB_BindNodes(28, OPT_notyp, &x, OPB_NewIntConst(0)); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else if (parno < 1) { + OPB_err(65); + } + } else { + if ((parno < 1 || (fctno > 21 && parno < 2)) || (fctno == 31 && parno < 3)) { + OPB_err(65); + } + } + *par0 = p; +} + +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar) +{ + INT16 f; + f = atyp->comp; + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((fvarpar && ftyp == OPT_bytetyp)) { + if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { + if (__IN(18, OPM_Options, 32)) { + OPB_err(-301); + } + } + } else if (__IN(f, 0x0c, 32)) { + if (ftyp->comp == 3) { + OPB_DynArrParCheck(ftyp, atyp, fvarpar); + } else if (ftyp != atyp) { + if ((((!fvarpar && ftyp->form == 11)) && atyp->form == 11)) { + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((ftyp->comp == 4 && atyp->comp == 4)) { + while ((((ftyp != atyp && atyp != NIL)) && atyp != OPT_undftyp)) { + atyp = atyp->BaseTyp; + } + if (atyp == NIL) { + OPB_err(113); + } + } else { + OPB_err(66); + } + } else { + OPB_err(66); + } + } + } else { + OPB_err(67); + } +} + +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp) +{ + if (fp->typ->form == 11) { + if ((*x)->class == 3) { + *x = (*x)->left; + } else { + OPB_err(71); + } + } +} + +void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar) +{ + if (((*x)->obj != NIL && __IN((*x)->obj->mode, 0x22c0, 32))) { + *fpar = (*x)->obj->link; + if ((*x)->obj->mode == 13) { + OPB_CheckReceiver(&(*x)->left, *fpar); + *fpar = (*fpar)->link; + } + } else if (((((*x)->class != 8 && (*x)->typ != NIL)) && (*x)->typ->form == 12)) { + *fpar = (*x)->typ->link; + } else { + OPB_err(121); + *fpar = NIL; + (*x)->typ = OPT_undftyp; + } +} + +void OPB_Param (OPT_Node ap, OPT_Object fp) +{ + OPT_Struct q = NIL; + if (fp->typ->form != 0) { + if (fp->mode == 2) { + if (OPB_NotVar(ap)) { + OPB_err(122); + } else { + OPB_CheckLeaf(ap, 0); + } + if (ap->readonly) { + OPB_err(76); + } + if (fp->typ->comp == 3) { + OPB_DynArrParCheck(fp->typ, ap->typ, 1); + } else if ((fp->typ->comp == 4 && ap->typ->comp == 4)) { + q = ap->typ; + while ((((q != fp->typ && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(111); + } + } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 11)) { + } else if ((ap->typ != fp->typ && !((((fp->typ->form == 1 && __IN(ap->typ->form, 0x1e, 32))) && ap->typ->size == 1)))) { + OPB_err(123); + } else if ((fp->typ->form == 11 && ap->class == 5)) { + OPB_err(123); + } + } else if (fp->typ->comp == 3) { + if ((ap->class == 7 && ap->typ->form == 3)) { + OPB_CharToString(ap); + } + if ((ap->typ->form == 8 && fp->typ->BaseTyp->form == 3)) { + } else if (ap->class >= 7) { + OPB_err(59); + } else { + OPB_DynArrParCheck(fp->typ, ap->typ, 0); + } + } else { + OPB_CheckAssign(fp->typ, ap); + } + } +} + +void OPB_StaticLink (INT8 dlev) +{ + OPT_Object scope = NIL; + scope = OPT_topScope; + while (dlev > 0) { + dlev -= 1; + scope->link->conval->setval |= __SETOF(3,64); + scope = scope->left; + } +} + +void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp) +{ + OPT_Struct typ = NIL; + OPT_Node p = NIL; + INT8 lev; + if ((*x)->class == 9) { + typ = (*x)->typ; + lev = (*x)->obj->mnolev; + if (lev > 0) { + OPB_StaticLink(OPT_topScope->mnolev - lev); + } + if ((*x)->obj->mode == 10) { + OPB_err(121); + } + } else if (((*x)->class == 2 && (*x)->obj->mode == 13)) { + typ = (*x)->typ; + (*x)->class = 9; + p = (*x)->left; + (*x)->left = NIL; + p->link = apar; + apar = p; + fp = (*x)->obj->link; + } else { + typ = (*x)->typ->BaseTyp; + } + OPB_BindNodes(13, typ, &*x, apar); + (*x)->obj = fp; +} + +void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc) +{ + OPT_Node x = NIL; + x = OPT_NewNode(18); + x->typ = OPT_notyp; + x->obj = proc; + x->left = *procdec; + x->right = stat; + *procdec = x; +} + +void OPB_Return (OPT_Node *x, OPT_Object proc) +{ + OPT_Node node = NIL; + if (proc == NIL) { + if (*x != NIL) { + OPB_err(124); + } + } else { + if (*x != NIL) { + OPB_CheckAssign(proc->typ, *x); + } else if (proc->typ != OPT_notyp) { + OPB_err(124); + } + } + node = OPT_NewNode(26); + node->typ = OPT_notyp; + node->obj = proc; + node->left = *x; + *x = node; +} + +void OPB_Assign (OPT_Node *x, OPT_Node y) +{ + OPT_Node z = NIL; + if ((*x)->class >= 7) { + OPB_err(56); + } + OPB_CheckAssign((*x)->typ, y); + if ((*x)->readonly) { + OPB_err(76); + } + if ((*x)->typ->comp == 4) { + if ((*x)->class == 5) { + z = (*x)->left; + } else { + z = *x; + } + if ((z->class == 3 && z->left->class == 5)) { + z->left = z->left->left; + } + if (((*x)->typ->strobj != NIL && (z->class == 3 || z->class == 1))) { + OPB_BindNodes(6, (*x)->typ, &z, NIL); + *x = z; + } + } else if (((((((*x)->typ->comp == 2 && (*x)->typ->BaseTyp == OPT_chartyp)) && y->typ->form == 8)) && y->conval->intval2 == 1)) { + y->typ = OPT_chartyp; + y->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + OPB_BindNodes(19, OPT_notyp, &*x, y); + (*x)->subcl = 0; +} + +void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ) +{ + OPT_Node node = NIL; + node = OPT_NewNode(14); + node->typ = typ; + node->conval = OPT_NewConst(); + node->conval->intval = typ->txtpos; + if (*inittd == NIL) { + *inittd = node; + } else { + (*last)->link = node; + } + *last = node; +} + + +export void *OPB__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPB", 0); +/* BEGIN */ + OPB_maxExp = OPB_log(4611686018427387904LL); + OPB_maxExp = OPB_exp; + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPB.h b/bootstrap/windows-48/OPB.h new file mode 100644 index 00000000..f66fcd66 --- /dev/null +++ b/bootstrap/windows-48/OPB.h @@ -0,0 +1,48 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPB__h +#define OPB__h + +#include "SYSTEM.h" +#include "OPS.h" +#include "OPT.h" + + + + +import void OPB_Assign (OPT_Node *x, OPT_Node y); +import void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +import void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +import void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +import void OPB_DeRef (OPT_Node *x); +import OPT_Node OPB_EmptySet (void); +import void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +import void OPB_Field (OPT_Node *x, OPT_Object y); +import void OPB_In (OPT_Node *x, OPT_Node y); +import void OPB_Index (OPT_Node *x, OPT_Node y); +import void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +import void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +import void OPB_MOp (INT8 op, OPT_Node *x); +import OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +import OPT_Node OPB_NewIntConst (INT64 intval); +import OPT_Node OPB_NewLeaf (OPT_Object obj); +import OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +import OPT_Node OPB_NewString (OPS_String str, INT64 len); +import OPT_Node OPB_Nil (void); +import void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +import void OPB_OptIf (OPT_Node *x); +import void OPB_Param (OPT_Node ap, OPT_Object fp); +import void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +import void OPB_Return (OPT_Node *x, OPT_Object proc); +import void OPB_SetElem (OPT_Node *x); +import void OPB_SetRange (OPT_Node *x, OPT_Node y); +import void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +import void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +import void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +import void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +import void OPB_StaticLink (INT8 dlev); +import void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +import void *OPB__init(void); + + +#endif // OPB diff --git a/bootstrap/windows-48/OPC.c b/bootstrap/windows-48/OPC.c new file mode 100644 index 00000000..7b92ccc1 --- /dev/null +++ b/bootstrap/windows-48/OPC.c @@ -0,0 +1,2025 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "OPM.h" +#include "OPT.h" + + +static INT16 OPC_indentLevel; +static INT8 OPC_hashtab[105]; +static CHAR OPC_keytab[50][9]; +static BOOLEAN OPC_GlbPtrs; +static CHAR OPC_BodyNameExt[13]; + + +export void OPC_Andent (OPT_Struct typ); +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); +export OPT_Object OPC_BaseTProc (OPT_Object obj); +export void OPC_BegBlk (void); +export void OPC_BegStat (void); +static void OPC_CProcDefs (OPT_Object obj, INT16 vis); +export void OPC_Case (INT64 caseVal, INT16 form); +static void OPC_CharacterLiteral (INT64 c); +export void OPC_Cmp (INT16 rel); +export void OPC_CompleteIdent (OPT_Object obj); +export void OPC_Constant (OPT_Const con, INT16 form); +static void OPC_DeclareBase (OPT_Object dcl); +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef); +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro); +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefAnonRecs (OPT_Node n); +export void OPC_DefineInter (OPT_Object proc); +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefineTProcTypes (OPT_Object obj); +static void OPC_DefineType (OPT_Struct str); +export void OPC_EndBlk (void); +export void OPC_EndBlk0 (void); +export void OPC_EndStat (void); +export void OPC_EnterBody (void); +export void OPC_EnterProc (OPT_Object proc); +export void OPC_ExitBody (void); +export void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign); +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign); +export void OPC_GenBdy (OPT_Node n); +static void OPC_GenDynTypes (OPT_Node n, INT16 vis); +export void OPC_GenEnumPtrs (OPT_Object var); +export void OPC_GenHdr (OPT_Node n); +export void OPC_GenHdrIncludes (void); +static void OPC_GenHeaderMsg (void); +export void OPC_Halt (INT32 n); +export void OPC_Ident (OPT_Object obj); +static void OPC_IdentList (OPT_Object obj, INT16 vis); +static void OPC_Include (CHAR *name, ADDRESS name__len); +static void OPC_IncludeImports (OPT_Object obj, INT16 vis); +export void OPC_Increment (BOOLEAN decrement); +export void OPC_Indent (INT16 count); +export void OPC_Init (void); +static void OPC_InitImports (OPT_Object obj); +static void OPC_InitKeywords (void); +export void OPC_InitTDesc (OPT_Struct typ); +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj); +export void OPC_IntLiteral (INT64 n, INT32 size); +export void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName); +static INT16 OPC_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN OPC_NeedsRetval (OPT_Object proc); +export INT32 OPC_NofPtrs (OPT_Struct typ); +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len); +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len); +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define); +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis); +static void OPC_PutBase (OPT_Struct typ); +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt); +static void OPC_RegCmds (OPT_Object obj); +export void OPC_SetInclude (BOOLEAN exclude); +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x); +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l); +export void OPC_TDescDecl (OPT_Struct typ); +export void OPC_TypeDefs (OPT_Object obj, INT16 vis); +export void OPC_TypeOf (OPT_Object ap); +static BOOLEAN OPC_Undefined (OPT_Object obj); + + +void OPC_Init (void) +{ + OPC_indentLevel = 0; + __MOVE("__init(void)", OPC_BodyNameExt, 13); +} + +void OPC_Indent (INT16 count) +{ + OPC_indentLevel += count; +} + +void OPC_BegStat (void) +{ + INT16 i; + i = OPC_indentLevel; + while (i > 0) { + OPM_Write(0x09); + i -= 1; + } +} + +void OPC_EndStat (void) +{ + OPM_Write(';'); + OPM_WriteLn(); +} + +void OPC_BegBlk (void) +{ + OPM_Write('{'); + OPM_WriteLn(); + OPC_indentLevel += 1; +} + +void OPC_EndBlk (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); + OPM_WriteLn(); +} + +void OPC_EndBlk0 (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); +} + +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x) +{ + CHAR ch; + INT16 i; + __DUP(s, s__len, CHAR); + ch = s[0]; + i = 0; + while (ch != 0x00) { + if (ch == '#') { + OPM_WriteInt(x); + } else { + OPM_Write(ch); + } + i += 1; + ch = s[__X(i, s__len)]; + } + __DEL(s); +} + +static INT16 OPC_Length (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + return i; +} + +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len) +{ + INT16 i, h; + i = 0; + h = 0; + while ((s[__X(i, s__len)] != 0x00 && i < 5)) { + h = 3 * h + (INT16)s[__X(i, s__len)]; + i += 1; + } + return (int)__MOD(h, 105); +} + +void OPC_Ident (OPT_Object obj) +{ + INT16 mode, level, h; + mode = obj->mode; + level = obj->mnolev; + if ((__IN(mode, 0x62, 32) && level > 0) || __IN(mode, 0x14, 32)) { + OPM_WriteStringVar((void*)obj->name, 256); + h = OPC_PerfectHash((void*)obj->name, 256); + if (OPC_hashtab[__X(h, 105)] >= 0) { + if (__STRCMP(OPC_keytab[__X(OPC_hashtab[__X(h, 105)], 50)], obj->name) == 0) { + OPM_Write('_'); + } + } + } else if ((mode == 5 && __IN(obj->typ->form, 0x90, 32))) { + if (obj->typ == OPT_adrtyp) { + OPM_WriteString((CHAR*)"ADDRESS", 8); + } else { + if (obj->typ->form == 4) { + OPM_WriteString((CHAR*)"INT", 4); + } else { + OPM_WriteString((CHAR*)"UINT", 5); + } + OPM_WriteInt(__ASHL(obj->typ->size, 3)); + } + } else { + if (mode != 5 || obj->linkadr != 2) { + if (mode == 13) { + OPC_Ident(obj->link->typ->strobj); + } else if (level < 0) { + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-level, 64)]->name, 256); + if (OPM_currFile == 0) { + OPT_GlbMod[__X(-level, 64)]->vis = 1; + } + } else { + OPM_WriteStringVar((void*)OPM_modName, 32); + } + OPM_Write('_'); + } else if (obj == OPT_sysptrtyp->strobj || obj == OPT_bytetyp->strobj) { + OPM_WriteString((CHAR*)"SYSTEM_", 8); + } + OPM_WriteStringVar((void*)obj->name, 256); + } +} + +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause) +{ + INT16 pointers; + *openClause = 0; + if (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->comp != 4)) { + if (__IN(typ->comp, 0x0c, 32)) { + OPC_Stars(typ->BaseTyp, &*openClause); + *openClause = typ->comp == 2; + } else if (typ->form == 12) { + OPM_Write('('); + OPM_Write('*'); + } else { + pointers = 0; + while (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->form == 11)) { + pointers += 1; + typ = typ->BaseTyp; + } + if (pointers > 0) { + if (typ->comp != 3) { + OPC_Stars(typ, &*openClause); + } + if (*openClause) { + OPM_Write('('); + *openClause = 0; + } + while (pointers > 0) { + OPM_Write('*'); + pointers -= 1; + } + } + } + } +} + +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef) +{ + OPT_Struct typ = NIL; + BOOLEAN varPar, openClause; + INT16 form, comp; + typ = dcl->typ; + varPar = ((dcl->mode == 2 && typ->comp != 2) || typ->comp == 3) || scopeDef; + OPC_Stars(typ, &openClause); + if (varPar) { + if (openClause) { + OPM_Write('('); + } + OPM_Write('*'); + } + if (dcl->name[0] != 0x00) { + OPC_Ident(dcl); + } + if ((varPar && openClause)) { + OPM_Write(')'); + } + openClause = 0; + for (;;) { + form = typ->form; + comp = typ->comp; + if (((typ->strobj != NIL && typ->strobj->name[0] != 0x00) || form == 10) || comp == 4) { + break; + } else if ((form == 11 && typ->BaseTyp->comp != 3)) { + openClause = 1; + } else if (form == 12 || __IN(comp, 0x0c, 32)) { + if (openClause) { + OPM_Write(')'); + openClause = 0; + } + if (form == 12) { + OPM_Write(')'); + OPC_AnsiParamList(typ->link, 0); + break; + } else if (comp == 2) { + OPM_Write('['); + OPM_WriteInt(typ->n); + OPM_Write(']'); + } + } else { + break; + } + typ = typ->BaseTyp; + } +} + +void OPC_Andent (OPT_Struct typ) +{ + if (typ->strobj == NIL || typ->align >= 65536) { + OPM_WriteStringVar((void*)OPM_modName, 32); + OPC_Str1((CHAR*)"__#", 4, __ASHR(typ->align, 16)); + } else { + OPC_Ident(typ->strobj); + } +} + +static BOOLEAN OPC_Undefined (OPT_Object obj) +{ + return obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (3 + OPM_currFile))) && obj->linkadr != 2); +} + +static void OPC_DeclareBase (OPT_Object dcl) +{ + OPT_Struct typ = NIL, prev = NIL; + OPT_Object obj = NIL; + INT16 nofdims; + INT32 off, n, dummy; + typ = dcl->typ; + prev = typ; + while ((((((((typ->strobj == NIL || typ->comp == 3) || OPC_Undefined(typ->strobj)) && typ->comp != 4)) && typ->form != 10)) && !((typ->form == 11 && typ->BaseTyp->comp == 3)))) { + prev = typ; + typ = typ->BaseTyp; + } + obj = typ->strobj; + if (typ->form == 10) { + OPM_WriteString((CHAR*)"void", 5); + } else if ((obj != NIL && !OPC_Undefined(obj))) { + OPC_Ident(obj); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"struct ", 8); + OPC_Andent(typ); + if ((prev->form != 11 && (obj != NIL || dcl->name[0] == 0x00))) { + if ((typ->BaseTyp != NIL && typ->BaseTyp->strobj->vis != 0)) { + OPM_WriteString((CHAR*)" { /* ", 7); + OPC_Ident(typ->BaseTyp->strobj); + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); + OPC_Indent(1); + } else { + OPM_Write(' '); + OPC_BegBlk(); + } + OPC_FieldList(typ, 1, &off, &n, &dummy); + OPC_EndBlk0(); + } + } else if ((typ->form == 11 && typ->BaseTyp->comp == 3)) { + typ = typ->BaseTyp->BaseTyp; + nofdims = 1; + while (typ->comp == 3) { + nofdims += 1; + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)"struct ", 8); + OPC_BegBlk(); + OPC_BegStat(); + OPC_Str1((CHAR*)"ADDRESS len[#]", 15, nofdims); + OPC_EndStat(); + OPC_BegStat(); + __NEW(obj, OPT_ObjDesc); + __NEW(obj->typ, OPT_StrDesc); + obj->typ->form = 13; + obj->typ->comp = 2; + obj->typ->n = 1; + obj->typ->BaseTyp = typ; + obj->mode = 4; + __MOVE("data", obj->name, 5); + obj->linkadr = 0; + OPC_DeclareBase(obj); + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + OPC_EndStat(); + OPC_EndBlk0(); + } +} + +INT32 OPC_NofPtrs (OPT_Struct typ) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n; + if ((typ->form == 11 && typ->sysflag == 0)) { + return 1; + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + n = OPC_NofPtrs(btyp); + } else { + n = 0; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + n = n + OPC_NofPtrs(fld->typ); + } else { + n += 1; + } + fld = fld->link; + } + return n; + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + return OPC_NofPtrs(btyp) * n; + } else { + return 0; + } + __RETCHK; +} + +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n, i; + if ((typ->form == 11 && typ->sysflag == 0)) { + OPM_WriteInt(adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + OPC_PutPtrOffsets(btyp, adr, &*cnt); + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + OPC_PutPtrOffsets(fld->typ, adr + fld->adr, &*cnt); + } else { + OPM_WriteInt(adr + fld->adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } + fld = fld->link; + } + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (OPC_NofPtrs(btyp) > 0) { + i = 0; + while (i < n) { + OPC_PutPtrOffsets(btyp, adr + i * btyp->size, &*cnt); + i += 1; + } + } + } +} + +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitTProcs(typ, obj->left); + if (obj->mode == 13) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITBP(", 10); + OPC_Ident(typ); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(obj); + OPC_Str1((CHAR*)", #)", 5, __ASHR(obj->adr, 16)); + OPC_EndStat(); + } + OPC_InitTProcs(typ, obj->right); + } +} + +static void OPC_PutBase (OPT_Struct typ) +{ + if (typ != NIL) { + OPC_PutBase(typ->BaseTyp); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)", ", 3); + } +} + +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName) +{ + OPT_Struct typ = NIL; + INT16 dim; + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + } + dim = 1; + typ = par->typ->BaseTyp; + while (typ->comp == 3) { + if (ansiDefine) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + } else { + OPM_WriteString((CHAR*)", ", 3); + } + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + dim += 1; + } +} + +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro) +{ + OPM_Write('('); + while (par != NIL) { + if (macro) { + OPM_WriteStringVar((void*)par->name, 256); + } else { + if ((par->mode == 1 && par->typ->form == 5)) { + OPM_Write('_'); + } + OPC_Ident(par); + } + if (par->typ->comp == 3) { + OPM_WriteString((CHAR*)", ", 3); + OPC_LenList(par, 0, 1); + } else if ((par->mode == 2 && par->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteStringVar((void*)par->name, 256); + OPM_WriteString((CHAR*)"__typ", 6); + } + par = par->link; + if (par != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static void OPC_DefineTProcTypes (OPT_Object obj) +{ + OPT_Object par = NIL; + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + par = obj->link; + while (par != NIL) { + OPC_DefineType(par->typ); + par = par->link; + } +} + +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DeclareTProcs(obj->left, &*empty); + if (obj->mode == 13) { + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + if (OPM_currFile == 0) { + if (obj->vis == 1) { + OPC_DefineTProcTypes(obj); + OPM_WriteString((CHAR*)"import ", 8); + *empty = 0; + OPC_ProcHeader(obj, 0); + } + } else { + *empty = 0; + OPC_DefineTProcTypes(obj); + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + } + OPC_DeclareTProcs(obj->right, &*empty); + } +} + +OPT_Object OPC_BaseTProc (OPT_Object obj) +{ + OPT_Struct typ = NIL, base = NIL; + INT32 mno; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + base = typ->BaseTyp; + mno = __ASHR(obj->adr, 16); + while ((base != NIL && mno < base->n)) { + typ = base; + base = typ->BaseTyp; + } + OPT_FindField(obj->name, typ, &obj); + return obj; +} + +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DefineTProcMacros(obj->left, &*empty); + if ((obj->mode == 13 && obj == OPC_BaseTProc(obj))) { + if (OPM_currFile == 1 || (OPM_currFile == 0 && obj->vis == 1)) { + OPM_WriteString((CHAR*)"#define __", 11); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_WriteString((CHAR*)" __SEND(", 9); + if (obj->link->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPC_Ident(obj->link); + OPM_Write(')'); + } else { + OPC_Ident(obj->link); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_Str1((CHAR*)", #, ", 6, __ASHR(obj->adr, 16)); + if (obj->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(obj->typ->strobj); + } + OPM_WriteString((CHAR*)"(*)", 4); + OPC_AnsiParamList(obj->link, 0); + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareParams(obj->link, 1); + OPM_Write(')'); + OPM_WriteLn(); + } + } + OPC_DefineTProcMacros(obj->right, &*empty); + } +} + +static void OPC_DefineType (OPT_Struct str) +{ + OPT_Object obj = NIL, field = NIL, par = NIL; + BOOLEAN empty; + if ((OPM_currFile == 1 || str->ref < 255) || (((OPM_currFile == 0 && str->strobj != NIL)) && str->strobj->vis == 1)) { + obj = str->strobj; + if (obj == NIL || OPC_Undefined(obj)) { + if (obj != NIL) { + if (obj->linkadr == 1) { + if (str->form != 11) { + OPM_Mark(244, str->txtpos); + obj->linkadr = 2; + } + } else { + obj->linkadr = 1; + } + } + if (str->comp == 4) { + if (str->BaseTyp != NIL) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while ((field != NIL && field->mode == 4)) { + if (field->vis != 0 || OPM_currFile == 1) { + OPC_DefineType(field->typ); + } + field = field->link; + } + } else if (str->form == 11) { + if (str->BaseTyp->comp != 4) { + OPC_DefineType(str->BaseTyp); + } + } else if (__IN(str->comp, 0x0c, 32)) { + if ((str->BaseTyp->strobj != NIL && str->BaseTyp->strobj->linkadr == 1)) { + OPM_Mark(244, str->txtpos); + str->BaseTyp->strobj->linkadr = 2; + } + OPC_DefineType(str->BaseTyp); + } else if (str->form == 12) { + if (str->BaseTyp != OPT_notyp) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while (field != NIL) { + OPC_DefineType(field->typ); + field = field->link; + } + } + } + if ((obj != NIL && OPC_Undefined(obj))) { + OPM_WriteString((CHAR*)"typedef", 8); + OPM_WriteLn(); + OPM_Write(0x09); + OPC_Indent(1); + obj->linkadr = 1; + OPC_DeclareBase(obj); + OPM_Write(' '); + obj->typ->strobj = NIL; + OPC_DeclareObj(obj, 0); + obj->typ->strobj = obj; + obj->linkadr = 3 + OPM_currFile; + OPC_EndStat(); + OPC_Indent(-1); + OPM_WriteLn(); + if (obj->typ->comp == 4) { + empty = 1; + OPC_DeclareTProcs(str->link, &empty); + OPC_DefineTProcMacros(str->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } else if ((obj->typ->form == 11 && obj->typ->BaseTyp->comp == 4)) { + empty = 1; + OPC_DeclareTProcs(obj->typ->BaseTyp->link, &empty); + OPC_DefineTProcMacros(obj->typ->BaseTyp->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } + } + } +} + +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len) +{ + INT16 i; + __DUP(y, y__len, CHAR); + i = 0; + while ((*x)[__X(i + 1, 256)] == y[__X(i, y__len)]) { + i += 1; + } + __DEL(y); + return y[__X(i, y__len)] == 0x00; +} + +static void OPC_CProcDefs (OPT_Object obj, INT16 vis) +{ + INT16 i; + OPT_ConstExt ext = NIL; + INT16 _for__7; + if (obj != NIL) { + OPC_CProcDefs(obj->left, vis); + if ((((obj->mode == 9 && (INT16)obj->vis >= vis)) && obj->adr == 1)) { + ext = obj->conval->ext; + i = 1; + if (((*ext)[1] != '#' && !(OPC_Prefixed(ext, (CHAR*)"extern ", 8) || OPC_Prefixed(ext, (CHAR*)"import ", 8)))) { + OPM_WriteString((CHAR*)"#define ", 9); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_Write(0x09); + } + _for__7 = (INT16)(*obj->conval->ext)[0]; + i = i; + while (i <= _for__7) { + OPM_Write((*obj->conval->ext)[__X(i, 256)]); + i += 1; + } + OPM_WriteLn(); + } + OPC_CProcDefs(obj->right, vis); + } +} + +void OPC_TypeDefs (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_TypeDefs(obj->left, vis); + if ((obj->mode == 5 && obj->typ->txtpos > 0)) { + OPC_DefineType(obj->typ); + } + OPC_TypeDefs(obj->right, vis); + } +} + +static void OPC_DefAnonRecs (OPT_Node n) +{ + OPT_Object o = NIL; + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if ((typ->strobj == NIL && (OPM_currFile == 1 || typ->ref < 255))) { + OPC_DefineType(typ); + __NEW(o, OPT_ObjDesc); + o->typ = typ; + o->name[0] = 0x00; + OPC_DeclareBase(o); + OPC_EndStat(); + OPM_WriteLn(); + } + n = n->link; + } +} + +void OPC_TDescDecl (OPT_Struct typ) +{ + INT32 nofptrs; + OPT_Object o = NIL; + OPC_BegStat(); + OPM_WriteString((CHAR*)"__TDESC(", 9); + OPC_Andent(typ); + OPC_Str1((CHAR*)", #", 4, typ->n + 1); + OPC_Str1((CHAR*)", #) = {__TDFLDS(", 18, OPC_NofPtrs(typ)); + OPM_Write('"'); + if (typ->strobj != NIL) { + OPM_WriteStringVar((void*)typ->strobj->name, 256); + } + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", 8, typ->size); + nofptrs = 0; + OPC_PutPtrOffsets(typ, 0, &nofptrs); + OPC_Str1((CHAR*)"#}}", 4, -((nofptrs + 1) * OPM_AddressSize)); + OPC_EndStat(); +} + +void OPC_InitTDesc (OPT_Struct typ) +{ + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITYP(", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + if (typ->BaseTyp != NIL) { + OPC_Andent(typ->BaseTyp); + } else { + OPC_Andent(typ); + } + OPC_Str1((CHAR*)", #)", 5, typ->extlev); + OPC_EndStat(); + if (typ->strobj != NIL) { + OPC_InitTProcs(typ->strobj, typ->link); + } +} + +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign) +{ + INT32 adr; + adr = off; + OPT_Align(&adr, align); + if ((*curAlign < align && gap - (adr - off) >= align)) { + gap -= (adr - off) + align; + OPC_BegStat(); + switch (align) { + case 2: + OPM_WriteString((CHAR*)"INT16", 6); + break; + case 4: + OPM_WriteString((CHAR*)"INT32", 6); + break; + case 8: + OPM_WriteString((CHAR*)"INT64", 6); + break; + default: + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected enclosing alignment in FillGap.", 43); + break; + } + OPC_Str1((CHAR*)" _prvt#", 8, *n); + *n += 1; + OPC_EndStat(); + *curAlign = align; + } + if (gap > 0) { + OPC_BegStat(); + OPC_Str1((CHAR*)"char _prvt#", 12, *n); + *n += 1; + OPC_Str1((CHAR*)"[#]", 4, gap); + OPC_EndStat(); + } +} + +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign) +{ + OPT_Object fld = NIL; + OPT_Struct base = NIL; + INT32 gap, adr, align, fldAlign; + fld = typ->link; + align = __MASK(typ->align, -65536); + if (typ->BaseTyp != NIL) { + OPC_FieldList(typ->BaseTyp, 0, &*off, &*n, &*curAlign); + } else { + *off = 0; + *n = 0; + *curAlign = 1; + } + while ((fld != NIL && fld->mode == 4)) { + if ((OPM_currFile == 0 && fld->vis == 0) || (((OPM_currFile == 1 && fld->vis == 0)) && typ->mno != 0)) { + fld = fld->link; + while ((((fld != NIL && fld->mode == 4)) && fld->vis == 0)) { + fld = fld->link; + } + } else { + adr = *off; + fldAlign = OPT_BaseAlignment(fld->typ); + OPT_Align(&adr, fldAlign); + gap = fld->adr - adr; + if (fldAlign > *curAlign) { + *curAlign = fldAlign; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + OPC_BegStat(); + OPC_DeclareBase(fld); + OPM_Write(' '); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + base = fld->typ; + fld = fld->link; + while ((((((((fld != NIL && fld->mode == 4)) && fld->typ == base)) && fld->adr == *off)) && ((OPM_currFile == 1 || fld->vis != 0) || fld->typ->strobj == NIL))) { + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + fld = fld->link; + } + OPC_EndStat(); + } + } + if (last) { + adr = typ->size - __ASHR(typ->sysflag, 8); + if (adr == 0) { + gap = 1; + } else { + gap = adr - *off; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + } +} + +static void OPC_IdentList (OPT_Object obj, INT16 vis) +{ + OPT_Struct base = NIL; + BOOLEAN first; + INT16 lastvis; + base = NIL; + first = 1; + while ((obj != NIL && obj->mode != 13)) { + if ((__IN(vis, 0x05, 32) || (vis == 1 && obj->vis != 0)) || (vis == 3 && !obj->leaf)) { + if (obj->typ != base || (INT16)obj->vis != lastvis) { + if (!first) { + OPC_EndStat(); + } + first = 0; + base = obj->typ; + lastvis = obj->vis; + OPC_BegStat(); + if ((vis == 1 && obj->vis != 0)) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((obj->mnolev == 0 && vis == 0)) { + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + } + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_WriteString((CHAR*)"double", 7); + } else { + OPC_DeclareBase(obj); + } + } else { + OPM_Write(','); + } + OPM_Write(' '); + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_Write('_'); + } + OPC_DeclareObj(obj, vis == 3); + if (obj->typ->comp == 3) { + OPC_EndStat(); + OPC_BegStat(); + base = OPT_adrtyp; + OPM_WriteString((CHAR*)"ADDRESS ", 9); + OPC_LenList(obj, 0, 1); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + base = NIL; + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + OPM_WriteString((CHAR*)" = NIL", 7); + } + } + obj = obj->link; + } + if (!first) { + OPC_EndStat(); + } +} + +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames) +{ + CHAR name[32]; + OPM_Write('('); + if (obj == NIL || obj->mode == 13) { + OPM_WriteString((CHAR*)"void", 5); + } else { + for (;;) { + OPC_DeclareBase(obj); + if (showParamNames) { + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + } else { + __COPY(obj->name, name, 32); + obj->name[0] = 0x00; + OPC_DeclareObj(obj, 0); + __COPY(name, obj->name, 256); + } + if (obj->typ->comp == 3) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + OPC_LenList(obj, 1, showParamNames); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ADDRESS *", 12); + if (showParamNames) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + } + } + if (obj->link == NIL || obj->link->mode == 13) { + break; + } + OPM_WriteString((CHAR*)", ", 3); + obj = obj->link; + } + } + OPM_Write(')'); +} + +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define) +{ + if (proc->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(proc->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(proc); + OPM_Write(' '); + OPC_AnsiParamList(proc->link, 1); + if (!define) { + OPM_Write(';'); + } + OPM_WriteLn(); +} + +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis) +{ + if (obj != NIL) { + OPC_ProcPredefs(obj->left, vis); + if ((((__IN(obj->mode, 0xc0, 32) && obj->vis >= vis)) && (obj->history != 4 || obj->mode == 6))) { + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + OPC_ProcPredefs(obj->right, vis); + } +} + +static void OPC_Include (CHAR *name, ADDRESS name__len) +{ + __DUP(name, name__len, CHAR); + OPM_WriteString((CHAR*)"#include ", 10); + OPM_Write('"'); + OPM_WriteStringVar((void*)name, name__len); + OPM_WriteString((CHAR*)".h", 3); + OPM_Write('"'); + OPM_WriteLn(); + __DEL(name); +} + +static void OPC_IncludeImports (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_IncludeImports(obj->left, vis); + if ((((obj->mode == 11 && obj->mnolev != 0)) && (INT16)OPT_GlbMod[__X(-obj->mnolev, 64)]->vis >= vis)) { + OPC_Include(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + } + OPC_IncludeImports(obj->right, vis); + } +} + +static void OPC_GenDynTypes (OPT_Node n, INT16 vis) +{ + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if (vis == 0 || typ->ref < 255) { + OPC_BegStat(); + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((typ->strobj != NIL && typ->strobj->mnolev > 0)) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_EndStat(); + } + n = n->link; + } +} + +void OPC_GenHdr (OPT_Node n) +{ + OPM_currFile = 0; + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 1); + OPM_WriteLn(); + OPC_GenDynTypes(n, 1); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 1); + OPM_WriteString((CHAR*)"import ", 8); + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPC_EndStat(); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#endif // ", 11); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteLn(); +} + +static void OPC_GenHeaderMsg (void) +{ + INT16 i; + OPM_WriteString((CHAR*)"/* ", 4); + OPM_WriteString((CHAR*)"voc", 4); + OPM_Write(' '); + OPM_WriteString(Configuration_versionLong, 76); + OPM_Write(' '); + i = 0; + while (i <= 31) { + if (__IN(i, OPM_Options, 32)) { + switch (i) { + case 0: + OPM_Write('x'); + break; + case 2: + OPM_Write('r'); + break; + case 3: + OPM_Write('t'); + break; + case 4: + OPM_Write('s'); + break; + case 5: + OPM_Write('p'); + break; + case 7: + OPM_Write('a'); + break; + case 9: + OPM_Write('e'); + break; + case 10: + OPM_Write('m'); + break; + case 13: + OPM_Write('S'); + break; + case 14: + OPM_Write('c'); + break; + case 15: + OPM_Write('M'); + break; + case 16: + OPM_Write('f'); + break; + case 17: + OPM_Write('F'); + break; + case 18: + OPM_Write('v'); + break; + default: + OPM_LogWStr((CHAR*)"( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg", 126); + OPM_LogWLn(); + break; + } + } + i += 1; + } + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); +} + +void OPC_GenHdrIncludes (void) +{ + OPM_currFile = 2; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#ifndef ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 1); + OPM_WriteLn(); +} + +void OPC_GenBdy (OPT_Node n) +{ + OPM_currFile = 1; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SHORTINT INT", 21); + OPM_WriteInt(__ASHL(OPT_sinttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define INTEGER INT", 21); + OPM_WriteInt(__ASHL(OPT_inttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define LONGINT INT", 21); + OPM_WriteInt(__ASHL(OPT_linttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SET UINT", 22); + OPM_WriteInt(__ASHL(OPT_settyp->size, 3)); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 0); + OPM_WriteLn(); + OPC_GenDynTypes(n, 0); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 0); + OPM_WriteLn(); +} + +static void OPC_RegCmds (OPT_Object obj) +{ + if (obj != NIL) { + OPC_RegCmds(obj->left); + if ((obj->mode == 7 && obj->history != 4)) { + if ((((obj->vis != 0 && obj->link == NIL)) && obj->typ == OPT_notyp)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__REGCMD(\"", 11); + OPM_WriteStringVar((void*)obj->name, 256); + OPM_WriteString((CHAR*)"\", ", 4); + OPC_Ident(obj); + OPM_Write(')'); + OPC_EndStat(); + } + } + OPC_RegCmds(obj->right); + } +} + +static void OPC_InitImports (OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitImports(obj->left); + if ((obj->mode == 11 && obj->mnolev != 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__MODULE_IMPORT(", 17); + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + OPM_Write(')'); + OPC_EndStat(); + } + OPC_InitImports(obj->right); + } +} + +void OPC_GenEnumPtrs (OPT_Object var) +{ + OPT_Struct typ = NIL; + INT32 n; + OPC_GlbPtrs = 0; + while (var != NIL) { + typ = var->typ; + if (OPC_NofPtrs(typ) > 0) { + if (!OPC_GlbPtrs) { + OPC_GlbPtrs = 1; + OPM_WriteString((CHAR*)"static void EnumPtrs(void (*P)(void*))", 39); + OPM_WriteLn(); + OPC_BegBlk(); + } + OPC_BegStat(); + if (typ->form == 11) { + OPM_WriteString((CHAR*)"P(", 3); + OPC_Ident(var); + OPM_Write(')'); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(&", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPM_WriteString((CHAR*)", 1, P)", 8); + } else if (typ->comp == 2) { + n = typ->n; + typ = typ->BaseTyp; + while (typ->comp == 2) { + n = n * typ->n; + typ = typ->BaseTyp; + } + if (typ->form == 11) { + OPM_WriteString((CHAR*)"__ENUMP(", 9); + OPC_Ident(var); + OPC_Str1((CHAR*)", #, P)", 8, n); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(", 9); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPC_Str1((CHAR*)", #, P)", 8, n); + } + } + OPC_EndStat(); + } + var = var->link; + } + if (OPC_GlbPtrs) { + OPC_EndBlk(); + OPM_WriteLn(); + } +} + +void OPC_EnterBody (void) +{ + OPM_WriteLn(); + OPM_WriteString((CHAR*)"export ", 8); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); + OPM_WriteLn(); + } else { + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteString(OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPM_WriteLn(); + } + OPC_BegBlk(); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); + } else { + OPM_WriteString((CHAR*)"__DEFMOD", 9); + } + OPC_EndStat(); + if ((__IN(10, OPM_Options, 32) && 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); + OPC_EndStat(); + } + OPC_InitImports(OPT_topScope->right); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); + } else { + OPM_WriteString((CHAR*)"__REGMOD(\"", 11); + } + OPM_WriteString(OPM_modName, 32); + if (OPC_GlbPtrs) { + OPM_WriteString((CHAR*)"\", EnumPtrs)", 13); + } else { + OPM_WriteString((CHAR*)"\", 0)", 6); + } + OPC_EndStat(); + if (__STRCMP(OPM_modName, "SYSTEM") != 0) { + OPC_RegCmds(OPT_topScope); + } +} + +void OPC_ExitBody (void) +{ + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI;", 8); + } else { + OPM_WriteString((CHAR*)"__ENDMOD;", 10); + } + OPM_WriteLn(); + OPC_EndBlk(); +} + +void OPC_DefineInter (OPT_Object proc) +{ + OPT_Object scope = NIL; + scope = proc->scope; + OPM_WriteString((CHAR*)"static ", 8); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPC_BegBlk(); + OPC_IdentList(proc->link, 3); + OPC_IdentList(scope->scope, 3); + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + OPC_EndBlk0(); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPM_WriteLn(); + OPC_ProcPredefs(scope->right, 0); + OPM_WriteLn(); +} + +BOOLEAN OPC_NeedsRetval (OPT_Object proc) +{ + return (proc->typ != OPT_notyp && !proc->scope->leaf); +} + +void OPC_EnterProc (OPT_Object proc) +{ + OPT_Object var = NIL, scope = NIL; + OPT_Struct typ = NIL; + INT16 dim; + if (proc->vis != 1) { + OPM_WriteString((CHAR*)"static ", 8); + } + OPC_ProcHeader(proc, 1); + OPC_BegBlk(); + scope = proc->scope; + OPC_IdentList(scope->scope, 0); + if (!scope->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } + if (OPC_NeedsRetval(proc)) { + OPC_BegStat(); + OPC_Ident(proc->typ->strobj); + OPM_WriteString((CHAR*)" __retval", 10); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((var->typ->comp == 2 && var->mode == 1)) { + OPC_BegStat(); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__copy", 7); + OPC_EndStat(); + } + var = var->link; + } + var = proc->link; + while (var != NIL) { + if ((((__IN(var->typ->comp, 0x0c, 32) && var->mode == 1)) && var->typ->sysflag == 0)) { + OPC_BegStat(); + if (var->typ->comp == 2) { + OPM_WriteString((CHAR*)"__DUPARR(", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + } else { + OPM_WriteString((CHAR*)"__DUP(", 7); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + typ = var->typ->BaseTyp; + dim = 1; + while (typ->comp == 3) { + OPM_WriteString((CHAR*)" * ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + typ = typ->BaseTyp; + dim += 1; + } + OPM_WriteString((CHAR*)", ", 3); + if (typ->strobj == NIL) { + OPM_Mark(200, typ->txtpos); + } else { + OPC_Ident(typ->strobj); + } + } + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + if (!scope->leaf) { + var = proc->link; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (__IN(var->typ->comp, 0x0c, 32)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } else if (var->mode != 2) { + OPM_Write('&'); + } + OPC_Ident(var); + if (var->typ->comp == 3) { + typ = var->typ; + dim = 0; + do { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + } while (!(typ->comp != 3)); + } else if ((var->mode == 2 && var->typ->comp == 4)) { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_EndStat(); + } + var = var->link; + } + var = scope->scope; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (var->typ->comp != 2) { + OPM_Write('&'); + } else { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPC_Ident(var); + OPC_EndStat(); + } + var = var->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_Write('&'); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } +} + +void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet) +{ + OPT_Object var = NIL; + BOOLEAN indent; + indent = eoBlock; + if ((implicitRet && proc->typ != OPT_notyp)) { + OPM_Write(0x09); + OPM_WriteString((CHAR*)"__RETCHK;", 10); + OPM_WriteLn(); + } else if (!eoBlock || implicitRet) { + if (!proc->scope->leaf) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteStringVar((void*)proc->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((((var->typ->comp == 3 && var->mode == 1)) && var->typ->sysflag == 0)) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteString((CHAR*)"__DEL(", 7); + OPC_Ident(var); + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + } + if (eoBlock) { + OPC_EndBlk(); + OPM_WriteLn(); + } else if (indent) { + OPC_BegStat(); + } +} + +void OPC_CompleteIdent (OPT_Object obj) +{ + INT16 comp, level; + level = obj->mnolev; + if (obj->adr == 1) { + if (obj->typ->comp == 4) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__", 3); + } else { + OPM_WriteString((CHAR*)"(*(", 4); + OPC_Ident(obj->typ->strobj); + OPM_WriteString((CHAR*)"*)&", 4); + OPC_Ident(obj); + OPM_Write(')'); + } + } else if ((level != OPM_level && level > 0)) { + comp = obj->typ->comp; + if ((obj->mode != 2 && comp != 3)) { + OPM_Write('*'); + } + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)"->", 3); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } +} + +void OPC_TypeOf (OPT_Object ap) +{ + INT16 i; + __ASSERT(ap->typ->comp == 4, 0); + if (ap->mode == 2) { + if ((INT16)ap->mnolev != OPM_level) { + OPM_WriteStringVar((void*)ap->scope->name, 256); + OPM_WriteString((CHAR*)"_s->", 5); + OPC_Ident(ap); + } else { + OPC_Ident(ap); + } + OPM_WriteString((CHAR*)"__typ", 6); + } else if (ap->typ->strobj != NIL) { + OPC_Ident(ap->typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + } else { + OPC_Andent(ap->typ); + } +} + +void OPC_Cmp (INT16 rel) +{ + switch (rel) { + case 9: + OPM_WriteString((CHAR*)" == ", 5); + break; + case 10: + OPM_WriteString((CHAR*)" != ", 5); + break; + case 11: + OPM_WriteString((CHAR*)" < ", 4); + break; + case 12: + OPM_WriteString((CHAR*)" <= ", 5); + break; + case 13: + OPM_WriteString((CHAR*)" > ", 4); + break; + case 14: + OPM_WriteString((CHAR*)" >= ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Cmp, rel = ", 34); + OPM_LogWNum(rel, 0); + OPM_LogWLn(); + break; + } +} + +static void OPC_CharacterLiteral (INT64 c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", 3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l) +{ + INT32 i; + INT16 c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (INT16)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write(__CHR(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write(__CHR(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write(__CHR(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + +void OPC_Case (INT64 caseVal, INT16 form) +{ + CHAR ch; + OPM_WriteString((CHAR*)"case ", 6); + switch (form) { + case 3: + OPC_CharacterLiteral(caseVal); + break; + case 4: + OPM_WriteInt(caseVal); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Case, form = ", 36); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } + OPM_WriteString((CHAR*)": ", 3); +} + +void OPC_SetInclude (BOOLEAN exclude) +{ + if (exclude) { + OPM_WriteString((CHAR*)" &= ~", 6); + } else { + OPM_WriteString((CHAR*)" |= ", 5); + } +} + +void OPC_Increment (BOOLEAN decrement) +{ + if (decrement) { + OPM_WriteString((CHAR*)" -= ", 5); + } else { + OPM_WriteString((CHAR*)" += ", 5); + } +} + +void OPC_Halt (INT32 n) +{ + OPC_Str1((CHAR*)"__HALT(#)", 10, n); +} + +void OPC_IntLiteral (INT64 n, INT32 size) +{ + if ((((size > 4 && n <= 2147483647)) && n > (-2147483647-1))) { + OPM_WriteString((CHAR*)"((INT", 6); + OPM_WriteInt(__ASHL(size, 3)); + OPM_WriteString((CHAR*)")(", 3); + OPM_WriteInt(n); + OPM_WriteString((CHAR*)"))", 3); + } else { + OPM_WriteInt(n); + } +} + +void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim) +{ + INT64 d; + d = dim; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPC_CompleteIdent(obj); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + } else { + OPM_WriteInt(array->n); + } +} + +void OPC_Constant (OPT_Const con, INT16 form) +{ + INT16 i; + UINT64 s; + INT64 hex; + BOOLEAN skipLeading; + switch (form) { + case 1: + OPM_WriteInt(con->intval); + break; + case 2: + OPM_WriteInt(con->intval); + break; + case 3: + OPC_CharacterLiteral(con->intval); + break; + case 4: + OPM_WriteInt(con->intval); + break; + case 5: + OPM_WriteReal(con->realval, 'f'); + break; + case 6: + OPM_WriteReal(con->realval, 0x00); + break; + case 7: + OPM_WriteString((CHAR*)"0x", 3); + skipLeading = 1; + s = con->setval; + i = 64; + do { + hex = 0; + do { + i -= 1; + hex = __ASHL(hex, 1); + if (__IN(i, s, 64)) { + hex += 1; + } + } while (!(__MASK(i, -8) == 0)); + if (hex != 0 || !skipLeading) { + OPM_WriteHex(hex); + skipLeading = 0; + } + } while (!(i == 0)); + if (skipLeading) { + OPM_Write('0'); + } + break; + case 8: + OPC_StringLiteral(*con->ext, 256, con->intval2 - 1); + break; + case 9: + OPM_WriteString((CHAR*)"NIL", 4); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Constant, form = ", 40); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } +} + +static struct InitKeywords__46 { + INT8 *n; + struct InitKeywords__46 *lnk; +} *InitKeywords__46_s; + +static void Enter__47 (CHAR *s, ADDRESS s__len); + +static void Enter__47 (CHAR *s, ADDRESS s__len) +{ + INT16 h; + __DUP(s, s__len, CHAR); + h = OPC_PerfectHash((void*)s, s__len); + OPC_hashtab[__X(h, 105)] = *InitKeywords__46_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__46_s->n, 50)], 9); + *InitKeywords__46_s->n += 1; + __DEL(s); +} + +static void OPC_InitKeywords (void) +{ + INT8 n, i; + struct InitKeywords__46 _s; + _s.n = &n; + _s.lnk = InitKeywords__46_s; + InitKeywords__46_s = &_s; + n = 0; + i = 0; + while (i <= 104) { + OPC_hashtab[__X(i, 105)] = -1; + i += 1; + } + Enter__47((CHAR*)"ADDRESS", 8); + Enter__47((CHAR*)"INT16", 6); + Enter__47((CHAR*)"INT32", 6); + Enter__47((CHAR*)"INT64", 6); + Enter__47((CHAR*)"INT8", 5); + Enter__47((CHAR*)"UINT16", 7); + Enter__47((CHAR*)"UINT32", 7); + Enter__47((CHAR*)"UINT64", 7); + Enter__47((CHAR*)"UINT8", 6); + Enter__47((CHAR*)"asm", 4); + Enter__47((CHAR*)"auto", 5); + Enter__47((CHAR*)"break", 6); + Enter__47((CHAR*)"case", 5); + Enter__47((CHAR*)"char", 5); + Enter__47((CHAR*)"const", 6); + Enter__47((CHAR*)"continue", 9); + Enter__47((CHAR*)"default", 8); + Enter__47((CHAR*)"do", 3); + Enter__47((CHAR*)"double", 7); + Enter__47((CHAR*)"else", 5); + Enter__47((CHAR*)"enum", 5); + Enter__47((CHAR*)"extern", 7); + Enter__47((CHAR*)"export", 7); + Enter__47((CHAR*)"float", 6); + Enter__47((CHAR*)"for", 4); + Enter__47((CHAR*)"fortran", 8); + Enter__47((CHAR*)"goto", 5); + Enter__47((CHAR*)"if", 3); + Enter__47((CHAR*)"import", 7); + Enter__47((CHAR*)"int", 4); + Enter__47((CHAR*)"long", 5); + Enter__47((CHAR*)"register", 9); + Enter__47((CHAR*)"return", 7); + Enter__47((CHAR*)"short", 6); + Enter__47((CHAR*)"signed", 7); + Enter__47((CHAR*)"sizeof", 7); + Enter__47((CHAR*)"size_t", 7); + Enter__47((CHAR*)"static", 7); + Enter__47((CHAR*)"struct", 7); + Enter__47((CHAR*)"switch", 7); + Enter__47((CHAR*)"typedef", 8); + Enter__47((CHAR*)"union", 6); + Enter__47((CHAR*)"unsigned", 9); + Enter__47((CHAR*)"void", 5); + Enter__47((CHAR*)"volatile", 9); + Enter__47((CHAR*)"while", 6); + InitKeywords__46_s = _s.lnk; +} + + +export void *OPC__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPT); + __REGMOD("OPC", 0); + __REGCMD("BegBlk", OPC_BegBlk); + __REGCMD("BegStat", OPC_BegStat); + __REGCMD("EndBlk", OPC_EndBlk); + __REGCMD("EndBlk0", OPC_EndBlk0); + __REGCMD("EndStat", OPC_EndStat); + __REGCMD("EnterBody", OPC_EnterBody); + __REGCMD("ExitBody", OPC_ExitBody); + __REGCMD("GenHdrIncludes", OPC_GenHdrIncludes); + __REGCMD("Init", OPC_Init); +/* BEGIN */ + OPC_InitKeywords(); + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPC.h b/bootstrap/windows-48/OPC.h new file mode 100644 index 00000000..3bfd88b8 --- /dev/null +++ b/bootstrap/windows-48/OPC.h @@ -0,0 +1,49 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPC__h +#define OPC__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPC_Andent (OPT_Struct typ); +import OPT_Object OPC_BaseTProc (OPT_Object obj); +import void OPC_BegBlk (void); +import void OPC_BegStat (void); +import void OPC_Case (INT64 caseVal, INT16 form); +import void OPC_Cmp (INT16 rel); +import void OPC_CompleteIdent (OPT_Object obj); +import void OPC_Constant (OPT_Const con, INT16 form); +import void OPC_DefineInter (OPT_Object proc); +import void OPC_EndBlk (void); +import void OPC_EndBlk0 (void); +import void OPC_EndStat (void); +import void OPC_EnterBody (void); +import void OPC_EnterProc (OPT_Object proc); +import void OPC_ExitBody (void); +import void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +import void OPC_GenBdy (OPT_Node n); +import void OPC_GenEnumPtrs (OPT_Object var); +import void OPC_GenHdr (OPT_Node n); +import void OPC_GenHdrIncludes (void); +import void OPC_Halt (INT32 n); +import void OPC_Ident (OPT_Object obj); +import void OPC_Increment (BOOLEAN decrement); +import void OPC_Indent (INT16 count); +import void OPC_Init (void); +import void OPC_InitTDesc (OPT_Struct typ); +import void OPC_IntLiteral (INT64 n, INT32 size); +import void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +import BOOLEAN OPC_NeedsRetval (OPT_Object proc); +import INT32 OPC_NofPtrs (OPT_Struct typ); +import void OPC_SetInclude (BOOLEAN exclude); +import void OPC_TDescDecl (OPT_Struct typ); +import void OPC_TypeDefs (OPT_Object obj, INT16 vis); +import void OPC_TypeOf (OPT_Object ap); +import void *OPC__init(void); + + +#endif // OPC diff --git a/bootstrap/windows-48/OPM.c b/bootstrap/windows-48/OPM.c new file mode 100644 index 00000000..bcb39247 --- /dev/null +++ b/bootstrap/windows-48/OPM.c @@ -0,0 +1,1183 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Files.h" +#include "Modules.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" +#include "Texts.h" +#include "VT100.h" + +typedef + CHAR OPM_FileName[32]; + + +static CHAR OPM_currentComment[256]; +static BOOLEAN OPM_hasComment; +static CHAR OPM_SourceFileName[256]; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static INT16 OPM_GlobalAddressSize; +export INT16 OPM_AddressSize; +static INT16 OPM_GlobalAlignment; +export INT16 OPM_Alignment; +export UINT32 OPM_GlobalOptions, OPM_Options; +export INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +export INT64 OPM_MaxIndex; +export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +export BOOLEAN OPM_noerr; +export INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +export INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +export CHAR OPM_modName[32]; +export CHAR OPM_objname[64]; +static INT32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; +static Texts_Reader OPM_inR; +static Texts_Text OPM_Log, OPM_Errors; +static Files_Rider OPM_oldSF, OPM_newSF; +static Files_Rider OPM_R[3]; +static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; +static INT16 OPM_S; +export CHAR OPM_InstallDir[1024]; +export CHAR OPM_ResourceDir[1024]; + + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F); +export void OPM_CloseFiles (void); +export void OPM_CloseOldSym (void); +export void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +export void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +export void OPM_FPrint (INT32 *fp, INT64 val); +export void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +export void OPM_FPrintReal (INT32 *fp, REAL val); +export void OPM_FPrintSet (INT32 *fp, UINT64 val); +static void OPM_FindInstallDir (void); +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos); +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len); +export void OPM_Get (CHAR *ch); +export void OPM_GetComment (CHAR *text, ADDRESS text__len); +export void OPM_Init (BOOLEAN *done); +export void OPM_InitOptions (void); +export INT16 OPM_Integer (INT64 n); +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len); +export void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +static void OPM_LogErrMsg (INT16 n); +export void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +export void OPM_LogW (CHAR ch); +export void OPM_LogWLn (void); +export void OPM_LogWNum (INT64 i, INT64 len); +export void OPM_LogWStr (CHAR *s, ADDRESS s__len); +export INT32 OPM_Longint (INT64 n); +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len); +export void OPM_Mark (INT16 n, INT32 pos); +export void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +export void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +export void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +export BOOLEAN OPM_OpenPar (void); +export void OPM_RegisterNewSym (void); +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len); +static void OPM_ShowLine (INT64 pos); +export INT64 OPM_SignedMaximum (INT32 bytecount); +export INT64 OPM_SignedMinimum (INT32 bytecount); +export void OPM_StoreComment (CHAR *text, ADDRESS text__len); +export void OPM_SymRCh (CHAR *ch); +export INT32 OPM_SymRInt (void); +export INT64 OPM_SymRInt64 (void); +export void OPM_SymRLReal (LONGREAL *lr); +export void OPM_SymRReal (REAL *r); +export void OPM_SymRSet (UINT64 *s); +export void OPM_SymWCh (CHAR ch); +export void OPM_SymWInt (INT64 i); +export void OPM_SymWLReal (LONGREAL lr); +export void OPM_SymWReal (REAL r); +export void OPM_SymWSet (UINT64 s); +export void OPM_Write (CHAR ch); +export void OPM_WriteHex (INT64 i); +export void OPM_WriteInt (INT64 i); +export void OPM_WriteLn (void); +export void OPM_WriteReal (LONGREAL r, CHAR suffx); +export void OPM_WriteString (CHAR *s, ADDRESS s__len); +export void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +export BOOLEAN OPM_eofSF (void); +export void OPM_err (INT16 n); + +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s + +void OPM_LogW (CHAR ch) +{ + Out_Char(ch); +} + +void OPM_LogWStr (CHAR *s, ADDRESS s__len) +{ + __DUP(s, s__len, CHAR); + Out_String(s, s__len); + __DEL(s); +} + +void OPM_LogWNum (INT64 i, INT64 len) +{ + Out_Int(i, len); +} + +void OPM_LogWLn (void) +{ + Out_Ln(); +} + +void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len) +{ + __DUP(vt100code, vt100code__len, CHAR); + if ((Out_IsConsole && !__IN(16, OPM_Options, 32))) { + VT100_SetAttr(vt100code, vt100code__len); + } + __DEL(vt100code); +} + +void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len) +{ + __DUP(modname, modname__len, CHAR); + OPM_LogWStr((CHAR*)"Compiling ", 11); + OPM_LogWStr(modname, modname__len); + if (__IN(18, OPM_Options, 32)) { + OPM_LogWStr((CHAR*)", s:", 5); + OPM_LogWNum(__ASHL(OPM_ShortintSize, 3), 1); + OPM_LogWStr((CHAR*)" i:", 4); + OPM_LogWNum(__ASHL(OPM_IntegerSize, 3), 1); + OPM_LogWStr((CHAR*)" l:", 4); + OPM_LogWNum(__ASHL(OPM_LongintSize, 3), 1); + OPM_LogWStr((CHAR*)" adr:", 6); + OPM_LogWNum(__ASHL(OPM_AddressSize, 3), 1); + OPM_LogWStr((CHAR*)" algn:", 7); + OPM_LogWNum(__ASHL(OPM_Alignment, 3), 1); + } + OPM_LogW('.'); + __DEL(modname); +} + +void OPM_StoreComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_currentComment[__X(i, 256)] = text[__X(i, text__len)]; + i += 1; + } + OPM_currentComment[__X(i, 256)] = 0x00; + OPM_hasComment = 1; + __DEL(text); +} + +void OPM_GetComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + if (OPM_hasComment) { + i = 0; + while ((((i < text__len && i < 256)) && OPM_currentComment[__X(i, 256)] != 0x00)) { + text[__X(i, text__len)] = OPM_currentComment[__X(i, 256)]; + i += 1; + } + text[__X(i, text__len)] = 0x00; + OPM_hasComment = 0; + } else { + text[0] = 0x00; + } +} + +INT64 OPM_SignedMaximum (INT32 bytecount) +{ + INT64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + return result - 1; +} + +INT64 OPM_SignedMinimum (INT32 bytecount) +{ + return -OPM_SignedMaximum(bytecount) - 1; +} + +INT32 OPM_Longint (INT64 n) +{ + return __VAL(INT32, n); +} + +INT16 OPM_Integer (INT64 n) +{ + return __VAL(INT16, n); +} + +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 1; + while (s[__X(i, s__len)] != 0x00) { + switch (s[__X(i, s__len)]) { + case 'p': + OPM_Options = OPM_Options ^ 0x20; + break; + case 'a': + OPM_Options = OPM_Options ^ 0x80; + break; + case 'r': + OPM_Options = OPM_Options ^ 0x04; + break; + case 't': + OPM_Options = OPM_Options ^ 0x08; + break; + case 'x': + OPM_Options = OPM_Options ^ 0x01; + break; + case 'e': + OPM_Options = OPM_Options ^ 0x0200; + break; + case 's': + OPM_Options = OPM_Options ^ 0x10; + break; + case 'F': + OPM_Options = OPM_Options ^ 0x020000; + break; + case 'm': + OPM_Options = OPM_Options ^ 0x0400; + break; + case 'M': + OPM_Options = OPM_Options ^ 0x8000; + break; + case 'S': + OPM_Options = OPM_Options ^ 0x2000; + break; + case 'c': + OPM_Options = OPM_Options ^ 0x4000; + break; + case 'f': + OPM_Options = OPM_Options ^ 0x010000; + break; + case 'V': + OPM_Options = OPM_Options ^ 0x040000; + break; + case 'O': + if (i + 1 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); + OPM_LogWLn(); + } else { + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); + } + i += 1; + } + break; + case 'A': + if (i + 2 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-M option requires two following digits.", 41); + OPM_LogWLn(); + } else { + OPM_AddressSize = (INT16)s[__X(i + 1, s__len)] - 48; + OPM_Alignment = (INT16)s[__X(i + 2, s__len)] - 48; + i += 2; + } + break; + default: + OPM_LogWStr((CHAR*)" warning: option ", 19); + OPM_LogW('-'); + OPM_LogW(s[__X(i, s__len)]); + OPM_LogWStr((CHAR*)" ignored", 9); + OPM_LogWLn(); + break; + } + i += 1; + } + __DEL(s); +} + +BOOLEAN OPM_OpenPar (void) +{ + CHAR s[256]; + if (Modules_ArgCount == 1) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Oberon-2 compiler v", 20); + OPM_LogWStr(Configuration_versionLong, 76); + OPM_LogW('.'); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Based on Ofront by J. Templ and Software Templ OEG.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Further development by Norayr Chilingarian, David Brown and others.", 68); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Loaded from ", 13); + OPM_LogWStr(Modules_BinaryDir, 1024); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Usage:", 7); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWStr((CHAR*)"voc", 4); + OPM_LogWStr((CHAR*)" options {files {options}}.", 28); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options:", 9); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Run time safety", 18); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -p Initialise pointers to NIL. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -a Halt on assertion failures. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -r Halt on range check failures.", 39); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -t Halt on type guard failure. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -x Halt on index out of range. On by default.", 52); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Symbol file management", 25); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -e Allow extension of old symbol file.", 45); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -s Allow generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -F Force generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" C compiler and linker control", 32); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -m This module is main. Link dynamically.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -M This module is main. Link statically.", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -S Don't call C compiler", 31); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -c Don't link.", 21); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Miscellaneous", 16); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -f Disable VT100 control characters in status output.", 60); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -V Display compiler debugging messages.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Size model for elementary types (default O2)", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Target machine address size and alignment (default is that of the running compiler binary)", 93); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86).", 79); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm).", 97); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms).", 71); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"All options are off by default, except where noted above.", 58); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Initial options specify defaults for all files.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options following a filename are specific to that file.", 56); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Repeating an option toggles its value.", 39); + OPM_LogWLn(); + return 0; + } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; + OPM_S = 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __MOVE(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; + return 1; + } + __RETCHK; +} + +void OPM_InitOptions (void) +{ + CHAR s[256]; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __MOVE(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); + } + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 4; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + __MOVE(OPM_InstallDir, OPM_ResourceDir, 1024); + if (OPM_ResourceDir[0] != 0x00) { + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + } + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); +} + +void OPM_Init (BOOLEAN *done) +{ + Texts_Text T = NIL; + INT32 beg, end, time; + CHAR s[256]; + *done = 0; + OPM_curpos = 0; + if (OPM_S >= Modules_ArgCount) { + return; + } + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + __NEW(T, Texts_TextDesc); + Texts_Open(T, s, 256); + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" ", 3); + __COPY(s, OPM_SourceFileName, 256); + if (T->len == 0) { + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" not found.", 12); + OPM_LogWLn(); + } else { + Texts_OpenReader(&OPM_inR, Texts_Reader__typ, T, 0); + *done = 1; + } + OPM_S += 1; + OPM_level = 0; + OPM_noerr = 1; + OPM_errpos = OPM_curpos; + OPM_lasterrpos = OPM_curpos - 10; + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; +} + +void OPM_Get (CHAR *ch) +{ + OPM_curpos = Texts_Pos(&OPM_inR, Texts_Reader__typ); + Texts_Read(&OPM_inR, Texts_Reader__typ, &*ch); + if ((*ch < 0x09 && !OPM_inR.eot)) { + *ch = ' '; + } +} + +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len) +{ + INT16 i, j; + CHAR ch; + __DUP(ext, ext__len, CHAR); + i = 0; + for (;;) { + ch = name[__X(i, name__len)]; + if (ch == 0x00) { + break; + } + FName[__X(i, FName__len)] = ch; + i += 1; + } + j = 0; + do { + ch = ext[__X(j, ext__len)]; + FName[__X(i, FName__len)] = ch; + i += 1; + j += 1; + } while (!(ch == 0x00)); + __DEL(ext); +} + +static void OPM_LogErrMsg (INT16 n) +{ + INT16 l; + Texts_Scanner S; + CHAR c; + if (n >= 0) { + OPM_LogVT100((CHAR*)"31m", 4); + OPM_LogWStr((CHAR*)" err ", 7); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + OPM_LogVT100((CHAR*)"35m", 4); + OPM_LogWStr((CHAR*)" warning ", 11); + n = -n; + OPM_LogVT100((CHAR*)"0m", 3); + } + OPM_LogWNum(n, 1); + OPM_LogWStr((CHAR*)" ", 3); + if (OPM_Errors == NIL) { + __NEW(OPM_Errors, Texts_TextDesc); + Texts_Open(OPM_Errors, (CHAR*)"Errors.Txt", 11); + } + Texts_OpenScanner(&S, Texts_Scanner__typ, OPM_Errors, 0); + do { + l = S.line; + Texts_Scan(&S, Texts_Scanner__typ); + } while (!((((l != S.line && S.class == 3)) && S.i == n) || S.eot)); + if (!S.eot) { + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + while ((!S.eot && c >= ' ')) { + Out_Char(c); + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + } + } +} + +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos) +{ + CHAR ch, cheol; + if (pos < (INT64)OPM_ErrorLineStartPos) { + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; + } + if (pos < (INT64)OPM_ErrorLineLimitPos) { + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); + return; + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineLimitPos); + Files_Read(&*r, r__typ, (void*)&ch); + while (((INT64)OPM_ErrorLineLimitPos < pos && !(*r).eof)) { + OPM_ErrorLineStartPos = OPM_ErrorLineLimitPos; + OPM_ErrorLineNumber += 1; + while ((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) { + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + } + cheol = ch; + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + if ((cheol == 0x0d && ch == 0x0a)) { + OPM_ErrorLineLimitPos += 1; + Files_Read(&*r, r__typ, (void*)&ch); + } + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); +} + +static void OPM_ShowLine (INT64 pos) +{ + Files_File f = NIL; + Files_Rider r; + CHAR line[1023]; + INT16 i; + CHAR ch; + f = Files_Old(OPM_SourceFileName, 256); + OPM_FindLine(f, &r, Files_Rider__typ, pos); + i = 0; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + while ((((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) && i < 1022)) { + line[__X(i, 1023)] = ch; + i += 1; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + } + line[__X(i, 1023)] = 0x00; + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWNum(OPM_ErrorLineNumber, 4); + OPM_LogWStr((CHAR*)": ", 3); + OPM_LogWStr(line, 1023); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 7); + if (pos >= (INT64)OPM_ErrorLineLimitPos) { + pos = OPM_ErrorLineLimitPos - 1; + } + i = __SHORTF(OPM_Longint(pos - (INT64)OPM_ErrorLineStartPos), 32768); + while (i > 0) { + OPM_LogW(' '); + i -= 1; + } + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogW('^'); + OPM_LogVT100((CHAR*)"0m", 3); +} + +void OPM_Mark (INT16 n, INT32 pos) +{ + if (pos == -1) { + pos = 0; + } + if (n >= 0) { + OPM_noerr = 0; + if (pos < OPM_lasterrpos || OPM_lasterrpos + 9 < pos) { + OPM_lasterrpos = pos; + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + if (n < 249) { + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + OPM_LogErrMsg(n); + } else if (n == 255) { + OPM_LogWStr((CHAR*)"pos", 4); + OPM_LogWNum(pos, 6); + OPM_LogWStr((CHAR*)" pc ", 6); + OPM_LogWNum(OPM_breakpc, 1); + } else if (n == 254) { + OPM_LogWStr((CHAR*)"pc not found", 13); + } else { + OPM_LogWStr(OPM_objname, 64); + if (n == 253) { + OPM_LogWStr((CHAR*)" is new, compile with option e", 31); + } else if (n == 252) { + OPM_LogWStr((CHAR*)" is redefined, compile with option s", 37); + } else if (n == 251) { + OPM_LogWStr((CHAR*)" is redefined (private part only), compile with option s", 57); + } else if (n == 250) { + OPM_LogWStr((CHAR*)" is no longer visible, compile with option s", 45); + } else if (n == 249) { + OPM_LogWStr((CHAR*)" is not consistently imported, recompile imports", 49); + } + } + } + } else { + if (pos >= 0) { + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + } + OPM_LogErrMsg(n); + if (pos < 0) { + OPM_LogWLn(); + } + } +} + +void OPM_err (INT16 n) +{ + OPM_Mark(n, OPM_errpos); +} + +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len) +{ + INT16 i; + INT32 l; + __ASSERT(__MASK(bytes__len, -4) == 0, 0); + i = 0; + while (i < bytes__len) { + __GET((ADDRESS)&bytes[__X(i, bytes__len)], l, INT32); + *fp = __ROTL((INT32)((UINT32)*fp ^ (UINT32)l), 1, 32); + i += 4; + } +} + +void OPM_FPrint (INT32 *fp, INT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintSet (INT32 *fp, UINT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintReal (INT32 *fp, REAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 4); +} + +void OPM_FPrintLReal (INT32 *fp, LONGREAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_SymRCh (CHAR *ch) +{ + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); +} + +INT32 OPM_SymRInt (void) +{ + INT32 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 4); + return k; +} + +INT64 OPM_SymRInt64 (void) +{ + INT64 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 8); + return k; +} + +void OPM_SymRSet (UINT64 *s) +{ + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&*s, 8); +} + +void OPM_SymRReal (REAL *r) +{ + Files_ReadReal(&OPM_oldSF, Files_Rider__typ, &*r); +} + +void OPM_SymRLReal (LONGREAL *lr) +{ + Files_ReadLReal(&OPM_oldSF, Files_Rider__typ, &*lr); +} + +void OPM_CloseOldSym (void) +{ + Files_Close(Files_Base(&OPM_oldSF, Files_Rider__typ)); +} + +void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done) +{ + CHAR tag, ver; + OPM_FileName fileName; + INT16 res; + OPM_oldSFile = NIL; + *done = 0; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_oldSFile = Files_Old(fileName, 32); + *done = OPM_oldSFile != NIL; + if (*done) { + Files_Set(&OPM_oldSF, Files_Rider__typ, OPM_oldSFile, 0); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&tag); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&ver); + if (tag != 0xf7 || ver != 0x84) { + if (!__IN(4, OPM_Options, 32)) { + OPM_err(-306); + } + OPM_CloseOldSym(); + *done = 0; + } + } +} + +BOOLEAN OPM_eofSF (void) +{ + return OPM_oldSF.eof; +} + +void OPM_SymWCh (CHAR ch) +{ + Files_Write(&OPM_newSF, Files_Rider__typ, ch); +} + +void OPM_SymWInt (INT64 i) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, i); +} + +void OPM_SymWSet (UINT64 s) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, (INT64)s); +} + +void OPM_SymWReal (REAL r) +{ + Files_WriteReal(&OPM_newSF, Files_Rider__typ, r); +} + +void OPM_SymWLReal (LONGREAL lr) +{ + Files_WriteLReal(&OPM_newSF, Files_Rider__typ, lr); +} + +void OPM_RegisterNewSym (void) +{ + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { + Files_Register(OPM_newSFile); + } +} + +void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".sym", 5); + Files_Delete(fn, 32, &res); +} + +void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".o", 3); + Files_Delete(fn, 32, &res); +} + +void OPM_NewSym (CHAR *modName, ADDRESS modName__len) +{ + OPM_FileName fileName; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_newSFile = Files_New(fileName, 32); + if (OPM_newSFile != NIL) { + Files_Set(&OPM_newSF, Files_Rider__typ, OPM_newSFile, 0); + Files_Write(&OPM_newSF, Files_Rider__typ, 0xf7); + Files_Write(&OPM_newSF, Files_Rider__typ, 0x84); + } else { + OPM_err(153); + } +} + +void OPM_Write (CHAR ch) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, ch); +} + +void OPM_WriteString (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteStringVar (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteHex (INT64 i) +{ + CHAR s[3]; + INT32 digit; + digit = __ASHR(__SHORT(i, 2147483648LL), 4); + if (digit < 10) { + s[0] = __CHR(48 + digit); + } else { + s[0] = __CHR(87 + digit); + } + digit = __MASK(__SHORT(i, 2147483648LL), -16); + if (digit < 10) { + s[1] = __CHR(48 + digit); + } else { + s[1] = __CHR(87 + digit); + } + s[2] = 0x00; + OPM_WriteString(s, 3); +} + +void OPM_WriteInt (INT64 i) +{ + CHAR s[26]; + INT64 i1, k; + if ((i == OPM_SignedMinimum(2) || i == OPM_SignedMinimum(4)) || i == OPM_SignedMinimum(8)) { + OPM_Write('('); + OPM_WriteInt(i + 1); + OPM_WriteString((CHAR*)"-1)", 4); + } else { + i1 = __ABS(i); + if (i1 <= 2147483647) { + k = 0; + } else { + __MOVE("LL", s, 3); + k = 2; + } + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + while (i1 > 0) { + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + } + if (i < 0) { + s[__X(k, 26)] = '-'; + k += 1; + } + while (k > 0) { + k -= 1; + OPM_Write(s[__X(k, 26)]); + } + } +} + +void OPM_WriteReal (LONGREAL r, CHAR suffx) +{ + Texts_Writer W; + Texts_Text T = NIL; + Texts_Reader R; + CHAR s[32]; + CHAR ch; + INT16 i; + if ((((r < OPM_SignedMaximum(OPM_LongintSize) && r > OPM_SignedMinimum(OPM_LongintSize))) && r == (__SHORT(__ENTIER(r), 2147483648LL)))) { + if (suffx == 'f') { + OPM_WriteString((CHAR*)"(REAL)", 7); + } else { + OPM_WriteString((CHAR*)"(LONGREAL)", 11); + } + OPM_WriteInt(__SHORT(__ENTIER(r), 2147483648LL)); + } else { + Texts_OpenWriter(&W, Texts_Writer__typ); + if (suffx == 'f') { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 16); + } else { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 23); + } + __NEW(T, Texts_TextDesc); + Texts_Open(T, (CHAR*)"", 1); + Texts_Append(T, W.buf); + Texts_OpenReader(&R, Texts_Reader__typ, T, 0); + i = 0; + Texts_Read(&R, Texts_Reader__typ, &ch); + while (ch != 0x00) { + s[__X(i, 32)] = ch; + i += 1; + Texts_Read(&R, Texts_Reader__typ, &ch); + } + s[__X(i, 32)] = 0x00; + i = 0; + ch = s[0]; + while ((ch != 'D' && ch != 0x00)) { + i += 1; + ch = s[__X(i, 32)]; + } + if (ch == 'D') { + s[__X(i, 32)] = 'e'; + } + OPM_WriteString(s, 32); + } +} + +void OPM_WriteLn (void) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, 0x0a); +} + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F) +{ + Files_Rider R1; + CHAR buffer[4096]; + if (F != NIL) { + Files_Set(&R1, Files_Rider__typ, F, 0); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + while (4096 - R1.res > 0) { + Files_WriteBytes(&*R, R__typ, (void*)buffer, 4096, 4096 - R1.res); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + } + } +} + +void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len) +{ + OPM_FileName FName; + __COPY(moduleName, OPM_modName, 32); + OPM_HFile = Files_New((CHAR*)"", 1); + if (OPM_HFile != NIL) { + Files_Set(&OPM_R[0], Files_Rider__typ, OPM_HFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".c", 3); + OPM_BFile = Files_New(FName, 32); + if (OPM_BFile != NIL) { + Files_Set(&OPM_R[1], Files_Rider__typ, OPM_BFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".h", 3); + OPM_HIFile = Files_New(FName, 32); + if (OPM_HIFile != NIL) { + Files_Set(&OPM_R[2], Files_Rider__typ, OPM_HIFile, 0); + } else { + OPM_err(153); + } +} + +void OPM_CloseFiles (void) +{ + OPM_FileName FName; + INT16 res; + if (OPM_noerr) { + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWNum(Files_Pos(&OPM_R[1], Files_Rider__typ), 0); + OPM_LogWStr((CHAR*)" chars.", 8); + } + if (OPM_noerr) { + if (__STRCMP(OPM_modName, "SYSTEM") == 0) { + if (!__IN(10, OPM_Options, 32)) { + Files_Register(OPM_BFile); + } + } else if (!__IN(10, OPM_Options, 32)) { + OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); + Files_Register(OPM_HIFile); + Files_Register(OPM_BFile); + } else { + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".h", 3); + Files_Delete(FName, 32, &res); + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".sym", 5); + Files_Delete(FName, 32, &res); + Files_Register(OPM_BFile); + } + } + OPM_HFile = NIL; + OPM_BFile = NIL; + OPM_HIFile = NIL; + OPM_newSFile = NIL; + OPM_oldSFile = NIL; + Files_Set(&OPM_R[0], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[1], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[2], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_newSF, Files_Rider__typ, NIL, 0); + Files_Set(&OPM_oldSF, Files_Rider__typ, NIL, 0); +} + +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len) +{ + CHAR testpath[4096]; + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/lib/lib", 9, (void*)testpath, 4096); + Strings_Append((CHAR*)"voc", 4, (void*)testpath, 4096); + Strings_Append((CHAR*)"-O2.a", 6, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/include/Oberon.h", 20, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/sym/Files.sym", 17, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __DEL(s); + return 1; +} + +static void OPM_FindInstallDir (void) +{ + INT16 i; + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + Strings_Append((CHAR*)"/", 2, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)"voc", 4, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)".d", 3, (void*)OPM_InstallDir, 1024); + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + i = Strings_Length(OPM_InstallDir, 1024); + while ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] != '/')) { + i -= 1; + } + if ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] == '/')) { + OPM_InstallDir[__X(i - 1, 1024)] = 0x00; + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + } + __COPY("", OPM_InstallDir, 1024); +} + +static void EnumPtrs(void (*P)(void*)) +{ + __ENUMR(&OPM_inR, Texts_Reader__typ, 48, 1, P); + P(OPM_Log); + P(OPM_Errors); + __ENUMR(&OPM_oldSF, Files_Rider__typ, 20, 1, P); + __ENUMR(&OPM_newSF, Files_Rider__typ, 20, 1, P); + __ENUMR(OPM_R, Files_Rider__typ, 20, 3, P); + P(OPM_oldSFile); + P(OPM_newSFile); + P(OPM_HFile); + P(OPM_BFile); + P(OPM_HIFile); +} + + +export void *OPM__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(Texts); + __MODULE_IMPORT(VT100); + __REGMOD("OPM", EnumPtrs); + __REGCMD("CloseFiles", OPM_CloseFiles); + __REGCMD("CloseOldSym", OPM_CloseOldSym); + __REGCMD("InitOptions", OPM_InitOptions); + __REGCMD("LogWLn", OPM_LogWLn); + __REGCMD("RegisterNewSym", OPM_RegisterNewSym); + __REGCMD("WriteLn", OPM_WriteLn); +/* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; + OPM_FindInstallDir(); + OPM_hasComment = 0; + OPM_currentComment[0] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPM.h b/bootstrap/windows-48/OPM.h new file mode 100644 index 00000000..64c15a28 --- /dev/null +++ b/bootstrap/windows-48/OPM.h @@ -0,0 +1,76 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPM__h +#define OPM__h + +#include "SYSTEM.h" + + +import CHAR OPM_Model[10]; +import INT16 OPM_AddressSize, OPM_Alignment; +import UINT32 OPM_GlobalOptions, OPM_Options; +import INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +import INT64 OPM_MaxIndex; +import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +import BOOLEAN OPM_noerr; +import INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +import INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +import CHAR OPM_modName[32]; +import CHAR OPM_objname[64]; +import CHAR OPM_InstallDir[1024]; +import CHAR OPM_ResourceDir[1024]; + + +import void OPM_CloseFiles (void); +import void OPM_CloseOldSym (void); +import void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +import void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +import void OPM_FPrint (INT32 *fp, INT64 val); +import void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +import void OPM_FPrintReal (INT32 *fp, REAL val); +import void OPM_FPrintSet (INT32 *fp, UINT64 val); +import void OPM_Get (CHAR *ch); +import void OPM_GetComment (CHAR *text, ADDRESS text__len); +import void OPM_Init (BOOLEAN *done); +import void OPM_InitOptions (void); +import INT16 OPM_Integer (INT64 n); +import void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +import void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +import void OPM_LogW (CHAR ch); +import void OPM_LogWLn (void); +import void OPM_LogWNum (INT64 i, INT64 len); +import void OPM_LogWStr (CHAR *s, ADDRESS s__len); +import INT32 OPM_Longint (INT64 n); +import void OPM_Mark (INT16 n, INT32 pos); +import void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +import void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +import void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +import BOOLEAN OPM_OpenPar (void); +import void OPM_RegisterNewSym (void); +import INT64 OPM_SignedMaximum (INT32 bytecount); +import INT64 OPM_SignedMinimum (INT32 bytecount); +import void OPM_StoreComment (CHAR *text, ADDRESS text__len); +import void OPM_SymRCh (CHAR *ch); +import INT32 OPM_SymRInt (void); +import INT64 OPM_SymRInt64 (void); +import void OPM_SymRLReal (LONGREAL *lr); +import void OPM_SymRReal (REAL *r); +import void OPM_SymRSet (UINT64 *s); +import void OPM_SymWCh (CHAR ch); +import void OPM_SymWInt (INT64 i); +import void OPM_SymWLReal (LONGREAL lr); +import void OPM_SymWReal (REAL r); +import void OPM_SymWSet (UINT64 s); +import void OPM_Write (CHAR ch); +import void OPM_WriteHex (INT64 i); +import void OPM_WriteInt (INT64 i); +import void OPM_WriteLn (void); +import void OPM_WriteReal (LONGREAL r, CHAR suffx); +import void OPM_WriteString (CHAR *s, ADDRESS s__len); +import void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +import BOOLEAN OPM_eofSF (void); +import void OPM_err (INT16 n); +import void *OPM__init(void); + + +#endif // OPM diff --git a/bootstrap/windows-48/OPP.c b/bootstrap/windows-48/OPP.c new file mode 100644 index 00000000..ad4a370a --- /dev/null +++ b/bootstrap/windows-48/OPP.c @@ -0,0 +1,1881 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPB.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +struct OPP__1 { + INT32 low, high; +}; + +typedef + struct OPP__1 OPP_CaseTable[128]; + + +static INT8 OPP_sym, OPP_level; +static INT16 OPP_LoopLevel; +static OPT_Node OPP_TDinit, OPP_lastTDinit; +static INT16 OPP_nofFwdPtr; +static OPT_Struct OPP_FwdPtr[64]; + +export ADDRESS *OPP__1__typ; + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar); +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq); +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab); +static void OPP_CheckMark (INT8 *vis); +static void OPP_CheckSym (INT16 s); +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_); +static void OPP_ConstExpression (OPT_Node *x); +static void OPP_Element (OPT_Node *x); +static void OPP_Expression (OPT_Node *x); +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b); +static void OPP_Factor (OPT_Node *x); +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp); +export void OPP_Module (OPT_Node *prog, UINT32 opt); +static void OPP_PointerType (OPT_Struct *typ); +static void OPP_ProcedureDeclaration (OPT_Node *x); +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec); +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Sets (OPT_Node *x); +static void OPP_SimpleExpression (OPT_Node *x); +static void OPP_StandProcCall (OPT_Node *x); +static void OPP_StatSeq (OPT_Node *stat); +static void OPP_Term (OPT_Node *x); +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_err (INT16 n); +static void OPP_qualident (OPT_Object *id); +static void OPP_selector (OPT_Node *x); + + +static void OPP_err (INT16 n) +{ + OPM_err(n); +} + +static void OPP_CheckSym (INT16 s) +{ + if ((INT16)OPP_sym == s) { + OPS_Get(&OPP_sym); + } else { + OPM_err(s); + } +} + +static void OPP_qualident (OPT_Object *id) +{ + OPT_Object obj = NIL; + INT8 lev; + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if ((((OPP_sym == 18 && obj != NIL)) && obj->mode == 11)) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPT_FindImport(obj, &obj); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + obj = NIL; + } + } + if (obj == NIL) { + OPP_err(0); + obj = OPT_NewObj(); + obj->mode = 1; + obj->typ = OPT_undftyp; + obj->adr = 0; + } else { + lev = obj->mnolev; + if ((__IN(obj->mode, 0x06, 32) && lev != OPP_level)) { + obj->leaf = 0; + if (lev > 0) { + OPB_StaticLink(OPP_level - lev); + } + } + } + *id = obj; +} + +static void OPP_ConstExpression (OPT_Node *x) +{ + OPP_Expression(&*x); + if ((*x)->class != 7) { + OPP_err(50); + *x = OPB_NewIntConst(1); + } +} + +static void OPP_CheckMark (INT8 *vis) +{ + OPS_Get(&OPP_sym); + if (OPP_sym == 1 || OPP_sym == 7) { + if (OPP_level > 0) { + OPP_err(47); + } + if (OPP_sym == 1) { + *vis = 1; + } else { + *vis = 2; + } + OPS_Get(&OPP_sym); + } else { + *vis = 0; + } +} + +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_) +{ + OPT_Node x = NIL; + INT64 sf; + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + if (!OPT_SYSimported) { + OPP_err(135); + } + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + sf = x->conval->intval; + if (sf < 0 || sf > 1) { + OPP_err(220); + sf = 0; + } + } else { + OPP_err(51); + sf = 0; + } + *sysflag = OPM_Integer(sf); + OPP_CheckSym(23); + } else { + *sysflag = default_; + } +} + +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object fld = NIL, first = NIL, last = NIL, base = NIL; + OPT_Struct ftyp = NIL; + INT16 sysflag; + *typ = OPT_NewStr(13, 4); + (*typ)->BaseTyp = NIL; + OPP_CheckSysFlag(&sysflag, -1); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&base); + if ((base->mode == 5 && base->typ->comp == 4)) { + if (base->typ == *banned) { + OPP_err(58); + } else { + base->typ->pvused = 1; + (*typ)->BaseTyp = base->typ; + (*typ)->extlev = base->typ->extlev + 1; + (*typ)->sysflag = base->typ->sysflag; + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } + if (sysflag >= 0) { + (*typ)->sysflag = sysflag; + } + OPT_OpenScope(0, NIL); + first = NIL; + last = NIL; + for (;;) { + if (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + if ((*typ)->BaseTyp != NIL) { + OPT_FindField(OPS_name, (*typ)->BaseTyp, &fld); + if (fld != NIL) { + OPP_err(1); + } + } + OPT_Insert(OPS_name, &fld); + OPP_CheckMark(&fld->vis); + fld->mode = 4; + fld->link = NIL; + fld->typ = OPT_undftyp; + if (first == NIL) { + first = fld; + } + if (last == NIL) { + (*typ)->link = fld; + } else { + last->link = fld; + } + last = fld; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&ftyp, &*banned); + ftyp->pvused = 1; + if (ftyp->comp == 3) { + ftyp = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = ftyp; + first = first->link; + } + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + OPT_CloseScope(); +} + +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Node x = NIL; + INT64 n; + INT16 sysflag; + OPP_CheckSysFlag(&sysflag, 0); + if (OPP_sym == 25) { + *typ = OPT_NewStr(13, 3); + (*typ)->mno = 0; + (*typ)->sysflag = sysflag; + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + } else { + *typ = OPT_NewStr(13, 2); + (*typ)->sysflag = sysflag; + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + n = x->conval->intval; + if (n <= 0 || n > OPM_MaxIndex) { + OPP_err(63); + n = 1; + } + } else { + OPP_err(51); + n = 1; + } + (*typ)->n = OPM_Longint(n); + if (OPP_sym == 25) { + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + } else if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + if (OPP_sym != 25) { + OPP_ArrayType(&(*typ)->BaseTyp, &*banned); + } + } else { + OPP_err(35); + } + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(88); + } + } +} + +static void OPP_PointerType (OPT_Struct *typ) +{ + OPT_Object id = NIL; + *typ = OPT_NewStr(11, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + OPP_CheckSym(28); + if (OPP_sym == 38) { + OPT_Find(&id); + if (id == NIL) { + if (OPP_nofFwdPtr < 64) { + OPP_FwdPtr[__X(OPP_nofFwdPtr, 64)] = *typ; + OPP_nofFwdPtr += 1; + } else { + OPP_err(224); + } + (*typ)->link = OPT_NewObj(); + __COPY(OPS_name, (*typ)->link->name, 256); + (*typ)->BaseTyp = OPT_undftyp; + OPS_Get(&OPP_sym); + } else { + OPP_qualident(&id); + if (id->mode == 5) { + if (__IN(id->typ->comp, 0x1c, 32)) { + (*typ)->BaseTyp = id->typ; + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(52); + } + } + } else { + OPP_Type(&(*typ)->BaseTyp, &OPT_notyp); + if (!__IN((*typ)->BaseTyp->comp, 0x1c, 32)) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } +} + +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp) +{ + INT8 mode; + OPT_Object par = NIL, first = NIL, last = NIL, res = NIL; + OPT_Struct typ = NIL; + first = NIL; + last = *firstPar; + if (OPP_sym == 38 || OPP_sym == 60) { + for (;;) { + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + mode = 2; + } else { + mode = 1; + } + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &par); + OPS_Get(&OPP_sym); + par->mode = mode; + par->link = NIL; + if (first == NIL) { + first = par; + } + if (*firstPar == NIL) { + *firstPar = par; + } else { + last->link = par; + } + last = par; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else if (OPP_sym == 60) { + OPP_err(19); + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + if (((typ->comp == 2 || typ->comp == 4) && typ->strobj == NIL)) { + OPP_err(-309); + } + if (mode == 1) { + typ->pvused = 1; + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + } + OPP_CheckSym(22); + if (OPP_sym == 20) { + OPS_Get(&OPP_sym); + *resTyp = OPT_undftyp; + if (OPP_sym == 38) { + OPP_qualident(&res); + if (res->mode == 5) { + if (res->typ->form < 13) { + *resTyp = res->typ; + } else { + OPP_err(54); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + *resTyp = OPT_notyp; + } +} + +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object id = NIL; + *typ = OPT_undftyp; + if (OPP_sym < 30) { + OPP_err(12); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + if (id->mode == 5) { + if (id->typ == *banned) { + OPP_err(58); + } else { + *typ = id->typ; + } + } else { + OPP_err(52); + } + } else if (OPP_sym == 54) { + OPS_Get(&OPP_sym); + OPP_ArrayType(&*typ, &*banned); + } else if (OPP_sym == 55) { + OPS_Get(&OPP_sym); + OPP_RecordType(&*typ, &*banned); + OPB_Inittd(&OPP_TDinit, &OPP_lastTDinit, *typ); + OPP_CheckSym(41); + } else if (OPP_sym == 56) { + OPS_Get(&OPP_sym); + OPP_PointerType(&*typ); + } else if (OPP_sym == 61) { + OPS_Get(&OPP_sym); + *typ = OPT_NewStr(12, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPT_OpenScope(OPP_level, NIL); + OPP_FormalParameters(&(*typ)->link, &(*typ)->BaseTyp); + OPT_CloseScope(); + } else { + (*typ)->BaseTyp = OPT_notyp; + (*typ)->link = NIL; + } + } else { + OPP_err(12); + } + for (;;) { + if (((OPP_sym >= 39 && OPP_sym <= 42) || OPP_sym == 22) || OPP_sym == 64) { + break; + } + OPP_err(15); + if (OPP_sym == 38) { + break; + } + OPS_Get(&OPP_sym); + } +} + +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned) +{ + OPP_TypeDecl(&*typ, &*banned); + if (((((*typ)->form == 11 && (*typ)->BaseTyp == OPT_undftyp)) && (*typ)->strobj == NIL)) { + OPP_err(0); + } +} + +static void OPP_selector (OPT_Node *x) +{ + OPT_Object obj = NIL, proc = NIL; + OPT_Node y = NIL; + OPT_Struct typ = NIL; + OPS_Name name; + for (;;) { + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + for (;;) { + if (((*x)->typ != NIL && (*x)->typ->form == 11)) { + OPB_DeRef(&*x); + } + OPP_Expression(&y); + OPB_Index(&*x, y); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(23); + } else if (OPP_sym == 18) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __MOVE(OPS_name, name, 256); + OPS_Get(&OPP_sym); + if ((*x)->typ != NIL) { + if ((*x)->typ->form == 11) { + OPB_DeRef(&*x); + } + if ((*x)->typ->comp == 4) { + OPT_FindField(name, (*x)->typ, &obj); + OPB_Field(&*x, obj); + if ((obj != NIL && obj->mode == 13)) { + if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + y = (*x)->left; + if (y->class == 3) { + y = y->left; + } + if (y->obj != NIL) { + proc = OPT_topScope; + while ((proc->link != NIL && proc->link->mode != 13)) { + proc = proc->left; + } + if (proc->link == NIL || proc->link->link != y->obj) { + OPP_err(75); + } + typ = y->obj->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField((*x)->obj->name, typ->BaseTyp, &proc); + if (proc != NIL) { + (*x)->subcl = 1; + } else { + OPP_err(74); + } + } else { + OPP_err(75); + } + } + if ((obj->typ != OPT_notyp && OPP_sym != 30)) { + OPP_err(30); + } + } + } else { + OPP_err(53); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + OPB_DeRef(&*x); + } else if ((((((OPP_sym == 30 && (*x)->class < 7)) && (*x)->typ->form != 12)) && ((*x)->obj == NIL || (*x)->obj->mode != 13))) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 1); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } else { + break; + } + } +} + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar) +{ + OPT_Node apar = NIL, last = NIL; + *aparlist = NIL; + last = NIL; + if (OPP_sym != 22) { + for (;;) { + OPP_Expression(&apar); + if (fpar != NIL) { + OPB_Param(apar, fpar); + OPB_Link(&*aparlist, &last, apar); + fpar = fpar->link; + } else { + OPP_err(64); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + } + if (fpar != NIL) { + OPP_err(65); + } +} + +static void OPP_StandProcCall (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 m; + INT16 n; + m = __SHORT(__SHORT((*x)->obj->adr, 32768), 128); + n = 0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym != 22) { + for (;;) { + if (n == 0) { + OPP_Expression(&*x); + OPB_StPar0(&*x, m); + n = 1; + } else if (n == 1) { + OPP_Expression(&y); + OPB_StPar1(&*x, y, m); + n = 2; + } else { + OPP_Expression(&y); + OPB_StParN(&*x, y, m, n); + n += 1; + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(22); + } else { + OPS_Get(&OPP_sym); + } + OPB_StFct(&*x, m, n); + } else { + OPP_err(30); + } + if ((OPP_level > 0 && (m == 1 || m == 30))) { + OPT_topScope->link->leaf = 0; + } +} + +static void OPP_Element (OPT_Node *x) +{ + OPT_Node y = NIL; + OPP_Expression(&*x); + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_SetRange(&*x, y); + } else { + OPB_SetElem(&*x); + } +} + +static void OPP_Sets (OPT_Node *x) +{ + OPT_Node y = NIL; + if (OPP_sym != 24) { + OPP_Element(&*x); + for (;;) { + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + OPP_Element(&y); + OPB_Op(6, &*x, y); + } + } else { + *x = OPB_EmptySet(); + } + OPP_CheckSym(24); +} + +static void OPP_Factor (OPT_Node *x) +{ + OPT_Object fpar = NIL, id = NIL; + OPT_Node apar = NIL; + if (OPP_sym < 30) { + OPP_err(13); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + *x = OPB_NewLeaf(id); + OPP_selector(&*x); + if (((*x)->class == 9 && (*x)->obj->mode == 8)) { + OPP_StandProcCall(&*x); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPB_PrepCall(&*x, &fpar); + OPP_ActualParameters(&apar, fpar); + OPB_Call(&*x, apar, fpar); + OPP_CheckSym(22); + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + } else if (OPP_sym == 35) { + switch (OPS_numtyp) { + case 1: + *x = OPB_NewIntConst(OPS_intval); + (*x)->typ = OPT_chartyp; + break; + case 2: + *x = OPB_NewIntConst(OPS_intval); + break; + case 3: + *x = OPB_NewRealConst(OPS_realval, OPT_realtyp); + break; + case 4: + *x = OPB_NewRealConst(OPS_lrlval, OPT_lrltyp); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPP.Factor, OPS.numtyp = ", 44); + OPM_LogWNum(OPS_numtyp, 0); + OPM_LogWLn(); + break; + } + OPS_Get(&OPP_sym); + } else if (OPP_sym == 37) { + *x = OPB_NewString(OPS_str, OPS_intval); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 36) { + *x = OPB_Nil(); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + OPP_err(30); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 32) { + OPS_Get(&OPP_sym); + OPP_Sets(&*x); + } else if (OPP_sym == 33) { + OPS_Get(&OPP_sym); + OPP_Factor(&*x); + OPB_MOp(33, &*x); + } else { + OPP_err(13); + OPS_Get(&OPP_sym); + *x = NIL; + } + if (*x == NIL) { + *x = OPB_NewIntConst(1); + (*x)->typ = OPT_undftyp; + } +} + +static void OPP_Term (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 mulop; + OPP_Factor(&*x); + while ((1 <= OPP_sym && OPP_sym <= 5)) { + mulop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Factor(&y); + OPB_Op(mulop, &*x, y); + } +} + +static void OPP_SimpleExpression (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 addop; + if (OPP_sym == 7) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(7, &*x); + } else if (OPP_sym == 6) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(6, &*x); + } else { + OPP_Term(&*x); + } + while ((6 <= OPP_sym && OPP_sym <= 8)) { + addop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Term(&y); + OPB_Op(addop, &*x, y); + } +} + +static void OPP_Expression (OPT_Node *x) +{ + OPT_Node y = NIL; + OPT_Object obj = NIL; + INT8 relation; + OPP_SimpleExpression(&*x); + if ((9 <= OPP_sym && OPP_sym <= 14)) { + relation = OPP_sym; + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_Op(relation, &*x, y); + } else if (OPP_sym == 15) { + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_In(&*x, y); + } else if (OPP_sym == 16) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 0); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } +} + +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec) +{ + OPT_Object obj = NIL; + *typ = OPT_undftyp; + *rec = NIL; + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + *mode = 2; + } else { + *mode = 1; + } + __MOVE(OPS_name, name, 256); + OPP_CheckSym(38); + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if (obj == NIL) { + OPP_err(0); + } else if (obj->mode != 5) { + OPP_err(72); + } else { + *typ = obj->typ; + *rec = *typ; + if ((*rec)->form == 11) { + *rec = (*rec)->BaseTyp; + } + if (!((((*mode == 1 && (*typ)->form == 11)) && (*rec)->comp == 4) || (*mode == 2 && (*typ)->comp == 4))) { + OPP_err(70); + *rec = NIL; + } + if ((*rec != NIL && (*rec)->mno != OPP_level)) { + OPP_err(72); + *rec = NIL; + } + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + if (*rec == NIL) { + *rec = OPT_NewStr(13, 4); + (*rec)->BaseTyp = NIL; + } +} + +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b) +{ + if ((b->form == 11 && x->form == 11)) { + b = b->BaseTyp; + x = x->BaseTyp; + } + if ((b->comp == 4 && x->comp == 4)) { + do { + x = x->BaseTyp; + } while (!(x == NIL || x == b)); + } + return x == b; +} + +static struct ProcedureDeclaration__16 { + OPT_Node *x; + OPT_Object *proc, *fwd; + OPS_Name *name; + INT8 *mode, *vis; + BOOLEAN *forward; + struct ProcedureDeclaration__16 *lnk; +} *ProcedureDeclaration__16_s; + +static void Body__17 (void); +static void GetCode__19 (void); +static void GetParams__21 (void); +static void TProcDecl__23 (void); + +static void GetCode__19 (void) +{ + OPT_ConstExt ext = NIL; + INT16 n; + INT64 c; + ext = OPT_NewExt(); + (*ProcedureDeclaration__16_s->proc)->conval->ext = ext; + n = 0; + if (OPP_sym == 37) { + while (OPS_str[__X(n, 256)] != 0x00) { + (*ext)[__X(n + 1, 256)] = OPS_str[__X(n, 256)]; + n += 1; + } + (*ext)[0] = __CHR(n); + OPS_Get(&OPP_sym); + } else { + for (;;) { + if (OPP_sym == 35) { + c = OPS_intval; + n += 1; + if ((c < 0 || c > 255) || n == 256) { + OPP_err(64); + c = 1; + n = 1; + } + OPS_Get(&OPP_sym); + (*ext)[__X(n, 256)] = __CHR(c); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35) { + OPP_err(19); + } else { + (*ext)[0] = __CHR(n); + break; + } + } + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); +} + +static void GetParams__21 (void) +{ + (*ProcedureDeclaration__16_s->proc)->vis = *ProcedureDeclaration__16_s->vis; + (*ProcedureDeclaration__16_s->proc)->mode = *ProcedureDeclaration__16_s->mode; + (*ProcedureDeclaration__16_s->proc)->typ = OPT_notyp; + (*ProcedureDeclaration__16_s->proc)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->proc)->conval->setval = 0x0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_FormalParameters(&(*ProcedureDeclaration__16_s->proc)->link, &(*ProcedureDeclaration__16_s->proc)->typ); + } + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link, (*ProcedureDeclaration__16_s->fwd)->link, 1); + if ((*ProcedureDeclaration__16_s->proc)->typ != (*ProcedureDeclaration__16_s->fwd)->typ) { + OPP_err(117); + } + *ProcedureDeclaration__16_s->proc = *ProcedureDeclaration__16_s->fwd; + OPT_topScope = (*ProcedureDeclaration__16_s->proc)->scope; + if (*ProcedureDeclaration__16_s->mode == 10) { + (*ProcedureDeclaration__16_s->proc)->mode = 10; + } + } +} + +static void Body__17 (void) +{ + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + c = OPM_errpos; + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); + OPP_CheckSym(39); + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, *ProcedureDeclaration__16_s->proc); + *ProcedureDeclaration__16_s->x = procdec; + (*ProcedureDeclaration__16_s->x)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->x)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, (*ProcedureDeclaration__16_s->proc)->name) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } +} + +static void TProcDecl__23 (void) +{ + OPT_Object baseProc = NIL; + OPT_Struct objTyp = NIL, recTyp = NIL; + INT8 objMode; + OPS_Name objName; + OPS_Get(&OPP_sym); + *ProcedureDeclaration__16_s->mode = 13; + if (OPP_level > 0) { + OPP_err(73); + } + OPP_Receiver(&objMode, objName, &objTyp, &recTyp); + if (OPP_sym == 38) { + __MOVE(OPS_name, *ProcedureDeclaration__16_s->name, 256); + OPP_CheckMark(&*ProcedureDeclaration__16_s->vis); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp, &*ProcedureDeclaration__16_s->fwd); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp->BaseTyp, &baseProc); + if ((baseProc != NIL && baseProc->mode != 13)) { + baseProc = NIL; + } + if (*ProcedureDeclaration__16_s->fwd == baseProc) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mnolev != OPP_level)) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mode == 13)) && !__IN(1, (*ProcedureDeclaration__16_s->fwd)->conval->setval, 64))) { + *ProcedureDeclaration__16_s->proc = OPT_NewObj(); + (*ProcedureDeclaration__16_s->proc)->leaf = 1; + if ((*ProcedureDeclaration__16_s->fwd)->vis != *ProcedureDeclaration__16_s->vis) { + OPP_err(118); + } + } else { + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPP_err(1); + *ProcedureDeclaration__16_s->fwd = NIL; + } + OPT_OpenScope(0, NIL); + OPT_topScope->right = recTyp->link; + OPT_Insert(*ProcedureDeclaration__16_s->name, &*ProcedureDeclaration__16_s->proc); + recTyp->link = OPT_topScope->right; + OPT_CloseScope(); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, *ProcedureDeclaration__16_s->proc); + OPT_Insert(objName, &(*ProcedureDeclaration__16_s->proc)->link); + (*ProcedureDeclaration__16_s->proc)->link->mode = objMode; + (*ProcedureDeclaration__16_s->proc)->link->typ = objTyp; + GetParams__21(); + if (baseProc != NIL) { + if (objMode != baseProc->link->mode || !OPP_Extends(objTyp, baseProc->link->typ)) { + OPP_err(115); + } + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link->link, baseProc->link->link, 0); + if ((*ProcedureDeclaration__16_s->proc)->typ != baseProc->typ) { + OPP_err(117); + } + if ((((((baseProc->vis == 1 && (*ProcedureDeclaration__16_s->proc)->vis == 0)) && recTyp->strobj != NIL)) && recTyp->strobj->vis == 1)) { + OPP_err(109); + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(2,64); + } + if (!*ProcedureDeclaration__16_s->forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } +} + +static void OPP_ProcedureDeclaration (OPT_Node *x) +{ + OPT_Object proc = NIL, fwd = NIL; + OPS_Name name; + INT8 mode, vis; + BOOLEAN forward; + struct ProcedureDeclaration__16 _s; + _s.x = x; + _s.proc = &proc; + _s.fwd = &fwd; + _s.name = (void*)name; + _s.mode = &mode; + _s.vis = &vis; + _s.forward = &forward; + _s.lnk = ProcedureDeclaration__16_s; + ProcedureDeclaration__16_s = &_s; + proc = NIL; + forward = 0; + *x = NIL; + mode = 6; + if ((OPP_sym != 38 && OPP_sym != 30)) { + if (OPP_sym == 1) { + } else if (OPP_sym == 17) { + forward = 1; + } else if (OPP_sym == 6) { + mode = 10; + } else if (OPP_sym == 7) { + mode = 9; + } else { + OPP_err(38); + } + if ((__IN(mode, 0x0600, 32) && !OPT_SYSimported)) { + OPP_err(135); + } + OPS_Get(&OPP_sym); + } + if (OPP_sym == 30) { + TProcDecl__23(); + } else if (OPP_sym == 38) { + OPT_Find(&fwd); + __MOVE(OPS_name, name, 256); + OPP_CheckMark(&vis); + if ((vis != 0 && mode == 6)) { + mode = 7; + } + if ((fwd != NIL && (fwd->mnolev != OPP_level || fwd->mode == 8))) { + fwd = NIL; + } + if ((((fwd != NIL && __IN(fwd->mode, 0xc0, 32))) && !__IN(1, fwd->conval->setval, 64))) { + proc = OPT_NewObj(); + proc->leaf = 1; + if (fwd->vis != vis) { + OPP_err(118); + } + } else { + if (fwd != NIL) { + OPP_err(1); + fwd = NIL; + } + OPT_Insert(name, &proc); + } + if ((mode != 6 && OPP_level > 0)) { + OPP_err(73); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, proc); + proc->link = NIL; + GetParams__21(); + if (mode == 9) { + GetCode__19(); + } else if (!forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } + ProcedureDeclaration__16_s = _s.lnk; +} + +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab) +{ + OPT_Node x = NIL, y = NIL, lastlab = NIL; + INT16 i, f; + INT32 xval, yval; + *lab = NIL; + lastlab = NIL; + for (;;) { + OPP_ConstExpression(&x); + f = x->typ->form; + if (__IN(f, 0x18, 32)) { + xval = OPM_Longint(x->conval->intval); + } else { + OPP_err(61); + xval = 1; + } + if (f == 4) { + if (!(LabelTyp->form == 4) || LabelTyp->size < x->typ->size) { + OPP_err(60); + } + } else if ((INT16)LabelTyp->form != f) { + OPP_err(60); + } + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&y); + yval = OPM_Longint(y->conval->intval); + if (((INT16)y->typ->form != f && !((f == 4 && y->typ->form == 4)))) { + OPP_err(60); + } + if (yval < xval) { + OPP_err(63); + yval = xval; + } + } else { + yval = xval; + } + x->conval->intval2 = yval; + i = *n; + if (i < 128) { + for (;;) { + if (i == 0) { + break; + } + if (tab[__X(i - 1, 128)].low <= yval) { + if (tab[__X(i - 1, 128)].high >= xval) { + OPP_err(62); + } + break; + } + tab[__X(i, 128)] = tab[__X(i - 1, 128)]; + i -= 1; + } + tab[__X(i, 128)].low = xval; + tab[__X(i, 128)].high = yval; + *n += 1; + } else { + OPP_err(213); + } + OPB_Link(&*lab, &lastlab, x); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35 || OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } +} + +static struct StatSeq__30 { + INT32 *pos; + struct StatSeq__30 *lnk; +} *StatSeq__30_s; + +static void CasePart__31 (OPT_Node *x); +static void CheckBool__33 (OPT_Node *x); +static void SetPos__35 (OPT_Node x); + +static void CasePart__31 (OPT_Node *x) +{ + INT16 n; + INT32 low, high; + BOOLEAN e; + OPP_CaseTable tab; + OPT_Node cases = NIL, lab = NIL, y = NIL, lastcase = NIL; + OPP_Expression(&*x); + *StatSeq__30_s->pos = OPM_errpos; + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + } else if (!__IN((*x)->typ->form, 0x18, 32)) { + OPP_err(125); + } + OPP_CheckSym(25); + cases = NIL; + lastcase = NIL; + n = 0; + for (;;) { + if (OPP_sym < 40) { + OPP_CaseLabelList(&lab, (*x)->typ, &n, tab); + OPP_CheckSym(20); + OPP_StatSeq(&y); + OPB_Construct(17, &lab, y); + OPB_Link(&cases, &lastcase, lab); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + if (n > 0) { + low = tab[0].low; + high = tab[__X(n - 1, 128)].high; + if (high - low > 512) { + OPP_err(209); + } + } else { + low = 1; + high = 0; + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + OPM_Mark(-307, OPM_curpos); + } + OPB_Construct(16, &cases, y); + OPB_Construct(21, &*x, cases); + cases->conval = OPT_NewConst(); + cases->conval->intval = low; + cases->conval->intval2 = high; + if (e) { + cases->conval->setval = 0x02; + } else { + cases->conval->setval = 0x0; + } +} + +static void SetPos__35 (OPT_Node x) +{ + x->conval = OPT_NewConst(); + x->conval->intval = *StatSeq__30_s->pos; +} + +static void CheckBool__33 (OPT_Node *x) +{ + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + *x = OPB_NewBoolConst(0); + } else if ((*x)->typ->form != 2) { + OPP_err(120); + *x = OPB_NewBoolConst(0); + } + *StatSeq__30_s->pos = OPM_errpos; +} + +static void OPP_StatSeq (OPT_Node *stat) +{ + OPT_Object fpar = NIL, id = NIL, t = NIL, obj = NIL; + OPT_Struct idtyp = NIL; + BOOLEAN e; + OPT_Node s = NIL, x = NIL, y = NIL, z = NIL, apar = NIL, last = NIL, lastif = NIL; + INT32 pos; + OPS_Name name; + struct StatSeq__30 _s; + _s.pos = &pos; + _s.lnk = StatSeq__30_s; + StatSeq__30_s = &_s; + *stat = NIL; + last = NIL; + for (;;) { + x = NIL; + if (OPP_sym < 38) { + OPP_err(14); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 38)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + x = OPB_NewLeaf(id); + OPP_selector(&x); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if (OPP_sym == 9) { + OPP_err(34); + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if ((x->class == 9 && x->obj->mode == 8)) { + OPP_StandProcCall(&x); + if ((x != NIL && x->typ != OPT_notyp)) { + OPP_err(55); + } + } else { + OPB_PrepCall(&x, &fpar); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_ActualParameters(&apar, fpar); + OPP_CheckSym(22); + } else { + apar = NIL; + if (fpar != NIL) { + OPP_err(65); + } + } + OPB_Call(&x, apar, fpar); + if (x->typ != OPT_notyp) { + OPP_err(55); + } + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + pos = OPM_errpos; + } else if (OPP_sym == 45) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(26); + OPP_StatSeq(&y); + OPB_Construct(15, &x, y); + SetPos__35(x); + lastif = x; + while (OPP_sym == 43) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + OPP_CheckSym(26); + OPP_StatSeq(&z); + OPB_Construct(15, &y, z); + SetPos__35(y); + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 42) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + } + OPB_Construct(20, &x, y); + OPP_CheckSym(41); + OPB_OptIf(&x); + pos = OPM_errpos; + } else if (OPP_sym == 46) { + OPS_Get(&OPP_sym); + CasePart__31(&x); + OPP_CheckSym(41); + } else if (OPP_sym == 47) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(27); + OPP_StatSeq(&y); + OPB_Construct(22, &x, y); + OPP_CheckSym(41); + } else if (OPP_sym == 48) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&x); + if (OPP_sym == 44) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + } else { + OPP_err(44); + } + OPB_Construct(23, &x, y); + } else if (OPP_sym == 49) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&id); + if (!(id->typ->form == 4)) { + OPP_err(68); + } + OPP_CheckSym(34); + OPP_Expression(&y); + pos = OPM_errpos; + x = OPB_NewLeaf(id); + OPB_Assign(&x, y); + SetPos__35(x); + OPP_CheckSym(28); + OPP_Expression(&y); + pos = OPM_errpos; + if (y->class != 7) { + __MOVE("@@", name, 3); + OPT_Insert(name, &t); + __MOVE("@for", t->name, 5); + t->mode = 1; + t->typ = x->left->typ; + obj = OPT_topScope->scope; + if (obj == NIL) { + OPT_topScope->scope = t; + } else { + while (obj->link != NIL) { + obj = obj->link; + } + obj->link = t; + } + z = OPB_NewLeaf(t); + OPB_Assign(&z, y); + SetPos__35(z); + OPB_Link(&*stat, &last, z); + y = OPB_NewLeaf(t); + } else if (!(y->typ->form == 4) || y->typ->size > x->left->typ->size) { + OPP_err(113); + } + OPB_Link(&*stat, &last, x); + if (OPP_sym == 29) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&z); + } else { + z = OPB_NewIntConst(1); + } + pos = OPM_errpos; + x = OPB_NewLeaf(id); + if (z->conval->intval > 0) { + OPB_Op(12, &x, y); + } else if (z->conval->intval < 0) { + OPB_Op(14, &x, y); + } else { + OPP_err(63); + OPB_Op(14, &x, y); + } + OPP_CheckSym(27); + OPP_StatSeq(&s); + y = OPB_NewLeaf(id); + OPB_StPar1(&y, z, 13); + SetPos__35(y); + if (s == NIL) { + s = y; + } else { + z = s; + while (z->link != NIL) { + z = z->link; + } + z->link = y; + } + OPP_CheckSym(41); + OPB_Construct(22, &x, s); + } else { + OPP_err(38); + } + } else if (OPP_sym == 50) { + OPS_Get(&OPP_sym); + OPP_LoopLevel += 1; + OPP_StatSeq(&x); + OPP_LoopLevel -= 1; + OPB_Construct(24, &x, NIL); + OPP_CheckSym(41); + pos = OPM_errpos; + } else if (OPP_sym == 51) { + OPS_Get(&OPP_sym); + idtyp = NIL; + x = NIL; + for (;;) { + if (OPP_sym == 38) { + OPP_qualident(&id); + y = OPB_NewLeaf(id); + if ((((id != NIL && id->typ->form == 11)) && (id->mode == 2 || !id->leaf))) { + OPP_err(245); + } + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPP_qualident(&t); + if (t->mode == 5) { + if (id != NIL) { + idtyp = id->typ; + OPB_TypTest(&y, t, 0); + id->typ = t->typ; + } else { + OPP_err(130); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + OPP_err(38); + } + pos = OPM_errpos; + OPP_CheckSym(27); + OPP_StatSeq(&s); + OPB_Construct(15, &y, s); + SetPos__35(y); + if (idtyp != NIL) { + id->typ = idtyp; + idtyp = NIL; + } + if (x == NIL) { + x = y; + lastif = x; + } else { + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&s); + } else { + s = NIL; + } + OPB_Construct(27, &x, s); + OPP_CheckSym(41); + if (e) { + x->subcl = 1; + } + } else if (OPP_sym == 52) { + OPS_Get(&OPP_sym); + if (OPP_LoopLevel == 0) { + OPP_err(46); + } + OPB_Construct(25, &x, NIL); + pos = OPM_errpos; + } else if (OPP_sym == 53) { + OPS_Get(&OPP_sym); + if (OPP_sym < 39) { + OPP_Expression(&x); + } + if (OPP_level > 0) { + OPB_Return(&x, OPT_topScope->link); + } else { + OPB_Return(&x, NIL); + } + pos = OPM_errpos; + } + if (x != NIL) { + SetPos__35(x); + OPB_Link(&*stat, &last, x); + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym <= 38 || (45 <= OPP_sym && OPP_sym <= 53)) { + OPP_err(39); + } else { + break; + } + } + StatSeq__30_s = _s.lnk; +} + +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq) +{ + OPT_Struct typ = NIL; + OPT_Object obj = NIL, first = NIL, last = NIL; + OPT_Node x = NIL, lastdec = NIL; + INT16 i; + first = NIL; + last = NIL; + OPP_nofFwdPtr = 0; + for (;;) { + if (OPP_sym == 58) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->typ = OPT_sinttyp; + obj->mode = 1; + if (OPP_sym == 9) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else if (OPP_sym == 34) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else { + OPP_err(9); + x = OPB_NewIntConst(1); + } + obj->mode = 3; + obj->typ = x->typ; + obj->conval = x->conval; + OPP_CheckSym(39); + } + } + if (OPP_sym == 59) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + obj->mode = 5; + obj->typ = OPT_undftyp; + OPP_CheckMark(&obj->vis); + if (OPP_sym == 9) { + if (((((((((__STRCMP(obj->name, "SHORTINT") == 0 || __STRCMP(obj->name, "INTEGER") == 0) || __STRCMP(obj->name, "LONGINT") == 0) || __STRCMP(obj->name, "HUGEINT") == 0) || __STRCMP(obj->name, "REAL") == 0) || __STRCMP(obj->name, "LONGREAL") == 0) || __STRCMP(obj->name, "SET") == 0) || __STRCMP(obj->name, "CHAR") == 0) || __STRCMP(obj->name, "TRUE") == 0) || __STRCMP(obj->name, "FALSE") == 0) { + OPM_Mark(-310, OPM_curpos); + } + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else if (OPP_sym == 34 || OPP_sym == 20) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else { + OPP_err(9); + } + if (obj->typ->strobj == NIL) { + obj->typ->strobj = obj; + } + if (__IN(obj->typ->comp, 0x1c, 32)) { + i = 0; + while (i < OPP_nofFwdPtr) { + typ = OPP_FwdPtr[__X(i, 64)]; + i += 1; + if (__STRCMP(typ->link->name, obj->name) == 0) { + typ->BaseTyp = obj->typ; + typ->link->name[0] = 0x00; + } + } + } + OPP_CheckSym(39); + } + } + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->mode = 1; + obj->link = NIL; + obj->leaf = obj->vis == 0; + obj->typ = OPT_undftyp; + if (first == NIL) { + first = obj; + } + if (last == NIL) { + OPT_topScope->scope = obj; + } else { + last->link = obj; + } + last = obj; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + typ->pvused = 1; + if (typ->comp == 3) { + typ = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + OPP_CheckSym(39); + } + } + if (OPP_sym < 58 || OPP_sym > 60) { + break; + } + } + i = 0; + while (i < OPP_nofFwdPtr) { + if (OPP_FwdPtr[__X(i, 64)]->link->name[0] != 0x00) { + OPP_err(128); + } + OPP_FwdPtr[__X(i, 64)] = NIL; + i += 1; + } + OPT_topScope->adr = OPM_errpos; + *procdec = NIL; + lastdec = NIL; + while (OPP_sym == 61) { + OPS_Get(&OPP_sym); + OPP_ProcedureDeclaration(&x); + if (x != NIL) { + if (lastdec == NIL) { + *procdec = x; + } else { + lastdec->link = x; + } + lastdec = x; + } + OPP_CheckSym(39); + } + if (OPP_sym == 57) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&*statseq); + } else { + *statseq = NIL; + } + if ((OPP_level == 0 && OPP_TDinit != NIL)) { + OPP_lastTDinit->link = *statseq; + *statseq = OPP_TDinit; + } + OPP_CheckSym(41); +} + +void OPP_Module (OPT_Node *prog, UINT32 opt) +{ + OPS_Name impName, aliasName; + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + BOOLEAN done; + OPS_Init(); + OPP_LoopLevel = 0; + OPP_level = 0; + OPS_Get(&OPP_sym); + if (OPP_sym == 63) { + OPS_Get(&OPP_sym); + } else { + OPP_err(16); + } + if (OPP_sym == 38) { + OPM_LogCompiling(OPS_name, 256); + OPT_Init(OPS_name, opt); + OPS_Get(&OPP_sym); + OPP_CheckSym(39); + if (OPP_sym == 62) { + OPS_Get(&OPP_sym); + for (;;) { + if (OPP_sym == 38) { + __COPY(OPS_name, aliasName, 256); + __COPY(aliasName, impName, 256); + OPS_Get(&OPP_sym); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __COPY(OPS_name, impName, 256); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + } + OPT_Import(aliasName, impName, &done); + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(39); + } + if (OPM_noerr) { + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; + c = OPM_errpos; + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, NIL); + *prog = procdec; + (*prog)->conval = OPT_NewConst(); + (*prog)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, OPT_SelfName) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + if (OPP_sym != 18) { + OPP_err(18); + } + } + } else { + OPP_err(38); + } + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPP_TDinit); + P(OPP_lastTDinit); + __ENUMP(OPP_FwdPtr, 64, P); +} + +__TDESC(OPP__1, 1, 0) = {__TDFLDS("", 8), {-4}}; + +export void *OPP__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPP", EnumPtrs); + __INITYP(OPP__1, OPP__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPP.h b/bootstrap/windows-48/OPP.h new file mode 100644 index 00000000..3d8cefe8 --- /dev/null +++ b/bootstrap/windows-48/OPP.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPP__h +#define OPP__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPP_Module (OPT_Node *prog, UINT32 opt); +import void *OPP__init(void); + + +#endif // OPP diff --git a/bootstrap/windows-48/OPS.c b/bootstrap/windows-48/OPS.c new file mode 100644 index 00000000..a25a2c12 --- /dev/null +++ b/bootstrap/windows-48/OPS.c @@ -0,0 +1,666 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +export OPS_Name OPS_name; +export OPS_String OPS_str; +export INT16 OPS_numtyp; +export INT64 OPS_intval; +export REAL OPS_realval; +export LONGREAL OPS_lrlval; +static CHAR OPS_ch; + + +export void OPS_Get (INT8 *sym); +static void OPS_Identifier (INT8 *sym); +export void OPS_Init (void); +static void OPS_Number (void); +static void OPS_Str (INT8 *sym); +static void OPS_err (INT16 n); + + +static void OPS_err (INT16 n) +{ + OPM_err(n); +} + +static void OPS_Str (INT8 *sym) +{ + INT16 i; + CHAR och; + i = 0; + och = OPS_ch; + for (;;) { + OPM_Get(&OPS_ch); + if (OPS_ch == och) { + break; + } + if (OPS_ch < ' ') { + OPS_err(3); + break; + } + if (i == 255) { + OPS_err(241); + break; + } + OPS_str[__X(i, 256)] = OPS_ch; + i += 1; + } + OPM_Get(&OPS_ch); + OPS_str[__X(i, 256)] = 0x00; + OPS_intval = i + 1; + if (OPS_intval == 2) { + *sym = 35; + OPS_numtyp = 1; + OPS_intval = (INT16)OPS_str[0]; + } else { + *sym = 37; + } +} + +static void OPS_Identifier (INT8 *sym) +{ + INT16 i; + i = 0; + do { + OPS_name[__X(i, 256)] = OPS_ch; + i += 1; + OPM_Get(&OPS_ch); + } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256)); + if (i == 256) { + OPS_err(240); + i -= 1; + } + OPS_name[__X(i, 256)] = 0x00; + *sym = 38; +} + +static struct Number__6 { + struct Number__6 *lnk; +} *Number__6_s; + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex); +static LONGREAL Ten__9 (INT16 e); + +static LONGREAL Ten__9 (INT16 e) +{ + LONGREAL x, p; + x = (LONGREAL)1; + p = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + x = x * p; + } + e = __ASHR(e, 1); + if (e > 0) { + p = p * p; + } + } + return x; +} + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex) +{ + if (ch <= '9') { + return (INT16)ch - 48; + } else if (hex) { + return ((INT16)ch - 65) + 10; + } else { + OPS_err(2); + return 0; + } + __RETCHK; +} + +static void OPS_Number (void) +{ + INT16 i, m, n, d, e; + CHAR dig[24]; + LONGREAL f; + CHAR expCh; + BOOLEAN neg; + struct Number__6 _s; + _s.lnk = Number__6_s; + Number__6_s = &_s; + i = 0; + m = 0; + n = 0; + d = 0; + for (;;) { + if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) { + if (m > 0 || OPS_ch != '0') { + if (n < 24) { + dig[__X(n, 24)] = OPS_ch; + n += 1; + } + m += 1; + } + OPM_Get(&OPS_ch); + i += 1; + } else if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPS_ch = 0x7f; + break; + } else if (d == 0) { + d = i; + } else { + OPS_err(2); + } + } else { + break; + } + } + if (d == 0) { + if (n == m) { + OPS_intval = 0; + i = 0; + if (OPS_ch == 'X') { + OPM_Get(&OPS_ch); + OPS_numtyp = 1; + if (n <= 2) { + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else if (OPS_ch == 'H') { + OPM_Get(&OPS_ch); + OPS_numtyp = 2; + if (n <= 16) { + if ((n == 16 && dig[0] > '7')) { + OPS_intval = -1; + } + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 2; + while (i < n) { + d = Ord__7(dig[__X(i, 24)], 0); + i += 1; + if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (INT64)d; + } else { + OPS_err(203); + } + } + } + } else { + OPS_err(203); + } + } else { + f = (LONGREAL)0; + e = 0; + expCh = 'E'; + while (n > 0) { + n -= 1; + f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10; + } + if (OPS_ch == 'E' || OPS_ch == 'D') { + expCh = OPS_ch; + OPM_Get(&OPS_ch); + neg = 0; + if (OPS_ch == '-') { + neg = 1; + OPM_Get(&OPS_ch); + } else if (OPS_ch == '+') { + OPM_Get(&OPS_ch); + } + if (('0' <= OPS_ch && OPS_ch <= '9')) { + do { + n = Ord__7(OPS_ch, 0); + OPM_Get(&OPS_ch); + if (e <= __DIV(32767 - n, 10)) { + e = e * 10 + n; + } else { + OPS_err(203); + } + } while (!(OPS_ch < '0' || '9' < OPS_ch)); + if (neg) { + e = -e; + } + } else { + OPS_err(2); + } + } + e -= (i - d) - m; + if (expCh == 'E') { + OPS_numtyp = 3; + if ((-37 < e && e <= 38)) { + if (e < 0) { + OPS_realval = (f / (LONGREAL)Ten__9(-e)); + } else { + OPS_realval = (f * Ten__9(e)); + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 4; + if ((-307 < e && e <= 308)) { + if (e < 0) { + OPS_lrlval = f / (LONGREAL)Ten__9(-e); + } else { + OPS_lrlval = f * Ten__9(e); + } + } else { + OPS_err(203); + } + } + } + Number__6_s = _s.lnk; +} + +static struct Get__1 { + struct Get__1 *lnk; +} *Get__1_s; + +static void Comment__2 (void); + +static void Comment__2 (void) +{ + BOOLEAN isExported; + CHAR commentText[256]; + INT16 i, nestLevel; + CHAR prevCh, nextCh; + i = 0; + while (i <= 255) { + commentText[__X(i, 256)] = 0x00; + i += 1; + } + isExported = 0; + i = 0; + nestLevel = 1; + prevCh = 0x00; + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + isExported = 1; + OPM_Get(&OPS_ch); + if (OPS_ch == ')') { + commentText[0] = 0x00; + OPM_StoreComment(commentText, 256); + OPM_Get(&OPS_ch); + return; + } + } + while ((nestLevel > 0 && OPS_ch != 0x00)) { + if ((prevCh == '(' && OPS_ch == '*')) { + nestLevel += 1; + prevCh = 0x00; + } else if ((prevCh == '*' && OPS_ch == ')')) { + nestLevel -= 1; + if (nestLevel == 0) { + OPM_Get(&OPS_ch); + } else { + prevCh = 0x00; + } + } else { + if ((((isExported && nestLevel == 1)) && prevCh != 0x00)) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } + } + prevCh = OPS_ch; + } + if (nestLevel > 0) { + OPM_Get(&OPS_ch); + } + } + if (OPS_ch == 0x00) { + OPS_err(5); + } + if ((((((isExported && nestLevel == 0)) && prevCh != 0x00)) && prevCh != '*')) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } else { + OPM_LogWStr((CHAR*)"Truncating final comment character", 35); + OPM_LogWLn(); + } + } + if (isExported) { + if (i >= 256) { + OPM_LogWStr((CHAR*)"Warning: commentText overflow", 30); + OPM_LogWLn(); + i = 255; + } + commentText[__X(i, 256)] = 0x00; + OPM_StoreComment(commentText, 256); + } +} + +void OPS_Get (INT8 *sym) +{ + INT8 s; + struct Get__1 _s; + _s.lnk = Get__1_s; + Get__1_s = &_s; + OPM_errpos = OPM_curpos - 1; + while (OPS_ch <= ' ') { + if (OPS_ch == 0x00) { + *sym = 64; + Get__1_s = _s.lnk; + return; + } else { + OPM_Get(&OPS_ch); + } + } + switch (OPS_ch) { + case '"': case '\'': + OPS_Str(&s); + break; + case '#': + s = 10; + OPM_Get(&OPS_ch); + break; + case '&': + s = 5; + OPM_Get(&OPS_ch); + break; + case '(': + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + Comment__2(); + OPS_Get(&s); + } else { + s = 30; + } + break; + case ')': + s = 22; + OPM_Get(&OPS_ch); + break; + case '*': + s = 1; + OPM_Get(&OPS_ch); + break; + case '+': + s = 6; + OPM_Get(&OPS_ch); + break; + case ',': + s = 19; + OPM_Get(&OPS_ch); + break; + case '-': + s = 7; + OPM_Get(&OPS_ch); + break; + case '.': + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + s = 21; + } else { + s = 18; + } + break; + case '/': + s = 2; + OPM_Get(&OPS_ch); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + OPS_Number(); + s = 35; + break; + case ':': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 34; + } else { + s = 20; + } + break; + case ';': + s = 39; + OPM_Get(&OPS_ch); + break; + case '<': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 12; + } else { + s = 11; + } + break; + case '=': + s = 9; + OPM_Get(&OPS_ch); + break; + case '>': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 14; + } else { + s = 13; + } + break; + case 'A': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "ARRAY") == 0) { + s = 54; + } + break; + case 'B': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "BEGIN") == 0) { + s = 57; + } else if (__STRCMP(OPS_name, "BY") == 0) { + s = 29; + } + break; + case 'C': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "CASE") == 0) { + s = 46; + } else if (__STRCMP(OPS_name, "CONST") == 0) { + s = 58; + } + break; + case 'D': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "DO") == 0) { + s = 27; + } else if (__STRCMP(OPS_name, "DIV") == 0) { + s = 3; + } + break; + case 'E': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "END") == 0) { + s = 41; + } else if (__STRCMP(OPS_name, "ELSE") == 0) { + s = 42; + } else if (__STRCMP(OPS_name, "ELSIF") == 0) { + s = 43; + } else if (__STRCMP(OPS_name, "EXIT") == 0) { + s = 52; + } + break; + case 'F': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "FOR") == 0) { + s = 49; + } + break; + case 'I': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "IF") == 0) { + s = 45; + } else if (__STRCMP(OPS_name, "IN") == 0) { + s = 15; + } else if (__STRCMP(OPS_name, "IS") == 0) { + s = 16; + } else if (__STRCMP(OPS_name, "IMPORT") == 0) { + s = 62; + } + break; + case 'L': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "LOOP") == 0) { + s = 50; + } + break; + case 'M': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "MOD") == 0) { + s = 4; + } else if (__STRCMP(OPS_name, "MODULE") == 0) { + s = 63; + } + break; + case 'N': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "NIL") == 0) { + s = 36; + } + break; + case 'O': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "OR") == 0) { + s = 8; + } else if (__STRCMP(OPS_name, "OF") == 0) { + s = 25; + } + break; + case 'P': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "PROCEDURE") == 0) { + s = 61; + } else if (__STRCMP(OPS_name, "POINTER") == 0) { + s = 56; + } + break; + case 'R': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "RECORD") == 0) { + s = 55; + } else if (__STRCMP(OPS_name, "REPEAT") == 0) { + s = 48; + } else if (__STRCMP(OPS_name, "RETURN") == 0) { + s = 53; + } + break; + case 'T': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "THEN") == 0) { + s = 26; + } else if (__STRCMP(OPS_name, "TO") == 0) { + s = 28; + } else if (__STRCMP(OPS_name, "TYPE") == 0) { + s = 59; + } + break; + case 'U': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "UNTIL") == 0) { + s = 44; + } + break; + case 'V': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "VAR") == 0) { + s = 60; + } + break; + case 'W': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "WHILE") == 0) { + s = 47; + } else if (__STRCMP(OPS_name, "WITH") == 0) { + s = 51; + } + break; + case 'G': case 'H': case 'J': case 'K': case 'Q': + case 'S': case 'X': case 'Y': case 'Z': + OPS_Identifier(&s); + break; + case '[': + s = 31; + OPM_Get(&OPS_ch); + break; + case ']': + s = 23; + OPM_Get(&OPS_ch); + break; + case '^': + s = 17; + OPM_Get(&OPS_ch); + break; + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + OPS_Identifier(&s); + break; + case '{': + s = 32; + OPM_Get(&OPS_ch); + break; + case '|': + s = 40; + OPM_Get(&OPS_ch); + break; + case '}': + s = 24; + OPM_Get(&OPS_ch); + break; + case '~': + s = 33; + OPM_Get(&OPS_ch); + break; + case 0x7f: + s = 21; + OPM_Get(&OPS_ch); + break; + default: + s = 0; + OPM_Get(&OPS_ch); + break; + } + *sym = s; + Get__1_s = _s.lnk; +} + +void OPS_Init (void) +{ + OPS_ch = ' '; +} + + +export void *OPS__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __REGMOD("OPS", 0); + __REGCMD("Init", OPS_Init); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPS.h b/bootstrap/windows-48/OPS.h new file mode 100644 index 00000000..19e222ac --- /dev/null +++ b/bootstrap/windows-48/OPS.h @@ -0,0 +1,28 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPS__h +#define OPS__h + +#include "SYSTEM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +import OPS_Name OPS_name; +import OPS_String OPS_str; +import INT16 OPS_numtyp; +import INT64 OPS_intval; +import REAL OPS_realval; +import LONGREAL OPS_lrlval; + + +import void OPS_Get (INT8 *sym); +import void OPS_Init (void); +import void *OPS__init(void); + + +#endif // OPS diff --git a/bootstrap/windows-48/OPT.c b/bootstrap/windows-48/OPT.c new file mode 100644 index 00000000..ebb47dd8 --- /dev/null +++ b/bootstrap/windows-48/OPT.c @@ -0,0 +1,2261 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_ExpCtxt { + INT32 reffp; + INT16 ref; + INT8 nofm; + INT8 locmno[64]; + } OPT_ExpCtxt; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_ImpCtxt { + INT32 nextTag, reffp; + INT16 nofr, minr, nofm; + BOOLEAN self; + OPT_Struct ref[255]; + OPT_Object old[255]; + INT32 pvfp[255]; + INT8 glbmno[64]; + } OPT_ImpCtxt; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused, fpdone, idfpdone; + INT32 idfp, pbfp, pvfp; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +export OPT_Object OPT_topScope; +export OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +export OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +export INT8 OPT_nofGmod; +export OPT_Object OPT_GlbMod[64]; +export OPS_Name OPT_SelfName; +export BOOLEAN OPT_SYSimported; +static OPT_Object OPT_universe, OPT_syslink; +static OPT_ImpCtxt OPT_impCtxt; +static OPT_ExpCtxt OPT_expCtxt; +static INT32 OPT_nofhdfld; +static BOOLEAN OPT_newsf, OPT_findpc, OPT_extsf, OPT_sfpresent, OPT_symExtended, OPT_symNew; +static INT32 OPT_recno; +export OPT_Link OPT_Links; + +export ADDRESS *OPT_ConstDesc__typ; +export ADDRESS *OPT_ObjDesc__typ; +export ADDRESS *OPT_StrDesc__typ; +export ADDRESS *OPT_NodeDesc__typ; +export ADDRESS *OPT_ImpCtxt__typ; +export ADDRESS *OPT_ExpCtxt__typ; +export ADDRESS *OPT_LinkDesc__typ; + +export void OPT_Align (INT32 *adr, INT32 base); +export INT32 OPT_BaseAlignment (OPT_Struct typ); +export void OPT_Close (void); +export void OPT_CloseScope (void); +static void OPT_DebugStruct (OPT_Struct btyp); +static void OPT_EnterBoolConst (OPS_Name name, INT32 value); +static void OPT_EnterProc (OPS_Name name, INT16 num); +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res); +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res); +export void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +export void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len); +export void OPT_FPrintObj (OPT_Object obj); +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par); +export void OPT_FPrintStr (OPT_Struct typ); +export void OPT_Find (OPT_Object *res); +export void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +export void OPT_FindImport (OPT_Object mod, OPT_Object *res); +export void OPT_IdFPrint (OPT_Struct typ); +export void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +static void OPT_InConstant (INT32 f, OPT_Const conval); +static OPT_Object OPT_InFld (void); +static void OPT_InLinks (void); +static void OPT_InMod (INT8 *mno); +static void OPT_InName (CHAR *name, ADDRESS name__len); +static OPT_Object OPT_InObj (INT8 mno); +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par); +static void OPT_InStruct (OPT_Struct *typ); +static OPT_Object OPT_InTProc (INT8 mno); +static OPT_Struct OPT_InTyp (INT32 tag); +export void OPT_Init (OPS_Name name, UINT32 opt); +export void OPT_InitRecno (void); +static void OPT_InitStruct (OPT_Struct *typ, INT8 form); +export void OPT_Insert (OPS_Name name, OPT_Object *obj); +export void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +export INT16 OPT_IntSize (INT64 n); +export OPT_Struct OPT_IntType (INT32 size); +export OPT_Const OPT_NewConst (void); +export OPT_ConstExt OPT_NewExt (void); +export OPT_Node OPT_NewNode (INT8 class); +export OPT_Object OPT_NewObj (void); +export OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +export void OPT_OpenScope (INT8 level, OPT_Object owner); +static void OPT_OutConstant (OPT_Object obj); +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void OPT_OutLinks (void); +static void OPT_OutMod (INT16 mno); +static void OPT_OutName (CHAR *name, ADDRESS name__len); +static void OPT_OutObj (OPT_Object obj); +static void OPT_OutSign (OPT_Struct result, OPT_Object par); +static void OPT_OutStr (OPT_Struct typ); +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj); +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len); +export OPT_Struct OPT_SetType (INT32 size); +export OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +export INT32 OPT_SizeAlignment (INT32 size); +export void OPT_TypSize (OPT_Struct typ); +static void OPT_err (INT16 n); + + +void OPT_InitRecno (void) +{ + OPT_recno = 0; +} + +static void OPT_err (INT16 n) +{ + OPM_err(n); +} + +INT16 OPT_IntSize (INT64 n) +{ + INT16 bytes; + if (n < 0) { + n = -(n + 1); + } + bytes = 1; + while ((bytes < 8 && __ASH(n, -(__ASHL(bytes, 3) - 1)) != 0)) { + bytes += 1; + } + return bytes; +} + +OPT_Struct OPT_IntType (INT32 size) +{ + if (size <= OPT_int8typ->size) { + return OPT_int8typ; + } + if (size <= OPT_int16typ->size) { + return OPT_int16typ; + } + if (size <= OPT_int32typ->size) { + return OPT_int32typ; + } + return OPT_int64typ; +} + +OPT_Struct OPT_SetType (INT32 size) +{ + if (size == OPT_set32typ->size) { + return OPT_set32typ; + } + return OPT_set64typ; +} + +OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir) +{ + INT16 i; + __ASSERT(x->form == 4, 0); + __ASSERT(x->BaseTyp == OPT_undftyp, 0); + __ASSERT(dir == 1 || dir == -1, 0); + if (dir > 0) { + if (x->size < OPT_sinttyp->size) { + return OPT_sinttyp; + } + if (x->size < OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size < OPT_linttyp->size) { + return OPT_linttyp; + } + return OPT_int64typ; + } else { + if (x->size > OPT_linttyp->size) { + return OPT_linttyp; + } + if (x->size > OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size > OPT_sinttyp->size) { + return OPT_sinttyp; + } + return OPT_int8typ; + } + __RETCHK; +} + +void OPT_Align (INT32 *adr, INT32 base) +{ + switch (base) { + case 2: + *adr += __MASK(*adr, -2); + break; + case 4: + *adr += __MASK(-*adr, -4); + break; + case 8: + *adr += __MASK(-*adr, -8); + break; + case 16: + *adr += __MASK(-*adr, -16); + break; + default: + break; + } +} + +INT32 OPT_SizeAlignment (INT32 size) +{ + INT32 alignment; + if (size < OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; + } + return alignment; +} + +INT32 OPT_BaseAlignment (OPT_Struct typ) +{ + INT32 alignment; + if (typ->form == 13) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPT_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPT_SizeAlignment(typ->size); + } + return alignment; +} + +void OPT_TypSize (OPT_Struct typ) +{ + INT16 f, c; + INT32 offset, size, base, fbase, off0; + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + if (typ == OPT_undftyp) { + OPM_err(58); + } else if (typ->size == -1) { + f = typ->form; + c = typ->comp; + if (c == 4) { + btyp = typ->BaseTyp; + if (btyp == NIL) { + offset = 0; + base = 1; + } else { + OPT_TypSize(btyp); + offset = btyp->size - __ASHR(btyp->sysflag, 8); + base = btyp->align; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + btyp = fld->typ; + OPT_TypSize(btyp); + size = btyp->size; + fbase = OPT_BaseAlignment(btyp); + OPT_Align(&offset, fbase); + fld->adr = offset; + offset += size; + if (fbase > base) { + base = fbase; + } + fld = fld->link; + } + off0 = offset; + if (offset == 0) { + offset = 1; + } + OPT_Align(&offset, base); + if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { + OPT_recno += 1; + base += __ASHL(OPT_recno, 16); + } + typ->size = offset; + typ->align = base; + typ->sysflag = __MASK(typ->sysflag, -256) + __SHORT(__ASHL(offset - off0, 8), 32768); + } else if (c == 2) { + OPT_TypSize(typ->BaseTyp); + typ->size = typ->n * typ->BaseTyp->size; + } else if (f == 11) { + typ->size = OPM_AddressSize; + if (typ->BaseTyp == OPT_undftyp) { + OPM_Mark(128, typ->n); + } else { + OPT_TypSize(typ->BaseTyp); + } + } else if (f == 12) { + typ->size = OPM_AddressSize; + } else if (c == 3) { + btyp = typ->BaseTyp; + OPT_TypSize(btyp); + if (btyp->comp == 3) { + typ->size = btyp->size + 4; + } else { + typ->size = 8; + } + } + } +} + +OPT_Const OPT_NewConst (void) +{ + OPT_Const const_ = NIL; + __NEW(const_, OPT_ConstDesc); + return const_; +} + +OPT_Object OPT_NewObj (void) +{ + OPT_Object obj = NIL; + __NEW(obj, OPT_ObjDesc); + obj->typ = NIL; + obj->conval = NIL; + obj->comment = NIL; + obj->name[0] = 0x00; + return obj; +} + +OPT_Struct OPT_NewStr (INT8 form, INT8 comp) +{ + OPT_Struct typ = NIL; + __NEW(typ, OPT_StrDesc); + typ->form = form; + typ->comp = comp; + typ->ref = 255; + if (form != 0) { + typ->txtpos = OPM_errpos; + } + typ->size = -1; + typ->BaseTyp = OPT_undftyp; + return typ; +} + +OPT_Node OPT_NewNode (INT8 class) +{ + OPT_Node node = NIL; + __NEW(node, OPT_NodeDesc); + node->class = class; + return node; +} + +OPT_ConstExt OPT_NewExt (void) +{ + OPT_ConstExt ext = NIL; + ext = __NEWARR(NIL, 1, 1, 1, 0, 256); + return ext; +} + +void OPT_OpenScope (INT8 level, OPT_Object owner) +{ + OPT_Object head = NIL; + head = OPT_NewObj(); + head->mode = 12; + head->mnolev = level; + head->link = owner; + if (owner != NIL) { + owner->scope = head; + } + head->left = OPT_topScope; + head->right = NIL; + head->scope = NIL; + OPT_topScope = head; +} + +void OPT_CloseScope (void) +{ + OPT_topScope = OPT_topScope->left; +} + +void OPT_Init (OPS_Name name, UINT32 opt) +{ + OPT_topScope = OPT_universe; + OPT_OpenScope(0, NIL); + OPT_SYSimported = 0; + __MOVE(name, OPT_SelfName, 256); + __MOVE(name, OPT_topScope->name, 256); + OPT_GlbMod[0] = OPT_topScope; + OPT_nofGmod = 1; + OPT_newsf = __IN(4, opt, 32); + OPT_findpc = __IN(8, opt, 32); + OPT_extsf = OPT_newsf || __IN(9, opt, 32); + OPT_sfpresent = 1; + __NEW(OPT_Links, OPT_LinkDesc); + __MOVE(name, OPT_Links->name, 256); +} + +void OPT_Close (void) +{ + INT16 i; + OPT_CloseScope(); + i = 0; + while (i < 64) { + OPT_GlbMod[__X(i, 64)] = NIL; + i += 1; + } + i = 14; + while (i < 255) { + OPT_impCtxt.ref[__X(i, 255)] = NIL; + OPT_impCtxt.old[__X(i, 255)] = NIL; + i += 1; + } +} + +void OPT_FindImport (OPT_Object mod, OPT_Object *res) +{ + OPT_Object obj = NIL; + obj = mod->scope; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + if ((obj->mode == 5 && obj->vis == 0)) { + obj = NIL; + } else { + obj->used = 1; + } + break; + } + } + *res = obj; +} + +void OPT_Find (OPT_Object *res) +{ + OPT_Object obj = NIL, head = NIL; + head = OPT_topScope; + for (;;) { + obj = head->right; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + break; + } + } + if (obj != NIL) { + break; + } + head = head->left; + if (head == NIL) { + break; + } + } + *res = obj; +} + +void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res) +{ + OPT_Object obj = NIL; + while (typ != NIL) { + obj = typ->link; + while (obj != NIL) { + if (__STRCMP(name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(name, obj->name) > 0) { + obj = obj->right; + } else { + *res = obj; + return; + } + } + typ = typ->BaseTyp; + } + *res = NIL; +} + +void OPT_Insert (OPS_Name name, OPT_Object *obj) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + INT8 mnolev; + CHAR commentText[256]; + INT16 j; + ob0 = OPT_topScope; + ob1 = ob0->right; + left = 0; + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob0->right; + left = 0; + } else { + OPT_err(1); + ob0 = ob1; + ob1 = ob0->right; + } + } else { + ob1 = OPT_NewObj(); + ob1->leaf = 1; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + __COPY(name, ob1->name, 256); + mnolev = OPT_topScope->mnolev; + ob1->mnolev = mnolev; + OPM_GetComment((void*)commentText, 256); + if (commentText[0] != 0x00) { + ob1->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((j < 255 && commentText[__X(j, 256)] != 0x00)) { + (*ob1->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*ob1->comment)[__X(j, 256)] = 0x00; + } + break; + } + } + *obj = ob1; +} + +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_FPrint(&*fp, (INT16)ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_DebugStruct (OPT_Struct btyp) +{ + OPM_LogWLn(); + if (btyp == NIL) { + OPM_LogWStr((CHAR*)"btyp is nil", 12); + OPM_LogWLn(); + } + OPM_LogWStr((CHAR*)"btyp^.strobji^.name = ", 23); + OPM_LogWStr(btyp->strobj->name, 256); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.form = ", 14); + OPM_LogWNum(btyp->form, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.comp = ", 14); + OPM_LogWNum(btyp->comp, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.mno = ", 13); + OPM_LogWNum(btyp->mno, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.extlev = ", 16); + OPM_LogWNum(btyp->extlev, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.size = ", 14); + OPM_LogWNum(btyp->size, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.align = ", 15); + OPM_LogWNum(btyp->align, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.txtpos = ", 16); + OPM_LogWNum(btyp->txtpos, 0); + OPM_LogWLn(); +} + +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par) +{ + OPT_IdFPrint(result); + OPM_FPrint(&*fp, result->idfp); + while (par != NIL) { + OPM_FPrint(&*fp, par->mode); + OPT_IdFPrint(par->typ); + OPM_FPrint(&*fp, par->typ->idfp); + par = par->link; + } +} + +void OPT_IdFPrint (OPT_Struct typ) +{ + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL; + INT32 idfp; + INT16 f, c; + if (!typ->idfpdone) { + typ->idfpdone = 1; + idfp = 0; + f = typ->form; + OPM_FPrint(&idfp, f); + if (__IN(f, 0x90, 32)) { + OPM_FPrint(&idfp, typ->size); + } + c = typ->comp; + OPM_FPrint(&idfp, c); + btyp = typ->BaseTyp; + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_FPrintName(&idfp, (void*)OPT_GlbMod[__X(typ->mno, 64)]->name, 256); + OPT_FPrintName(&idfp, (void*)strobj->name, 256); + } + if ((f == 11 || (c == 4 && btyp != NIL)) || c == 3) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + } else if (c == 2) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + OPM_FPrint(&idfp, typ->n); + } else if (f == 12) { + OPT_FPrintSign(&idfp, btyp, typ->link); + } + typ->idfp = idfp; + } +} + +static struct FPrintStr__15 { + INT32 *pbfp, *pvfp; + struct FPrintStr__15 *lnk; +} *FPrintStr__15_s; + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void FPrintTProcs__20 (OPT_Object obj); + +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + FPrintFlds__16(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + FPrintHdFld__18(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + FPrintHdFld__18(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_FPrint(&*FPrintStr__15_s->pvfp, 11); + OPM_FPrint(&*FPrintStr__15_s->pvfp, adr); + OPT_nofhdfld += 1; + } +} + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->vis); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)fld->name, 256); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->adr); + OPT_FPrintStr(fld->typ); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->typ->pbfp); + OPM_FPrint(&*FPrintStr__15_s->pvfp, fld->typ->pvfp); + } else { + FPrintHdFld__18(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void FPrintTProcs__20 (OPT_Object obj) +{ + if (obj != NIL) { + FPrintTProcs__20(obj->left); + if (obj->mode == 13) { + if (obj->vis != 0) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, 13); + OPM_FPrint(&*FPrintStr__15_s->pbfp, __ASHR(obj->adr, 16)); + OPT_FPrintSign(&*FPrintStr__15_s->pbfp, obj->typ, obj->link); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)obj->name, 256); + } + } + FPrintTProcs__20(obj->right); + } +} + +void OPT_FPrintStr (OPT_Struct typ) +{ + INT16 f, c; + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL, bstrobj = NIL; + INT32 pbfp, pvfp; + struct FPrintStr__15 _s; + _s.pbfp = &pbfp; + _s.pvfp = &pvfp; + _s.lnk = FPrintStr__15_s; + FPrintStr__15_s = &_s; + if (!typ->fpdone) { + OPT_IdFPrint(typ); + pbfp = typ->idfp; + if (typ->sysflag != 0) { + OPM_FPrint(&pbfp, typ->sysflag); + } + pvfp = pbfp; + typ->pbfp = pbfp; + typ->pvfp = pvfp; + typ->fpdone = 1; + f = typ->form; + c = typ->comp; + btyp = typ->BaseTyp; + if (f == 11) { + strobj = typ->strobj; + bstrobj = btyp->strobj; + if (((strobj == NIL || strobj->name[0] == 0x00) || bstrobj == NIL) || bstrobj->name[0] == 0x00) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + pvfp = pbfp; + } + } else if (f == 12) { + } else if (__IN(c, 0x0c, 32)) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pvfp); + pvfp = pbfp; + } else { + if (btyp != NIL) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + OPM_FPrint(&pvfp, btyp->pvfp); + } + OPM_FPrint(&pvfp, typ->size); + OPM_FPrint(&pvfp, typ->align); + OPM_FPrint(&pvfp, typ->n); + OPT_nofhdfld = 0; + FPrintFlds__16(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(225, typ->txtpos); + } + FPrintTProcs__20(typ->link); + OPM_FPrint(&pvfp, pbfp); + strobj = typ->strobj; + if (strobj == NIL || strobj->name[0] == 0x00) { + pbfp = pvfp; + } + } + typ->pbfp = pbfp; + typ->pvfp = pvfp; + } + FPrintStr__15_s = _s.lnk; +} + +void OPT_FPrintObj (OPT_Object obj) +{ + INT32 fprint; + INT16 f, m; + REAL rval; + OPT_ConstExt ext = NIL; + if (!obj->fpdone) { + fprint = 0; + obj->fpdone = 1; + OPM_FPrint(&fprint, obj->mode); + if (obj->mode == 3) { + f = obj->typ->form; + OPM_FPrint(&fprint, f); + switch (f) { + case 2: case 3: case 4: + OPM_FPrint(&fprint, obj->conval->intval); + break; + case 7: + OPM_FPrintSet(&fprint, obj->conval->setval); + break; + case 5: + rval = obj->conval->realval; + OPM_FPrintReal(&fprint, rval); + break; + case 6: + OPM_FPrintLReal(&fprint, obj->conval->realval); + break; + case 8: + OPT_FPrintName(&fprint, (void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } + } else if (obj->mode == 1) { + OPM_FPrint(&fprint, obj->vis); + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } else if (__IN(obj->mode, 0x0480, 32)) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + } else if (obj->mode == 9) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + ext = obj->conval->ext; + m = (INT16)(*ext)[0]; + f = 1; + OPM_FPrint(&fprint, m); + while (f <= m) { + OPM_FPrint(&fprint, (INT16)(*ext)[__X(f, 256)]); + f += 1; + } + } else if (obj->mode == 5) { + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } + obj->fprint = fprint; + } +} + +void OPT_FPrintErr (OPT_Object obj, INT16 errcode) +{ + INT16 i, j; + CHAR ch; + if (obj->mnolev != 0) { + __COPY(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, OPM_objname, 64); + i = 0; + while (OPM_objname[__X(i, 64)] != 0x00) { + i += 1; + } + OPM_objname[__X(i, 64)] = '.'; + j = 0; + i += 1; + do { + ch = obj->name[__X(j, 256)]; + OPM_objname[__X(i, 64)] = ch; + j += 1; + i += 1; + } while (!(ch == 0x00)); + } else { + __COPY(obj->name, OPM_objname, 64); + } + if (errcode == 249) { + if (OPM_noerr) { + OPT_err(errcode); + } + } else if (errcode == 253) { + if ((((!OPT_symNew && !OPT_symExtended)) && !OPT_extsf)) { + OPT_err(errcode); + } + OPT_symExtended = 1; + } else { + if ((!OPT_symNew && !OPT_newsf)) { + OPT_err(errcode); + } + OPT_symNew = 1; + } +} + +void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + if (*root == NIL) { + *root = obj; + *old = NIL; + } else { + ob0 = *root; + ob1 = ob0->right; + left = 0; + if (__STRCMP(obj->name, ob0->name) < 0) { + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(obj->name, ob0->name) > 0) { + ob1 = ob0->right; + left = 0; + } else { + *old = ob0; + return; + } + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(obj->name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob1->left; + left = 1; + } else if (__STRCMP(obj->name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob1->right; + left = 0; + } else { + *old = ob1; + break; + } + } else { + ob1 = obj; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + *old = NIL; + break; + } + } + } +} + +static void OPT_InName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + OPM_SymRCh(&ch); + name[__X(i, name__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_InMod (INT8 *mno) +{ + OPT_Object head = NIL; + OPS_Name name; + INT32 mn; + INT8 i; + mn = OPM_SymRInt(); + if (mn == 0) { + *mno = OPT_impCtxt.glbmno[0]; + } else { + if (mn == 16) { + OPT_InName((void*)name, 256); + if ((__STRCMP(name, OPT_SelfName) == 0 && !OPT_impCtxt.self)) { + OPT_err(154); + } + i = 0; + while ((i < OPT_nofGmod && __STRCMP(name, OPT_GlbMod[__X(i, 64)]->name) != 0)) { + i += 1; + } + if (i < OPT_nofGmod) { + *mno = i; + } else { + head = OPT_NewObj(); + head->mode = 12; + __COPY(name, head->name, 256); + *mno = OPT_nofGmod; + head->mnolev = -*mno; + if (OPT_nofGmod < 64) { + OPT_GlbMod[__X(*mno, 64)] = head; + OPT_nofGmod += 1; + } else { + OPT_err(227); + } + } + OPT_impCtxt.glbmno[__X(OPT_impCtxt.nofm, 64)] = *mno; + OPT_impCtxt.nofm += 1; + } else { + *mno = OPT_impCtxt.glbmno[__X(-mn, 64)]; + } + } +} + +static void OPT_InLinks (void) +{ + OPS_Name linkname; + OPT_Link l = NIL; + OPT_InName((void*)linkname, 256); + while (linkname[0] != 0x00) { + l = OPT_Links; + while ((l != NIL && __STRCMP(l->name, linkname) != 0)) { + l = l->next; + } + if (l == NIL) { + l = OPT_Links; + __NEW(OPT_Links, OPT_LinkDesc); + OPT_Links->next = l; + __MOVE(linkname, OPT_Links->name, 256); + } + OPT_InName((void*)linkname, 256); + } +} + +static void OPT_InConstant (INT32 f, OPT_Const conval) +{ + CHAR ch; + INT16 i; + OPT_ConstExt ext = NIL; + REAL rval; + switch (f) { + case 1: case 3: case 2: + OPM_SymRCh(&ch); + conval->intval = (INT16)ch; + break; + case 4: + conval->intval = OPM_SymRInt(); + break; + case 7: + OPM_SymRSet(&conval->setval); + break; + case 5: + OPM_SymRReal(&rval); + conval->realval = rval; + conval->intval = -1; + break; + case 6: + OPM_SymRLReal(&conval->realval); + conval->intval = -1; + break; + case 8: + ext = OPT_NewExt(); + conval->ext = ext; + i = 0; + do { + OPM_SymRCh(&ch); + (*ext)[__X(i, 256)] = ch; + i += 1; + } while (!(ch == 0x00)); + conval->intval2 = i; + conval->intval = -1; + break; + case 9: + conval->intval = 0; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", 37); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } +} + +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par) +{ + OPT_Object last = NIL, new = NIL; + INT32 tag; + OPT_InStruct(&*res); + tag = OPM_SymRInt(); + last = NIL; + while (tag != 18) { + if (tag < 0 || tag > 100) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag value in InSign: ", 37); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return; + } + new = OPT_NewObj(); + new->mnolev = -mno; + if (last == NIL) { + *par = new; + } else { + last->link = new; + } + if (tag == 23) { + new->mode = 1; + } else { + new->mode = 2; + } + OPT_InStruct(&new->typ); + new->adr = OPM_SymRInt(); + OPT_InName((void*)new->name, 256); + last = new; + tag = OPM_SymRInt(); + } +} + +static OPT_Object OPT_InFld (void) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + if (tag <= 26) { + obj->mode = 4; + if (tag == 26) { + obj->vis = 2; + } else { + obj->vis = 1; + } + OPT_InStruct(&obj->typ); + OPT_InName((void*)obj->name, 256); + obj->adr = OPM_SymRInt(); + } else { + obj->mode = 4; + if (tag == 27) { + __MOVE("@ptr", obj->name, 5); + } else { + __MOVE("@proc", obj->name, 6); + } + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = OPM_SymRInt(); + } + return obj; +} + +static OPT_Object OPT_InTProc (INT8 mno) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + obj->mnolev = -mno; + if (tag == 29) { + obj->mode = 13; + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + obj->vis = 1; + OPT_InName((void*)obj->name, 256); + obj->adr = __ASHL(OPM_SymRInt(), 16); + } else { + obj->mode = 13; + __MOVE("@tproc", obj->name, 7); + obj->link = OPT_NewObj(); + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = __ASHL(OPM_SymRInt(), 16); + } + return obj; +} + +static OPT_Struct OPT_InTyp (INT32 tag) +{ + if (tag == 4) { + return OPT_IntType(OPM_SymRInt()); + } else if (tag == 7) { + return OPT_SetType(OPM_SymRInt()); + } else { + return OPT_impCtxt.ref[__X(tag, 255)]; + } + __RETCHK; +} + +static void OPT_InStruct (OPT_Struct *typ) +{ + INT8 mno; + INT16 ref; + INT32 tag; + OPS_Name name; + OPT_Struct t = NIL; + OPT_Object obj = NIL, last = NIL, fld = NIL, old = NIL, dummy = NIL; + tag = OPM_SymRInt(); + if (tag != 34) { + *typ = OPT_InTyp(-tag); + } else { + ref = OPT_impCtxt.nofr; + OPT_impCtxt.nofr += 1; + if (ref < OPT_impCtxt.minr) { + OPT_impCtxt.minr = ref; + } + OPT_InMod(&mno); + OPT_InName((void*)name, 256); + obj = OPT_NewObj(); + if (name[0] == 0x00) { + if (OPT_impCtxt.self) { + old = NIL; + } else { + __MOVE("@", obj->name, 2); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + obj->name[0] = 0x00; + } + *typ = OPT_NewStr(0, 1); + } else { + __MOVE(name, obj->name, 256); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (old != NIL) { + OPT_FPrintObj(old); + OPT_impCtxt.pvfp[__X(ref, 255)] = old->typ->pvfp; + if (OPT_impCtxt.self) { + *typ = OPT_NewStr(0, 1); + } else { + *typ = old->typ; + (*typ)->link = NIL; + (*typ)->sysflag = 0; + (*typ)->fpdone = 0; + (*typ)->idfpdone = 0; + } + } else { + *typ = OPT_NewStr(0, 1); + } + } + OPT_impCtxt.ref[__X(ref, 255)] = *typ; + OPT_impCtxt.old[__X(ref, 255)] = old; + (*typ)->ref = ref + 255; + (*typ)->mno = mno; + (*typ)->allocated = 1; + (*typ)->strobj = obj; + obj->mode = 5; + obj->typ = *typ; + obj->mnolev = -mno; + obj->vis = 0; + tag = OPM_SymRInt(); + if (tag == 35) { + (*typ)->sysflag = __SHORTF(OPM_SymRInt(), 32768); + tag = OPM_SymRInt(); + } + switch (tag) { + case 36: + (*typ)->form = 11; + (*typ)->size = OPM_AddressSize; + (*typ)->n = 0; + OPT_InStruct(&(*typ)->BaseTyp); + break; + case 37: + (*typ)->form = 13; + (*typ)->comp = 2; + OPT_InStruct(&(*typ)->BaseTyp); + (*typ)->n = OPM_SymRInt(); + OPT_TypSize(*typ); + break; + case 38: + (*typ)->form = 13; + (*typ)->comp = 3; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + OPT_TypSize(*typ); + break; + case 39: + (*typ)->form = 13; + (*typ)->comp = 4; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp == OPT_notyp) { + (*typ)->BaseTyp = NIL; + } + (*typ)->extlev = 0; + t = (*typ)->BaseTyp; + while (t != NIL) { + (*typ)->extlev += 1; + t = t->BaseTyp; + } + (*typ)->size = OPM_SymRInt(); + (*typ)->align = OPM_SymRInt(); + (*typ)->n = OPM_SymRInt(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + last = NIL; + while ((OPT_impCtxt.nextTag >= 25 && OPT_impCtxt.nextTag <= 28)) { + fld = OPT_InFld(); + fld->mnolev = -mno; + if (last != NIL) { + last->link = fld; + } + last = fld; + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + while (OPT_impCtxt.nextTag != 18) { + fld = OPT_InTProc(mno); + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + break; + case 40: + (*typ)->form = 12; + (*typ)->size = OPM_AddressSize; + OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", 35); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + break; + } + if (ref == OPT_impCtxt.minr) { + while (ref < OPT_impCtxt.nofr) { + t = OPT_InTyp(ref); + OPT_FPrintStr(t); + obj = t->strobj; + if (obj->name[0] != 0x00) { + OPT_FPrintObj(obj); + } + old = OPT_impCtxt.old[__X(ref, 255)]; + if (old != NIL) { + t->strobj = old; + if (OPT_impCtxt.self) { + if (old->mnolev < 0) { + if (old->history != 5) { + if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } + } + } else if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } else if (old->vis == 0) { + old->history = 1; + } else { + old->history = 0; + } + } else { + if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 5; + } + if (old->fprint != obj->fprint) { + OPT_FPrintErr(old, 249); + } + } + } else if (OPT_impCtxt.self) { + obj->history = 4; + } else { + obj->history = 1; + } + ref += 1; + } + OPT_impCtxt.minr = 255; + } + } +} + +static OPT_Object OPT_InObj (INT8 mno) +{ + INT16 i, s; + CHAR ch; + OPT_Object obj = NIL, old = NIL; + OPT_Struct typ = NIL; + INT32 tag; + OPT_ConstExt ext = NIL; + OPS_Name commentText; + BOOLEAN hasComment; + INT16 j; + INT32 len; + tag = OPT_impCtxt.nextTag; + hasComment = 0; + while (tag == 41) { + len = OPM_SymRInt(); + if (len < 0) { + len = 0; + } + if (len > 255) { + len = 255; + } + i = 0; + while (i < len) { + OPM_SymRCh(&commentText[__X(i, 256)]); + i += 1; + } + commentText[__X(i, 256)] = 0x00; + hasComment = 1; + tag = OPM_SymRInt(); + } + OPT_impCtxt.nextTag = tag; + if (tag < 0 || tag > 50) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag in InObj: ", 30); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + if (tag == 19) { + OPT_InStruct(&typ); + obj = typ->strobj; + if (!OPT_impCtxt.self) { + obj->vis = 1; + } + } else { + obj = OPT_NewObj(); + obj->mnolev = -mno; + obj->vis = 1; + if (tag <= 11) { + obj->mode = 3; + obj->conval = OPT_NewConst(); + OPT_InConstant(tag, obj->conval); + obj->typ = OPT_InTyp(tag); + } else if ((tag >= 31 && tag <= 33)) { + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + switch (tag) { + case 31: + obj->mode = 7; + break; + case 32: + obj->mode = 10; + break; + case 33: + obj->mode = 9; + ext = OPT_NewExt(); + obj->conval->ext = ext; + s = __SHORTF(OPM_SymRInt(), 32768); + (*ext)[0] = __CHR(s); + i = 1; + while (i <= s) { + OPM_SymRCh(&(*ext)[__X(i, 256)]); + i += 1; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", 32); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + break; + } + } else if (tag == 20) { + obj->mode = 5; + OPT_InStruct(&obj->typ); + } else if (tag == 21 || tag == 22) { + obj->mode = 1; + if (tag == 22) { + obj->vis = 2; + } + OPT_InStruct(&obj->typ); + } else { + OPM_LogWStr((CHAR*)"ERROR: Unexpected tag in InObj: ", 33); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + OPT_InName((void*)obj->name, 256); + } + if ((hasComment && obj != NIL)) { + obj->comment = __NEWARR(NIL, 1, 1, 1, 0, 256); + j = 0; + while ((((j < 255 && j < len)) && commentText[__X(j, 256)] != 0x00)) { + (*obj->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*obj->comment)[__X(j, 256)] = 0x00; + } + OPT_FPrintObj(obj); + if ((obj->mode == 1 && (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00))) { + OPM_FPrint(&OPT_impCtxt.reffp, obj->typ->ref - 255); + } + if (tag != 19) { + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (OPT_impCtxt.self) { + if (old != NIL) { + if (old->vis == 0) { + old->history = 4; + } else { + OPT_FPrintObj(old); + if (obj->fprint != old->fprint) { + old->history = 2; + } else if (obj->typ->pvfp != old->typ->pvfp) { + old->history = 3; + } else { + old->history = 1; + } + } + } else { + obj->history = 4; + } + } + } else { + if (OPT_impCtxt.self) { + if (obj->vis == 0) { + obj->history = 4; + } else if (obj->history == 0) { + obj->history = 1; + } + } + } + return obj; +} + +void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done) +{ + OPT_Object obj = NIL; + INT8 mno; + OPS_Name aliasName__copy; + __DUPARR(aliasName, OPS_Name); + if (__STRCMP(name, "SYSTEM") == 0) { + OPT_SYSimported = 1; + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->mnolev = 0; + obj->scope = OPT_syslink; + obj->typ = OPT_notyp; + } else { + OPT_impCtxt.nofr = 14; + OPT_impCtxt.minr = 255; + OPT_impCtxt.nofm = 0; + OPT_impCtxt.self = __STRCMP(aliasName, "@self") == 0; + OPT_impCtxt.reffp = 0; + if ((OPT_impCtxt.self && __IN(17, OPM_Options, 32))) { + OPM_DeleteSym((void*)name, 256); + *done = 0; + } else { + OPM_OldSym((void*)name, 256, &*done); + } + if (*done) { + OPT_InMod(&mno); + OPT_InLinks(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + while (!OPM_eofSF()) { + obj = OPT_InObj(mno); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->scope = OPT_GlbMod[__X(mno, 64)]->right; + OPT_GlbMod[__X(mno, 64)]->link = obj; + obj->mnolev = -mno; + obj->typ = OPT_notyp; + OPM_CloseOldSym(); + } else if (OPT_impCtxt.self) { + OPT_newsf = 1; + OPT_extsf = 1; + OPT_sfpresent = 0; + } else { + OPT_err(152); + } + } +} + +static void OPT_OutName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_SymWCh(ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_OutMod (INT16 mno) +{ + if (OPT_expCtxt.locmno[__X(mno, 64)] < 0) { + OPM_SymWInt(16); + OPT_expCtxt.locmno[__X(mno, 64)] = OPT_expCtxt.nofm; + OPT_expCtxt.nofm += 1; + OPT_OutName((void*)OPT_GlbMod[__X(mno, 64)]->name, 256); + } else { + OPM_SymWInt(-OPT_expCtxt.locmno[__X(mno, 64)]); + } +} + +static void OPT_OutLinks (void) +{ + OPT_Link l = NIL; + l = OPT_Links; + while (l != NIL) { + OPT_OutName((void*)l->name, 256); + l = l->next; + } + OPM_SymWCh(0x00); +} + +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + OPT_OutFlds(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + OPT_OutHdFld(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + OPT_OutHdFld(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_SymWInt(27); + OPM_SymWInt(adr); + OPT_nofhdfld += 1; + } +} + +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + if (fld->vis == 2) { + OPM_SymWInt(26); + } else { + OPM_SymWInt(25); + } + OPT_OutStr(fld->typ); + OPT_OutName((void*)fld->name, 256); + OPM_SymWInt(fld->adr); + } else { + OPT_OutHdFld(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void OPT_OutSign (OPT_Struct result, OPT_Object par) +{ + OPT_OutStr(result); + while (par != NIL) { + if (par->mode == 1) { + OPM_SymWInt(23); + } else { + OPM_SymWInt(24); + } + OPT_OutStr(par->typ); + OPM_SymWInt(par->adr); + OPT_OutName((void*)par->name, 256); + par = par->link; + } + OPM_SymWInt(18); +} + +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj) +{ + if (obj != NIL) { + OPT_OutTProcs(typ, obj->left); + if (obj->mode == 13) { + if ((((typ->BaseTyp != NIL && __ASHR(obj->adr, 16) < typ->BaseTyp->n)) && obj->vis == 0)) { + OPM_Mark(109, typ->txtpos); + } + if (obj->vis != 0) { + if (obj->vis != 0) { + OPM_SymWInt(29); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } else { + OPM_SymWInt(30); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } + } + } + OPT_OutTProcs(typ, obj->right); + } +} + +static void OPT_OutStr (OPT_Struct typ) +{ + OPT_Object strobj = NIL; + if (typ->ref < OPT_expCtxt.ref) { + OPM_SymWInt(-typ->ref); + if (__IN(typ->ref, 0x90, 32)) { + OPM_SymWInt(typ->size); + } + } else { + OPM_SymWInt(34); + typ->ref = OPT_expCtxt.ref; + OPT_expCtxt.ref += 1; + if (OPT_expCtxt.ref >= 255) { + OPT_err(228); + } + OPT_OutMod(typ->mno); + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_OutName((void*)strobj->name, 256); + switch (strobj->history) { + case 2: + OPT_FPrintErr(strobj, 252); + break; + case 3: + OPT_FPrintErr(strobj, 251); + break; + case 5: + OPT_FPrintErr(strobj, 249); + break; + default: + break; + } + } else { + OPM_SymWCh(0x00); + } + if (typ->sysflag != 0) { + OPM_SymWInt(35); + OPM_SymWInt(typ->sysflag); + } + switch (typ->form) { + case 11: + OPM_SymWInt(36); + OPT_OutStr(typ->BaseTyp); + break; + case 12: + OPM_SymWInt(40); + OPT_OutSign(typ->BaseTyp, typ->link); + break; + case 13: + switch (typ->comp) { + case 2: + OPM_SymWInt(37); + OPT_OutStr(typ->BaseTyp); + OPM_SymWInt(typ->n); + break; + case 3: + OPM_SymWInt(38); + OPT_OutStr(typ->BaseTyp); + break; + case 4: + OPM_SymWInt(39); + if (typ->BaseTyp == NIL) { + OPT_OutStr(OPT_notyp); + } else { + OPT_OutStr(typ->BaseTyp); + } + OPM_SymWInt(typ->size); + OPM_SymWInt(typ->align); + OPM_SymWInt(typ->n); + OPT_nofhdfld = 0; + OPT_OutFlds(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(223, typ->txtpos); + } + OPT_OutTProcs(typ, typ->link); + OPM_SymWInt(18); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", 39); + OPM_LogWNum(typ->comp, 0); + OPM_LogWLn(); + break; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", 39); + OPM_LogWNum(typ->form, 0); + OPM_LogWLn(); + break; + } + } +} + +static void OPT_OutConstant (OPT_Object obj) +{ + INT16 f; + REAL rval; + f = obj->typ->form; + OPM_SymWInt(f); + switch (f) { + case 2: case 3: + OPM_SymWCh(__CHR(obj->conval->intval)); + break; + case 4: + OPM_SymWInt(obj->conval->intval); + OPM_SymWInt(obj->typ->size); + break; + case 7: + OPM_SymWSet(obj->conval->setval); + OPM_SymWInt(obj->typ->size); + break; + case 5: + rval = obj->conval->realval; + OPM_SymWReal(rval); + break; + case 6: + OPM_SymWLReal(obj->conval->realval); + break; + case 8: + OPT_OutName((void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } +} + +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_SymWCh(text[__X(i, text__len)]); + i += 1; + } + OPM_SymWCh(0x00); + __DEL(text); +} + +static void OPT_OutObj (OPT_Object obj) +{ + INT16 i, j; + OPT_ConstExt ext = NIL; + INT16 k, l; + if (obj != NIL) { + OPT_OutObj(obj->left); + if (__IN(obj->mode, 0x06ea, 32)) { + if (obj->comment != NIL) { + OPM_SymWInt(41); + k = 0; + while ((k < 255 && (*obj->comment)[__X(k, 256)] != 0x00)) { + k += 1; + } + OPM_SymWInt(k); + l = 0; + while (l < k) { + OPM_SymWCh((*obj->comment)[__X(l, 256)]); + l += 1; + } + } + if (obj->history == 4) { + OPT_FPrintErr(obj, 250); + } else if (obj->vis != 0) { + switch (obj->history) { + case 0: + OPT_FPrintErr(obj, 253); + break; + case 1: + break; + case 2: + OPT_FPrintErr(obj, 252); + break; + case 3: + OPT_FPrintErr(obj, 251); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", 42); + OPM_LogWNum(obj->history, 0); + OPM_LogWLn(); + break; + } + switch (obj->mode) { + case 3: + OPT_OutConstant(obj); + OPT_OutName((void*)obj->name, 256); + break; + case 5: + if (obj->typ->strobj == obj) { + OPM_SymWInt(19); + OPT_OutStr(obj->typ); + } else { + OPM_SymWInt(20); + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + } + break; + case 1: + if (obj->vis == 2) { + OPM_SymWInt(22); + } else { + OPM_SymWInt(21); + } + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + if (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00) { + OPM_FPrint(&OPT_expCtxt.reffp, obj->typ->ref); + } + break; + case 7: + OPM_SymWInt(31); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 10: + OPM_SymWInt(32); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 9: + OPM_SymWInt(33); + OPT_OutSign(obj->typ, obj->link); + ext = obj->conval->ext; + j = (INT16)(*ext)[0]; + i = 1; + OPM_SymWInt(j); + while (i <= j) { + OPM_SymWCh((*ext)[__X(i, 256)]); + i += 1; + } + OPT_OutName((void*)obj->name, 256); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", 38); + OPM_LogWNum(obj->mode, 0); + OPM_LogWLn(); + break; + } + } + } + OPT_OutObj(obj->right); + } +} + +void OPT_Export (BOOLEAN *ext, BOOLEAN *new) +{ + INT16 i; + INT8 nofmod; + BOOLEAN done; + OPT_symExtended = 0; + OPT_symNew = 0; + nofmod = OPT_nofGmod; + OPT_Import((CHAR*)"@self", OPT_SelfName, &done); + OPT_nofGmod = nofmod; + if (OPM_noerr) { + OPM_NewSym((void*)OPT_SelfName, 256); + if (OPM_noerr) { + OPM_SymWInt(16); + OPT_OutName((void*)OPT_SelfName, 256); + OPT_OutLinks(); + OPT_expCtxt.reffp = 0; + OPT_expCtxt.ref = 14; + OPT_expCtxt.nofm = 1; + OPT_expCtxt.locmno[0] = 0; + i = 1; + while (i < 64) { + OPT_expCtxt.locmno[__X(i, 64)] = -1; + i += 1; + } + OPT_OutObj(OPT_topScope->right); + *ext = (OPT_sfpresent && OPT_symExtended); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); + if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { + *new = 1; + if (!OPT_extsf) { + OPT_err(155); + } + } + OPT_newsf = 0; + OPT_symNew = 0; + if (!OPM_noerr || OPT_findpc) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } +} + +static void OPT_InitStruct (OPT_Struct *typ, INT8 form) +{ + *typ = OPT_NewStr(form, 1); + (*typ)->ref = form; + (*typ)->size = 1; + (*typ)->allocated = 1; + (*typ)->strobj = OPT_NewObj(); + (*typ)->pbfp = form; + (*typ)->pvfp = form; + (*typ)->fpdone = 1; + (*typ)->idfp = form; + (*typ)->idfpdone = 1; +} + +static void OPT_EnterBoolConst (OPS_Name name, INT32 value) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->conval = OPT_NewConst(); + obj->mode = 3; + obj->typ = OPT_booltyp; + obj->conval->intval = value; +} + +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + typ = OPT_NewStr(form, 1); + obj->mode = 5; + obj->typ = typ; + obj->vis = 1; + typ->strobj = obj; + typ->size = size; + typ->ref = form; + typ->allocated = 1; + typ->pbfp = form; + typ->pvfp = form; + typ->fpdone = 1; + typ->idfp = form; + typ->idfpdone = 1; + if (__IN(form, 0x90, 32)) { + OPM_FPrint(&typ->idfp, typ->size); + } + *res = typ; +} + +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 5; + obj->typ = NIL; + obj->vis = 1; + *res = obj; +} + +static void OPT_EnterProc (OPS_Name name, INT16 num) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 8; + obj->typ = OPT_notyp; + obj->adr = num; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPT_topScope); + P(OPT_undftyp); + P(OPT_niltyp); + P(OPT_notyp); + P(OPT_bytetyp); + P(OPT_cpbytetyp); + P(OPT_booltyp); + P(OPT_chartyp); + P(OPT_sinttyp); + P(OPT_inttyp); + P(OPT_linttyp); + P(OPT_hinttyp); + P(OPT_int8typ); + P(OPT_int16typ); + P(OPT_int32typ); + P(OPT_int64typ); + P(OPT_settyp); + P(OPT_set32typ); + P(OPT_set64typ); + P(OPT_realtyp); + P(OPT_lrltyp); + P(OPT_stringtyp); + P(OPT_adrtyp); + P(OPT_sysptrtyp); + P(OPT_sintobj); + P(OPT_intobj); + P(OPT_lintobj); + P(OPT_setobj); + __ENUMP(OPT_GlbMod, 64, P); + P(OPT_universe); + P(OPT_syslink); + __ENUMR(&OPT_impCtxt, OPT_ImpCtxt__typ, 3140, 1, P); + P(OPT_Links); +} + +__TDESC(OPT_ConstDesc, 1, 1) = {__TDFLDS("ConstDesc", 40), {0, -8}}; +__TDESC(OPT_ObjDesc, 1, 7) = {__TDFLDS("ObjDesc", 308), {0, 4, 8, 12, 284, 288, 304, -32}}; +__TDESC(OPT_StrDesc, 1, 3) = {__TDFLDS("StrDesc", 56), {44, 48, 52, -16}}; +__TDESC(OPT_NodeDesc, 1, 6) = {__TDFLDS("NodeDesc", 28), {0, 4, 8, 16, 20, 24, -28}}; +__TDESC(OPT_ImpCtxt, 1, 510) = {__TDFLDS("ImpCtxt", 3140), {16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60, 64, 68, 72, 76, + 80, 84, 88, 92, 96, 100, 104, 108, 112, 116, 120, 124, 128, 132, 136, 140, + 144, 148, 152, 156, 160, 164, 168, 172, 176, 180, 184, 188, 192, 196, 200, 204, + 208, 212, 216, 220, 224, 228, 232, 236, 240, 244, 248, 252, 256, 260, 264, 268, + 272, 276, 280, 284, 288, 292, 296, 300, 304, 308, 312, 316, 320, 324, 328, 332, + 336, 340, 344, 348, 352, 356, 360, 364, 368, 372, 376, 380, 384, 388, 392, 396, + 400, 404, 408, 412, 416, 420, 424, 428, 432, 436, 440, 444, 448, 452, 456, 460, + 464, 468, 472, 476, 480, 484, 488, 492, 496, 500, 504, 508, 512, 516, 520, 524, + 528, 532, 536, 540, 544, 548, 552, 556, 560, 564, 568, 572, 576, 580, 584, 588, + 592, 596, 600, 604, 608, 612, 616, 620, 624, 628, 632, 636, 640, 644, 648, 652, + 656, 660, 664, 668, 672, 676, 680, 684, 688, 692, 696, 700, 704, 708, 712, 716, + 720, 724, 728, 732, 736, 740, 744, 748, 752, 756, 760, 764, 768, 772, 776, 780, + 784, 788, 792, 796, 800, 804, 808, 812, 816, 820, 824, 828, 832, 836, 840, 844, + 848, 852, 856, 860, 864, 868, 872, 876, 880, 884, 888, 892, 896, 900, 904, 908, + 912, 916, 920, 924, 928, 932, 936, 940, 944, 948, 952, 956, 960, 964, 968, 972, + 976, 980, 984, 988, 992, 996, 1000, 1004, 1008, 1012, 1016, 1020, 1024, 1028, 1032, 1036, + 1040, 1044, 1048, 1052, 1056, 1060, 1064, 1068, 1072, 1076, 1080, 1084, 1088, 1092, 1096, 1100, + 1104, 1108, 1112, 1116, 1120, 1124, 1128, 1132, 1136, 1140, 1144, 1148, 1152, 1156, 1160, 1164, + 1168, 1172, 1176, 1180, 1184, 1188, 1192, 1196, 1200, 1204, 1208, 1212, 1216, 1220, 1224, 1228, + 1232, 1236, 1240, 1244, 1248, 1252, 1256, 1260, 1264, 1268, 1272, 1276, 1280, 1284, 1288, 1292, + 1296, 1300, 1304, 1308, 1312, 1316, 1320, 1324, 1328, 1332, 1336, 1340, 1344, 1348, 1352, 1356, + 1360, 1364, 1368, 1372, 1376, 1380, 1384, 1388, 1392, 1396, 1400, 1404, 1408, 1412, 1416, 1420, + 1424, 1428, 1432, 1436, 1440, 1444, 1448, 1452, 1456, 1460, 1464, 1468, 1472, 1476, 1480, 1484, + 1488, 1492, 1496, 1500, 1504, 1508, 1512, 1516, 1520, 1524, 1528, 1532, 1536, 1540, 1544, 1548, + 1552, 1556, 1560, 1564, 1568, 1572, 1576, 1580, 1584, 1588, 1592, 1596, 1600, 1604, 1608, 1612, + 1616, 1620, 1624, 1628, 1632, 1636, 1640, 1644, 1648, 1652, 1656, 1660, 1664, 1668, 1672, 1676, + 1680, 1684, 1688, 1692, 1696, 1700, 1704, 1708, 1712, 1716, 1720, 1724, 1728, 1732, 1736, 1740, + 1744, 1748, 1752, 1756, 1760, 1764, 1768, 1772, 1776, 1780, 1784, 1788, 1792, 1796, 1800, 1804, + 1808, 1812, 1816, 1820, 1824, 1828, 1832, 1836, 1840, 1844, 1848, 1852, 1856, 1860, 1864, 1868, + 1872, 1876, 1880, 1884, 1888, 1892, 1896, 1900, 1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, + 1936, 1940, 1944, 1948, 1952, 1956, 1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, + 2000, 2004, 2008, 2012, 2016, 2020, 2024, 2028, 2032, 2036, 2040, 2044, 2048, 2052, -2044}}; +__TDESC(OPT_ExpCtxt, 1, 0) = {__TDFLDS("ExpCtxt", 72), {-4}}; +__TDESC(OPT_LinkDesc, 1, 1) = {__TDFLDS("LinkDesc", 260), {256, -8}}; + +export void *OPT__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __REGMOD("OPT", EnumPtrs); + __REGCMD("Close", OPT_Close); + __REGCMD("CloseScope", OPT_CloseScope); + __REGCMD("InitRecno", OPT_InitRecno); + __INITYP(OPT_ConstDesc, OPT_ConstDesc, 0); + __INITYP(OPT_ObjDesc, OPT_ObjDesc, 0); + __INITYP(OPT_StrDesc, OPT_StrDesc, 0); + __INITYP(OPT_NodeDesc, OPT_NodeDesc, 0); + __INITYP(OPT_ImpCtxt, OPT_ImpCtxt, 0); + __INITYP(OPT_ExpCtxt, OPT_ExpCtxt, 0); + __INITYP(OPT_LinkDesc, OPT_LinkDesc, 0); +/* BEGIN */ + OPT_topScope = NIL; + OPT_OpenScope(0, NIL); + OPM_errpos = 0; + OPT_InitStruct(&OPT_undftyp, 0); + OPT_undftyp->BaseTyp = OPT_undftyp; + OPT_InitStruct(&OPT_notyp, 10); + OPT_InitStruct(&OPT_stringtyp, 8); + OPT_InitStruct(&OPT_niltyp, 9); + OPT_EnterTyp((CHAR*)"BYTE", 1, 1, &OPT_bytetyp); + OPT_EnterTyp((CHAR*)"PTR", 11, -1, &OPT_sysptrtyp); + OPT_EnterTyp((CHAR*)"ADDRESS", 4, -1, &OPT_adrtyp); + OPT_EnterTyp((CHAR*)"INT8", 4, 1, &OPT_int8typ); + OPT_EnterTyp((CHAR*)"INT16", 4, 2, &OPT_int16typ); + OPT_EnterTyp((CHAR*)"INT32", 4, 4, &OPT_int32typ); + OPT_EnterTyp((CHAR*)"INT64", 4, 8, &OPT_int64typ); + OPT_EnterTyp((CHAR*)"SET32", 7, 4, &OPT_set32typ); + OPT_EnterTyp((CHAR*)"SET64", 7, 8, &OPT_set64typ); + OPT_EnterProc((CHAR*)"ADR", 20); + OPT_EnterProc((CHAR*)"CC", 21); + OPT_EnterProc((CHAR*)"LSH", 22); + OPT_EnterProc((CHAR*)"ROT", 23); + OPT_EnterProc((CHAR*)"GET", 24); + OPT_EnterProc((CHAR*)"PUT", 25); + OPT_EnterProc((CHAR*)"GETREG", 26); + OPT_EnterProc((CHAR*)"PUTREG", 27); + OPT_EnterProc((CHAR*)"BIT", 28); + OPT_EnterProc((CHAR*)"VAL", 29); + OPT_EnterProc((CHAR*)"NEW", 30); + OPT_EnterProc((CHAR*)"MOVE", 31); + OPT_syslink = OPT_topScope->right; + OPT_universe = OPT_topScope; + OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, 1, &OPT_booltyp); + OPT_EnterTyp((CHAR*)"CHAR", 3, 1, &OPT_chartyp); + OPT_EnterTyp((CHAR*)"REAL", 5, 4, &OPT_realtyp); + OPT_EnterTyp((CHAR*)"LONGREAL", 6, 8, &OPT_lrltyp); + OPT_EnterTyp((CHAR*)"HUGEINT", 4, 8, &OPT_hinttyp); + OPT_EnterTyp((CHAR*)"BYTE@", 4, 1, &OPT_cpbytetyp); + OPT_EnterTypeAlias((CHAR*)"SHORTINT", &OPT_sintobj); + OPT_EnterTypeAlias((CHAR*)"INTEGER", &OPT_intobj); + OPT_EnterTypeAlias((CHAR*)"LONGINT", &OPT_lintobj); + OPT_EnterTypeAlias((CHAR*)"SET", &OPT_setobj); + OPT_EnterBoolConst((CHAR*)"FALSE", 0); + OPT_EnterBoolConst((CHAR*)"TRUE", 1); + OPT_EnterProc((CHAR*)"HALT", 0); + OPT_EnterProc((CHAR*)"NEW", 1); + OPT_EnterProc((CHAR*)"ABS", 2); + OPT_EnterProc((CHAR*)"CAP", 3); + OPT_EnterProc((CHAR*)"ORD", 4); + OPT_EnterProc((CHAR*)"ENTIER", 5); + OPT_EnterProc((CHAR*)"ODD", 6); + OPT_EnterProc((CHAR*)"MIN", 7); + OPT_EnterProc((CHAR*)"MAX", 8); + OPT_EnterProc((CHAR*)"CHR", 9); + OPT_EnterProc((CHAR*)"SHORT", 10); + OPT_EnterProc((CHAR*)"LONG", 11); + OPT_EnterProc((CHAR*)"SIZE", 12); + OPT_EnterProc((CHAR*)"INC", 13); + OPT_EnterProc((CHAR*)"DEC", 14); + OPT_EnterProc((CHAR*)"INCL", 15); + OPT_EnterProc((CHAR*)"EXCL", 16); + OPT_EnterProc((CHAR*)"LEN", 17); + OPT_EnterProc((CHAR*)"COPY", 18); + OPT_EnterProc((CHAR*)"ASH", 19); + OPT_EnterProc((CHAR*)"ASSERT", 32); + OPT_impCtxt.ref[0] = OPT_undftyp; + OPT_impCtxt.ref[1] = OPT_bytetyp; + OPT_impCtxt.ref[2] = OPT_booltyp; + OPT_impCtxt.ref[3] = OPT_chartyp; + OPT_impCtxt.ref[4] = OPT_int32typ; + OPT_impCtxt.ref[5] = OPT_realtyp; + OPT_impCtxt.ref[6] = OPT_lrltyp; + OPT_impCtxt.ref[7] = OPT_settyp; + OPT_impCtxt.ref[8] = OPT_stringtyp; + OPT_impCtxt.ref[9] = OPT_niltyp; + OPT_impCtxt.ref[10] = OPT_notyp; + OPT_impCtxt.ref[11] = OPT_sysptrtyp; + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPT.h b/bootstrap/windows-48/OPT.h new file mode 100644 index 00000000..cf456af5 --- /dev/null +++ b/bootstrap/windows-48/OPT.h @@ -0,0 +1,128 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPT__h +#define OPT__h + +#include "SYSTEM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused; + char _prvt0[4]; + INT32 idfp; + char _prvt1[8]; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +import OPT_Object OPT_topScope; +import OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +import OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +import INT8 OPT_nofGmod; +import OPT_Object OPT_GlbMod[64]; +import OPS_Name OPT_SelfName; +import BOOLEAN OPT_SYSimported; +import OPT_Link OPT_Links; + +import ADDRESS *OPT_ConstDesc__typ; +import ADDRESS *OPT_ObjDesc__typ; +import ADDRESS *OPT_StrDesc__typ; +import ADDRESS *OPT_NodeDesc__typ; +import ADDRESS *OPT_LinkDesc__typ; + +import void OPT_Align (INT32 *adr, INT32 base); +import INT32 OPT_BaseAlignment (OPT_Struct typ); +import void OPT_Close (void); +import void OPT_CloseScope (void); +import void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +import void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +import void OPT_FPrintObj (OPT_Object obj); +import void OPT_FPrintStr (OPT_Struct typ); +import void OPT_Find (OPT_Object *res); +import void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +import void OPT_FindImport (OPT_Object mod, OPT_Object *res); +import void OPT_IdFPrint (OPT_Struct typ); +import void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +import void OPT_Init (OPS_Name name, UINT32 opt); +import void OPT_InitRecno (void); +import void OPT_Insert (OPS_Name name, OPT_Object *obj); +import void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +import INT16 OPT_IntSize (INT64 n); +import OPT_Struct OPT_IntType (INT32 size); +import OPT_Const OPT_NewConst (void); +import OPT_ConstExt OPT_NewExt (void); +import OPT_Node OPT_NewNode (INT8 class); +import OPT_Object OPT_NewObj (void); +import OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +import void OPT_OpenScope (INT8 level, OPT_Object owner); +import OPT_Struct OPT_SetType (INT32 size); +import OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +import INT32 OPT_SizeAlignment (INT32 size); +import void OPT_TypSize (OPT_Struct typ); +import void *OPT__init(void); + + +#endif // OPT diff --git a/bootstrap/windows-48/OPV.c b/bootstrap/windows-48/OPV.c new file mode 100644 index 00000000..0425b2e0 --- /dev/null +++ b/bootstrap/windows-48/OPV.c @@ -0,0 +1,1585 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPC.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +typedef + struct OPV_ExitInfo { + INT16 level, label; + } OPV_ExitInfo; + + +static INT16 OPV_stamp; +static OPV_ExitInfo OPV_exit; +static INT16 OPV_nofExitLabels; + +export ADDRESS *OPV_ExitInfo__typ; + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp); +export void OPV_AdrAndSize (OPT_Object topScope); +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec); +static void OPV_DefineTDescs (OPT_Node n); +static void OPV_Entier (OPT_Node n, INT16 prec); +static void OPV_GetTProcNum (OPT_Object obj); +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc); +static BOOLEAN OPV_ImplicitReturn (OPT_Node n); +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim); +export void OPV_Init (void); +static void OPV_InitTDescs (OPT_Node n); +static void OPV_Len (OPT_Node n, INT64 dim); +export void OPV_Module (OPT_Node prog); +static void OPV_NewArr (OPT_Node d, OPT_Node x); +static void OPV_ParIntLiteral (INT64 n, INT32 size); +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp); +static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (OPT_Node n, INT32 to); +static void OPV_Stamp (OPS_Name s); +static OPT_Object OPV_SuperProc (OPT_Node n); +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); +static void OPV_TraverseRecord (OPT_Struct typ); +static void OPV_TypeOf (OPT_Node n); +static void OPV_design (OPT_Node n, INT16 prec); +static void OPV_expr (OPT_Node n, INT16 prec); +static void OPV_stat (OPT_Node n, OPT_Object outerProc); + + +void OPV_Init (void) +{ + OPV_stamp = 0; + OPV_nofExitLabels = 0; +} + +static void OPV_GetTProcNum (OPT_Object obj) +{ + INT32 oldPos; + OPT_Struct typ = NIL; + OPT_Object redef = NIL; + oldPos = OPM_errpos; + OPM_errpos = obj->scope->adr; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(obj->name, typ->BaseTyp, &redef); + if (redef != NIL) { + obj->adr = __ASHL(__ASHR(redef->adr, 16), 16); + if (!__IN(2, obj->conval->setval, 64)) { + OPM_err(119); + } + } else { + obj->adr += __ASHL(typ->n, 16); + typ->n += 1; + } + OPM_errpos = oldPos; +} + +static void OPV_TraverseRecord (OPT_Struct typ) +{ + if (!typ->allocated) { + if (typ->BaseTyp != NIL) { + OPV_TraverseRecord(typ->BaseTyp); + typ->n = typ->BaseTyp->n; + } + typ->allocated = 1; + OPV_Traverse(typ->link, typ->strobj, 0); + } +} + +static void OPV_Stamp (OPS_Name s) +{ + INT16 i, j, k; + CHAR n[10]; + OPV_stamp += 1; + i = 0; + j = OPV_stamp; + while (s[__X(i, 256)] != 0x00) { + i += 1; + } + if (i > 25) { + i = 25; + } + s[__X(i, 256)] = '_'; + s[__X(i + 1, 256)] = '_'; + i += 2; + k = 0; + do { + n[__X(k, 10)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } while (!(j == 0)); + do { + k -= 1; + s[__X(i, 256)] = n[__X(k, 10)]; + i += 1; + } while (!(k == 0)); + s[__X(i, 256)] = 0x00; +} + +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported) +{ + INT16 mode; + OPT_Object scope = NIL; + OPT_Struct typ = NIL; + if (obj != NIL) { + OPV_Traverse(obj->left, outerScope, exported); + if (obj->name[0] == '@') { + obj->name[0] = '_'; + OPV_Stamp(obj->name); + } + obj->linkadr = 0; + mode = obj->mode; + if ((mode == 5 && (obj->vis != 0) == exported)) { + typ = obj->typ; + OPT_TypSize(obj->typ); + if (typ->form == 11) { + typ = typ->BaseTyp; + } + if (typ->comp == 4) { + OPV_TraverseRecord(typ); + } + } else if (mode == 13) { + OPV_GetTProcNum(obj); + } else if (mode == 1) { + OPT_TypSize(obj->typ); + } + if (!exported) { + if ((__IN(mode, 0x60, 32) && obj->mnolev > 0)) { + OPV_Stamp(obj->name); + } + if (__IN(mode, 0x26, 32)) { + obj->scope = outerScope; + } else if (__IN(mode, 0x26c0, 32)) { + if (obj->conval->setval == 0x0) { + OPM_err(129); + } + scope = obj->scope; + scope->leaf = 1; + __MOVE(obj->name, scope->name, 256); + OPV_Stamp(scope->name); + if (mode == 9) { + obj->adr = 1; + } + if (scope->mnolev > 1) { + outerScope->leaf = 0; + } + OPV_Traverse(obj->scope->right, obj->scope, 0); + } + } + OPV_Traverse(obj->right, outerScope, exported); + } +} + +void OPV_AdrAndSize (OPT_Object topScope) +{ + __ASSERT(OPT_sinttyp != NIL, 0); + __ASSERT(OPT_inttyp != NIL, 0); + __ASSERT(OPT_linttyp != NIL, 0); + OPM_errpos = topScope->adr; + topScope->leaf = 1; + OPV_Traverse(topScope->right, topScope, 1); + OPV_Traverse(topScope->right, topScope, 0); + OPT_chartyp->strobj->linkadr = 2; + OPT_cpbytetyp->strobj->linkadr = 2; + OPT_settyp->strobj->linkadr = 2; + OPT_realtyp->strobj->linkadr = 2; + OPT_adrtyp->strobj->linkadr = 2; + OPT_int8typ->strobj->linkadr = 2; + OPT_int16typ->strobj->linkadr = 2; + OPT_int32typ->strobj->linkadr = 2; + OPT_int64typ->strobj->linkadr = 2; + OPT_set32typ->strobj->linkadr = 2; + OPT_set64typ->strobj->linkadr = 2; + OPT_hinttyp->strobj->linkadr = 2; + OPT_lrltyp->strobj->linkadr = 2; + OPT_booltyp->strobj->linkadr = 2; + OPT_bytetyp->strobj->linkadr = 2; + OPT_sysptrtyp->strobj->linkadr = 2; +} + +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp) +{ + switch (class) { + case 7: case 0: case 2: case 4: case 9: + case 13: + return 10; + break; + case 5: + if (__IN(3, OPM_Options, 32)) { + return 10; + } else { + return 9; + } + break; + case 1: + if (__IN(comp, 0x0c, 32)) { + return 10; + } else { + return 9; + } + break; + case 3: + return 9; + break; + case 11: + switch (subclass) { + case 33: case 7: case 24: case 29: case 20: + return 9; + break; + case 16: case 21: case 22: case 23: case 25: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 12: + switch (subclass) { + case 1: + if (form == 7) { + return 4; + } else { + return 8; + } + break; + case 2: + if (form == 7) { + return 3; + } else { + return 8; + } + break; + case 3: case 4: + return 10; + break; + case 6: + if (form == 7) { + return 2; + } else { + return 7; + } + break; + case 7: + if (form == 7) { + return 4; + } else { + return 7; + } + break; + case 11: case 12: case 13: case 14: + return 6; + break; + case 9: case 10: + return 5; + break; + case 5: + return 1; + break; + case 8: + return 0; + break; + case 19: case 15: case 17: case 18: case 26: + case 27: case 28: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 10: + return 10; + break; + case 8: case 6: + return 12; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence, class = ", 43); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + __RETCHK; +} + +static void OPV_Len (OPT_Node n, INT64 dim) +{ + INT64 d; + OPT_Struct array = NIL; + while ((n->class == 4 && n->typ->comp == 3)) { + dim += 1; + n = n->left; + } + if ((n->class == 3 && n->typ->comp == 3)) { + d = dim; + array = n->typ; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->len[", 7); + OPM_WriteInt(dim); + OPM_Write(']'); + } else { + OPM_WriteInt(array->n); + } + } else { + OPC_Len(n->obj, n->typ, dim); + } +} + +static BOOLEAN OPV_SideEffects (OPT_Node n) +{ + if (n != NIL) { + return (n->class == 13 || OPV_SideEffects(n->left)) || OPV_SideEffects(n->right); + } else { + return 0; + } + __RETCHK; +} + +static void OPV_Entier (OPT_Node n, INT16 prec) +{ + if (__IN(n->typ->form, 0x60, 32)) { + OPM_WriteString((CHAR*)"__ENTIER(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else { + OPV_expr(n, prec); + } +} + +static void OPV_SizeCast (OPT_Node n, INT32 to) +{ + if ((to < n->typ->size && __IN(2, OPM_Options, 32))) { + OPM_WriteString((CHAR*)"__SHORT", 8); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPM_SignedMaximum(to) + 1); + OPM_Write(')'); + } else { + if ((n->typ->size != to && (n->typ->size > 4 || to != 4))) { + OPM_WriteString((CHAR*)"(INT", 5); + OPM_WriteInt(__ASHL(to, 3)); + OPM_WriteString((CHAR*)")", 2); + } + OPV_Entier(n, 9); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec) +{ + INT16 from, to; + from = n->typ->form; + to = newtype->form; + if (to == 7) { + if (from == 7) { + OPV_SizeCast(n, newtype->size); + } else { + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(newtype->size, 3)); + OPM_Write(')'); + } + } else if (to == 4) { + OPV_SizeCast(n, newtype->size); + } else if (to == 3) { + if (__IN(2, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__CHR", 6); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_Write(')'); + } else { + OPM_WriteString((CHAR*)"(CHAR)", 7); + OPV_Entier(n, 9); + } + } else { + OPV_expr(n, prec); + } +} + +static void OPV_TypeOf (OPT_Node n) +{ + if (n->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else if (__IN(n->class, 0x15, 32)) { + OPC_Andent(n->typ); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (n->class == 3) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n->left, -1); + OPM_Write(')'); + } else if (n->class == 5) { + OPV_TypeOf(n->left); + } else if ((n->class == 11 && n->subcl == 29)) { + OPC_TypeOf(n->left->obj); + } else { + OPC_TypeOf(n->obj); + } +} + +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim) +{ + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + OPV_expr(n->right, prec); + } else { + if (OPV_SideEffects(n->right)) { + OPM_WriteString((CHAR*)"__XF(", 6); + } else { + OPM_WriteString((CHAR*)"__X(", 5); + } + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(d, dim); + OPM_Write(')'); + } +} + +static void OPV_design (OPT_Node n, INT16 prec) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT16 class, designPrec, comp; + OPT_Node d = NIL, x = NIL; + INT16 dims, i, _for__26; + comp = n->typ->comp; + obj = n->obj; + class = n->class; + designPrec = OPV_Precedence(class, n->subcl, n->typ->form, comp); + if ((((((class == 0 && obj->mnolev > 0)) && (INT16)obj->mnolev != OPM_level)) && prec == 10)) { + designPrec = 9; + } + if (prec > designPrec) { + OPM_Write('('); + } + if (prec == 11) { + OPM_Write('*'); + } + switch (class) { + case 9: + OPC_Ident(n->obj); + break; + case 0: + OPC_CompleteIdent(n->obj); + break; + case 1: + if (!__IN(comp, 0x0c, 32)) { + OPM_Write('*'); + } + OPC_CompleteIdent(n->obj); + break; + case 2: + if (n->left->class == 3) { + OPV_design(n->left->left, designPrec); + OPM_WriteString((CHAR*)"->", 3); + } else { + OPV_design(n->left, designPrec); + OPM_Write('.'); + } + OPC_Ident(n->obj); + break; + case 3: + if (n->typ->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->data", 7); + } else { + OPM_Write('*'); + OPV_design(n->left, designPrec); + } + break; + case 4: + d = n->left; + if (d->typ->comp == 3) { + dims = 0; + while (d->class == 4) { + d = d->left; + dims += 1; + } + if (n->typ->comp == 3) { + OPM_Write('&'); + } + OPV_design(d, designPrec); + OPM_Write('['); + if (n->typ->comp == 3) { + OPM_Write('('); + } + i = dims; + x = n; + while (x != d) { + if (x->left != d) { + OPV_Index(x, d, 7, i); + OPM_WriteString((CHAR*)" + ", 4); + OPV_Len(d, i); + OPM_WriteString((CHAR*)" * (", 5); + i -= 1; + } else { + OPV_Index(x, d, -1, i); + } + x = x->left; + } + _for__26 = dims; + i = 1; + while (i <= _for__26) { + OPM_Write(')'); + i += 1; + } + if (n->typ->comp == 3) { + OPM_Write(')'); + while (i < __ASHR(d->typ->size - 4, 2)) { + OPM_WriteString((CHAR*)" * ", 4); + OPV_Len(d, i); + i += 1; + } + } + OPM_Write(']'); + } else { + OPV_design(n->left, designPrec); + OPM_Write('['); + OPV_Index(n, n->left, -1, 0); + OPM_Write(']'); + } + break; + case 5: + typ = n->typ; + obj = n->left->obj; + if (__IN(3, OPM_Options, 32)) { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__GUARDR(", 10); + if ((INT16)obj->mnolev != OPM_level) { + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"__curr->", 9); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } + } else { + if (typ->BaseTyp->strobj == NIL) { + OPM_WriteString((CHAR*)"__GUARDA(", 10); + } else { + OPM_WriteString((CHAR*)"__GUARDP(", 10); + } + OPV_expr(n->left, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + } else { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + OPC_CompleteIdent(obj); + } else { + OPM_Write('('); + OPC_Ident(typ->strobj); + OPM_Write(')'); + OPV_expr(n->left, designPrec); + } + } + break; + case 6: + if (__IN(3, OPM_Options, 32)) { + if (n->left->class == 1) { + OPM_WriteString((CHAR*)"__GUARDEQR(", 12); + OPC_CompleteIdent(n->left->obj); + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n->left); + } else { + OPM_WriteString((CHAR*)"__GUARDEQP(", 12); + OPV_expr(n->left->left, -1); + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + } else { + OPV_expr(n->left, -1); + } + break; + case 11: + if (n->subcl == 29) { + OPV_design(n->left, prec); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.design, class = ", 39); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + if (prec > designPrec) { + OPM_Write(')'); + } +} + +static void OPV_ParIntLiteral (INT64 n, INT32 size) +{ + OPM_WriteInt(n); +} + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp) +{ + OPT_Struct typ = NIL, aptyp = NIL; + INT16 comp, form, mode, prec, dim; + OPM_Write('('); + while (n != NIL) { + typ = fp->typ; + comp = typ->comp; + form = typ->form; + mode = fp->mode; + prec = -1; + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + prec = 10; + } + if (!__IN(n->typ->comp, 0x0c, 32)) { + if (mode == 2) { + if (typ != n->typ) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPM_Write('&'); + prec = 9; + } else { + if ((__IN(comp, 0x0c, 32) && n->class == 7)) { + OPM_WriteString((CHAR*)"(CHAR*)", 8); + } else if ((((form == 11 && typ != n->typ)) && n->typ != OPT_niltyp)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + } else { + if ((((mode == 2 && typ != n->typ)) && prec == -1)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPV_expr(n->left, prec); + } else if ((form == 4 && n->class == 7)) { + OPV_ParIntLiteral(n->conval->intval, n->typ->size); + } else { + OPV_expr(n, prec); + } + if ((comp == 4 && mode == 2)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n); + } else if (comp == 3) { + if (n->class == 7) { + OPM_WriteString((CHAR*)", ", 3); + OPV_ParIntLiteral(n->conval->intval2, OPM_AddressSize); + } else { + aptyp = n->typ; + dim = 0; + while ((typ->comp == 3 && typ->BaseTyp->form != 1)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n, dim); + typ = typ->BaseTyp; + aptyp = aptyp->BaseTyp; + dim += 1; + } + if ((typ->comp == 3 && typ->BaseTyp->form == 1)) { + OPM_WriteString((CHAR*)", ", 3); + while (aptyp->comp == 3) { + OPV_Len(n, dim); + OPM_WriteString((CHAR*)" * ", 4); + dim += 1; + aptyp = aptyp->BaseTyp; + } + OPV_ParIntLiteral(aptyp->size, OPM_AddressSize); + } + } + } + n = n->link; + fp = fp->link; + if (n != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static OPT_Object OPV_SuperProc (OPT_Node n) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + typ = n->right->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(n->left->obj->name, typ->BaseTyp, &obj); + return obj; +} + +static void OPV_expr (OPT_Node n, INT16 prec) +{ + INT16 class, subclass, form, exprPrec; + OPT_Struct typ = NIL; + OPT_Node l = NIL, r = NIL; + OPT_Object proc = NIL; + class = n->class; + subclass = n->subcl; + form = n->typ->form; + l = n->left; + r = n->right; + exprPrec = OPV_Precedence(class, subclass, form, n->typ->comp); + if ((exprPrec <= prec && __IN(class, 0x3ce0, 32))) { + OPM_Write('('); + } + switch (class) { + case 7: + OPC_Constant(n->conval, form); + break; + case 10: + OPM_WriteString((CHAR*)"__SETRNG(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(__ASHL(n->typ->size, 3)); + OPM_Write(')'); + break; + case 11: + switch (subclass) { + case 33: + OPM_Write('!'); + OPV_expr(l, exprPrec); + break; + case 7: + if (form == 7) { + OPM_Write('~'); + } else { + OPM_Write('-'); + } + OPV_expr(l, exprPrec); + break; + case 16: + typ = n->obj->typ; + if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"__IS(", 6); + OPC_TypeOf(l->obj); + } else { + OPM_WriteString((CHAR*)"__ISP(", 7); + OPV_expr(l, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + break; + case 20: + OPV_Convert(l, n->typ, exprPrec); + break; + case 21: + if (OPV_SideEffects(l)) { + if (l->typ->form < 5) { + if (l->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__ABSF(", 8); + } else { + OPM_WriteString((CHAR*)"__ABSFD(", 9); + } + } else { + OPM_WriteString((CHAR*)"__ABS(", 7); + } + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 22: + OPM_WriteString((CHAR*)"__CAP(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 23: + OPM_WriteString((CHAR*)"__ODD(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + if (l->class == 1) { + OPC_CompleteIdent(l->obj); + } else { + if ((l->typ->form != 8 && !__IN(l->typ->comp, 0x0c, 32))) { + OPM_Write('&'); + } + OPV_expr(l, exprPrec); + } + break; + case 29: + if (!__IN(l->class, 0x17, 32) || (((__IN(n->typ->form, 0x1890, 32) && __IN(l->typ->form, 0x1890, 32))) && n->typ->size == l->typ->size)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + if (__IN(n->typ->form, 0x1800, 32) || __IN(l->typ->form, 0x1800, 32)) { + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + } + OPV_expr(l, exprPrec); + } else { + OPM_WriteString((CHAR*)"__VAL(", 7); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_Write(')'); + } + break; + default: + OPM_err(200); + break; + } + break; + case 12: + switch (subclass) { + case 19: + OPV_Len(l, r->conval->intval); + break; + case 15: case 17: case 18: case 26: case 27: + case 28: case 3: case 4: + switch (subclass) { + case 15: + OPM_WriteString((CHAR*)"__IN(", 6); + break; + case 17: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ASHL(", 8); + } else { + OPM_WriteString((CHAR*)"__ASHR(", 8); + } + } else if (OPV_SideEffects(r)) { + OPM_WriteString((CHAR*)"__ASHF(", 8); + } else { + OPM_WriteString((CHAR*)"__ASH(", 7); + } + break; + case 18: + OPM_WriteString((CHAR*)"__MASK(", 8); + break; + case 26: + OPM_WriteString((CHAR*)"__BIT(", 7); + break; + case 27: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__LSHL(", 8); + } else { + OPM_WriteString((CHAR*)"__LSHR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__LSH(", 7); + } + break; + case 28: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ROTL(", 8); + } else { + OPM_WriteString((CHAR*)"__ROTR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__ROT(", 7); + } + break; + case 3: + if (OPV_SideEffects(n)) { + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__DIVF(", 8); + } else { + OPM_WriteString((CHAR*)"__DIV(", 7); + } + break; + case 4: + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + if (OPV_SideEffects(n)) { + OPM_WriteString((CHAR*)"__MODF(", 8); + } else { + OPM_WriteString((CHAR*)"__MOD(", 7); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if ((((__IN(subclass, 0x18020000, 32) && r->class == 7)) && r->conval->intval < 0)) { + OPM_WriteInt(-r->conval->intval); + } else { + OPV_expr(r, -1); + } + if (__IN(subclass, 0x18008000, 32)) { + OPM_WriteString((CHAR*)", ", 3); + if (subclass == 15) { + OPM_WriteInt(__ASHL(r->typ->size, 3)); + } else { + OPM_WriteInt(__ASHL(l->typ->size, 3)); + } + } + OPM_Write(')'); + break; + case 9: case 10: case 11: case 12: case 13: + case 14: + if (__IN(l->typ->form, 0x2100, 32)) { + OPM_WriteString((CHAR*)"__STRCMP(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_Write(')'); + OPC_Cmp(subclass); + OPM_Write('0'); + } else { + OPV_expr(l, exprPrec); + OPC_Cmp(subclass); + typ = l->typ; + if ((((((typ->form == 11 && r->typ->form != 9)) && r->typ != typ)) && r->typ != OPT_sysptrtyp)) { + OPM_WriteString((CHAR*)"(void *) ", 10); + } + OPV_expr(r, exprPrec); + } + break; + default: + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write('('); + } + OPV_expr(l, exprPrec); + switch (subclass) { + case 1: + if (form == 7) { + OPM_WriteString((CHAR*)" & ", 4); + } else { + OPM_WriteString((CHAR*)" * ", 4); + } + break; + case 2: + if (form == 7) { + OPM_WriteString((CHAR*)" ^ ", 4); + } else { + OPM_WriteString((CHAR*)" / ", 4); + if (r->obj == NIL || r->obj->typ->form == 4) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + } + } + break; + case 5: + OPM_WriteString((CHAR*)" && ", 5); + break; + case 6: + if (form == 7) { + OPM_WriteString((CHAR*)" | ", 4); + } else { + OPM_WriteString((CHAR*)" + ", 4); + } + break; + case 7: + if (form == 7) { + OPM_WriteString((CHAR*)" & ~", 5); + } else { + OPM_WriteString((CHAR*)" - ", 4); + } + break; + case 8: + OPM_WriteString((CHAR*)" || ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(r, exprPrec); + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write(')'); + } + break; + } + break; + case 13: + if ((l->obj != NIL && l->obj->mode == 13)) { + if (l->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(l->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (l->class == 9) { + OPV_design(l, 10); + } else { + OPV_design(l, 11); + } + OPV_ActualPar(r, n->obj); + break; + default: + OPV_design(n, prec); + break; + } + if ((exprPrec <= prec && __IN(class, 0x3ca0, 32))) { + OPM_Write(')'); + } +} + +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc) +{ + OPT_Node if_ = NIL; + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT32 adr; + if_ = n->left; + while (if_ != NIL) { + OPM_WriteString((CHAR*)"if ", 4); + OPV_expr(if_->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + if ((n->class == 27 && if_->left->left != NIL)) { + obj = if_->left->left->obj; + typ = obj->typ; + adr = obj->adr; + if (typ->comp == 4) { + OPC_BegStat(); + OPC_Ident(if_->left->obj); + OPM_WriteString((CHAR*)" *", 3); + OPM_WriteString(obj->name, 256); + OPM_WriteString((CHAR*)"__ = (void*)", 13); + obj->adr = 0; + OPC_CompleteIdent(obj); + OPC_EndStat(); + } + obj->adr = 1; + obj->typ = if_->left->obj->typ; + OPV_stat(if_->right, outerProc); + obj->typ = typ; + obj->adr = adr; + } else { + OPV_stat(if_->right, outerProc); + } + if_ = if_->link; + if ((if_ != NIL || n->right != NIL) || withtrap) { + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" else ", 7); + } else { + OPC_EndBlk(); + } + } + if (withtrap) { + OPM_WriteString((CHAR*)"__WITHCHK", 10); + OPC_EndStat(); + } else if (n->right != NIL) { + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + } +} + +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Node switchCase = NIL, label = NIL; + INT64 low, high; + INT16 form, i; + OPM_WriteString((CHAR*)"switch ", 8); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + form = n->left->typ->form; + switchCase = n->right->left; + while (switchCase != NIL) { + label = switchCase->left; + i = 0; + while (label != NIL) { + low = label->conval->intval; + high = label->conval->intval2; + while (low <= high) { + if (i == 0) { + OPC_BegStat(); + } + OPC_Case(low, form); + low += 1; + i += 1; + if (i == 5) { + OPM_WriteLn(); + i = 0; + } + } + label = label->link; + } + if (i > 0) { + OPM_WriteLn(); + } + OPC_Indent(1); + OPV_stat(switchCase->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_EndStat(); + OPC_Indent(-1); + switchCase = switchCase->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"default: ", 10); + if (n->right->conval->setval != 0x0) { + OPC_Indent(1); + OPM_WriteLn(); + OPV_stat(n->right->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_Indent(-1); + } else { + OPM_WriteString((CHAR*)"__CASECHK", 10); + } + OPC_EndStat(); + OPC_EndBlk(); +} + +static BOOLEAN OPV_ImplicitReturn (OPT_Node n) +{ + while ((n != NIL && n->class != 26)) { + n = n->link; + } + return n == NIL; +} + +static void OPV_NewArr (OPT_Node d, OPT_Node x) +{ + OPT_Struct typ = NIL, base = NIL; + INT16 nofdim, nofdyn; + typ = d->typ->BaseTyp; + base = typ; + nofdim = 0; + nofdyn = 0; + while (base->comp == 3) { + nofdim += 1; + nofdyn += 1; + base = base->BaseTyp; + } + OPV_design(d, -1); + OPM_WriteString((CHAR*)" = __NEWARR(", 13); + while (base->comp == 2) { + nofdim += 1; + base = base->BaseTyp; + } + if ((base->comp == 4 && OPC_NofPtrs(base) != 0)) { + OPC_Andent(base); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (base->form == 11) { + OPM_WriteString((CHAR*)"POINTER__typ", 13); + } else { + OPM_WriteString((CHAR*)"NIL", 4); + } + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(base->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPT_BaseAlignment(base)); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdim); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdyn); + while (typ != base) { + OPM_WriteString((CHAR*)", ", 3); + if (typ->comp == 3) { + if (x->class == 7) { + OPC_IntLiteral(x->conval->intval, OPM_AddressSize); + } else { + OPM_WriteString((CHAR*)"((ADDRESS)(", 12); + OPV_expr(x, 10); + OPM_WriteString((CHAR*)"))", 3); + } + x = x->link; + } else { + OPC_IntLiteral(typ->n, OPM_AddressSize); + } + typ = typ->BaseTyp; + } + OPM_Write(')'); +} + +static void OPV_DefineTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_TDescDecl(n->typ); + n = n->link; + } +} + +static void OPV_InitTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_InitTDesc(n->typ); + n = n->link; + } +} + +static void OPV_stat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Object proc = NIL; + OPV_ExitInfo saved; + OPT_Node l = NIL, r = NIL; + while ((n != NIL && OPM_noerr)) { + OPM_errpos = OPM_Longint(n->conval->intval); + if (n->class != 14) { + OPC_BegStat(); + } + switch (n->class) { + case 18: + if (n->obj == NIL) { + OPM_level += 1; + OPV_stat(n->left, outerProc); + OPM_level -= 1; + OPC_GenEnumPtrs(OPT_topScope->scope); + OPV_DefineTDescs(n->right); + OPC_EnterBody(); + OPV_InitTDescs(n->right); + OPM_WriteString((CHAR*)"/* BEGIN */", 12); + OPM_WriteLn(); + OPV_stat(n->right, outerProc); + OPC_ExitBody(); + } else { + proc = n->obj; + OPC_TypeDefs(proc->scope->right, 0); + if (!proc->scope->leaf) { + OPC_DefineInter(proc); + } + OPM_level += 1; + OPV_stat(n->left, proc); + OPM_level -= 1; + OPC_EnterProc(proc); + OPV_stat(n->right, proc); + OPC_ExitProc(proc, 1, OPV_ImplicitReturn(n->right)); + } + break; + case 14: + break; + case 19: + switch (n->subcl) { + case 0: + l = n->left; + r = n->right; + if (l->typ->comp == 2) { + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if (r->typ == OPT_stringtyp) { + OPM_WriteInt(r->conval->intval2); + } else if (r->typ->comp == 3) { + OPM_WriteString((CHAR*)"__X(", 5); + OPC_Len(r->obj, r->typ, 0); + OPM_WriteString((CHAR*)" * ", 4); + OPM_WriteInt(r->typ->BaseTyp->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(l->typ->size + 1); + OPM_Write(')'); + } else { + __ASSERT(r->typ->comp == 2, 0); + __ASSERT(r->typ->size <= l->typ->size, 0); + OPM_WriteInt(r->typ->size); + } + OPM_Write(')'); + } else { + if ((((((l->typ->form == 11 && l->obj != NIL)) && l->obj->adr == 1)) && l->obj->mode == 1)) { + l->obj->adr = 0; + OPV_design(l, -1); + l->obj->adr = 1; + if (r->typ->form != 9) { + OPM_WriteString((CHAR*)" = (void*)", 11); + } else { + OPM_WriteString((CHAR*)" = ", 4); + } + } else { + OPV_design(l, -1); + OPM_WriteString((CHAR*)" = ", 4); + } + if (l->typ == r->typ) { + OPV_expr(r, -1); + } else if ((((l->typ->form == 11 && r->typ->form != 9)) && l->typ->strobj != NIL)) { + OPM_Write('('); + OPC_Ident(l->typ->strobj); + OPM_Write(')'); + OPV_expr(r, -1); + } else if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Andent(l->typ); + OPM_WriteString((CHAR*)"*)&", 4); + OPV_expr(r, 9); + } else { + OPV_expr(r, -1); + } + } + break; + case 1: + if (n->left->typ->BaseTyp->comp == 4) { + OPM_WriteString((CHAR*)"__NEW(", 7); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(n->left->typ->BaseTyp); + OPM_WriteString((CHAR*)")", 2); + } else if (__IN(n->left->typ->BaseTyp->comp, 0x0c, 32)) { + OPV_NewArr(n->left, n->right); + } + break; + case 13: case 14: + OPV_expr(n->left, -1); + OPC_Increment(n->subcl == 14); + OPV_expr(n->right, -1); + break; + case 15: case 16: + OPV_expr(n->left, -1); + OPC_SetInclude(n->subcl == 16); + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(n->left->typ->size, 3)); + OPM_Write(')'); + break; + case 18: + OPM_WriteString((CHAR*)"__COPY(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n->left, 0); + OPM_Write(')'); + break; + case 31: + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right->link, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"__GET(", 7); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + break; + case 25: + OPM_WriteString((CHAR*)"__PUT(", 7); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->right->typ->strobj); + OPM_Write(')'); + break; + case 26: case 27: + OPM_err(200); + break; + case 30: + OPM_WriteString((CHAR*)"__SYSNEW(", 10); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_Write(')'); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.subcl = ", 40); + OPM_LogWNum(n->subcl, 0); + OPM_LogWLn(); + break; + } + break; + case 13: + if ((n->left->obj != NIL && n->left->obj->mode == 13)) { + if (n->left->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(n->left->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (n->left->class == 9) { + OPV_design(n->left, 10); + } else { + OPV_design(n->left, 11); + } + OPV_ActualPar(n->right, n->obj); + break; + case 20: + if (n->subcl != 32) { + OPV_IfStat(n, 0, outerProc); + } else if (__IN(7, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__ASSERT(", 10); + OPV_expr(n->left->left->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(n->left->right->right->conval->intval); + OPM_Write(')'); + OPC_EndStat(); + } + break; + case 21: + OPV_exit.level += 1; + OPV_CaseStat(n, outerProc); + OPV_exit.level -= 1; + break; + case 22: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"while ", 7); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + OPV_exit.level -= 1; + break; + case 23: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"do ", 4); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" while (!", 10); + OPV_expr(n->right, 9); + OPM_Write(')'); + OPV_exit.level -= 1; + break; + case 24: + saved = OPV_exit; + OPV_exit.level = 0; + OPV_exit.label = -1; + OPM_WriteString((CHAR*)"for (;;) ", 10); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk(); + if (OPV_exit.label != -1) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"exit__", 7); + OPM_WriteInt(OPV_exit.label); + OPM_Write(':'); + OPC_EndStat(); + } + OPV_exit = saved; + break; + case 25: + if (OPV_exit.level == 0) { + OPM_WriteString((CHAR*)"break", 6); + } else { + if (OPV_exit.label == -1) { + OPV_exit.label = OPV_nofExitLabels; + OPV_nofExitLabels += 1; + } + OPM_WriteString((CHAR*)"goto exit__", 12); + OPM_WriteInt(OPV_exit.label); + } + break; + case 26: + if (OPM_level == 0) { + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI", 7); + } else { + OPM_WriteString((CHAR*)"__ENDMOD", 9); + } + } else if (OPC_NeedsRetval(outerProc)) { + OPM_WriteString((CHAR*)"__retval = ", 12); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + OPC_EndStat(); + OPC_BegStat(); + OPC_ExitProc(outerProc, 0, 0); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"return __retval", 16); + } else { + OPC_ExitProc(outerProc, 0, 0); + OPM_WriteString((CHAR*)"return", 7); + if (n->left != NIL) { + OPM_Write(' '); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + } + } + break; + case 27: + OPV_IfStat(n, n->subcl == 0, outerProc); + break; + case 28: + OPC_Halt(OPM_Longint(n->right->conval->intval)); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.class = ", 40); + OPM_LogWNum(n->class, 0); + OPM_LogWLn(); + break; + } + if (!__IN(n->class, 0x09744000, 32)) { + OPC_EndStat(); + } + n = n->link; + } +} + +void OPV_Module (OPT_Node prog) +{ + if (!__IN(10, OPM_Options, 32)) { + OPC_GenHdr(prog->right); + OPC_GenHdrIncludes(); + } + OPC_GenBdy(prog->right); + OPV_stat(prog, NIL); +} + +__TDESC(OPV_ExitInfo, 1, 0) = {__TDFLDS("ExitInfo", 4), {-4}}; + +export void *OPV__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPV", 0); + __REGCMD("Init", OPV_Init); + __INITYP(OPV_ExitInfo, OPV_ExitInfo, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/OPV.h b/bootstrap/windows-48/OPV.h new file mode 100644 index 00000000..fbabd8f4 --- /dev/null +++ b/bootstrap/windows-48/OPV.h @@ -0,0 +1,18 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPV__h +#define OPV__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPV_AdrAndSize (OPT_Object topScope); +import void OPV_Init (void); +import void OPV_Module (OPT_Node prog); +import void *OPV__init(void); + + +#endif // OPV diff --git a/bootstrap/windows-48/Out.c b/bootstrap/windows-48/Out.c new file mode 100644 index 00000000..b43e55f1 --- /dev/null +++ b/bootstrap/windows-48/Out.c @@ -0,0 +1,345 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export BOOLEAN Out_IsConsole; +static CHAR Out_buf[128]; +static INT16 Out_in; + + +export void Out_Char (CHAR ch); +export void Out_Flush (void); +export void Out_Hex (INT64 x, INT64 n); +export void Out_Int (INT64 x, INT64 n); +static INT32 Out_Length (CHAR *s, ADDRESS s__len); +export void Out_Ln (void); +export void Out_LongReal (LONGREAL x, INT16 n); +export void Out_Open (void); +export void Out_Real (REAL x, INT16 n); +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_); +export void Out_String (CHAR *str, ADDRESS str__len); +export LONGREAL Out_Ten (INT16 e); +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i); +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i); + +#define Out_Entier64(x) (INT64)(x) + +void Out_Flush (void) +{ + INT16 error; + if (Out_in > 0) { + error = Platform_Write(Platform_StdOut, (ADDRESS)Out_buf, Out_in); + } + Out_in = 0; +} + +void Out_Open (void) +{ +} + +void Out_Char (CHAR ch) +{ + if (Out_in >= 128) { + Out_Flush(); + } + Out_buf[__X(Out_in, 128)] = ch; + Out_in += 1; + if (ch == 0x0a) { + Out_Flush(); + } +} + +static INT32 Out_Length (CHAR *s, ADDRESS s__len) +{ + INT32 l; + l = 0; + while ((l < s__len && s[__X(l, s__len)] != 0x00)) { + l += 1; + } + return l; +} + +void Out_String (CHAR *str, ADDRESS str__len) +{ + INT32 l; + INT16 error; + __DUP(str, str__len, CHAR); + l = Out_Length((void*)str, str__len); + if (Out_in + l > 128) { + Out_Flush(); + } + if (l > 128) { + error = Platform_Write(Platform_StdOut, (ADDRESS)str, l); + } else { + __MOVE((ADDRESS)str, (ADDRESS)&Out_buf[__X(Out_in, 128)], l); + Out_in += __SHORT(l, 32768); + } + __DEL(str); +} + +void Out_Int (INT64 x, INT64 n) +{ + CHAR s[22]; + INT16 i; + BOOLEAN negative; + negative = x < 0; + if (x == (-9223372036854775807LL-1)) { + __MOVE("8085774586302733229", s, 20); + i = 19; + } else { + if (x < 0) { + x = -x; + } + s[0] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i = 1; + while (x != 0) { + s[__X(i, 22)] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i += 1; + } + } + if (negative) { + s[__X(i, 22)] = '-'; + i += 1; + } + while (n > (INT64)i) { + Out_Char(' '); + n -= 1; + } + while (i > 0) { + i -= 1; + Out_Char(s[__X(i, 22)]); + } +} + +void Out_Hex (INT64 x, INT64 n) +{ + if (n < 1) { + n = 1; + } else if (n > 16) { + n = 16; + } + if (x >= 0) { + while ((n < 16 && __LSH(x, -__ASHL(n, 2), 64) != 0)) { + n += 1; + } + } + x = __ROT(x, __ASHL(16 - n, 2), 64); + while (n > 0) { + x = __ROTL(x, 4, 64); + n -= 1; + if (__MASK(x, -16) < 10) { + Out_Char(__CHR(__MASK(x, -16) + 48)); + } else { + Out_Char(__CHR((__MASK(x, -16) - 10) + 65)); + } + } +} + +void Out_Ln (void) +{ + Out_String(Platform_NL, 3); + Out_Flush(); +} + +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i) +{ + *i -= 1; + s[__X(*i, s__len)] = __CHR(__MOD(n, 10) + 48); +} + +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i) +{ + INT16 j; + INT32 l; + __DUP(t, t__len, CHAR); + l = Out_Length((void*)t, t__len); + if (l > *i) { + l = *i; + } + *i -= __SHORT(l, 32768); + j = 0; + while (j < l) { + s[__X(*i + j, s__len)] = t[__X(j, t__len)]; + j += 1; + } + __DEL(t); +} + +LONGREAL Out_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_) +{ + INT16 e; + INT64 f; + CHAR s[30]; + INT16 i, el; + LONGREAL x0; + BOOLEAN nn, en; + INT64 m; + INT16 d, dr; + e = (INT16)__MASK(__ASHR((__VAL(INT64, x)), 52), -2048); + f = __MASK((__VAL(INT64, x)), -4503599627370496LL); + nn = (__VAL(INT64, x) < 0 && !((e == 2047 && f != 0))); + if (nn) { + n -= 1; + } + i = 30; + if (e == 2047) { + if (f == 0) { + Out_prepend((CHAR*)"Infinity", 9, (void*)s, 30, &i); + } else { + Out_prepend((CHAR*)"NaN", 4, (void*)s, 30, &i); + } + } else { + if (long_) { + el = 3; + dr = n - 6; + if (dr > 17) { + dr = 17; + } + d = dr; + if (d < 15) { + d = 15; + } + } else { + el = 2; + dr = n - 5; + if (dr > 9) { + dr = 9; + } + d = dr; + if (d < 6) { + d = 6; + } + } + if (e == 0) { + while (el > 0) { + i -= 1; + s[__X(i, 30)] = '0'; + el -= 1; + } + i -= 1; + s[__X(i, 30)] = '+'; + m = 0; + } else { + if (nn) { + x = -x; + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Out_Ten(e); + } else { + x = Out_Ten(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + en = e < 0; + if (en) { + e = -e; + } + while (el > 0) { + Out_digit(e, (void*)s, 30, &i); + e = __DIV(e, 10); + el -= 1; + } + i -= 1; + if (en) { + s[__X(i, 30)] = '-'; + } else { + s[__X(i, 30)] = '+'; + } + x0 = Out_Ten(d - 1); + x = x0 * x; + x = x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + m = Out_Entier64(x); + } + i -= 1; + if (long_) { + s[__X(i, 30)] = 'D'; + } else { + s[__X(i, 30)] = 'E'; + } + if (dr < 2) { + dr = 2; + } + while ((d > dr && __MOD(m, 10) == 0)) { + m = __DIV(m, 10); + d -= 1; + } + while (d > 1) { + Out_digit(m, (void*)s, 30, &i); + m = __DIV(m, 10); + d -= 1; + } + i -= 1; + s[__X(i, 30)] = '.'; + Out_digit(m, (void*)s, 30, &i); + } + n -= 30 - i; + while (n > 0) { + Out_Char(' '); + n -= 1; + } + if (nn) { + Out_Char('-'); + } + while (i < 30) { + Out_Char(s[__X(i, 30)]); + i += 1; + } +} + +void Out_Real (REAL x, INT16 n) +{ + Out_RealP(x, n, 0); +} + +void Out_LongReal (LONGREAL x, INT16 n) +{ + Out_RealP(x, n, 1); +} + + +export void *Out__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Out", 0); + __REGCMD("Flush", Out_Flush); + __REGCMD("Ln", Out_Ln); + __REGCMD("Open", Out_Open); +/* BEGIN */ + Out_IsConsole = Platform_IsConsole(Platform_StdOut); + Out_in = 0; + __ENDMOD; +} diff --git a/bootstrap/windows-48/Out.h b/bootstrap/windows-48/Out.h new file mode 100644 index 00000000..a72547f4 --- /dev/null +++ b/bootstrap/windows-48/Out.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Out__h +#define Out__h + +#include "SYSTEM.h" + + +import BOOLEAN Out_IsConsole; + + +import void Out_Char (CHAR ch); +import void Out_Flush (void); +import void Out_Hex (INT64 x, INT64 n); +import void Out_Int (INT64 x, INT64 n); +import void Out_Ln (void); +import void Out_LongReal (LONGREAL x, INT16 n); +import void Out_Open (void); +import void Out_Real (REAL x, INT16 n); +import void Out_String (CHAR *str, ADDRESS str__len); +import LONGREAL Out_Ten (INT16 e); +import void *Out__init(void); + + +#endif // Out diff --git a/bootstrap/windows-48/Platform.c b/bootstrap/windows-48/Platform.c new file mode 100644 index 00000000..9b1f0e4f --- /dev/null +++ b/bootstrap/windows-48/Platform.c @@ -0,0 +1,590 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 volume, indexhigh, indexlow, mtimehigh, mtimelow; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +export BOOLEAN Platform_LittleEndian; +export INT16 Platform_PID; +export CHAR Platform_CWD[4096]; +static INT32 Platform_TimeStart; +export INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +export INT32 Platform_StdIn, Platform_StdOut, Platform_StdErr; +export CHAR Platform_NL[3]; + +export ADDRESS *Platform_FileIdentity__typ; + +export BOOLEAN Platform_Absent (INT16 e); +export INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +export INT16 Platform_Close (INT32 h); +export BOOLEAN Platform_ConnectionFailed (INT16 e); +export void Platform_Delay (INT32 ms); +export BOOLEAN Platform_DifferentFilesystems (INT16 e); +static void Platform_EnableVT100 (void); +export INT16 Platform_Error (void); +export void Platform_Exit (INT32 code); +export void Platform_GetClock (INT32 *t, INT32 *d); +export void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +export void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +export INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export BOOLEAN Platform_Inaccessible (INT16 e); +export BOOLEAN Platform_Interrupted (INT16 e); +export BOOLEAN Platform_IsConsole (INT32 h); +export void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +export INT16 Platform_MaxNameLength (void); +export INT16 Platform_MaxPathLength (void); +export INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +export BOOLEAN Platform_NoSuchDirectory (INT16 e); +export INT32 Platform_OSAllocate (INT32 size); +export void Platform_OSFree (INT32 address); +export INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +export INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +export INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +export INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +export BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +export BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +export INT16 Platform_Seek (INT32 h, INT32 o, INT16 r); +export void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +export void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +export INT16 Platform_Size (INT32 h, INT32 *l); +export INT16 Platform_Sync (INT32 h); +export INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +static void Platform_TestLittleEndian (void); +export INT32 Platform_Time (void); +export BOOLEAN Platform_TimedOut (INT16 e); +export BOOLEAN Platform_TooManyFiles (INT16 e); +export INT16 Platform_Truncate (INT32 h, INT32 limit); +export INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +export INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +static void Platform_YMDHMStoClock (INT16 ye, INT16 mo, INT16 da, INT16 ho, INT16 mi, INT16 se, INT32 *t, INT32 *d); +export BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); + +#include "WindowsWrapper.h" +#define Platform_ECONNABORTED() WSAECONNABORTED +#define Platform_ECONNREFUSED() WSAECONNREFUSED +#define Platform_EHOSTUNREACH() WSAEHOSTUNREACH +#define Platform_EINTR() WSAEINTR +#define Platform_ENETUNREACH() WSAENETUNREACH +#define Platform_ERRORACCESSDENIED() ERROR_ACCESS_DENIED +#define Platform_ERRORFILENOTFOUND() ERROR_FILE_NOT_FOUND +#define Platform_ERRORNOTREADY() ERROR_NOT_READY +#define Platform_ERRORNOTSAMEDEVICE() ERROR_NOT_SAME_DEVICE +#define Platform_ERRORPATHNOTFOUND() ERROR_PATH_NOT_FOUND +#define Platform_ERRORSHARINGVIOLATION() ERROR_SHARING_VIOLATION +#define Platform_ERRORTOOMANYOPENFILES() ERROR_TOO_MANY_OPEN_FILES +#define Platform_ERRORWRITEPROTECT() ERROR_WRITE_PROTECT +#define Platform_ETIMEDOUT() WSAETIMEDOUT +#define Platform_GetConsoleMode(h, m) GetConsoleMode((HANDLE)h, (DWORD*)m) +#define Platform_GetTickCount() (LONGINT)(UINT32)GetTickCount() +#define Platform_MAXPATH() MAX_PATH +#define Platform_SetConsoleMode(h, m) SetConsoleMode((HANDLE)h, (DWORD)m) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((ADDRESS)h) +#define Platform_allocate(size) (ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) +#define Platform_bhfiIndexHigh() (LONGINT)bhfi.nFileIndexHigh +#define Platform_bhfiIndexLow() (LONGINT)bhfi.nFileIndexLow +#define Platform_bhfiMtimeHigh() (LONGINT)bhfi.ftLastWriteTime.dwHighDateTime +#define Platform_bhfiMtimeLow() (LONGINT)bhfi.ftLastWriteTime.dwLowDateTime +#define Platform_bhfiVsn() (LONGINT)bhfi.dwVolumeSerialNumber +#define Platform_byHandleFileInformation() BY_HANDLE_FILE_INFORMATION bhfi +#define Platform_cleanupProcess() CloseHandle(pi.hProcess); CloseHandle(pi.hThread); +#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)h) +#define Platform_createProcess(str, str__len) (INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi) +#define Platform_deleteFile(n, n__len) (INTEGER)DeleteFile((char*)n) +#define Platform_err() (INTEGER)GetLastError() +#define Platform_exit(code) ExitProcess((UINT)code) +#define Platform_fileTimeToSysTime() SYSTEMTIME st; FileTimeToSystemTime(&ft, &st) +#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)h) +#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)address) +#define Platform_ftToUli() ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime +#define Platform_getCurrentDirectory(n, n__len) GetCurrentDirectory(n__len, (char*)n) +#define Platform_getExitCodeProcess(exitcode) GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode); +#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)h, &bhfi) +#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart +#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)h, &li) +#define Platform_getLocalTime() SYSTEMTIME st; GetLocalTime(&st) +#define Platform_getenv(name, name__len, buf, buf__len) (INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len) +#define Platform_getpid() (INTEGER)GetCurrentProcessId() +#define Platform_getstderrhandle() (ADDRESS)GetStdHandle(STD_ERROR_HANDLE) +#define Platform_getstdinhandle() (ADDRESS)GetStdHandle(STD_INPUT_HANDLE) +#define Platform_getstdouthandle() (ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE) +#define Platform_identityToFileTime(i) FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow +#define Platform_invalidHandleValue() ((ADDRESS)INVALID_HANDLE_VALUE) +#define Platform_largeInteger() LARGE_INTEGER li +#define Platform_liLongint() (LONGINT)li.QuadPart +#define Platform_moveFile(o, o__len, n, n__len) (INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING) +#define Platform_opennew(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openro(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openrw(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_processInfo() PROCESS_INFORMATION pi = {0}; +#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile((HANDLE)fd, (void*)p, (DWORD)l, (DWORD*)n, 0) +#define Platform_seekcur() FILE_CURRENT +#define Platform_seekend() FILE_END +#define Platform_seekset() FILE_BEGIN +#define Platform_setCurrentDirectory(n, n__len) (INTEGER)SetCurrentDirectory((char*)n) +#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)h) +#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, li, 0, (DWORD)r) +#define Platform_sleep(ms) Sleep((DWORD)ms) +#define Platform_stToFt() FILETIME ft; SystemTimeToFileTime(&st, &ft) +#define Platform_startupInfo() STARTUPINFO si = {0}; si.cb = sizeof(si); +#define Platform_sthour() (INTEGER)st.wHour +#define Platform_stmday() (INTEGER)st.wDay +#define Platform_stmin() (INTEGER)st.wMinute +#define Platform_stmon() (INTEGER)st.wMonth +#define Platform_stmsec() (INTEGER)st.wMilliseconds +#define Platform_stsec() (INTEGER)st.wSecond +#define Platform_styear() (INTEGER)st.wYear +#define Platform_tous1970() ul.QuadPart = (ul.QuadPart - 116444736000000000ULL)/10LL +#define Platform_ulSec() (LONGINT)(ul.QuadPart / 1000000LL) +#define Platform_uluSec() (LONGINT)(ul.QuadPart % 1000000LL) +#define Platform_waitForProcess() (INTEGER)WaitForSingleObject(pi.hProcess, INFINITE) +#define Platform_writefile(fd, p, l, n) (INTEGER)WriteFile((HANDLE)fd, (void*)(p), (DWORD)l, (DWORD*)n, 0) + +BOOLEAN Platform_TooManyFiles (INT16 e) +{ + return e == Platform_ERRORTOOMANYOPENFILES(); +} + +BOOLEAN Platform_NoSuchDirectory (INT16 e) +{ + return e == Platform_ERRORPATHNOTFOUND(); +} + +BOOLEAN Platform_DifferentFilesystems (INT16 e) +{ + return e == Platform_ERRORNOTSAMEDEVICE(); +} + +BOOLEAN Platform_Inaccessible (INT16 e) +{ + return ((e == Platform_ERRORACCESSDENIED() || e == Platform_ERRORWRITEPROTECT()) || e == Platform_ERRORNOTREADY()) || e == Platform_ERRORSHARINGVIOLATION(); +} + +BOOLEAN Platform_Absent (INT16 e) +{ + return e == Platform_ERRORFILENOTFOUND() || e == Platform_ERRORPATHNOTFOUND(); +} + +BOOLEAN Platform_TimedOut (INT16 e) +{ + return e == Platform_ETIMEDOUT(); +} + +BOOLEAN Platform_ConnectionFailed (INT16 e) +{ + return ((e == Platform_ECONNREFUSED() || e == Platform_ECONNABORTED()) || e == Platform_ENETUNREACH()) || e == Platform_EHOSTUNREACH(); +} + +BOOLEAN Platform_Interrupted (INT16 e) +{ + return e == Platform_EINTR(); +} + +INT16 Platform_MaxNameLength (void) +{ + return Platform_MAXPATH(); +} + +INT16 Platform_MaxPathLength (void) +{ + return Platform_MAXPATH(); +} + +INT32 Platform_OSAllocate (INT32 size) +{ + return Platform_allocate(size); +} + +void Platform_OSFree (INT32 address) +{ + Platform_free(address); +} + +BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + CHAR buf[4096]; + INT16 res; + __DUP(var, var__len, CHAR); + res = Platform_getenv(var, var__len, (void*)buf, 4096); + if ((res > 0 && res < 4096)) { + __COPY(buf, val, val__len); + __DEL(var); + return 1; + } else { + __DEL(var); + return 0; + } + __RETCHK; +} + +void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + __DUP(var, var__len, CHAR); + if (!Platform_getEnv(var, var__len, (void*)val, val__len)) { + val[0] = 0x00; + } + __DEL(var); +} + +void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) +{ +} + +static void Platform_YMDHMStoClock (INT16 ye, INT16 mo, INT16 da, INT16 ho, INT16 mi, INT16 se, INT32 *t, INT32 *d) +{ + *d = (__ASHL((int)__MOD(ye, 100), 9) + __ASHL((mo + 1), 5)) + da; + *t = (__ASHL(ho, 12) + __ASHL(mi, 6)) + se; +} + +void Platform_GetClock (INT32 *t, INT32 *d) +{ + Platform_getLocalTime(); + Platform_YMDHMStoClock(Platform_styear(), Platform_stmon(), Platform_stmday(), Platform_sthour(), Platform_stmin(), Platform_stsec(), &*t, &*d); +} + +INT32 Platform_Time (void) +{ + INT32 ms; + ms = Platform_GetTickCount(); + return (int)__MOD(ms - Platform_TimeStart, 2147483647); +} + +void Platform_Delay (INT32 ms) +{ + while (ms > 30000) { + Platform_sleep(30000); + ms = ms - 30000; + } + if (ms > 0) { + Platform_sleep(ms); + } +} + +void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec) +{ + Platform_getLocalTime(); + Platform_stToFt(); + Platform_ftToUli(); + Platform_tous1970(); + *sec = Platform_ulSec(); + *usec = Platform_uluSec(); +} + +INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len) +{ + INT16 result; + __DUP(cmd, cmd__len, CHAR); + result = 127; + Platform_startupInfo(); + Platform_processInfo(); + if (Platform_createProcess(cmd, cmd__len) != 0) { + if (Platform_waitForProcess() == 0) { + Platform_getExitCodeProcess(&result); + } + Platform_cleanupProcess(); + } + __DEL(cmd); + return __ASHL(result, 8); +} + +INT16 Platform_Error (void) +{ + return Platform_err(); +} + +INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT32 fd; + fd = Platform_openro(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT32 fd; + fd = Platform_openrw(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h) +{ + INT32 fd; + fd = Platform_opennew(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_Close (INT32 h) +{ + if (Platform_closeHandle(h) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + Platform_byHandleFileInformation(); + if (Platform_getFileInformationByHandle(h) == 0) { + return Platform_err(); + } + (*identity).volume = Platform_bhfiVsn(); + (*identity).indexhigh = Platform_bhfiIndexHigh(); + (*identity).indexlow = Platform_bhfiIndexLow(); + (*identity).mtimehigh = Platform_bhfiMtimeHigh(); + (*identity).mtimelow = Platform_bhfiMtimeLow(); + return 0; +} + +INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + INT32 h; + INT16 e, i; + __DUP(n, n__len, CHAR); + e = Platform_OldRO((void*)n, n__len, &h); + if (e != 0) { + __DEL(n); + return e; + } + e = Platform_Identify(h, &*identity, identity__typ); + i = Platform_Close(h); + __DEL(n); + return e; +} + +BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (((i1.indexhigh == i2.indexhigh && i1.indexlow == i2.indexlow)) && i1.volume == i2.volume); +} + +BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (i1.mtimehigh == i2.mtimehigh && i1.mtimelow == i2.mtimelow); +} + +void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source) +{ + (*target).mtimehigh = source.mtimehigh; + (*target).mtimelow = source.mtimelow; +} + +void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d) +{ + Platform_identityToFileTime(i); + Platform_fileTimeToSysTime(); + Platform_YMDHMStoClock(Platform_styear(), Platform_stmon(), Platform_stmday(), Platform_sthour(), Platform_stmin(), Platform_stsec(), &*t, &*d); +} + +INT16 Platform_Size (INT32 h, INT32 *l) +{ + Platform_largeInteger(); + if (Platform_getFileSize(h) == 0) { + return Platform_err(); + } + *l = Platform_liLongint(); + return 0; +} + +INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n) +{ + INT16 result; + INT32 lengthread; + result = Platform_readfile(h, p, l, &lengthread); + if (result == 0) { + *n = 0; + return Platform_err(); + } else { + *n = lengthread; + return 0; + } + __RETCHK; +} + +INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n) +{ + INT16 result; + INT32 lengthread; + result = Platform_readfile(h, (ADDRESS)b, b__len, &lengthread); + if (result == 0) { + *n = 0; + return Platform_err(); + } else { + *n = lengthread; + return 0; + } + __RETCHK; +} + +INT16 Platform_Write (INT32 h, INT32 p, INT32 l) +{ + INT32 n; + if (Platform_writefile(h, p, l, &n) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Sync (INT32 h) +{ + if (Platform_flushFileBuffers(h) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Seek (INT32 h, INT32 o, INT16 r) +{ + INT16 rc; + Platform_largeInteger(); + Platform_setFilePointerEx(h, o, r, &rc); + if (rc == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Truncate (INT32 h, INT32 limit) +{ + INT16 rc; + INT32 oldpos; + Platform_largeInteger(); + Platform_getFilePos(h, &oldpos, &rc); + if (rc == 0) { + return Platform_err(); + } + Platform_setFilePointerEx(h, limit, Platform_seekset(), &rc); + if (rc == 0) { + return Platform_err(); + } + if (Platform_setEndOfFile(h) == 0) { + return Platform_err(); + } + Platform_setFilePointerEx(h, oldpos, Platform_seekset(), &rc); + if (rc == 0) { + return Platform_err(); + } + return 0; +} + +INT16 Platform_Unlink (CHAR *n, ADDRESS n__len) +{ + if (Platform_deleteFile(n, n__len) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Chdir (CHAR *n, ADDRESS n__len) +{ + INT16 r; + r = Platform_setCurrentDirectory(n, n__len); + if (r == 0) { + return Platform_err(); + } + Platform_getCurrentDirectory((void*)Platform_CWD, 4096); + return 0; +} + +INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len) +{ + if (Platform_moveFile(o, o__len, n, n__len) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +void Platform_Exit (INT32 code) +{ + Platform_exit(code); +} + +static void Platform_EnableVT100 (void) +{ + INT32 mode; + if (Platform_GetConsoleMode(Platform_StdOut, &mode)) { + Platform_SetConsoleMode(Platform_StdOut, mode + 4); + } +} + +BOOLEAN Platform_IsConsole (INT32 h) +{ + INT32 mode; + return Platform_GetConsoleMode(Platform_StdOut, &mode); +} + +static void Platform_TestLittleEndian (void) +{ + INT16 i; + i = 1; + __GET((ADDRESS)&i, Platform_LittleEndian, BOOLEAN); +} + +__TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 20), {-4}}; + +export void *Platform__init(void) +{ + __DEFMOD; + __REGMOD("Platform", 0); + __INITYP(Platform_FileIdentity, Platform_FileIdentity, 0); +/* BEGIN */ + Platform_TestLittleEndian(); + Platform_TimeStart = 0; + Platform_TimeStart = Platform_Time(); + Platform_CWD[0] = 0x00; + Platform_getCurrentDirectory((void*)Platform_CWD, 4096); + Platform_PID = Platform_getpid(); + Platform_SeekSet = Platform_seekset(); + Platform_SeekCur = Platform_seekcur(); + Platform_SeekEnd = Platform_seekend(); + Platform_StdIn = Platform_getstdinhandle(); + Platform_StdOut = Platform_getstdouthandle(); + Platform_StdErr = Platform_getstderrhandle(); + Platform_EnableVT100(); + Platform_NL[0] = 0x0d; + Platform_NL[1] = 0x0a; + Platform_NL[2] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/windows-48/Platform.h b/bootstrap/windows-48/Platform.h new file mode 100644 index 00000000..b1ed4c6f --- /dev/null +++ b/bootstrap/windows-48/Platform.h @@ -0,0 +1,75 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Platform__h +#define Platform__h + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 _prvt0; + char _prvt1[16]; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +import BOOLEAN Platform_LittleEndian; +import INT16 Platform_PID; +import CHAR Platform_CWD[4096]; +import INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +import INT32 Platform_StdIn, Platform_StdOut, Platform_StdErr; +import CHAR Platform_NL[3]; + +import ADDRESS *Platform_FileIdentity__typ; + +import BOOLEAN Platform_Absent (INT16 e); +import INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +import INT16 Platform_Close (INT32 h); +import BOOLEAN Platform_ConnectionFailed (INT16 e); +import void Platform_Delay (INT32 ms); +import BOOLEAN Platform_DifferentFilesystems (INT16 e); +import INT16 Platform_Error (void); +import void Platform_Exit (INT32 code); +import void Platform_GetClock (INT32 *t, INT32 *d); +import void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +import INT16 Platform_Identify (INT32 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import BOOLEAN Platform_Inaccessible (INT16 e); +import BOOLEAN Platform_Interrupted (INT16 e); +import BOOLEAN Platform_IsConsole (INT32 h); +import void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +import INT16 Platform_MaxNameLength (void); +import INT16 Platform_MaxPathLength (void); +import INT16 Platform_New (CHAR *n, ADDRESS n__len, INT32 *h); +import BOOLEAN Platform_NoSuchDirectory (INT16 e); +import INT32 Platform_OSAllocate (INT32 size); +import void Platform_OSFree (INT32 address); +import INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT32 *h); +import INT16 Platform_Read (INT32 h, INT32 p, INT32 l, INT32 *n); +import INT16 Platform_ReadBuf (INT32 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +import INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +import BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +import BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +import INT16 Platform_Seek (INT32 h, INT32 o, INT16 r); +import void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +import void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +import INT16 Platform_Size (INT32 h, INT32 *l); +import INT16 Platform_Sync (INT32 h); +import INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +import INT32 Platform_Time (void); +import BOOLEAN Platform_TimedOut (INT16 e); +import BOOLEAN Platform_TooManyFiles (INT16 e); +import INT16 Platform_Truncate (INT32 h, INT32 limit); +import INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +import INT16 Platform_Write (INT32 h, INT32 p, INT32 l); +import BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void *Platform__init(void); + +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((ADDRESS)h) + +#endif // Platform diff --git a/bootstrap/windows-48/Reals.c b/bootstrap/windows-48/Reals.c new file mode 100644 index 00000000..512ec2c4 --- /dev/null +++ b/bootstrap/windows-48/Reals.c @@ -0,0 +1,157 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + + + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len); +export void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +export void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +export void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +export void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +export INT16 Reals_Expo (REAL x); +export INT16 Reals_ExpoL (LONGREAL x); +export void Reals_SetExpo (REAL *x, INT16 ex); +export REAL Reals_Ten (INT16 e); +export LONGREAL Reals_TenL (INT16 e); +static CHAR Reals_ToHex (INT16 i); + + +REAL Reals_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +LONGREAL Reals_TenL (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + for (;;) { + if (__ODD(e)) { + r = r * power; + } + e = __ASHR(e, 1); + if (e <= 0) { + return r; + } + power = power * power; + } + __RETCHK; +} + +INT16 Reals_Expo (REAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 2, i, INT16); + return __MASK(__ASHR(i, 7), -256); +} + +void Reals_SetExpo (REAL *x, INT16 ex) +{ + CHAR c; + __GET((ADDRESS)x + 3, c, CHAR); + __PUT((ADDRESS)x + 3, __CHR(__ASHL(__ASHR((INT16)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((ADDRESS)x + 2, c, CHAR); + __PUT((ADDRESS)x + 2, __CHR(__MASK((INT16)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); +} + +INT16 Reals_ExpoL (LONGREAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 6, i, INT16); + return __MASK(__ASHR(i, 4), -2048); +} + +void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + INT32 i, j, k; + if (x < (LONGREAL)0) { + x = -x; + } + k = 0; + if (n > 9) { + i = __SHORT(__ENTIER(x / (LONGREAL)(LONGREAL)1000000000), 2147483648LL); + j = __SHORT(__ENTIER(x - i * (LONGREAL)1000000000), 2147483648LL); + if (j < 0) { + j = 0; + } + while (k < 9) { + d[__X(k, d__len)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } + } else { + i = __SHORT(__ENTIER(x), 2147483648LL); + } + while (k < n) { + d[__X(k, d__len)] = __CHR((int)__MOD(i, 10) + 48); + i = __DIV(i, 10); + k += 1; + } +} + +void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + Reals_ConvertL(x, n, (void*)d, d__len); +} + +static CHAR Reals_ToHex (INT16 i) +{ + if (i < 10) { + return __CHR(i + 48); + } else { + return __CHR(i + 55); + } + __RETCHK; +} + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len) +{ + INT16 i; + INT32 l; + CHAR by; + i = 0; + l = b__len; + while (i < l) { + by = __VAL(CHAR, b[__X(i, b__len)]); + d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((INT16)by, 4)); + d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((INT16)by, -16)); + i += 1; + } +} + +void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&y, 4, (void*)d, d__len * 1); +} + +void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&x, 8, (void*)d, d__len * 1); +} + + +export void *Reals__init(void) +{ + __DEFMOD; + __REGMOD("Reals", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/Reals.h b/bootstrap/windows-48/Reals.h new file mode 100644 index 00000000..93e7fa75 --- /dev/null +++ b/bootstrap/windows-48/Reals.h @@ -0,0 +1,23 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Reals__h +#define Reals__h + +#include "SYSTEM.h" + + + + +import void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +import void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +import void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +import void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +import INT16 Reals_Expo (REAL x); +import INT16 Reals_ExpoL (LONGREAL x); +import void Reals_SetExpo (REAL *x, INT16 ex); +import REAL Reals_Ten (INT16 e); +import LONGREAL Reals_TenL (INT16 e); +import void *Reals__init(void); + + +#endif // Reals diff --git a/bootstrap/windows-48/Strings.c b/bootstrap/windows-48/Strings.c new file mode 100644 index 00000000..4b18812f --- /dev/null +++ b/bootstrap/windows-48/Strings.c @@ -0,0 +1,374 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Reals.h" + + + + +export void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +export void Strings_Cap (CHAR *s, ADDRESS s__len); +export void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +export void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +export void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export INT16 Strings_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +export INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +export void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +export void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); + + +INT16 Strings_Length (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + if (i <= 32767) { + __DEL(s); + return __SHORT(i, 32768); + } else { + __DEL(s); + return 32767; + } + __RETCHK; +} + +void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(extra, extra__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(extra, extra__len); + i = 0; + while ((i < n2 && (i + n1) < dest__len)) { + dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; + i += 1; + } + if ((i + n1) < dest__len) { + dest[__X(i + n1, dest__len)] = 0x00; + } + __DEL(extra); +} + +void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(source, source__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(source, source__len); + if (pos < 0) { + pos = 0; + } + if (pos > n1) { + Strings_Append(dest, dest__len, (void*)source, source__len); + __DEL(source); + return; + } + if ((pos + n2) < dest__len) { + i = n1; + while (i >= pos) { + if ((i + n2) < dest__len) { + dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; + } + i -= 1; + } + } + i = 0; + while (i < n2) { + dest[__X(pos + i, dest__len)] = source[__X(i, source__len)]; + i += 1; + } + __DEL(source); +} + +void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n) +{ + INT16 len, i; + len = Strings_Length(s, s__len); + if (pos < 0) { + pos = 0; + } else if (pos >= len) { + return; + } + if (pos + n < len) { + i = pos + n; + while (i < len) { + s[__X(i - n, s__len)] = s[__X(i, s__len)]; + i += 1; + } + if ((i - n) < s__len) { + s[__X(i - n, s__len)] = 0x00; + } + } else { + s[__X(pos, s__len)] = 0x00; + } +} + +void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + __DUP(source, source__len, CHAR); + Strings_Delete((void*)dest, dest__len, pos, pos + Strings_Length(source, source__len)); + Strings_Insert(source, source__len, pos, (void*)dest, dest__len); + __DEL(source); +} + +void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len) +{ + INT16 len, destLen, i; + __DUP(source, source__len, CHAR); + len = Strings_Length(source, source__len); + destLen = __SHORT(dest__len, 32768) - 1; + if (pos < 0) { + pos = 0; + } + if (pos >= len) { + dest[0] = 0x00; + __DEL(source); + return; + } + i = 0; + while (((((pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + if (i < destLen) { + dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; + } + i += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(source); +} + +INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos) +{ + INT16 n1, n2, i, j; + __DUP(pattern, pattern__len, CHAR); + __DUP(s, s__len, CHAR); + n1 = Strings_Length(s, s__len); + n2 = Strings_Length(pattern, pattern__len); + if (n2 == 0) { + __DEL(pattern); + __DEL(s); + return 0; + } + i = pos; + while (i <= n1 - n2) { + if (s[__X(i, s__len)] == pattern[0]) { + j = 1; + while ((j < n2 && s[__X(i + j, s__len)] == pattern[__X(j, pattern__len)])) { + j += 1; + } + if (j == n2) { + __DEL(pattern); + __DEL(s); + return i; + } + } + i += 1; + } + __DEL(pattern); + __DEL(s); + return -1; +} + +void Strings_Cap (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + if (('a' <= s[__X(i, s__len)] && s[__X(i, s__len)] <= 'z')) { + s[__X(i, s__len)] = __CAP(s[__X(i, s__len)]); + } + i += 1; + } +} + +static struct Match__7 { + struct Match__7 *lnk; +} *Match__7_s; + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m); + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m) +{ + while ((((n >= 0 && m >= 0)) && mask[__X(m, mask__len)] != '*')) { + if (name[__X(n, name__len)] != mask[__X(m, mask__len)]) { + return 0; + } + n -= 1; + m -= 1; + } + if (m < 0) { + return n < 0; + } + while ((m >= 0 && mask[__X(m, mask__len)] == '*')) { + m -= 1; + } + if (m < 0) { + return 1; + } + while (n >= 0) { + if (M__8(name, name__len, mask, mask__len, n, m)) { + return 1; + } + n -= 1; + } + return 0; +} + +BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len) +{ + struct Match__7 _s; + BOOLEAN __retval; + __DUP(string, string__len, CHAR); + __DUP(pattern, pattern__len, CHAR); + _s.lnk = Match__7_s; + Match__7_s = &_s; + __retval = M__8((void*)string, string__len, (void*)pattern, pattern__len, Strings_Length(string, string__len) - 1, Strings_Length(pattern, pattern__len) - 1); + Match__7_s = _s.lnk; + __DEL(string); + __DEL(pattern); + ; + return __retval; +} + +void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r) +{ + INT16 p, e; + REAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (REAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (REAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (REAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (REAL)(REAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (REAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + +void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r) +{ + INT16 p, e; + LONGREAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (LONGREAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (LONGREAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (LONGREAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (LONGREAL)(LONGREAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (LONGREAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + + +export void *Strings__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Reals); + __REGMOD("Strings", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/Strings.h b/bootstrap/windows-48/Strings.h new file mode 100644 index 00000000..f0e3ae34 --- /dev/null +++ b/bootstrap/windows-48/Strings.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Strings__h +#define Strings__h + +#include "SYSTEM.h" + + + + +import void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +import void Strings_Cap (CHAR *s, ADDRESS s__len); +import void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +import void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +import void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import INT16 Strings_Length (CHAR *s, ADDRESS s__len); +import BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +import INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +import void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +import void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); +import void *Strings__init(void); + + +#endif // Strings diff --git a/bootstrap/windows-48/Texts.c b/bootstrap/windows-48/Texts.c new file mode 100644 index 00000000..43c3858f --- /dev/null +++ b/bootstrap/windows-48/Texts.c @@ -0,0 +1,1833 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Files.h" +#include "Modules.h" +#include "Reals.h" + +typedef + struct Texts_RunDesc *Texts_Run; + +typedef + struct Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_RunDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + } Texts_RunDesc; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + struct Texts_ElemDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + } Texts_ElemDesc; + +struct Texts__1 { /* Texts_ElemDesc */ + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + Files_File file; + INT32 org, span; + CHAR mod[32], proc[32]; +}; + +typedef + struct Texts__1 *Texts_Alien; + +typedef + struct Texts_BufDesc { + INT32 len; + Texts_Run head; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + CHAR name[32]; + } Texts_FontDesc; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_PieceDesc *Texts_Piece; + +typedef + struct Texts_PieceDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + Files_File file; + INT32 org; + } Texts_PieceDesc; + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + Texts_Run head, cache; + INT32 corg; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + Files_Rider rider; + Files_File file; + } Texts_Writer; + + +export Texts_Elem Texts_new; +static Texts_Buffer Texts_del; +static Texts_FontsFont Texts_FontsDefault; + +export ADDRESS *Texts_FontDesc__typ; +export ADDRESS *Texts_RunDesc__typ; +export ADDRESS *Texts_PieceDesc__typ; +export ADDRESS *Texts_ElemMsg__typ; +export ADDRESS *Texts_ElemDesc__typ; +export ADDRESS *Texts_FileMsg__typ; +export ADDRESS *Texts_CopyMsg__typ; +export ADDRESS *Texts_IdentifyMsg__typ; +export ADDRESS *Texts_BufDesc__typ; +export ADDRESS *Texts_TextDesc__typ; +export ADDRESS *Texts_Reader__typ; +export ADDRESS *Texts_Scanner__typ; +export ADDRESS *Texts_Writer__typ; +export ADDRESS *Texts__1__typ; + +export void Texts_Append (Texts_Text T, Texts_Buffer B); +export void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +static Texts_Elem Texts_CloneElem (Texts_Elem e); +static Texts_Piece Texts_ClonePiece (Texts_Piece p); +export void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +export void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +export void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +export Texts_Text Texts_ElemBase (Texts_Elem E); +export INT32 Texts_ElemPos (Texts_Elem E); +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off); +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len); +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ); +export void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +export void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v); +export void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_OpenBuf (Texts_Buffer B); +export void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +export void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +export void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +export INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +export void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Recall (Texts_Buffer *B); +export void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +export void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +export void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +export void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +export void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base); +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un); +export void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +export void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +export void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +export void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +export void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +export void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +export void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +export void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +export void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +export void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +export void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +export void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +export void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); + + +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len) +{ + Texts_FontsFont F = NIL; + __NEW(F, Texts_FontDesc); + __COPY(name, F->name, 32); + return F; +} + +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off) +{ + Texts_Run v = NIL; + INT32 m; + if (*pos >= T->len) { + *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) { + while (m >= v->len) { + m -= v->len; + v = v->next; + } + } else { + while (m < 0) { + v = v->prev; + m += v->len; + } + } + *u = v; + *org = *pos - m; + *off = m; + T->cache = v->prev; + T->corg = *org; + } +} + +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un) +{ + Texts_Piece p = NIL, U = NIL; + if (off == 0) { + *un = *u; + *u = (*un)->prev; + } else if (off >= (*u)->len) { + *un = (*u)->next; + } else { + __NEW(p, Texts_PieceDesc); + *un = (Texts_Run)p; + U = __GUARDP(*u, Texts_PieceDesc, 1); + __GUARDEQP(p, Texts_PieceDesc) = *U; + p->org += off; + p->len -= off; + U->len -= p->len; + p->ascii = (*u)->ascii; + p->prev = (Texts_Run)U; + p->next = U->next; + p->next->prev = (Texts_Run)p; + U->next = (Texts_Run)p; + } +} + +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v) +{ + Texts_Piece p = NIL, q = NIL; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __ISP(*v, Texts_PieceDesc, 1))) && __STRCMP(u->fnt->name, (*v)->fnt->name) == 0)) && u->col == (*v)->col)) && u->voff == (*v)->voff)) && __GUARDP(u, Texts_PieceDesc, 1)->ascii == __GUARDP(*v, Texts_PieceDesc, 1)->ascii)) { + p = __GUARDP(u, Texts_PieceDesc, 1); + q = __GUARDP(*v, Texts_PieceDesc, 1); + if ((p->file == q->file && p->org + p->len == q->org)) { + if (T->cache == u) { + T->corg += q->len; + } else if (T->cache == *v) { + T->cache = T->head; + T->corg = 0; + } + p->len += q->len; + *v = (*v)->next; + } + } +} + +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base) +{ + Texts_Run u = NIL; + if (v != w->next) { + u = un->prev; + u->next = v; + v->prev = u; + un->prev = w; + w->next = un; + do { + if (__ISP(v, Texts_ElemDesc, 1)) { + __GUARDP(v, Texts_ElemDesc, 1)->base = base; + } + v = v->next; + } while (!(v == un)); + } +} + +static Texts_Piece Texts_ClonePiece (Texts_Piece p) +{ + Texts_Piece q = NIL; + __NEW(q, Texts_PieceDesc); + __GUARDEQP(q, Texts_PieceDesc) = *p; + return q; +} + +static Texts_Elem Texts_CloneElem (Texts_Elem e) +{ + Texts_CopyMsg msg; + msg.e = NIL; + (*e->handle)(e, (void*)&msg, Texts_CopyMsg__typ); + return msg.e; +} + +void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE) +{ + 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; +} + +Texts_Text Texts_ElemBase (Texts_Elem E) +{ + return E->base; +} + +INT32 Texts_ElemPos (Texts_Elem E) +{ + Texts_Run u = NIL; + INT32 pos; + u = E->base->head->next; + pos = 0; + while (u != (void *) E) { + pos = pos + u->len; + u = u->next; + } + return pos; +} + +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ) +{ + Texts_Alien e = NIL; + Files_Rider r; + INT32 i; + CHAR ch; + if (__ISP(E, Texts__1, 2)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + Texts_CopyMsg *msg__ = (void*)msg; + __NEW(e, Texts__1); + Texts_CopyElem((void*)(*(Texts_Alien*)&E), (void*)e); + e->file = (*(Texts_Alien*)&E)->file; + e->org = (*(Texts_Alien*)&E)->org; + e->span = (*(Texts_Alien*)&E)->span; + __MOVE((*(Texts_Alien*)&E)->mod, e->mod, 32); + __MOVE((*(Texts_Alien*)&E)->proc, e->proc, 32); + (*msg__).e = (Texts_Elem)e; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + Texts_IdentifyMsg *msg__ = (void*)msg; + __COPY((*(Texts_Alien*)&E)->mod, (*msg__).mod, 32); + __COPY((*(Texts_Alien*)&E)->proc, (*msg__).proc, 32); + (*msg__).mod[31] = 0x01; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_FileMsg, 1)) { + if (__IS(msg__typ, Texts_FileMsg, 1)) { + Texts_FileMsg *msg__ = (void*)msg; + if ((*msg__).id == 1) { + Files_Set(&r, Files_Rider__typ, (*(Texts_Alien*)&E)->file, (*(Texts_Alien*)&E)->org); + i = (*(Texts_Alien*)&E)->span; + while (i > 0) { + Files_Read(&r, Files_Rider__typ, (void*)&ch); + Files_Write(&(*msg__).r, Files_Rider__typ, ch); + i -= 1; + } + } + } else __WITHCHK; + } + } else __WITHCHK; +} + +void Texts_OpenBuf (Texts_Buffer B) +{ + Texts_Run u = NIL; + __NEW(u, Texts_RunDesc); + u->next = u; + u->prev = u; + B->head = u; + B->len = 0; +} + +void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB) +{ + Texts_Run u = NIL, v = NIL, vn = NIL; + u = SB->head->next; + v = DB->head->prev; + while (u != SB->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + vn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + } else { + vn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + v->next = vn; + vn->prev = v; + v = vn; + u = u->next; + } + v->next = DB->head; + DB->head->prev = v; + DB->len += SB->len; +} + +void Texts_Recall (Texts_Buffer *B) +{ + *B = Texts_del; + Texts_del = NIL; +} + +void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B) +{ + Texts_Run u = NIL, v = NIL, w = NIL, wn = NIL; + INT32 uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Find(T, &end, &v, &vo, &vd); + w = B->head->prev; + while (u != v) { + if (__ISP(u, Texts_PieceDesc, 1)) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + wn->len -= ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + } else { + wn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + w->next = wn; + wn->prev = w; + w = wn; + u = u->next; + ud = 0; + } + if (vd > 0) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(v, Texts_PieceDesc, 1)); + wn->len = vd - ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + w->next = wn; + wn->prev = w; + w = wn; + } + w->next = B->head; + B->head->prev = w; + B->len += end - beg; +} + +void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B) +{ + Texts_Run u = NIL, un = NIL, v = NIL; + Texts_Piece p = NIL, q = NIL; + INT32 uo, ud, len; + Texts_Find(T, &pos, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + len = B->len; + v = B->head->next; + Texts_Merge(T, u, &v); + Texts_Splice(un, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Append (Texts_Text T, Texts_Buffer B) +{ + Texts_Run v = NIL; + INT32 pos, len; + pos = T->len; + len = B->len; + v = B->head->next; + Texts_Merge(T, T->head->prev, &v); + Texts_Splice(T->head, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Delete (Texts_Text T, INT32 beg, INT32 end) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + __NEW(Texts_del, Texts_BufDesc); + Texts_OpenBuf(Texts_del); + Texts_del->len = end - beg; + Texts_Splice(Texts_del->head, un, v, NIL); + Texts_Merge(T, u, &vn); + u->next = vn; + vn->prev = u; + T->len -= end - beg; + if (T->notify != NIL) { + (*T->notify)(T, 2, beg, end); + } +} + +void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + while (un != vn) { + if ((__IN(0, sel, 32) && fnt != NIL)) { + un->fnt = fnt; + } + if (__IN(1, sel, 32)) { + un->col = col; + } + if (__IN(2, sel, 32)) { + un->voff = voff; + } + Texts_Merge(T, u, &un); + if (u->next == un) { + u = un; + un = un->next; + } else { + u->next = un; + un->prev = u; + } + } + Texts_Merge(T, u, &un); + u->next = un; + un->prev = u; + if (T->notify != NIL) { + (*T->notify)(T, 0, beg, end); + } +} + +void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos) +{ + Texts_Run u = NIL; + if (pos >= T->len) { + pos = T->len; + } + Texts_Find(T, &pos, &u, &(*R).org, &(*R).off); + (*R).run = u; + (*R).eot = 0; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, __GUARDP(u, Texts_PieceDesc, 1)->org + (*R).off); + } +} + +void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch) +{ + Texts_Run u = NIL; + INT32 pos; + CHAR nextch; + u = (*R).run; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).off += 1; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&*ch); + (*R).elem = NIL; + if ((*ch == 0x0a && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + *ch = 0x0d; + } else if ((*ch == 0x0d && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + pos = Files_Pos(&(*R).rider, Files_Rider__typ); + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&nextch); + if (nextch == 0x0a) { + (*R).off += 1; + } else { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, pos); + } + } + } else if (__ISP(u, Texts_ElemDesc, 1)) { + *ch = 0x1c; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + *ch = 0x00; + (*R).elem = NIL; + (*R).eot = 1; + } + if ((*R).off == u->len) { + (*R).org += u->len; + u = u->next; + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + } else __WITHCHK; + } + (*R).run = u; + (*R).off = 0; + } +} + +void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL, un = NIL; + u = (*R).run; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org += u->len; + u = u->next; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + un = u->next; + (*R).run = un; + (*R).org += 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + if (__ISP(un, Texts_PieceDesc, 1)) { + if (__ISP(un, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&un)->file, (*(Texts_Piece*)&un)->org); + } else __WITHCHK; + } + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL; + u = (*R).run->prev; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org -= u->len; + u = u->prev; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + (*R).run = u; + (*R).org -= 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ) +{ + return (*R).org + (*R).off; +} + +void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos) +{ + Texts_OpenReader((void*)&*S, S__typ, T, pos); + (*S).line = 0; + (*S).nextCh = ' '; +} + +static struct Scan__31 { + Texts_Scanner *S; + ADDRESS *S__typ; + CHAR *ch; + BOOLEAN *negE; + INT16 *e; + struct Scan__31 *lnk; +} *Scan__31_s; + +static void ReadScaleFactor__32 (void); + +static void ReadScaleFactor__32 (void) +{ + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + if (*Scan__31_s->ch == '-') { + *Scan__31_s->negE = 1; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } else { + *Scan__31_s->negE = 0; + if (*Scan__31_s->ch == '+') { + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } + } + while (('0' <= *Scan__31_s->ch && *Scan__31_s->ch <= '9')) { + *Scan__31_s->e = (*Scan__31_s->e * 10 + (INT16)*Scan__31_s->ch) - 48; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } +} + +void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ) +{ + CHAR ch, term; + BOOLEAN neg, negE, hex; + INT8 i, j, h; + INT16 e; + INT32 k; + REAL x, f; + LONGREAL y, g; + CHAR d[32]; + struct Scan__31 _s; + _s.S = S; _s.S__typ = S__typ; + _s.ch = &ch; + _s.negE = &negE; + _s.e = &e; + _s.lnk = Scan__31_s; + Scan__31_s = &_s; + ch = (*S).nextCh; + i = 0; + for (;;) { + if (ch == 0x0d) { + (*S).line += 1; + } else if ((ch != ' ' && ch != 0x09)) { + break; + } + Texts_Read((void*)&*S, S__typ, &ch); + } + if ((('A' <= __CAP(ch) && __CAP(ch) <= 'Z') || ch == '/') || ch == '.') { + do { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } while (!((((__CAP(ch) > 'Z' && ch != '_') || ('A' > __CAP(ch) && ch > '9')) || ((('0' > ch && ch != '.')) && ch != '/')) || i == 63)); + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i; + (*S).class = 1; + } else if (ch == '"') { + Texts_Read((void*)&*S, S__typ, &ch); + while ((((ch != '"' && ch >= ' ')) && i != 63)) { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i + 1; + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 2; + } else { + if (ch == '-') { + neg = 1; + Texts_Read((void*)&*S, S__typ, &ch); + } else { + neg = 0; + } + if (('0' <= ch && ch <= '9')) { + hex = 0; + j = 0; + for (;;) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + if (ch < '0') { + break; + } + if ('9' < ch) { + if (('A' <= ch && ch <= 'F')) { + hex = 1; + ch = __CHR((INT16)ch - 7); + } else if (('a' <= ch && ch <= 'f')) { + hex = 1; + ch = __CHR((INT16)ch - 39); + } else { + break; + } + } + } + if (ch == 'H') { + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 3; + if (i - j > 8) { + j = i - 8; + } + k = (INT16)d[__X(j, 32)] - 48; + j += 1; + if ((i - j == 7 && k >= 8)) { + k -= 16; + } + while (j < i) { + k = __ASHL(k, 4) + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + } else if (ch == '.') { + Texts_Read((void*)&*S, S__typ, &ch); + h = i; + while (('0' <= ch && ch <= '9')) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + if (ch == 'D') { + e = 0; + y = (LONGREAL)0; + g = (LONGREAL)1; + do { + y = y * (LONGREAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + g = g / (LONGREAL)(LONGREAL)10; + y = ((INT16)d[__X(j, 32)] - 48) * g + y; + j += 1; + } + ReadScaleFactor__32(); + if (negE) { + if (e <= 308) { + y = y / (LONGREAL)Reals_TenL(e); + } else { + y = (LONGREAL)0; + } + } else if (e > 0) { + if (e <= 308) { + y = Reals_TenL(e) * y; + } else { + __HALT(40); + } + } + if (neg) { + y = -y; + } + (*S).class = 5; + (*S).y = y; + } else { + e = 0; + x = (REAL)0; + f = (REAL)1; + do { + x = x * (REAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + f = f / (REAL)(REAL)10; + x = ((INT16)d[__X(j, 32)] - 48) * f + x; + j += 1; + } + if (ch == 'E') { + ReadScaleFactor__32(); + } + if (negE) { + if (e <= 38) { + x = x / (REAL)Reals_Ten(e); + } else { + x = (REAL)0; + } + } else if (e > 0) { + if (e <= 38) { + x = Reals_Ten(e) * x; + } else { + __HALT(40); + } + } + if (neg) { + x = -x; + } + (*S).class = 4; + (*S).x = x; + } + if (hex) { + (*S).class = 0; + } + } else { + (*S).class = 3; + k = 0; + do { + k = k * 10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == i)); + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + if (hex) { + (*S).class = 0; + } else { + (*S).class = 3; + } + } + } else { + (*S).class = 6; + if (neg) { + (*S).c = '-'; + } else { + (*S).c = ch; + Texts_Read((void*)&*S, S__typ, &ch); + } + } + } + (*S).nextCh = ch; + Scan__31_s = _s.lnk; +} + +void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ) +{ + __NEW((*W).buf, Texts_BufDesc); + Texts_OpenBuf((*W).buf); + (*W).fnt = Texts_FontsDefault; + (*W).col = 15; + (*W).voff = 0; + (*W).file = Files_New((CHAR*)"", 1); + Files_Set(&(*W).rider, Files_Rider__typ, (*W).file, 0); +} + +void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt) +{ + (*W).fnt = fnt; +} + +void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col) +{ + (*W).col = col; +} + +void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff) +{ + (*W).voff = voff; +} + +void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Files_Write(&(*W).rider, Files_Rider__typ, ch); + (*W).buf->len += 1; + un = (*W).buf->head; + u = un->prev; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __GUARDP(u, Texts_PieceDesc, 1)->file == (*W).file)) && __STRCMP(u->fnt->name, (*W).fnt->name) == 0)) && u->col == (*W).col)) && u->voff == (*W).voff)) && !__GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + u->len += 1; + } else { + __NEW(p, Texts_PieceDesc); + u->next = (Texts_Run)p; + p->prev = u; + p->next = un; + un->prev = (Texts_Run)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 = 0; + } +} + +void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e) +{ + Texts_Run u = NIL, un = NIL; + if (e->base != NIL) { + __HALT(99); + } + (*W).buf->len += 1; + e->len = 1; + e->fnt = (*W).fnt; + e->col = (*W).col; + e->voff = (*W).voff; + un = (*W).buf->head; + u = un->prev; + u->next = (Texts_Run)e; + e->prev = u; + e->next = un; + un->prev = (Texts_Run)e; +} + +void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ) +{ + Texts_Write(&*W, W__typ, 0x0d); +} + +void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while (s[__X(i, s__len)] >= ' ') { + Texts_Write(&*W, W__typ, s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n) +{ + INT16 i; + INT64 x0; + CHAR a[24]; + i = 0; + if (x < 0) { + if (x == (-9223372036854775807LL-1)) { + Texts_WriteString(&*W, W__typ, (CHAR*)" -9223372036854775808", 22); + return; + } else { + n -= 1; + x0 = -x; + } + } else { + x0 = x; + } + do { + a[__X(i, 24)] = __CHR(__MOD(x0, 10) + 48); + x0 = __DIV(x0, 10); + i += 1; + } while (!(x0 == 0)); + while (n > (INT64)i) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + if (x < 0) { + Texts_Write(&*W, W__typ, '-'); + } + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 24)]); + } while (!(i == 0)); +} + +void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x) +{ + INT16 i; + INT32 y; + CHAR a[20]; + i = 0; + Texts_Write(&*W, W__typ, ' '); + do { + y = __MASK(x, -16); + if (y < 10) { + a[__X(i, 20)] = __CHR(y + 48); + } else { + a[__X(i, 20)] = __CHR(y + 55); + } + x = __ASHR(x, 4); + i += 1; + } while (!(i == 8)); + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 20)]); + } while (!(i == 0)); +} + +void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n) +{ + INT16 e; + REAL x0; + CHAR d[9]; + e = Reals_Expo(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 9) { + n = 3; + } else { + n -= 6; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 8)); + if (x < (REAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __ASHR((e - 127) * 77, 8); + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + x0 = Reals_Ten(n - 1); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + x = x * 1.0000000e-001; + e += 1; + } + Reals_Convert(x, n, (void*)d, 9); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'E'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +static struct WriteRealFix__53 { + Texts_Writer *W; + ADDRESS *W__typ; + INT16 *i; + CHAR (*d)[9]; + struct WriteRealFix__53 *lnk; +} *WriteRealFix__53_s; + +static void dig__54 (INT16 n); +static void seq__56 (CHAR ch, INT16 n); + +static void seq__56 (CHAR ch, INT16 n) +{ + while (n > 0) { + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, ch); + n -= 1; + } +} + +static void dig__54 (INT16 n) +{ + while (n > 0) { + *WriteRealFix__53_s->i -= 1; + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, (*WriteRealFix__53_s->d)[__X(*WriteRealFix__53_s->i, 9)]); + n -= 1; + } +} + +void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k) +{ + INT16 e, i; + CHAR sign; + REAL x0; + CHAR d[9]; + struct WriteRealFix__53 _s; + _s.W = W; _s.W__typ = W__typ; + _s.i = &i; + _s.d = (void*)d; + _s.lnk = WriteRealFix__53_s; + WriteRealFix__53_s = &_s; + e = Reals_Expo(x); + if (k < 0) { + k = 0; + } + if (e == 0) { + seq__56(' ', (n - k) - 2); + Texts_Write(&*W, W__typ, '0'); + seq__56(' ', k + 1); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + seq__56(' ', n - 4); + } else { + e = __ASHR((e - 127) * 77, 8); + if (x < (REAL)0) { + sign = '-'; + x = -x; + } else { + sign = ' '; + } + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + if (k + e >= 8) { + k = 8 - e; + } else if (k + e < 0) { + k = -e; + x = (REAL)0; + } + x0 = Reals_Ten(k + e); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + e += 1; + } + e += 1; + i = k + e; + Reals_Convert(x, i, (void*)d, 9); + if (e > 0) { + seq__56(' ', ((n - e) - k) - 2); + Texts_Write(&*W, W__typ, sign); + dig__54(e); + Texts_Write(&*W, W__typ, '.'); + dig__54(k); + } else { + seq__56(' ', (n - k) - 3); + Texts_Write(&*W, W__typ, sign); + Texts_Write(&*W, W__typ, '0'); + Texts_Write(&*W, W__typ, '.'); + seq__56('0', -e); + dig__54(k + e); + } + } + WriteRealFix__53_s = _s.lnk; +} + +void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x) +{ + INT16 i; + CHAR d[8]; + Reals_ConvertH(x, (void*)d, 8); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 8)]); + i += 1; + } while (!(i == 8)); +} + +void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n) +{ + INT16 e; + LONGREAL x0; + CHAR d[16]; + e = Reals_ExpoL(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 2047) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 10) { + n = 3; + } else { + n -= 7; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 16)); + if (x < (LONGREAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Reals_TenL(e); + } else { + x = Reals_TenL(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + x0 = Reals_TenL(n - 1); + x = x0 * x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + Reals_ConvertL(x, n, (void*)d, 16); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'D'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 100) + 48)); + e = (int)__MOD(e, 100); + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x) +{ + INT16 i; + CHAR d[16]; + Reals_ConvertHL(x, (void*)d, 16); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 16)]); + i += 1; + } while (!(i == 16)); +} + +static struct WriteDate__43 { + Texts_Writer *W; + ADDRESS *W__typ; + struct WriteDate__43 *lnk; +} *WriteDate__43_s; + +static void WritePair__44 (CHAR ch, INT32 x); + +static void WritePair__44 (CHAR ch, INT32 x) +{ + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, ch); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR(__DIV(x, 10) + 48)); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR((int)__MOD(x, 10) + 48)); +} + +void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d) +{ + struct WriteDate__43 _s; + _s.W = W; _s.W__typ = W__typ; + _s.lnk = WriteDate__43_s; + WriteDate__43_s = &_s; + WritePair__44(' ', __MASK(d, -32)); + WritePair__44('.', __MASK(__ASHR(d, 5), -16)); + WritePair__44('.', __MASK(__ASHR(d, 9), -128)); + WritePair__44(' ', __MASK(__ASHR(t, 12), -32)); + WritePair__44(':', __MASK(__ASHR(t, 6), -64)); + WritePair__44(':', __MASK(t, -64)); + WriteDate__43_s = _s.lnk; +} + +static struct Load0__16 { + Texts_Text *T; + INT8 *ecnt; + Files_File *f; + Texts_FileMsg *msg; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Load0__16 *lnk; +} *Load0__16_s; + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e); + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e) +{ + Heap_Module M = NIL; + Heap_Command Cmd; + Texts_Alien a = NIL; + INT32 org, ew, eh; + INT8 eno; + Texts_new = NIL; + Files_ReadLInt(&*r, r__typ, &ew); + Files_ReadLInt(&*r, r__typ, &eh); + Files_Read(&*r, r__typ, (void*)&eno); + if (eno > *Load0__16_s->ecnt) { + *Load0__16_s->ecnt = eno; + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->mods)[__X(eno, 64)], 32); + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->procs)[__X(eno, 64)], 32); + } + org = Files_Pos(&*r, r__typ); + M = Modules_ThisMod((*Load0__16_s->mods)[__X(eno, 64)], 32); + if (M != NIL) { + Cmd = Modules_ThisCommand(M, (*Load0__16_s->procs)[__X(eno, 64)], 32); + if (Cmd != NIL) { + (*Cmd)(); + } + } + *e = Texts_new; + if (*e != NIL) { + (*e)->W = ew; + (*e)->H = eh; + (*e)->base = *Load0__16_s->T; + (*Load0__16_s->msg).pos = pos; + (*(*e)->handle)(*e, (void*)&*Load0__16_s->msg, Texts_FileMsg__typ); + if (Files_Pos(&*r, r__typ) != org + span) { + *e = NIL; + } + } + if (*e == NIL) { + Files_Set(&*r, r__typ, *Load0__16_s->f, org + span); + __NEW(a, Texts__1); + a->W = ew; + a->H = eh; + a->handle = Texts_HandleAlien; + a->base = *Load0__16_s->T; + a->file = *Load0__16_s->f; + a->org = org; + a->span = span; + __COPY((*Load0__16_s->mods)[__X(eno, 64)], a->mod, 32); + __COPY((*Load0__16_s->procs)[__X(eno, 64)], a->proc, 32); + *e = (Texts_Elem)a; + } +} + +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Texts_Elem e = NIL; + INT32 org, pos, hlen, plen; + INT8 ecnt, fcnt, fno, col, voff; + Files_File f = NIL; + Texts_FileMsg msg; + CHAR mods[64][32], procs[64][32]; + CHAR name[32]; + Texts_FontsFont fnts[32]; + struct Load0__16 _s; + _s.T = &T; + _s.ecnt = &ecnt; + _s.f = &f; + _s.msg = &msg; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Load0__16_s; + Load0__16_s = &_s; + pos = Files_Pos(&*r, r__typ); + f = Files_Base(&*r, r__typ); + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + T->head = u; + ecnt = 0; + fcnt = 0; + msg.id = 0; + msg.r = *r; + Files_ReadLInt(&msg.r, Files_Rider__typ, &hlen); + org = (pos - 2) + hlen; + pos = org; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + while (fno != 0) { + if (fno > fcnt) { + fcnt = fno; + Files_ReadString(&msg.r, Files_Rider__typ, (void*)name, 32); + fnts[__X(fno, 32)] = Texts_FontsThis((void*)name, 32); + } + Files_Read(&msg.r, Files_Rider__typ, (void*)&col); + Files_Read(&msg.r, Files_Rider__typ, (void*)&voff); + Files_ReadLInt(&msg.r, Files_Rider__typ, &plen); + if (plen > 0) { + __NEW(p, Texts_PieceDesc); + p->file = f; + p->org = pos; + p->ascii = 0; + un = (Texts_Run)p; + un->len = plen; + } else { + LoadElem__17(&msg.r, Files_Rider__typ, pos - org, -plen, &e); + un = (Texts_Run)e; + un->len = 1; + } + un->col = col; + un->voff = voff; + pos += un->len; + u->next = un; + un->prev = u; + u = un; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + } + u->next = T->head; + T->head->prev = u; + T->cache = T->head; + T->corg = 0; + Files_ReadLInt(&msg.r, Files_Rider__typ, &T->len); + Files_Set(&*r, r__typ, f, Files_Pos(&msg.r, Files_Rider__typ) + T->len); + Load0__16_s = _s.lnk; +} + +void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + INT16 tag; + Files_ReadInt(&*r, r__typ, &tag); + if (tag != -4095) { + Files_Set(&*r, r__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ) - 2); + } + Texts_Load0(&*r, r__typ, T); +} + +void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + Texts_Run u = NIL; + Texts_Piece p = NIL; + CHAR tag, version; + INT32 hlen; + __DUP(name, name__len, CHAR); + f = Files_Old(name, name__len); + if (f == NIL) { + f = Files_New((CHAR*)"", 1); + } + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Read(&r, Files_Rider__typ, (void*)&tag); + Files_Read(&r, Files_Rider__typ, (void*)&version); + if (tag == 0xf0 || (tag == 0x01 && version == 0xf0)) { + Texts_Load0(&r, Files_Rider__typ, T); + } else { + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + __NEW(p, Texts_PieceDesc); + if ((tag == 0xf7 && version == 0x07)) { + Files_Set(&r, Files_Rider__typ, f, 28); + Files_ReadLInt(&r, Files_Rider__typ, &hlen); + Files_Set(&r, Files_Rider__typ, f, 22 + hlen); + Files_ReadLInt(&r, Files_Rider__typ, &T->len); + p->org = 26 + hlen; + } else { + T->len = Files_Length(f); + p->org = 0; + } + if (T->len > 0) { + p->len = T->len; + p->fnt = Texts_FontsDefault; + p->col = 15; + p->voff = 0; + p->file = f; + p->ascii = 1; + u->next = (Texts_Run)p; + u->prev = (Texts_Run)p; + p->next = u; + p->prev = u; + } else { + u->next = u; + u->prev = u; + } + T->head = u; + T->cache = T->head; + T->corg = 0; + } + __DEL(name); +} + +static struct Store__39 { + INT8 *ecnt; + Texts_FileMsg *msg; + Texts_IdentifyMsg *iden; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Store__39 *lnk; +} *Store__39_s; + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e); + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e) +{ + Files_Rider r1; + INT32 org, span; + INT8 eno; + __COPY((*Store__39_s->iden).mod, (*Store__39_s->mods)[__X(*Store__39_s->ecnt, 64)], 32); + __COPY((*Store__39_s->iden).proc, (*Store__39_s->procs)[__X(*Store__39_s->ecnt, 64)], 32); + eno = 1; + while (__STRCMP((*Store__39_s->mods)[__X(eno, 64)], (*Store__39_s->iden).mod) != 0 || __STRCMP((*Store__39_s->procs)[__X(eno, 64)], (*Store__39_s->iden).proc) != 0) { + eno += 1; + } + Files_Set(&r1, Files_Rider__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ)); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_Write(&*r, r__typ, eno); + if (eno == *Store__39_s->ecnt) { + *Store__39_s->ecnt += 1; + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).mod, 32); + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).proc, 32); + } + (*Store__39_s->msg).pos = pos; + org = Files_Pos(&*r, r__typ); + (*e->handle)(e, (void*)&*Store__39_s->msg, Texts_FileMsg__typ); + span = Files_Pos(&*r, r__typ) - org; + Files_WriteLInt(&r1, Files_Rider__typ, -span); + Files_WriteLInt(&r1, Files_Rider__typ, e->W); + Files_WriteLInt(&r1, Files_Rider__typ, e->H); +} + +void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Files_Rider r1; + Texts_Run u = NIL, un = NIL; + Texts_Elem e = NIL; + INT32 org, pos, delta, hlen, rlen; + INT8 ecnt, fcnt; + CHAR ch; + INT8 fno; + Texts_FileMsg msg; + Texts_IdentifyMsg iden; + CHAR mods[64][32], procs[64][32]; + Texts_FontsFont fnts[32]; + CHAR block[1024]; + struct Store__39 _s; + _s.ecnt = &ecnt; + _s.msg = &msg; + _s.iden = &iden; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Store__39_s; + Store__39_s = &_s; + org = Files_Pos(&*r, r__typ); + msg.id = 1; + msg.r = *r; + Files_WriteLInt(&msg.r, Files_Rider__typ, 0); + u = T->head->next; + pos = 0; + delta = 0; + fcnt = 1; + ecnt = 1; + while (u != T->head) { + if (__ISP(u, Texts_ElemDesc, 1)) { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + } else { + iden.mod[0] = 0x01; + } + if (iden.mod[0] != 0x00) { + fnts[__X(fcnt, 32)] = u->fnt; + fno = 1; + while (__STRCMP(fnts[__X(fno, 32)]->name, u->fnt->name) != 0) { + fno += 1; + } + Files_Write(&msg.r, Files_Rider__typ, fno); + if (fno == fcnt) { + fcnt += 1; + Files_WriteString(&msg.r, Files_Rider__typ, u->fnt->name, 32); + } + Files_Write(&msg.r, Files_Rider__typ, u->col); + Files_Write(&msg.r, Files_Rider__typ, u->voff); + } + if (__ISP(u, Texts_PieceDesc, 1)) { + rlen = u->len; + un = u->next; + while ((((((__ISP(un, Texts_PieceDesc, 1) && un->fnt == u->fnt)) && un->col == u->col)) && un->voff == u->voff)) { + rlen += un->len; + un = un->next; + } + Files_WriteLInt(&msg.r, Files_Rider__typ, rlen); + pos += rlen; + u = un; + } else if (iden.mod[0] != 0x00) { + StoreElem__40(&msg.r, Files_Rider__typ, pos, __GUARDP(u, Texts_ElemDesc, 1)); + pos += 1; + u = u->next; + } else { + delta += 1; + u = u->next; + } + } + Files_Write(&msg.r, Files_Rider__typ, 0); + Files_WriteLInt(&msg.r, Files_Rider__typ, T->len - delta); + hlen = (Files_Pos(&msg.r, Files_Rider__typ) - org) + 2; + Files_Set(&r1, Files_Rider__typ, Files_Base(&msg.r, Files_Rider__typ), org); + Files_WriteLInt(&r1, Files_Rider__typ, hlen); + u = T->head->next; + while (u != T->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if ((*(Texts_Piece*)&u)->ascii) { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 0) { + Files_Read(&r1, Files_Rider__typ, (void*)&ch); + delta -= 1; + if (ch == 0x0a) { + Files_Write(&msg.r, Files_Rider__typ, 0x0d); + } else { + Files_Write(&msg.r, Files_Rider__typ, ch); + } + } + } else { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 1024) { + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, 1024); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, 1024); + delta -= 1024; + } + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, delta); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, delta); + } + } else __WITHCHK; + } else { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + if (iden.mod[0] != 0x00) { + Files_Write(&msg.r, Files_Rider__typ, 0x1c); + } + } + u = u->next; + } + __GUARDEQR(r, r__typ, Files_Rider) = msg.r; + if (T->notify != NIL) { + (*T->notify)(T, 3, 0, 0); + } + Store__39_s = _s.lnk; +} + +void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + INT16 i, res; + CHAR bak[64]; + __DUP(name, name__len, CHAR); + f = Files_New(name, name__len); + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Write(&r, Files_Rider__typ, 0xf0); + Files_Write(&r, Files_Rider__typ, 0x01); + Texts_Store(&r, Files_Rider__typ, T); + i = 0; + while (name[__X(i, name__len)] != 0x00) { + i += 1; + } + __COPY(name, bak, 64); + bak[__X(i, 64)] = '.'; + bak[__X(i + 1, 64)] = 'B'; + bak[__X(i + 2, 64)] = 'a'; + bak[__X(i + 3, 64)] = 'k'; + bak[__X(i + 4, 64)] = 0x00; + Files_Rename(name, name__len, bak, 64, &res); + Files_Register(f); + __DEL(name); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Texts_new); + P(Texts_del); + P(Texts_FontsDefault); +} + +__TDESC(Texts_FontDesc, 1, 0) = {__TDFLDS("FontDesc", 32), {-4}}; +__TDESC(Texts_RunDesc, 1, 3) = {__TDFLDS("RunDesc", 20), {0, 4, 12, -16}}; +__TDESC(Texts_PieceDesc, 1, 4) = {__TDFLDS("PieceDesc", 28), {0, 4, 12, 20, -20}}; +__TDESC(Texts_ElemMsg, 1, 0) = {__TDFLDS("ElemMsg", 1), {-4}}; +__TDESC(Texts_ElemDesc, 1, 4) = {__TDFLDS("ElemDesc", 36), {0, 4, 12, 32, -20}}; +__TDESC(Texts_FileMsg, 1, 1) = {__TDFLDS("FileMsg", 28), {16, -8}}; +__TDESC(Texts_CopyMsg, 1, 1) = {__TDFLDS("CopyMsg", 4), {0, -8}}; +__TDESC(Texts_IdentifyMsg, 1, 0) = {__TDFLDS("IdentifyMsg", 64), {-4}}; +__TDESC(Texts_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 8), {4, -8}}; +__TDESC(Texts_TextDesc, 1, 2) = {__TDFLDS("TextDesc", 20), {8, 12, -12}}; +__TDESC(Texts_Reader, 1, 4) = {__TDFLDS("Reader", 48), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Scanner, 1, 4) = {__TDFLDS("Scanner", 144), {4, 12, 24, 36, -20}}; +__TDESC(Texts_Writer, 1, 4) = {__TDFLDS("Writer", 36), {0, 4, 20, 32, -20}}; +__TDESC(Texts__1, 1, 5) = {__TDFLDS("", 112), {0, 4, 12, 32, 36, -24}}; + +export void *Texts__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Reals); + __REGMOD("Texts", EnumPtrs); + __INITYP(Texts_FontDesc, Texts_FontDesc, 0); + __INITYP(Texts_RunDesc, Texts_RunDesc, 0); + __INITYP(Texts_PieceDesc, Texts_RunDesc, 1); + __INITYP(Texts_ElemMsg, Texts_ElemMsg, 0); + __INITYP(Texts_ElemDesc, Texts_RunDesc, 1); + __INITYP(Texts_FileMsg, Texts_ElemMsg, 1); + __INITYP(Texts_CopyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_IdentifyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_BufDesc, Texts_BufDesc, 0); + __INITYP(Texts_TextDesc, Texts_TextDesc, 0); + __INITYP(Texts_Reader, Texts_Reader, 0); + __INITYP(Texts_Scanner, Texts_Reader, 1); + __INITYP(Texts_Writer, Texts_Writer, 0); + __INITYP(Texts__1, Texts_ElemDesc, 2); +/* BEGIN */ + Texts_del = NIL; + __NEW(Texts_FontsDefault, Texts_FontDesc); + __MOVE("Syntax10.Scn.Fnt", Texts_FontsDefault->name, 17); + __ENDMOD; +} diff --git a/bootstrap/windows-48/Texts.h b/bootstrap/windows-48/Texts.h new file mode 100644 index 00000000..fd0c0fa5 --- /dev/null +++ b/bootstrap/windows-48/Texts.h @@ -0,0 +1,173 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Texts__h +#define Texts__h + +#include "SYSTEM.h" +#include "Files.h" + +typedef + struct Texts_BufDesc { + INT32 len; + char _prvt0[4]; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_RunDesc { + INT32 _prvt0; + char _prvt1[15]; + } Texts_RunDesc; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_ElemDesc { + char _prvt0[20]; + INT32 W, H; + Texts_Handler handle; + char _prvt1[4]; + } Texts_ElemDesc; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + char _prvt0[32]; + } Texts_FontDesc; + +typedef + Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[32]; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + INT64 _prvt0; + char _prvt1[24]; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + char _prvt0[12]; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + char _prvt0[26]; + } Texts_Writer; + + +import Texts_Elem Texts_new; + +import ADDRESS *Texts_FontDesc__typ; +import ADDRESS *Texts_RunDesc__typ; +import ADDRESS *Texts_ElemMsg__typ; +import ADDRESS *Texts_ElemDesc__typ; +import ADDRESS *Texts_FileMsg__typ; +import ADDRESS *Texts_CopyMsg__typ; +import ADDRESS *Texts_IdentifyMsg__typ; +import ADDRESS *Texts_BufDesc__typ; +import ADDRESS *Texts_TextDesc__typ; +import ADDRESS *Texts_Reader__typ; +import ADDRESS *Texts_Scanner__typ; +import ADDRESS *Texts_Writer__typ; + +import void Texts_Append (Texts_Text T, Texts_Buffer B); +import void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +import void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +import void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +import void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +import Texts_Text Texts_ElemBase (Texts_Elem E); +import INT32 Texts_ElemPos (Texts_Elem E); +import void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +import void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_OpenBuf (Texts_Buffer B); +import void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +import void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +import void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +import INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +import void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Recall (Texts_Buffer *B); +import void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +import void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +import void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +import void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +import void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +import void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +import void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +import void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +import void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +import void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +import void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +import void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +import void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +import void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +import void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +import void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +import void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); +import void *Texts__init(void); + + +#endif // Texts diff --git a/bootstrap/windows-48/VT100.c b/bootstrap/windows-48/VT100.c new file mode 100644 index 00000000..346fb37b --- /dev/null +++ b/bootstrap/windows-48/VT100.c @@ -0,0 +1,275 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Out.h" +#include "Strings.h" + + +export CHAR VT100_CSI[5]; +static CHAR VT100_tmpstr[32]; + + +export void VT100_CHA (INT16 n); +export void VT100_CNL (INT16 n); +export void VT100_CPL (INT16 n); +export void VT100_CUB (INT16 n); +export void VT100_CUD (INT16 n); +export void VT100_CUF (INT16 n); +export void VT100_CUP (INT16 n, INT16 m); +export void VT100_CUU (INT16 n); +export void VT100_DECTCEMh (void); +export void VT100_DECTCEMl (void); +export void VT100_DSR (INT16 n); +export void VT100_ED (INT16 n); +export void VT100_EL (INT16 n); +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len); +export void VT100_HVP (INT16 n, INT16 m); +export void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +export void VT100_RCP (void); +export void VT100_Reset (void); +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end); +export void VT100_SCP (void); +export void VT100_SD (INT16 n); +export void VT100_SGR (INT16 n); +export void VT100_SGR2 (INT16 n, INT16 m); +export void VT100_SU (INT16 n); +export void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); + + +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end) +{ + CHAR h; + while (start < end) { + h = str[__X(start, str__len)]; + str[__X(start, str__len)] = str[__X(end, str__len)]; + str[__X(end, str__len)] = h; + start += 1; + end -= 1; + } +} + +void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len) +{ + CHAR b[21]; + INT16 s, e; + INT8 maxLength; + maxLength = 11; + if (int_ == (-2147483647-1)) { + __MOVE("-2147483648", b, 12); + e = 11; + } else { + if (int_ < 0) { + b[0] = '-'; + int_ = -int_; + s = 1; + } else { + s = 0; + } + e = s; + do { + b[__X(e, 21)] = __CHR((int)__MOD(int_, 10) + 48); + int_ = __DIV(int_, 10); + e += 1; + } while (!(int_ == 0)); + b[__X(e, 21)] = 0x00; + VT100_Reverse0((void*)b, 21, s, e - 1); + } + __COPY(b, str, str__len); +} + +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len) +{ + CHAR cmd[9]; + __DUP(letter, letter__len, CHAR); + __COPY(VT100_CSI, cmd, 9); + Strings_Append(letter, letter__len, (void*)cmd, 9); + Out_String(cmd, 9); + __DEL(letter); +} + +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[5], mstr[5]; + CHAR cmd[12]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 5); + VT100_IntToStr(m, (void*)mstr, 5); + __COPY(VT100_CSI, cmd, 12); + Strings_Append(nstr, 5, (void*)cmd, 12); + Strings_Append((CHAR*)";", 2, (void*)cmd, 12); + Strings_Append(mstr, 5, (void*)cmd, 12); + Strings_Append(letter, letter__len, (void*)cmd, 12); + Out_String(cmd, 12); + __DEL(letter); +} + +void VT100_Reset (void) +{ + CHAR cmd[6]; + __COPY("\033", cmd, 6); + Strings_Append((CHAR*)"c", 2, (void*)cmd, 6); + Out_String(cmd, 6); + Out_Ln(); +} + +void VT100_CUU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"A", 2); +} + +void VT100_CUD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"B", 2); +} + +void VT100_CUF (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"C", 2); +} + +void VT100_CUB (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"D", 2); +} + +void VT100_CNL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"E", 2); +} + +void VT100_CPL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"F", 2); +} + +void VT100_CHA (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"G", 2); +} + +void VT100_CUP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"H", 2); +} + +void VT100_ED (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"J", 2); +} + +void VT100_EL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"K", 2); +} + +void VT100_SU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"S", 2); +} + +void VT100_SD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"T", 2); +} + +void VT100_HVP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"f", 2); +} + +void VT100_SGR (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"m", 2); +} + +void VT100_SGR2 (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"m", 2); +} + +void VT100_DSR (INT16 n) +{ + VT100_EscSeq(6, (CHAR*)"n", 2); +} + +void VT100_SCP (void) +{ + VT100_EscSeq0((CHAR*)"s", 2); +} + +void VT100_RCP (void) +{ + VT100_EscSeq0((CHAR*)"u", 2); +} + +void VT100_DECTCEMl (void) +{ + VT100_EscSeq0((CHAR*)"\?25l", 5); +} + +void VT100_DECTCEMh (void) +{ + VT100_EscSeq0((CHAR*)"\?25h", 5); +} + +void VT100_SetAttr (CHAR *attr, ADDRESS attr__len) +{ + CHAR tmpstr[16]; + __DUP(attr, attr__len, CHAR); + __COPY(VT100_CSI, tmpstr, 16); + Strings_Append(attr, attr__len, (void*)tmpstr, 16); + Out_String(tmpstr, 16); + __DEL(attr); +} + + +export void *VT100__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Strings); + __REGMOD("VT100", 0); + __REGCMD("DECTCEMh", VT100_DECTCEMh); + __REGCMD("DECTCEMl", VT100_DECTCEMl); + __REGCMD("RCP", VT100_RCP); + __REGCMD("Reset", VT100_Reset); + __REGCMD("SCP", VT100_SCP); +/* BEGIN */ + __COPY("\033", VT100_CSI, 5); + Strings_Append((CHAR*)"[", 2, (void*)VT100_CSI, 5); + __ENDMOD; +} diff --git a/bootstrap/windows-48/VT100.h b/bootstrap/windows-48/VT100.h new file mode 100644 index 00000000..4e708647 --- /dev/null +++ b/bootstrap/windows-48/VT100.h @@ -0,0 +1,38 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef VT100__h +#define VT100__h + +#include "SYSTEM.h" + + +import CHAR VT100_CSI[5]; + + +import void VT100_CHA (INT16 n); +import void VT100_CNL (INT16 n); +import void VT100_CPL (INT16 n); +import void VT100_CUB (INT16 n); +import void VT100_CUD (INT16 n); +import void VT100_CUF (INT16 n); +import void VT100_CUP (INT16 n, INT16 m); +import void VT100_CUU (INT16 n); +import void VT100_DECTCEMh (void); +import void VT100_DECTCEMl (void); +import void VT100_DSR (INT16 n); +import void VT100_ED (INT16 n); +import void VT100_EL (INT16 n); +import void VT100_HVP (INT16 n, INT16 m); +import void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +import void VT100_RCP (void); +import void VT100_Reset (void); +import void VT100_SCP (void); +import void VT100_SD (INT16 n); +import void VT100_SGR (INT16 n); +import void VT100_SGR2 (INT16 n, INT16 m); +import void VT100_SU (INT16 n); +import void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); +import void *VT100__init(void); + + +#endif // VT100 diff --git a/bootstrap/windows-48/extTools.c b/bootstrap/windows-48/extTools.c new file mode 100644 index 00000000..ce2fc413 --- /dev/null +++ b/bootstrap/windows-48/extTools.c @@ -0,0 +1,139 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "Modules.h" +#include "OPM.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + CHAR extTools_CommandString[4096]; + + +static extTools_CommandString extTools_CFLAGS; + + +export void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len); +export void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len); + + +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len) +{ + INT16 r, status, exitcode; + extTools_CommandString fullcmd; + __DUP(title, title__len, CHAR); + __DUP(cmd, cmd__len, CHAR); + if (__IN(18, OPM_Options, 32)) { + Out_String((CHAR*)" ", 3); + Out_String(cmd, cmd__len); + Out_Ln(); + } + __COPY(cmd, fullcmd, 4096); + Heap_GC(0); + r = Platform_System(fullcmd, 4096); + status = __MASK(r, -128); + exitcode = __ASHR(r, 8); + if (exitcode > 127) { + exitcode = exitcode - 256; + } + if (r != 0) { + Out_String(title, title__len); + Out_String(cmd, cmd__len); + Out_Ln(); + Out_String((CHAR*)"-- failed: status ", 19); + Out_Int(status, 1); + Out_String((CHAR*)", exitcode ", 12); + Out_Int(exitcode, 1); + Out_String((CHAR*)".", 2); + Out_Ln(); + if ((status == 0 && exitcode == 127)) { + Out_String((CHAR*)"Is the C compiler in the current command path\?", 47); + Out_Ln(); + } + if (status != 0) { + Modules_Halt(status); + } else { + Modules_Halt(exitcode); + } + } + __DEL(title); + __DEL(cmd); +} + +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + __DUP(additionalopts, additionalopts__len, CHAR); + __COPY("gcc -fPIC -g -Wno-stringop-overflow", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Strings_Append(additionalopts, additionalopts__len, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 4096); + Strings_Append(extTools_CFLAGS, 4096, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + __DEL(additionalopts); +} + +void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len) +{ + extTools_CommandString cmd; + __DUP(moduleName, moduleName__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, (CHAR*)"", 1); + Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c", 3, (void*)cmd, 4096); + extTools_execute((CHAR*)"C compile: ", 12, cmd, 4096); + __DEL(moduleName); +} + +void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + extTools_CommandString cmd; + __DUP(additionalopts, additionalopts__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, additionalopts, additionalopts__len); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c ", 4, (void*)cmd, 4096); + if (statically) { + Strings_Append((CHAR*)" -static", 9, (void*)cmd, 4096); + } + Strings_Append((CHAR*)" -o ", 5, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + if (!statically || 1) { + Strings_Append((CHAR*)" -L\"", 5, (void*)cmd, 4096); + Strings_Append(OPM_InstallDir, 1024, (void*)cmd, 4096); + Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 4096); + Strings_Append((CHAR*)" -lvoc", 7, (void*)cmd, 4096); + Strings_Append((CHAR*)"-O", 3, (void*)cmd, 4096); + Strings_Append(OPM_Model, 10, (void*)cmd, 4096); + Strings_Append((CHAR*)"", 1, (void*)cmd, 4096); + } + extTools_execute((CHAR*)"C compile and link: ", 21, cmd, 4096); + __DEL(additionalopts); +} + + +export void *extTools__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("extTools", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-48/extTools.h b/bootstrap/windows-48/extTools.h new file mode 100644 index 00000000..686f0b4e --- /dev/null +++ b/bootstrap/windows-48/extTools.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef extTools__h +#define extTools__h + +#include "SYSTEM.h" + + + + +import void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +import void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +import void *extTools__init(void); + + +#endif // extTools diff --git a/bootstrap/windows-88/Compiler.c b/bootstrap/windows-88/Compiler.c new file mode 100644 index 00000000..4460479d --- /dev/null +++ b/bootstrap/windows-88/Compiler.c @@ -0,0 +1,213 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspamS */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "OPB.h" +#include "OPC.h" +#include "OPM.h" +#include "OPP.h" +#include "OPT.h" +#include "OPV.h" +#include "Platform.h" +#include "Strings.h" +#include "VT100.h" +#include "extTools.h" + + + + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len); +export void Compiler_Module (BOOLEAN *done); +static void Compiler_PropagateElementaryTypeSizes (void); +export void Compiler_Translate (void); +static void Compiler_Trap (INT32 sig); + + +void Compiler_Module (BOOLEAN *done) +{ + BOOLEAN ext, new; + OPT_Node p = NIL; + OPP_Module(&p, OPM_Options); + if (OPM_noerr) { + OPV_Init(); + OPT_InitRecno(); + OPV_AdrAndSize(OPT_topScope); + OPT_Export(&ext, &new); + if (OPM_noerr) { + OPM_OpenFiles((void*)OPT_SelfName, 256); + OPM_DeleteObj((void*)OPT_SelfName, 256); + OPC_Init(); + OPV_Module(p); + if (OPM_noerr) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" Main program.", 16); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + if (new) { + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogWStr((CHAR*)" New symbol file.", 19); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_RegisterNewSym(); + } else if (ext) { + OPM_LogWStr((CHAR*)" Extended symbol file.", 24); + OPM_RegisterNewSym(); + } + } + } else { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } + OPM_CloseFiles(); + OPT_Close(); + OPM_LogWLn(); + *done = OPM_noerr; +} + +static void Compiler_PropagateElementaryTypeSizes (void) +{ + OPT_Struct adrinttyp = NIL; + OPT_sysptrtyp->size = OPM_AddressSize; + OPT_sysptrtyp->idfp = OPT_sysptrtyp->form; + OPM_FPrint(&OPT_sysptrtyp->idfp, OPT_sysptrtyp->size); + OPT_adrtyp->size = OPM_AddressSize; + OPT_adrtyp->idfp = OPT_adrtyp->form; + OPM_FPrint(&OPT_adrtyp->idfp, OPT_adrtyp->size); + adrinttyp = OPT_IntType(OPM_AddressSize); + OPT_adrtyp->strobj = adrinttyp->strobj; + OPT_sinttyp = OPT_IntType(OPM_ShortintSize); + OPT_inttyp = OPT_IntType(OPM_IntegerSize); + OPT_linttyp = OPT_IntType(OPM_LongintSize); + OPT_sintobj->typ = OPT_sinttyp; + OPT_intobj->typ = OPT_inttyp; + OPT_lintobj->typ = OPT_linttyp; + switch (OPM_SetSize) { + case 4: + OPT_settyp = OPT_set32typ; + break; + default: + OPT_settyp = OPT_set64typ; + break; + } + OPT_setobj->typ = OPT_settyp; + if (__STRCMP(OPM_Model, "C") == 0) { + OPT_cpbytetyp->strobj->name[4] = 0x00; + } else { + OPT_cpbytetyp->strobj->name[4] = '@'; + } +} + +static void Compiler_FindLocalObjectFiles (CHAR *objectnames, ADDRESS objectnames__len) +{ + OPT_Link l = NIL; + CHAR fn[64]; + Platform_FileIdentity id; + objectnames[0] = 0x00; + l = OPT_Links; + while (l != NIL) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".sym", 5, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + __COPY(l->name, fn, 64); + Strings_Append((CHAR*)".o", 3, (void*)fn, 64); + if (Platform_IdentifyByName(fn, 64, &id, Platform_FileIdentity__typ) == 0) { + Strings_Append((CHAR*)" ", 2, (void*)objectnames, objectnames__len); + Strings_Append(fn, 64, (void*)objectnames, objectnames__len); + } else { + OPM_LogVT100((CHAR*)"91m", 4); + OPM_LogWStr((CHAR*)"Link warning: a local symbol file is present for module ", 57); + OPM_LogWStr(l->name, 256); + OPM_LogWStr((CHAR*)", but local object file '", 26); + OPM_LogWStr(fn, 64); + OPM_LogWStr((CHAR*)"' is missing.", 14); + OPM_LogVT100((CHAR*)"0m", 3); + OPM_LogWLn(); + } + } + l = l->next; + } +} + +void Compiler_Translate (void) +{ + BOOLEAN done; + CHAR linkfiles[2048]; + if (OPM_OpenPar()) { + for (;;) { + OPM_Init(&done); + if (!done) { + return; + } + OPM_InitOptions(); + Compiler_PropagateElementaryTypeSizes(); + Heap_GC(0); + Compiler_Module(&done); + if (!done) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Module compilation failed.", 27); + OPM_LogWLn(); + Platform_Exit(1); + } + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + if (!__IN(10, OPM_Options, 32)) { + extTools_Assemble(OPM_modName, 32); + } else { + Compiler_FindLocalObjectFiles((void*)linkfiles, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), linkfiles, 2048); + } + } + } + } + } +} + +static void Compiler_Trap (INT32 sig) +{ + Heap_FINALL(); + if (sig == 3) { + Platform_Exit(0); + } else { + if (sig == 4) { + OPM_LogWStr((CHAR*)" --- Oberon compiler internal error", 36); + OPM_LogWLn(); + } + Platform_Exit(2); + } +} + + +export int main(int argc, char **argv) +{ + __INIT(argc, argv); + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPP); + __MODULE_IMPORT(OPT); + __MODULE_IMPORT(OPV); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(VT100); + __MODULE_IMPORT(extTools); + __REGMAIN("Compiler", 0); + __REGCMD("Translate", Compiler_Translate); +/* BEGIN */ + Platform_SetInterruptHandler(Compiler_Trap); + Platform_SetQuitHandler(Compiler_Trap); + Platform_SetBadInstructionHandler(Compiler_Trap); + Compiler_Translate(); + __FINI; +} diff --git a/bootstrap/windows-88/Configuration.c b/bootstrap/windows-88/Configuration.c new file mode 100644 index 00000000..fa87c9de --- /dev/null +++ b/bootstrap/windows-88/Configuration.c @@ -0,0 +1,24 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + +export CHAR Configuration_versionLong[76]; + + + + + +export void *Configuration__init(void) +{ + __DEFMOD; + __REGMOD("Configuration", 0); +/* BEGIN */ + __MOVE("2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 76); + __ENDMOD; +} diff --git a/bootstrap/windows-88/Configuration.h b/bootstrap/windows-88/Configuration.h new file mode 100644 index 00000000..c3c54eed --- /dev/null +++ b/bootstrap/windows-88/Configuration.h @@ -0,0 +1,15 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Configuration__h +#define Configuration__h + +#include "SYSTEM.h" + + +import CHAR Configuration_versionLong[76]; + + +import void *Configuration__init(void); + + +#endif // Configuration diff --git a/bootstrap/windows-88/Files.c b/bootstrap/windows-88/Files.c new file mode 100644 index 00000000..07655515 --- /dev/null +++ b/bootstrap/windows-88/Files.c @@ -0,0 +1,1099 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_BufDesc { + Files_File f; + BOOLEAN chg; + INT32 org, size; + SYSTEM_BYTE data[4096]; + } Files_BufDesc; + +typedef + Files_BufDesc *Files_Buffer; + +typedef + CHAR Files_FileName[256]; + +typedef + struct Files_FileDesc { + Files_FileName workName, registerName; + BOOLEAN tempFile; + Platform_FileIdentity identity; + INT64 fd; + INT32 len, pos; + Files_Buffer bufs[4]; + INT16 swapper, state; + struct Files_FileDesc *next; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + Files_Buffer buf; + INT32 org, offset; + } Files_Rider; + + +export INT16 Files_MaxPathLength, Files_MaxNameLength; +static Files_FileDesc *Files_files; +static INT16 Files_tempno; +static CHAR Files_HOME[1024]; +static struct { + ADDRESS len[1]; + CHAR data[1]; +} *Files_SearchPath; + +export ADDRESS *Files_FileDesc__typ; +export ADDRESS *Files_BufDesc__typ; +export ADDRESS *Files_Rider__typ; + +static void Files_Assert (BOOLEAN truth); +export Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +static Files_File Files_CacheEntry (Platform_FileIdentity identity); +export void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +export void Files_Close (Files_File f); +static void Files_CloseOSFile (Files_File f); +static void Files_Create (Files_File f); +export void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +static void Files_Deregister (CHAR *name, ADDRESS name__len); +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode); +static void Files_Finalize (SYSTEM_PTR o); +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len); +static void Files_Flush (Files_Buffer buf); +export void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +export void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len); +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len); +export INT32 Files_Length (Files_File f); +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len); +export Files_File Files_New (CHAR *name, ADDRESS name__len); +export Files_File Files_Old (CHAR *name, ADDRESS name__len); +export INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +export void Files_Purge (Files_File f); +export void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +export void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +export void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +export void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +export void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +export void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +export void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +export void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +export void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +export void Files_Register (Files_File f); +export void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len); +export void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +export void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +export void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +export void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +export void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +export void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +export void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +export void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +export void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +export void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +export void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +export void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); + +#define Files_IdxTrap() __HALT(-1) + +static void Files_Assert (BOOLEAN truth) +{ + if (!truth) { + Out_Ln(); + __ASSERT(truth, 0); + } +} + +static void Files_Err (CHAR *s, ADDRESS s__len, Files_File f, INT16 errcode) +{ + __DUP(s, s__len, CHAR); + Out_Ln(); + Out_String((CHAR*)"-- ", 4); + Out_String(s, s__len); + Out_String((CHAR*)": ", 3); + if (f != NIL) { + if (f->registerName[0] != 0x00) { + Out_String(f->registerName, 256); + } else { + Out_String(f->workName, 256); + } + if (f->fd != 0) { + Out_String((CHAR*)", f.fd = ", 10); + Out_Int(f->fd, 1); + } + } + if (errcode != 0) { + Out_String((CHAR*)", errcode = ", 13); + Out_Int(errcode, 1); + } + Out_Ln(); + __HALT(99); + __DEL(s); +} + +static void Files_MakeFileName (CHAR *dir, ADDRESS dir__len, CHAR *name, ADDRESS name__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 i, j, ld, ln; + __DUP(dir, dir__len, CHAR); + __DUP(name, name__len, CHAR); + ld = Strings_Length(dir, dir__len); + ln = Strings_Length(name, name__len); + while ((ld > 0 && dir[__X(ld - 1, dir__len)] == '/')) { + ld -= 1; + } + if (((ld + ln) + 2) > dest__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + i = 0; + while (i < ld) { + dest[__X(i, dest__len)] = dir[__X(i, dir__len)]; + i += 1; + } + if (i > 0) { + dest[__X(i, dest__len)] = '/'; + i += 1; + } + j = 0; + while (j < ln) { + dest[__X(i, dest__len)] = name[__X(j, name__len)]; + i += 1; + j += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(dir); + __DEL(name); +} + +static void Files_GetTempName (CHAR *finalName, ADDRESS finalName__len, CHAR *name, ADDRESS name__len) +{ + INT16 i, n; + __DUP(finalName, finalName__len, CHAR); + if (finalName[0] == '/') { + __COPY(finalName, name, name__len); + } else { + Files_MakeFileName(Platform_CWD, 4096, finalName, finalName__len, (void*)name, name__len); + } + i = Strings_Length(name, name__len) - 1; + while ((i > 0 && name[__X(i, name__len)] != '/')) { + i -= 1; + } + if ((i + 16) >= name__len) { + Files_Err((CHAR*)"File name too long", 19, NIL, 0); + } + Files_tempno += 1; + n = Files_tempno; + name[__X(i + 1, name__len)] = '.'; + name[__X(i + 2, name__len)] = 't'; + name[__X(i + 3, name__len)] = 'm'; + name[__X(i + 4, name__len)] = 'p'; + name[__X(i + 5, name__len)] = '.'; + i += 6; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = '.'; + i += 1; + n = Platform_PID; + while (n > 0) { + name[__X(i, name__len)] = __CHR((int)__MOD(n, 10) + 48); + n = __DIV(n, 10); + i += 1; + } + name[__X(i, name__len)] = 0x00; + __DEL(finalName); +} + +static void Files_Deregister (CHAR *name, ADDRESS name__len) +{ + Platform_FileIdentity identity; + Files_File osfile = NIL; + INT16 error; + __DUP(name, name__len, CHAR); + if (Platform_IdentifyByName(name, name__len, &identity, Platform_FileIdentity__typ) == 0) { + osfile = (Files_File)Files_files; + while ((osfile != NIL && !Platform_SameFile(osfile->identity, identity))) { + osfile = (Files_File)osfile->next; + } + if (osfile != NIL) { + __ASSERT(!osfile->tempFile, 0); + __ASSERT(osfile->fd >= 0, 0); + __MOVE(osfile->workName, osfile->registerName, 256); + Files_GetTempName(osfile->registerName, 256, (void*)osfile->workName, 256); + osfile->tempFile = 1; + osfile->state = 0; + error = Platform_Rename((void*)osfile->registerName, 256, (void*)osfile->workName, 256); + if (error != 0) { + Files_Err((CHAR*)"Couldn't rename previous version of file being registered", 58, osfile, error); + } + } + } + __DEL(name); +} + +static void Files_Create (Files_File f) +{ + BOOLEAN done; + INT16 error; + CHAR err[32]; + if (f->fd == -1) { + if (f->state == 1) { + Files_GetTempName(f->registerName, 256, (void*)f->workName, 256); + f->tempFile = 1; + } else { + __ASSERT(f->state == 2, 0); + Files_Deregister(f->registerName, 256); + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } + error = Platform_Unlink((void*)f->workName, 256); + error = Platform_New((void*)f->workName, 256, &f->fd); + done = error == 0; + if (done) { + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->state = 0; + f->pos = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + } else { + if (Platform_NoSuchDirectory(error)) { + __MOVE("no such directory", err, 18); + } else if (Platform_TooManyFiles(error)) { + __MOVE("too many files open", err, 20); + } else { + __MOVE("file not created", err, 17); + } + Files_Err(err, 32, f, error); + } + } +} + +static void Files_Flush (Files_Buffer buf) +{ + INT16 error; + Files_File f = NIL; + if (buf->chg) { + f = buf->f; + Files_Create(f); + if (buf->org != f->pos) { + error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); + } + error = Platform_Write(f->fd, (ADDRESS)buf->data, buf->size); + if (error != 0) { + Files_Err((CHAR*)"error writing file", 19, f, error); + } + f->pos = buf->org + buf->size; + buf->chg = 0; + error = Platform_Identify(f->fd, &f->identity, Platform_FileIdentity__typ); + if (error != 0) { + Files_Err((CHAR*)"error identifying file", 23, f, error); + } + } +} + +void Files_Close (Files_File f) +{ + INT32 i; + INT16 error; + if (f->state != 1 || f->registerName[0] != 0x00) { + Files_Create(f); + i = 0; + while ((i < 4 && f->bufs[__X(i, 4)] != NIL)) { + Files_Flush(f->bufs[__X(i, 4)]); + i += 1; + } + } +} + +INT32 Files_Length (Files_File f) +{ + return f->len; +} + +Files_File Files_New (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + __DUP(name, name__len, CHAR); + __NEW(f, Files_FileDesc); + f->workName[0] = 0x00; + __COPY(name, f->registerName, 256); + f->fd = -1; + f->state = 1; + f->len = 0; + f->pos = 0; + f->swapper = -1; + __DEL(name); + return f; +} + +static void Files_ScanPath (INT16 *pos, CHAR *dir, ADDRESS dir__len) +{ + INT16 i; + CHAR ch; + i = 0; + if (Files_SearchPath == NIL) { + if (*pos == 0) { + dir[0] = '.'; + i = 1; + *pos += 1; + } + } else { + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (ch == ' ' || ch == ';') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + if (ch == '~') { + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + while (Files_HOME[__X(i, 1024)] != 0x00) { + dir[__X(i, dir__len)] = Files_HOME[__X(i, 1024)]; + i += 1; + } + if ((((((ch != '/' && ch != 0x00)) && ch != ';')) && ch != ' ')) { + while ((i > 0 && dir[__X(i - 1, dir__len)] != '/')) { + i -= 1; + } + } + } + while ((ch != 0x00 && ch != ';')) { + dir[__X(i, dir__len)] = ch; + i += 1; + *pos += 1; + ch = (Files_SearchPath->data)[__X(*pos, Files_SearchPath->len[0])]; + } + while ((i > 0 && dir[__X(i - 1, dir__len)] == ' ')) { + i -= 1; + } + } + dir[__X(i, dir__len)] = 0x00; +} + +static BOOLEAN Files_HasDir (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + ch = name[0]; + while ((ch != 0x00 && ch != '/')) { + i += 1; + ch = name[__X(i, name__len)]; + } + return ch == '/'; +} + +static Files_File Files_CacheEntry (Platform_FileIdentity identity) +{ + Files_File f = NIL; + INT16 i, error; + f = (Files_File)Files_files; + while (f != NIL) { + if (Platform_SameFile(identity, f->identity)) { + if (!Platform_SameFileTime(identity, f->identity)) { + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + f->swapper = -1; + f->identity = identity; + error = Platform_Size(f->fd, &f->len); + } + return f; + } + f = (Files_File)f->next; + } + return NIL; +} + +Files_File Files_Old (CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + INT64 fd; + INT16 pos; + BOOLEAN done; + CHAR dir[256], path[256]; + INT16 error; + Platform_FileIdentity identity; + __DUP(name, name__len, CHAR); + if (name[0] != 0x00) { + if (Files_HasDir((void*)name, name__len)) { + dir[0] = 0x00; + __COPY(name, path, 256); + } else { + pos = 0; + Files_ScanPath(&pos, (void*)dir, 256); + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + for (;;) { + error = Platform_OldRW((void*)path, 256, &fd); + done = error == 0; + if ((!done && Platform_TooManyFiles(error))) { + Files_Err((CHAR*)"too many files open", 20, f, error); + } + if ((!done && Platform_Inaccessible(error))) { + error = Platform_OldRO((void*)path, 256, &fd); + done = error == 0; + } + if ((!done && !Platform_Absent(error))) { + Out_String((CHAR*)"Warning: Files.Old ", 20); + Out_String(name, name__len); + Out_String((CHAR*)" error = ", 10); + Out_Int(error, 0); + Out_Ln(); + } + if (done) { + error = Platform_Identify(fd, &identity, Platform_FileIdentity__typ); + f = Files_CacheEntry(identity); + if (f != NIL) { + error = Platform_Close(fd); + __DEL(name); + return f; + } else { + __NEW(f, Files_FileDesc); + Heap_RegisterFinalizer((void*)f, Files_Finalize); + f->fd = fd; + f->state = 0; + f->pos = 0; + f->swapper = -1; + error = Platform_Size(fd, &f->len); + __COPY(name, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + f->identity = identity; + f->next = Files_files; + Files_files = f; + Heap_FileCount += 1; + __DEL(name); + return f; + } + } else if (dir[0] == 0x00) { + __DEL(name); + return NIL; + } else { + Files_MakeFileName(dir, 256, name, name__len, (void*)path, 256); + Files_ScanPath(&pos, (void*)dir, 256); + } + } + } else { + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Files_Purge (Files_File f) +{ + INT16 i; + Platform_FileIdentity identity; + INT16 error; + i = 0; + while (i < 4) { + if (f->bufs[__X(i, 4)] != NIL) { + f->bufs[__X(i, 4)]->org = -1; + f->bufs[__X(i, 4)] = NIL; + } + i += 1; + } + if (f->fd != -1) { + error = Platform_Truncate(f->fd, 0); + error = Platform_Seek(f->fd, 0, Platform_SeekSet); + } + f->pos = 0; + f->len = 0; + f->swapper = -1; + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_SetMTime(&f->identity, Platform_FileIdentity__typ, identity); +} + +void Files_GetDate (Files_File f, INT32 *t, INT32 *d) +{ + Platform_FileIdentity identity; + INT16 error; + Files_Create(f); + error = Platform_Identify(f->fd, &identity, Platform_FileIdentity__typ); + Platform_MTimeAsClock(identity, &*t, &*d); +} + +INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ) +{ + Files_Assert((*r).offset <= 4096); + return (*r).org + (*r).offset; +} + +void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos) +{ + INT32 org, offset, i, n; + Files_Buffer buf = NIL; + INT16 error; + if (f != NIL) { + if (pos > f->len) { + pos = f->len; + } else if (pos < 0) { + pos = 0; + } + offset = __MASK(pos, -4096); + org = pos - offset; + i = 0; + while ((((i < 4 && f->bufs[__X(i, 4)] != NIL)) && org != f->bufs[__X(i, 4)]->org)) { + i += 1; + } + if (i < 4) { + if (f->bufs[__X(i, 4)] == NIL) { + __NEW(buf, Files_BufDesc); + buf->chg = 0; + buf->org = -1; + buf->f = f; + f->bufs[__X(i, 4)] = buf; + } else { + buf = f->bufs[__X(i, 4)]; + } + } else { + f->swapper = __MASK(f->swapper + 1, -4); + buf = f->bufs[__X(f->swapper, 4)]; + Files_Flush(buf); + } + if (buf->org != org) { + if (org == f->len) { + buf->size = 0; + } else { + Files_Create(f); + if (f->pos != org) { + error = Platform_Seek(f->fd, org, Platform_SeekSet); + } + error = Platform_ReadBuf(f->fd, (void*)buf->data, 4096, &n); + if (error != 0) { + Files_Err((CHAR*)"read from file not done", 24, f, error); + } + f->pos = org + n; + buf->size = n; + } + buf->org = org; + buf->chg = 0; + } + } else { + buf = NIL; + org = 0; + offset = 0; + } + Files_Assert(offset <= 4096); + (*r).buf = buf; + (*r).org = org; + (*r).offset = offset; + (*r).eof = 0; + (*r).res = 0; +} + +void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + INT32 offset; + Files_Buffer buf = NIL; + buf = (*r).buf; + offset = (*r).offset; + if ((*r).org != buf->org) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= buf->size); + if (offset < buf->size) { + *x = buf->data[__X(offset, 4096)]; + (*r).offset = offset + 1; + } else if ((*r).org + offset < buf->f->len) { + Files_Set(&*r, r__typ, (*r).buf->f, (*r).org + offset); + *x = (*r).buf->data[0]; + (*r).offset = 1; + } else { + *x = 0x00; + (*r).eof = 1; + } +} + +void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x) +{ + Files_Read(&*r, r__typ, &*x); +} + +void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + restInBuf = buf->size - offset; + if (restInBuf == 0) { + (*r).res = n; + (*r).eof = 1; + return; + } else if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&buf->data[__X(offset, 4096)], (ADDRESS)&x[__X(xpos, x__len)], min); + offset += min; + (*r).offset = offset; + xpos += min; + n -= min; + Files_Assert(offset <= 4096); + } + (*r).res = 0; + (*r).eof = 0; +} + +Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ) +{ + return (*r).buf->f; +} + +void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x) +{ + Files_Buffer buf = NIL; + INT32 offset; + buf = (*r).buf; + offset = (*r).offset; + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset < 4096); + buf->data[__X(offset, 4096)] = x; + buf->chg = 1; + if (offset == buf->size) { + buf->size += 1; + buf->f->len += 1; + } + (*r).offset = offset + 1; + (*r).res = 0; +} + +void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n) +{ + INT32 xpos, min, restInBuf, offset; + Files_Buffer buf = NIL; + if (n > x__len) { + Files_IdxTrap(); + } + xpos = 0; + buf = (*r).buf; + offset = (*r).offset; + while (n > 0) { + Files_Assert(offset <= 4096); + if ((*r).org != buf->org || offset >= 4096) { + Files_Set(&*r, r__typ, buf->f, (*r).org + offset); + buf = (*r).buf; + offset = (*r).offset; + } + Files_Assert(offset <= 4096); + restInBuf = 4096 - offset; + if (n > restInBuf) { + min = restInBuf; + } else { + min = n; + } + __MOVE((ADDRESS)&x[__X(xpos, x__len)], (ADDRESS)&buf->data[__X(offset, 4096)], min); + offset += min; + (*r).offset = offset; + Files_Assert(offset <= 4096); + if (offset > buf->size) { + buf->f->len += offset - buf->size; + buf->size = offset; + } + xpos += min; + n -= min; + buf->chg = 1; + } + (*r).res = 0; +} + +void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res) +{ + __DUP(name, name__len, CHAR); + Files_Deregister(name, name__len); + *res = Platform_Unlink((void*)name, name__len); + __DEL(name); +} + +void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res) +{ + INT64 fdold, fdnew; + INT32 n; + INT16 error, ignore; + Platform_FileIdentity oldidentity, newidentity; + CHAR buf[4096]; + __DUP(old, old__len, CHAR); + __DUP(new, new__len, CHAR); + error = Platform_IdentifyByName(old, old__len, &oldidentity, Platform_FileIdentity__typ); + if (error == 0) { + error = Platform_IdentifyByName(new, new__len, &newidentity, Platform_FileIdentity__typ); + if ((error != 0 && !Platform_SameFile(oldidentity, newidentity))) { + Files_Delete(new, new__len, &error); + } + error = Platform_Rename((void*)old, old__len, (void*)new, new__len); + if (!Platform_DifferentFilesystems(error)) { + *res = error; + __DEL(old); + __DEL(new); + return; + } else { + error = Platform_OldRO((void*)old, old__len, &fdold); + if (error != 0) { + *res = 2; + __DEL(old); + __DEL(new); + return; + } + error = Platform_New((void*)new, new__len, &fdnew); + if (error != 0) { + error = Platform_Close(fdold); + *res = 3; + __DEL(old); + __DEL(new); + return; + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + while (n > 0) { + error = Platform_Write(fdnew, (ADDRESS)buf, n); + if (error != 0) { + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + error = Platform_Read(fdold, (ADDRESS)buf, 4096, &n); + } + ignore = Platform_Close(fdold); + ignore = Platform_Close(fdnew); + if (n == 0) { + error = Platform_Unlink((void*)old, old__len); + *res = 0; + } else { + Files_Err((CHAR*)"cannot move file", 17, NIL, error); + } + } + } else { + *res = 2; + } + __DEL(old); + __DEL(new); +} + +void Files_Register (Files_File f) +{ + INT16 idx, errcode; + Files_File f1 = NIL; + if ((f->state == 1 && f->registerName[0] != 0x00)) { + f->state = 2; + } + Files_Close(f); + if (f->registerName[0] != 0x00) { + Files_Deregister(f->registerName, 256); + Files_Rename(f->workName, 256, f->registerName, 256, &errcode); + if (errcode != 0) { + Files_Err((CHAR*)"Couldn't rename temp name as register name", 43, f, errcode); + } + __MOVE(f->registerName, f->workName, 256); + f->registerName[0] = 0x00; + f->tempFile = 0; + } +} + +void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res) +{ + __DUP(path, path__len, CHAR); + *res = Platform_Chdir((void*)path, path__len); + __DEL(path); +} + +static void Files_FlipBytes (SYSTEM_BYTE *src, ADDRESS src__len, SYSTEM_BYTE *dest, ADDRESS dest__len) +{ + INT32 i, j; + if (!Platform_LittleEndian) { + i = src__len; + j = 0; + while (i > 0) { + i -= 1; + dest[__X(j, dest__len)] = src[__X(i, src__len)]; + j += 1; + } + } else { + __MOVE((ADDRESS)src, (ADDRESS)dest, src__len); + } +} + +void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x) +{ + Files_Read(&*R, R__typ, (CHAR*)(void*)&*x); +} + +void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x) +{ + CHAR b[2]; + Files_ReadBytes(&*R, R__typ, (void*)b, 2, 2); + *x = (INT16)b[0] + __ASHL((INT16)b[1], 8); +} + +void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + *x = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); +} + +void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x) +{ + CHAR b[4]; + INT32 l; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + l = (((INT16)b[0] + __ASHL((INT16)b[1], 8)) + __ASHL(b[2], 16)) + __ASHL(b[3], 24); + *x = (UINT32)l; +} + +void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x) +{ + CHAR b[4]; + Files_ReadBytes(&*R, R__typ, (void*)b, 4, 4); + Files_FlipBytes((void*)b, 4, (void*)&*x, 4); +} + +void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x) +{ + CHAR b[8]; + Files_ReadBytes(&*R, R__typ, (void*)b, 8, 8); + Files_FlipBytes((void*)b, 8, (void*)&*x, 8); +} + +void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&ch); + x[__X(i, x__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + do { + Files_Read(&*R, R__typ, (void*)&x[__X(i, x__len)]); + i += 1; + } while (!(x[__X(i - 1, x__len)] == 0x00 || x[__X(i - 1, x__len)] == 0x0a)); + if (x[__X(i - 1, x__len)] == 0x0a) { + i -= 1; + } + if ((i > 0 && x[__X(i - 1, x__len)] == 0x0d)) { + i -= 1; + } + x[__X(i, x__len)] = 0x00; +} + +void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len) +{ + INT8 s, b; + INT64 q; + s = 0; + q = 0; + Files_Read(&*R, R__typ, (void*)&b); + while (b < 0) { + q += (INT64)__ASH(((INT16)b + 128), s); + s += 7; + Files_Read(&*R, R__typ, (void*)&b); + } + q += (INT64)__ASH((__MASK(b, -64) - __ASHL(__ASHR(b, 6), 6)), s); + Files_Assert(x__len <= 8); + __MOVE((ADDRESS)&q, (ADDRESS)x, x__len); +} + +void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x) +{ + Files_Write(&*R, R__typ, __VAL(CHAR, x)); +} + +void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x) +{ + CHAR b[2]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + Files_WriteBytes(&*R, R__typ, (void*)b, 2, 2); +} + +void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x) +{ + CHAR b[4]; + b[0] = __CHR(x); + b[1] = __CHR(__ASHR(x, 8)); + b[2] = __CHR(__ASHR(x, 16)); + b[3] = __CHR(__ASHR(x, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x) +{ + CHAR b[4]; + INT32 i; + UINT64 y; + y = x; + i = __VAL(INT32, y); + b[0] = __CHR(i); + b[1] = __CHR(__ASHR(i, 8)); + b[2] = __CHR(__ASHR(i, 16)); + b[3] = __CHR(__ASHR(i, 24)); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x) +{ + CHAR b[4]; + Files_FlipBytes((void*)&x, 4, (void*)b, 4); + Files_WriteBytes(&*R, R__typ, (void*)b, 4, 4); +} + +void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x) +{ + CHAR b[8]; + Files_FlipBytes((void*)&x, 8, (void*)b, 8); + Files_WriteBytes(&*R, R__typ, (void*)b, 8, 8); +} + +void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len) +{ + INT16 i; + i = 0; + while (x[__X(i, x__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&*R, R__typ, (void*)x, x__len * 1, i + 1); +} + +void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x) +{ + while (x < -64 || x > 63) { + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128) + 128)); + x = __ASHR(x, 7); + } + Files_Write(&*R, R__typ, __CHR(__MASK(x, -128))); +} + +void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len) +{ + __COPY(f->workName, name, name__len); +} + +static void Files_CloseOSFile (Files_File f) +{ + Files_File prev = NIL; + INT16 error; + if (Files_files == (void *) f) { + Files_files = f->next; + } else { + prev = (Files_File)Files_files; + while ((prev != NIL && prev->next != (void *) f)) { + prev = (Files_File)prev->next; + } + if (prev->next != NIL) { + prev->next = f->next; + } + } + error = Platform_Close(f->fd); + f->fd = -1; + f->state = 1; + Heap_FileCount -= 1; +} + +static void Files_Finalize (SYSTEM_PTR o) +{ + Files_File f = NIL; + INT32 res; + f = (Files_File)(ADDRESS)o; + if (f->fd >= 0) { + Files_CloseOSFile(f); + if (f->tempFile) { + res = Platform_Unlink((void*)f->workName, 256); + } + } +} + +void Files_SetSearchPath (CHAR *path, ADDRESS path__len) +{ + __DUP(path, path__len, CHAR); + if (Strings_Length(path, path__len) != 0) { + Files_SearchPath = __NEWARR(NIL, 1, 1, 1, 1, ((ADDRESS)((Strings_Length(path, path__len) + 1)))); + __COPY(path, Files_SearchPath->data, Files_SearchPath->len[0]); + } else { + Files_SearchPath = NIL; + } + __DEL(path); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Files_SearchPath); +} + +__TDESC(Files_FileDesc, 1, 4) = {__TDFLDS("FileDesc", 600), {552, 560, 568, 576, -40}}; +__TDESC(Files_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 4120), {0, -16}}; +__TDESC(Files_Rider, 1, 1) = {__TDFLDS("Rider", 24), {8, -16}}; + +export void *Files__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("Files", EnumPtrs); + __INITYP(Files_FileDesc, Files_FileDesc, 0); + __INITYP(Files_BufDesc, Files_BufDesc, 0); + __INITYP(Files_Rider, Files_Rider, 0); +/* BEGIN */ + Files_tempno = -1; + Heap_FileCount = 0; + Files_HOME[0] = 0x00; + Platform_GetEnv((CHAR*)"HOME", 5, (void*)Files_HOME, 1024); + Files_MaxPathLength = Platform_MaxPathLength(); + Files_MaxNameLength = Platform_MaxNameLength(); + __ENDMOD; +} diff --git a/bootstrap/windows-88/Files.h b/bootstrap/windows-88/Files.h new file mode 100644 index 00000000..8a7e59f8 --- /dev/null +++ b/bootstrap/windows-88/Files.h @@ -0,0 +1,71 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Files__h +#define Files__h + +#include "SYSTEM.h" + +typedef + struct Files_FileDesc *Files_File; + +typedef + struct Files_FileDesc { + INT64 _prvt0; + char _prvt1[592]; + } Files_FileDesc; + +typedef + struct Files_Rider { + INT32 res; + BOOLEAN eof; + INT64 _prvt0; + char _prvt1[8]; + } Files_Rider; + + +import INT16 Files_MaxPathLength, Files_MaxNameLength; + +import ADDRESS *Files_FileDesc__typ; +import ADDRESS *Files_Rider__typ; + +import Files_File Files_Base (Files_Rider *r, ADDRESS *r__typ); +import void Files_ChangeDirectory (CHAR *path, ADDRESS path__len, INT16 *res); +import void Files_Close (Files_File f); +import void Files_Delete (CHAR *name, ADDRESS name__len, INT16 *res); +import void Files_GetDate (Files_File f, INT32 *t, INT32 *d); +import void Files_GetName (Files_File f, CHAR *name, ADDRESS name__len); +import INT32 Files_Length (Files_File f); +import Files_File Files_New (CHAR *name, ADDRESS name__len); +import Files_File Files_Old (CHAR *name, ADDRESS name__len); +import INT32 Files_Pos (Files_Rider *r, ADDRESS *r__typ); +import void Files_Purge (Files_File f); +import void Files_Read (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN *x); +import void Files_ReadByte (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x); +import void Files_ReadBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_ReadInt (Files_Rider *R, ADDRESS *R__typ, INT16 *x); +import void Files_ReadLInt (Files_Rider *R, ADDRESS *R__typ, INT32 *x); +import void Files_ReadLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL *x); +import void Files_ReadLine (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_ReadNum (Files_Rider *R, ADDRESS *R__typ, SYSTEM_BYTE *x, ADDRESS x__len); +import void Files_ReadReal (Files_Rider *R, ADDRESS *R__typ, REAL *x); +import void Files_ReadSet (Files_Rider *R, ADDRESS *R__typ, UINT32 *x); +import void Files_ReadString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void Files_Register (Files_File f); +import void Files_Rename (CHAR *old, ADDRESS old__len, CHAR *new, ADDRESS new__len, INT16 *res); +import void Files_Set (Files_Rider *r, ADDRESS *r__typ, Files_File f, INT32 pos); +import void Files_SetSearchPath (CHAR *path, ADDRESS path__len); +import void Files_Write (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE x); +import void Files_WriteBool (Files_Rider *R, ADDRESS *R__typ, BOOLEAN x); +import void Files_WriteBytes (Files_Rider *r, ADDRESS *r__typ, SYSTEM_BYTE *x, ADDRESS x__len, INT32 n); +import void Files_WriteInt (Files_Rider *R, ADDRESS *R__typ, INT16 x); +import void Files_WriteLInt (Files_Rider *R, ADDRESS *R__typ, INT32 x); +import void Files_WriteLReal (Files_Rider *R, ADDRESS *R__typ, LONGREAL x); +import void Files_WriteNum (Files_Rider *R, ADDRESS *R__typ, INT64 x); +import void Files_WriteReal (Files_Rider *R, ADDRESS *R__typ, REAL x); +import void Files_WriteSet (Files_Rider *R, ADDRESS *R__typ, UINT32 x); +import void Files_WriteString (Files_Rider *R, ADDRESS *R__typ, CHAR *x, ADDRESS x__len); +import void *Files__init(void); + + +#endif // Files diff --git a/bootstrap/windows-88/Heap.c b/bootstrap/windows-88/Heap.c new file mode 100644 index 00000000..7b004b60 --- /dev/null +++ b/bootstrap/windows-88/Heap.c @@ -0,0 +1,799 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +struct Heap__1 { + CHAR ch; + SYSTEM_PTR p; +}; + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + struct Heap_FinDesc *Heap_FinNode; + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_FinDesc { + Heap_FinNode next; + INT64 obj; + BOOLEAN marked; + Heap_Finalizer finalize; + } Heap_FinDesc; + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT64 types; + Heap_EnumProc enumPtrs; + INT32 reserved1, reserved2; + } Heap_ModuleDesc; + + +export SYSTEM_PTR Heap_modules; +static INT64 Heap_freeList[10]; +static INT64 Heap_bigBlocks; +export INT64 Heap_allocated; +static BOOLEAN Heap_firstTry; +static INT16 Heap_ldUnit; +export INT64 Heap_heap; +static INT64 Heap_heapMin, Heap_heapMax; +export INT64 Heap_heapsize, Heap_heapMinExpand; +static Heap_FinNode Heap_fin; +static INT16 Heap_lockdepth; +static BOOLEAN Heap_interrupted; +export INT16 Heap_FileCount; + +export ADDRESS *Heap_ModuleDesc__typ; +export ADDRESS *Heap_CmdDesc__typ; +export ADDRESS *Heap_FinDesc__typ; +export ADDRESS *Heap__1__typ; + +static void Heap_CheckFin (void); +static void Heap_ExtendHeap (INT64 blksz); +export void Heap_FINALL (void); +static void Heap_Finalize (void); +export INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +export void Heap_GC (BOOLEAN markStack); +static void Heap_HeapSort (INT32 n, INT64 *a, ADDRESS a__len); +export void Heap_INCREF (Heap_Module m); +export void Heap_InitHeap (void); +export void Heap_Lock (void); +static void Heap_Mark (INT64 q); +static void Heap_MarkCandidates (INT32 n, INT64 *cand, ADDRESS cand__len); +static void Heap_MarkP (SYSTEM_PTR p); +static void Heap_MarkStack (INT64 n, INT64 *cand, ADDRESS cand__len); +export SYSTEM_PTR Heap_NEWBLK (INT64 size); +export SYSTEM_PTR Heap_NEWREC (INT64 tag); +static INT64 Heap_NewChunk (INT64 blksz); +export void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +export SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +export void Heap_REGTYP (Heap_Module m, INT64 typ); +export void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +static void Heap_Scan (void); +static void Heap_Sift (INT32 l, INT32 r, INT64 *a, ADDRESS a__len); +export void Heap_Unlock (void); + +extern void *Heap__init(); +extern ADDRESS Modules_MainStackFrame; +extern ADDRESS Platform_OSAllocate(ADDRESS size); +#define Heap_HeapModuleInit() Heap__init() +#define Heap_ModulesHalt(code) Modules_Halt(code) +#define Heap_ModulesMainStackFrame() Modules_MainStackFrame +#define Heap_OSAllocate(size) Platform_OSAllocate(size) +#define Heap_uLE(x, y) ((size_t)x <= (size_t)y) +#define Heap_uLT(x, y) ((size_t)x < (size_t)y) + +void Heap_Lock (void) +{ + Heap_lockdepth += 1; +} + +void Heap_Unlock (void) +{ + Heap_lockdepth -= 1; + if ((Heap_interrupted && Heap_lockdepth == 0)) { + Heap_ModulesHalt(-9); + } +} + +SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) +{ + Heap_Module m; + if (__STRCMP(name, "Heap") == 0) { + __SYSNEW(m, 64); + } else { + __NEW(m, Heap_ModuleDesc); + } + m->types = 0; + m->cmds = NIL; + __COPY(name, m->name, 20); + m->refcnt = 0; + m->enumPtrs = enumPtrs; + m->next = (Heap_Module)(ADDRESS)Heap_modules; + Heap_modules = (SYSTEM_PTR)m; + return (void*)m; +} + +INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len) +{ + Heap_Module m, p; + __DUP(name, name__len, CHAR); + m = (Heap_Module)(ADDRESS)Heap_modules; + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + p = m; + m = m->next; + } + if ((m != NIL && m->refcnt == 0)) { + if (m == (Heap_Module)(ADDRESS)Heap_modules) { + Heap_modules = (SYSTEM_PTR)m->next; + } else { + p->next = m->next; + } + __DEL(name); + return 0; + } else { + if (m == NIL) { + __DEL(name); + return -1; + } else { + __DEL(name); + return m->refcnt; + } + } + __RETCHK; +} + +void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd) +{ + Heap_Cmd c; + if (__STRCMP(m->name, "Heap") == 0) { + __SYSNEW(c, 40); + } else { + __NEW(c, Heap_CmdDesc); + } + __COPY(name, c->name, 24); + c->cmd = cmd; + c->next = m->cmds; + m->cmds = c; +} + +void Heap_REGTYP (Heap_Module m, INT64 typ) +{ + __PUT(typ, m->types, INT64); + m->types = typ; +} + +void Heap_INCREF (Heap_Module m) +{ + m->refcnt += 1; +} + +static INT64 Heap_NewChunk (INT64 blksz) +{ + INT64 chnk, blk, end; + chnk = Heap_OSAllocate(blksz + 24); + if (chnk != 0) { + blk = chnk + 24; + end = blk + blksz; + __PUT(chnk + 8, end, INT64); + __PUT(blk, blk + 8, INT64); + __PUT(blk + 8, blksz, INT64); + __PUT(blk + 16, -8, INT64); + __PUT(blk + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = blk; + Heap_heapsize += blksz; + if (Heap_uLT(blk + 8, Heap_heapMin)) { + Heap_heapMin = blk + 8; + } + if (Heap_uLT(Heap_heapMax, end)) { + Heap_heapMax = end; + } + } + return chnk; +} + +static void Heap_ExtendHeap (INT64 blksz) +{ + INT64 size, chnk, j, next; + if (Heap_uLT(Heap_heapMinExpand, blksz)) { + size = blksz; + } else { + size = Heap_heapMinExpand; + } + chnk = Heap_NewChunk(size); + if (chnk != 0) { + if (Heap_uLT(chnk, Heap_heap)) { + __PUT(chnk, Heap_heap, INT64); + Heap_heap = chnk; + } else { + j = Heap_heap; + __GET(j, next, INT64); + while ((next != 0 && Heap_uLT(next, chnk))) { + j = next; + __GET(j, next, INT64); + } + __PUT(chnk, next, INT64); + __PUT(j, chnk, INT64); + } + } else if (!Heap_firstTry) { + Heap_heapMinExpand = 32; + } +} + +SYSTEM_PTR Heap_NEWREC (INT64 tag) +{ + INT64 i, i0, di, blksz, restsize, t, adr, end, next, prev; + SYSTEM_PTR new; + Heap_Lock(); + __GET(tag, blksz, INT64); + i0 = __LSH(blksz, -Heap_ldUnit, 64); + i = i0; + if (i < 9) { + adr = Heap_freeList[i]; + while (adr == 0) { + i += 1; + adr = Heap_freeList[i]; + } + } + if (i < 9) { + __GET(adr + 24, next, INT64); + Heap_freeList[i] = next; + if (i != i0) { + di = i - i0; + restsize = __ASHL(di, 5); + end = adr + restsize; + __PUT(end + 8, blksz, INT64); + __PUT(end + 16, -8, INT64); + __PUT(end, end + 8, INT64); + __PUT(adr + 8, restsize, INT64); + __PUT(adr + 24, Heap_freeList[di], INT64); + Heap_freeList[di] = adr; + adr += restsize; + } + } else { + adr = Heap_bigBlocks; + prev = 0; + for (;;) { + if (adr == 0) { + if (Heap_firstTry) { + Heap_GC(1); + blksz += 32; + t = __LSH(Heap_allocated + blksz, -(2 + Heap_ldUnit), 64) * 160; + if (Heap_uLT(Heap_heapsize, t)) { + Heap_ExtendHeap(t - Heap_heapsize); + } + Heap_firstTry = 0; + new = Heap_NEWREC(tag); + if (new == NIL) { + Heap_ExtendHeap(blksz); + new = Heap_NEWREC(tag); + } + Heap_firstTry = 1; + Heap_Unlock(); + return new; + } else { + Heap_Unlock(); + return NIL; + } + } + __GET(adr + 8, t, INT64); + if (Heap_uLE(blksz, t)) { + break; + } + prev = adr; + __GET(adr + 24, adr, INT64); + } + restsize = t - blksz; + end = adr + restsize; + __PUT(end + 8, blksz, INT64); + __PUT(end + 16, -8, INT64); + __PUT(end, end + 8, INT64); + if (Heap_uLT(288, restsize)) { + __PUT(adr + 8, restsize, INT64); + } else { + __GET(adr + 24, next, INT64); + if (prev == 0) { + Heap_bigBlocks = next; + } else { + __PUT(prev + 24, next, INT64); + } + if (restsize != 0) { + di = __ASHR(restsize, 5); + __PUT(adr + 8, restsize, INT64); + __PUT(adr + 24, Heap_freeList[di], INT64); + Heap_freeList[di] = adr; + } + } + adr += restsize; + } + i = adr + 32; + end = adr + blksz; + while (Heap_uLT(i, end)) { + __PUT(i, 0, INT64); + __PUT(i + 8, 0, INT64); + __PUT(i + 16, 0, INT64); + __PUT(i + 24, 0, INT64); + i += 32; + } + __PUT(adr + 24, 0, INT64); + __PUT(adr, tag, INT64); + __PUT(adr + 8, 0, INT64); + __PUT(adr + 16, 0, INT64); + Heap_allocated += blksz; + Heap_Unlock(); + return (SYSTEM_PTR)(ADDRESS)(adr + 8); +} + +SYSTEM_PTR Heap_NEWBLK (INT64 size) +{ + INT64 blksz, tag; + SYSTEM_PTR new; + Heap_Lock(); + blksz = __ASHL(__ASHR(size + 63, 5), 5); + new = Heap_NEWREC((ADDRESS)&blksz); + tag = ((INT64)(ADDRESS)new + blksz) - 24; + __PUT(tag - 8, 0, INT64); + __PUT(tag, blksz, INT64); + __PUT(tag + 8, -8, INT64); + __PUT((INT64)(ADDRESS)new - 8, tag, INT64); + Heap_Unlock(); + return new; +} + +static void Heap_Mark (INT64 q) +{ + INT64 p, tag, offset, fld, n, tagbits; + if (q != 0) { + __GET(q - 8, tagbits, INT64); + if (!__ODD(tagbits)) { + __PUT(q - 8, tagbits + 1, INT64); + p = 0; + tag = tagbits + 8; + for (;;) { + __GET(tag, offset, INT64); + if (offset < 0) { + __PUT(q - 8, (tag + offset) + 1, INT64); + if (p == 0) { + break; + } + n = q; + q = p; + __GET(q - 8, tag, INT64); + tag -= 1; + __GET(tag, offset, INT64); + fld = q + offset; + __GET(fld, p, INT64); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)n, SYSTEM_PTR); + } else { + fld = q + offset; + __GET(fld, n, INT64); + if (n != 0) { + __GET(n - 8, tagbits, INT64); + if (!__ODD(tagbits)) { + __PUT(n - 8, tagbits + 1, INT64); + __PUT(q - 8, tag + 1, INT64); + __PUT(fld, (SYSTEM_PTR)(ADDRESS)p, SYSTEM_PTR); + p = q; + q = n; + tag = tagbits; + } + } + } + tag += 8; + } + } + } +} + +static void Heap_MarkP (SYSTEM_PTR p) +{ + Heap_Mark((INT64)(ADDRESS)p); +} + +static void Heap_Scan (void) +{ + INT64 chnk, adr, end, start, tag, i, size, freesize; + Heap_bigBlocks = 0; + i = 1; + while (i < 9) { + Heap_freeList[i] = 0; + i += 1; + } + freesize = 0; + Heap_allocated = 0; + chnk = Heap_heap; + while (chnk != 0) { + adr = chnk + 24; + __GET(chnk + 8, end, INT64); + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT64); + if (__ODD(tag)) { + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 8, INT64); + __PUT(start + 8, freesize, INT64); + __PUT(start + 16, -8, INT64); + i = __LSH(freesize, -Heap_ldUnit, 64); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 24, Heap_freeList[i], INT64); + Heap_freeList[i] = start; + } else { + __PUT(start + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = start; + } + } + tag -= 1; + __PUT(adr, tag, INT64); + __GET(tag, size, INT64); + Heap_allocated += size; + adr += size; + } else { + __GET(tag, size, INT64); + freesize += size; + adr += size; + } + } + if (freesize != 0) { + start = adr - freesize; + __PUT(start, start + 8, INT64); + __PUT(start + 8, freesize, INT64); + __PUT(start + 16, -8, INT64); + i = __LSH(freesize, -Heap_ldUnit, 64); + freesize = 0; + if (Heap_uLT(i, 9)) { + __PUT(start + 24, Heap_freeList[i], INT64); + Heap_freeList[i] = start; + } else { + __PUT(start + 24, Heap_bigBlocks, INT64); + Heap_bigBlocks = start; + } + } + __GET(chnk, chnk, INT64); + } +} + +static void Heap_Sift (INT32 l, INT32 r, INT64 *a, ADDRESS a__len) +{ + INT32 i, j; + INT64 x; + j = l; + x = a[j]; + for (;;) { + i = j; + j = __ASHL(j, 1) + 1; + if ((j < r && Heap_uLT(a[j], a[j + 1]))) { + j += 1; + } + if (j > r || Heap_uLE(a[j], x)) { + break; + } + a[i] = a[j]; + } + a[i] = x; +} + +static void Heap_HeapSort (INT32 n, INT64 *a, ADDRESS a__len) +{ + INT32 l, r; + INT64 x; + l = __ASHR(n, 1); + r = n - 1; + while (l > 0) { + l -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } + while (r > 0) { + x = a[0]; + a[0] = a[r]; + a[r] = x; + r -= 1; + Heap_Sift(l, r, (void*)a, a__len); + } +} + +static void Heap_MarkCandidates (INT32 n, INT64 *cand, ADDRESS cand__len) +{ + INT64 chnk, end, adr, tag, next, i, ptr, size; + chnk = Heap_heap; + i = 0; + while (chnk != 0) { + __GET(chnk + 8, end, INT64); + adr = chnk + 24; + while (Heap_uLT(adr, end)) { + __GET(adr, tag, INT64); + if (__ODD(tag)) { + __GET(tag - 1, size, INT64); + adr += size; + ptr = adr + 8; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == (INT64)n) { + return; + } + } + } else { + __GET(tag, size, INT64); + ptr = adr + 8; + adr += size; + while (Heap_uLT(cand[i], ptr)) { + i += 1; + if (i == (INT64)n) { + return; + } + } + if (Heap_uLT(cand[i], adr)) { + Heap_Mark(ptr); + } + } + if (Heap_uLE(end, cand[i])) { + adr = end; + } + } + __GET(chnk, chnk, INT64); + } +} + +static void Heap_CheckFin (void) +{ + Heap_FinNode n; + INT64 tag; + n = Heap_fin; + while (n != NIL) { + __GET(n->obj - 8, tag, INT64); + if (!__ODD(tag)) { + n->marked = 0; + Heap_Mark(n->obj); + } else { + n->marked = 1; + } + n = n->next; + } +} + +static void Heap_Finalize (void) +{ + Heap_FinNode n, prev; + n = Heap_fin; + prev = NIL; + while (n != NIL) { + if (!n->marked) { + if (n == Heap_fin) { + Heap_fin = Heap_fin->next; + } else { + prev->next = n->next; + } + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + if (prev == NIL) { + n = Heap_fin; + } else { + n = n->next; + } + } else { + prev = n; + n = n->next; + } + } +} + +void Heap_FINALL (void) +{ + Heap_FinNode n; + while (Heap_fin != NIL) { + n = Heap_fin; + Heap_fin = Heap_fin->next; + (*n->finalize)((SYSTEM_PTR)(ADDRESS)n->obj); + } +} + +static void Heap_MarkStack (INT64 n, INT64 *cand, ADDRESS cand__len) +{ + SYSTEM_PTR frame; + INT32 nofcand; + INT64 inc, sp, p, stack0; + struct Heap__1 align; + if (n > 0) { + Heap_MarkStack(n - 1, cand, cand__len); + if (n > 100) { + return; + } + } + if (n == 0) { + nofcand = 0; + sp = (ADDRESS)&frame; + stack0 = Heap_ModulesMainStackFrame(); + inc = (ADDRESS)&align.p - (ADDRESS)&align; + if (Heap_uLT(stack0, sp)) { + inc = -inc; + } + while (sp != stack0) { + __GET(sp, p, INT64); + if ((Heap_uLE(Heap_heapMin, p) && Heap_uLT(p, Heap_heapMax))) { + if (nofcand == cand__len) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + nofcand = 0; + } + cand[nofcand] = p; + nofcand += 1; + } + sp += inc; + } + if (nofcand > 0) { + Heap_HeapSort(nofcand, (void*)cand, cand__len); + Heap_MarkCandidates(nofcand, (void*)cand, cand__len); + } + } +} + +void Heap_GC (BOOLEAN markStack) +{ + Heap_Module m; + INT64 i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23; + INT64 cand[10000]; + Heap_Lock(); + m = (Heap_Module)(ADDRESS)Heap_modules; + while (m != NIL) { + if (m->enumPtrs != NIL) { + (*m->enumPtrs)(Heap_MarkP); + } + m = m->next; + } + if (markStack) { + 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; + for (;;) { + i0 += 1; + i1 += 2; + i2 += 3; + i3 += 4; + i4 += 5; + i5 += 6; + i6 += 7; + i7 += 8; + i8 += 9; + i9 += 10; + i10 += 11; + i11 += 12; + i12 += 13; + i13 += 14; + i14 += 15; + i15 += 16; + i16 += 17; + i17 += 18; + i18 += 19; + i19 += 20; + i20 += 21; + i21 += 22; + i22 += 23; + i23 += 24; + if ((i0 == -99 && i15 == 24)) { + Heap_MarkStack(32, (void*)cand, 10000); + break; + } + } + 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) { + return; + } + } + Heap_CheckFin(); + Heap_Scan(); + Heap_Finalize(); + Heap_Unlock(); +} + +void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) +{ + Heap_FinNode f; + __NEW(f, Heap_FinDesc); + f->obj = (INT64)(ADDRESS)obj; + f->finalize = finalize; + f->marked = 1; + f->next = Heap_fin; + Heap_fin = f; +} + +void Heap_InitHeap (void) +{ + Heap_heap = 0; + Heap_heapsize = 0; + Heap_allocated = 0; + Heap_lockdepth = 0; + Heap_heapMin = -1; + Heap_heapMax = 0; + Heap_bigBlocks = 0; + Heap_heapMinExpand = 256000; + Heap_ldUnit = 5; + Heap_heap = Heap_NewChunk(256000); + __PUT(Heap_heap, 0, INT64); + Heap_firstTry = 1; + Heap_freeList[9] = 1; + Heap_FileCount = 0; + Heap_modules = NIL; + Heap_fin = NIL; + Heap_interrupted = 0; + Heap_HeapModuleInit(); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Heap_modules); + P(Heap_fin); +} + +__TDESC(Heap_ModuleDesc, 1, 2) = {__TDFLDS("ModuleDesc", 64), {0, 32, -24}}; +__TDESC(Heap_CmdDesc, 1, 1) = {__TDFLDS("CmdDesc", 40), {0, -16}}; +__TDESC(Heap_FinDesc, 1, 1) = {__TDFLDS("FinDesc", 32), {0, -16}}; +__TDESC(Heap__1, 1, 1) = {__TDFLDS("", 16), {8, -16}}; + +export void *Heap__init(void) +{ + __DEFMOD; + __REGMOD("Heap", EnumPtrs); + __REGCMD("FINALL", Heap_FINALL); + __REGCMD("InitHeap", Heap_InitHeap); + __REGCMD("Lock", Heap_Lock); + __REGCMD("Unlock", Heap_Unlock); + __INITYP(Heap_ModuleDesc, Heap_ModuleDesc, 0); + __INITYP(Heap_CmdDesc, Heap_CmdDesc, 0); + __INITYP(Heap_FinDesc, Heap_FinDesc, 0); + __INITYP(Heap__1, Heap__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/Heap.h b/bootstrap/windows-88/Heap.h new file mode 100644 index 00000000..45a9c6d2 --- /dev/null +++ b/bootstrap/windows-88/Heap.h @@ -0,0 +1,73 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. rtsSF */ + +#ifndef Heap__h +#define Heap__h + +#include "SYSTEM.h" + +typedef + struct Heap_CmdDesc *Heap_Cmd; + +typedef + CHAR Heap_CmdName[24]; + +typedef + void (*Heap_Command)(void); + +typedef + struct Heap_CmdDesc { + Heap_Cmd next; + Heap_CmdName name; + Heap_Command cmd; + } Heap_CmdDesc; + +typedef + void (*Heap_EnumProc)(void(*)(SYSTEM_PTR)); + +typedef + void (*Heap_Finalizer)(SYSTEM_PTR); + +typedef + struct Heap_ModuleDesc *Heap_Module; + +typedef + CHAR Heap_ModuleName[20]; + +typedef + struct Heap_ModuleDesc { + Heap_Module next; + Heap_ModuleName name; + INT32 refcnt; + Heap_Cmd cmds; + INT64 types; + Heap_EnumProc enumPtrs; + char _prvt0[8]; + } Heap_ModuleDesc; + + +import SYSTEM_PTR Heap_modules; +import INT64 Heap_allocated; +import INT64 Heap_heap; +import INT64 Heap_heapsize, Heap_heapMinExpand; +import INT16 Heap_FileCount; + +import ADDRESS *Heap_ModuleDesc__typ; +import ADDRESS *Heap_CmdDesc__typ; + +import void Heap_FINALL (void); +import INT32 Heap_FreeModule (CHAR *name, ADDRESS name__len); +import void Heap_GC (BOOLEAN markStack); +import void Heap_INCREF (Heap_Module m); +import void Heap_InitHeap (void); +import void Heap_Lock (void); +import SYSTEM_PTR Heap_NEWBLK (INT64 size); +import SYSTEM_PTR Heap_NEWREC (INT64 tag); +import void Heap_REGCMD (Heap_Module m, Heap_CmdName name, Heap_Command cmd); +import SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs); +import void Heap_REGTYP (Heap_Module m, INT64 typ); +import void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize); +import void Heap_Unlock (void); +import void *Heap__init(void); + + +#endif // Heap diff --git a/bootstrap/windows-88/Modules.c b/bootstrap/windows-88/Modules.c new file mode 100644 index 00000000..7a49b8ff --- /dev/null +++ b/bootstrap/windows-88/Modules.c @@ -0,0 +1,506 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export INT16 Modules_res; +export CHAR Modules_resMsg[256]; +export Heap_ModuleName Modules_imported, Modules_importing; +export INT64 Modules_MainStackFrame; +export INT16 Modules_ArgCount; +export INT64 Modules_ArgVector; +export CHAR Modules_BinaryDir[1024]; + + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +export void Modules_AssertFail (INT32 code); +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len); +static void Modules_DisplayHaltCode (INT32 code); +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len); +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len); +export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +export void Modules_GetIntArg (INT16 n, INT32 *val); +export void Modules_Halt (INT32 code); +export void Modules_Init (INT32 argc, INT64 argvadr); +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len); +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len); +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len); +export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len); +static void Modules_errch (CHAR c); +static void Modules_errint (INT32 l); +static void Modules_errstring (CHAR *s, ADDRESS s__len); + +extern void Heap_InitHeap(); +extern void *Modules__init(void); +#define Modules_InitHeap() Heap_InitHeap() +#define Modules_ModulesInit() Modules__init() +#define Modules_modules() (Heap_Module)Heap_modules + +void Modules_Init (INT32 argc, INT64 argvadr) +{ + Modules_MainStackFrame = argvadr; + Modules_ArgCount = __VAL(INT16, argc); + __GET(argvadr, Modules_ArgVector, INT64); + Modules_InitHeap(); + Modules_ModulesInit(); +} + +typedef + CHAR (*argptr__15)[1024]; + +void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len) +{ + argptr__15 arg = NIL; + if (n < Modules_ArgCount) { + __GET(Modules_ArgVector + (INT64)__ASHL(n, 3), arg, argptr__15); + __COPY(*arg, val, val__len); + } +} + +void Modules_GetIntArg (INT16 n, INT32 *val) +{ + CHAR s[64]; + INT32 k, d, i; + s[0] = 0x00; + Modules_GetArg(n, (void*)s, 64); + i = 0; + if (s[0] == '-') { + i = 1; + } + k = 0; + d = (INT16)s[__X(i, 64)] - 48; + while ((d >= 0 && d <= 9)) { + k = k * 10 + d; + i += 1; + d = (INT16)s[__X(i, 64)] - 48; + } + if (s[0] == '-') { + k = -k; + i -= 1; + } + if (i > 0) { + *val = k; + } +} + +INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len) +{ + INT16 i; + CHAR arg[256]; + __DUP(s, s__len, CHAR); + i = 0; + Modules_GetArg(i, (void*)arg, 256); + while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) { + i += 1; + Modules_GetArg(i, (void*)arg, 256); + } + __DEL(s); + return i; +} + +static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return i; +} + +static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + __DUP(s, s__len, CHAR); + i = 0; + j = Modules_CharCount(d, d__len); + if ((j > 0 && d[__X(j - 1, d__len)] != c)) { + d[__X(j, d__len)] = c; + j += 1; + } + while (s[__X(i, s__len)] != 0x00) { + d[__X(j, d__len)] = s[__X(i, s__len)]; + i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + __DEL(s); +} + +static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + if (c == 0x00) { + __DEL(s); + return 0; + } + i = 0; + while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + __DEL(s); + return s[__X(i, s__len)] == c; +} + +static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len) +{ + __DUP(d, d__len, CHAR); + if (d[0] == 0x00) { + __DEL(d); + return 0; + } + if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) { + __DEL(d); + return 1; + } + if (d[__X(1, d__len)] == ':') { + __DEL(d); + return 1; + } + __DEL(d); + return 0; +} + +static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + __DUP(s, s__len, CHAR); + if (Modules_IsAbsolute(s, s__len)) { + __COPY(s, d, d__len); + } else { + __COPY(Platform_CWD, d, d__len); + Modules_AppendPart('/', s, s__len, (void*)d, d__len); + } + __DEL(s); +} + +static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len) +{ + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __DEL(s); + return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0; +} + +static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len) +{ + INT16 j; + __DUP(s, s__len, CHAR); + __DUP(p, p__len, CHAR); + j = 0; + while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) { + d[__X(j, d__len)] = s[__X(*i, s__len)]; + *i += 1; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) { + *i += 1; + } + __DEL(s); + __DEL(p); +} + +static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len) +{ + INT16 i, j; + CHAR part[1024]; + __DUP(s, s__len, CHAR); + i = 0; + j = 0; + while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) { + i += 1; + d[__X(j, d__len)] = '/'; + j += 1; + } + d[__X(j, d__len)] = 0x00; + while (s[__X(i, s__len)] != 0x00) { + Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024); + if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) { + Modules_AppendPart('/', part, 1024, (void*)d, d__len); + } + } + __DEL(s); +} + +typedef + CHAR pathstring__12[4096]; + +static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len) +{ + pathstring__12 arg0, pathlist, pathdir, tempstr; + INT16 i, j, k; + BOOLEAN present; + if (Modules_ArgCount < 1) { + binarydir[0] = 0x00; + return; + } + Modules_GetArg(0, (void*)arg0, 4096); + i = 0; + while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) { + i += 1; + } + if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') { + Modules_Trim(arg0, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } else { + Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096); + i = 0; + present = 0; + while ((!present && pathlist[__X(i, 4096)] != 0x00)) { + Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096); + Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096); + Modules_Trim(pathdir, 4096, (void*)tempstr, 4096); + Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len); + present = Modules_IsFilePresent(binarydir, binarydir__len); + } + } + if (present) { + k = Modules_CharCount(binarydir, binarydir__len); + while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) { + k -= 1; + } + if (k == 0) { + binarydir[__X(k, binarydir__len)] = 0x00; + } else { + binarydir[__X(k - 1, binarydir__len)] = 0x00; + } + } else { + binarydir[0] = 0x00; + } +} + +Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len) +{ + Heap_Module m = NIL; + CHAR bodyname[64]; + Heap_Command body; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + while ((m != NIL && __STRCMP(m->name, name) != 0)) { + m = m->next; + } + if (m != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + } else { + Modules_res = 1; + __COPY(name, Modules_importing, 20); + __MOVE(" module \"", Modules_resMsg, 10); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + } + __DEL(name); + return m; +} + +Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len) +{ + Heap_Cmd c = NIL; + __DUP(name, name__len, CHAR); + c = mod->cmds; + while ((c != NIL && __STRCMP(c->name, name) != 0)) { + c = c->next; + } + if (c != NIL) { + Modules_res = 0; + Modules_resMsg[0] = 0x00; + __DEL(name); + return c->cmd; + } else { + Modules_res = 2; + __MOVE(" command \"", Modules_resMsg, 11); + __COPY(name, Modules_importing, 20); + Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256); + Modules_Append(name, name__len, (void*)Modules_resMsg, 256); + Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256); + __DEL(name); + return NIL; + } + __RETCHK; +} + +void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all) +{ + Heap_Module m = NIL, p = NIL; + INT32 refcount; + __DUP(name, name__len, CHAR); + m = Modules_modules(); + if (all) { + Modules_res = 1; + __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34); + } else { + refcount = Heap_FreeModule(name, name__len); + if (refcount == 0) { + Modules_res = 0; + } else { + if (refcount < 0) { + __MOVE("module not found", Modules_resMsg, 17); + } else { + __MOVE("clients of this module exist", Modules_resMsg, 29); + } + Modules_res = 1; + } + } + __DEL(name); +} + +static void Modules_errch (CHAR c) +{ + INT16 e; + e = Platform_Write(Platform_StdOut, (ADDRESS)&c, 1); +} + +static void Modules_errstring (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + Modules_errch(s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +static void Modules_errint (INT32 l) +{ + if (l < 0) { + Modules_errch('-'); + l = -l; + } + if (l >= 10) { + Modules_errint(__DIV(l, 10)); + } + Modules_errch(__CHR((int)__MOD(l, 10) + 48)); +} + +static void Modules_DisplayHaltCode (INT32 code) +{ + switch (code) { + case -1: + Modules_errstring((CHAR*)"Assertion failure.", 19); + break; + case -2: + Modules_errstring((CHAR*)"Index out of range.", 20); + break; + case -3: + Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49); + break; + case -4: + Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47); + break; + case -5: + Modules_errstring((CHAR*)"Type guard failed.", 19); + break; + case -6: + Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49); + break; + case -7: + Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32); + break; + case -8: + Modules_errstring((CHAR*)"Value out of range.", 20); + break; + case -9: + Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60); + break; + case -10: + Modules_errstring((CHAR*)"NIL access.", 12); + break; + case -11: + Modules_errstring((CHAR*)"Alignment error.", 17); + break; + case -12: + Modules_errstring((CHAR*)"Divide by zero.", 16); + break; + case -13: + Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31); + break; + case -14: + Modules_errstring((CHAR*)"Invalid function argument.", 27); + break; + case -15: + Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52); + break; + case -20: + Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60); + break; + default: + break; + } +} + +void Modules_Halt (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Terminated by Halt(", 20); + Modules_errint(code); + Modules_errstring((CHAR*)"). ", 4); + if (code < 0) { + Modules_DisplayHaltCode(code); + } + Modules_errstring(Platform_NL, 3); + Platform_Exit(code); +} + +void Modules_AssertFail (INT32 code) +{ + Heap_FINALL(); + Modules_errstring((CHAR*)"Assertion failure.", 19); + if (code != 0) { + Modules_errstring((CHAR*)" ASSERT code ", 14); + Modules_errint(code); + Modules_errstring((CHAR*)".", 2); + } + Modules_errstring(Platform_NL, 3); + if (code > 0) { + Platform_Exit(code); + } else { + Platform_Exit(-1); + } +} + + +export void *Modules__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Modules", 0); +/* BEGIN */ + Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024); + __ENDMOD; +} diff --git a/bootstrap/windows-88/Modules.h b/bootstrap/windows-88/Modules.h new file mode 100644 index 00000000..ee65a938 --- /dev/null +++ b/bootstrap/windows-88/Modules.h @@ -0,0 +1,31 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Modules__h +#define Modules__h + +#include "SYSTEM.h" +#include "Heap.h" + + +import INT16 Modules_res; +import CHAR Modules_resMsg[256]; +import Heap_ModuleName Modules_imported, Modules_importing; +import INT64 Modules_MainStackFrame; +import INT16 Modules_ArgCount; +import INT64 Modules_ArgVector; +import CHAR Modules_BinaryDir[1024]; + + +import INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len); +import void Modules_AssertFail (INT32 code); +import void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all); +import void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len); +import void Modules_GetIntArg (INT16 n, INT32 *val); +import void Modules_Halt (INT32 code); +import void Modules_Init (INT32 argc, INT64 argvadr); +import Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len); +import Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len); +import void *Modules__init(void); + + +#endif // Modules diff --git a/bootstrap/windows-88/OPB.c b/bootstrap/windows-88/OPB.c new file mode 100644 index 00000000..913fbf2d --- /dev/null +++ b/bootstrap/windows-88/OPB.c @@ -0,0 +1,2592 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + + +static INT16 OPB_exp; +static INT64 OPB_maxExp; + + +export void OPB_Assign (OPT_Node *x, OPT_Node y); +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static INT16 OPB_BoolToInt (BOOLEAN b); +export void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +static void OPB_CharToString (OPT_Node n); +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode); +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo); +export void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +static void OPB_CheckProc (OPT_Struct x, OPT_Object y); +static void OPB_CheckPtr (OPT_Node x, OPT_Node y); +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x); +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp); +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y); +export void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +static void OPB_Convert (OPT_Node *x, OPT_Struct typ); +export void OPB_DeRef (OPT_Node *x); +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar); +export OPT_Node OPB_EmptySet (void); +export void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +export void OPB_Field (OPT_Node *x, OPT_Object y); +export void OPB_In (OPT_Node *x, OPT_Node y); +export void OPB_Index (OPT_Node *x, OPT_Node y); +export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +static BOOLEAN OPB_IntToBool (INT64 i); +export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +export void OPB_MOp (INT8 op, OPT_Node *x); +export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +export OPT_Node OPB_NewIntConst (INT64 intval); +export OPT_Node OPB_NewLeaf (OPT_Object obj); +export OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +export OPT_Node OPB_NewString (OPS_String str, INT64 len); +export OPT_Node OPB_Nil (void); +static BOOLEAN OPB_NotVar (OPT_Node x); +export void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +export void OPB_OptIf (OPT_Node *x); +export void OPB_Param (OPT_Node ap, OPT_Object fp); +export void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +export void OPB_Return (OPT_Node *x, OPT_Object proc); +export void OPB_SetElem (OPT_Node *x); +static void OPB_SetIntType (OPT_Node node); +export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static void OPB_SetSetType (OPT_Node node); +export void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +export void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +export void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +export void OPB_StaticLink (INT8 dlev); +export void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +static void OPB_err (INT16 n); +static INT64 OPB_log (INT64 x); + + +static void OPB_err (INT16 n) +{ + OPM_err(n); +} + +OPT_Node OPB_NewLeaf (OPT_Object obj) +{ + OPT_Node node = NIL; + switch (obj->mode) { + case 1: + node = OPT_NewNode(0); + node->readonly = (obj->vis == 2 && obj->mnolev < 0); + break; + case 2: + node = OPT_NewNode(1); + break; + case 3: + node = OPT_NewNode(7); + node->conval = OPT_NewConst(); + __GUARDEQP(node->conval, OPT_ConstDesc) = *obj->conval; + break; + case 5: + node = OPT_NewNode(8); + break; + case 6: case 7: case 8: case 9: case 10: + node = OPT_NewNode(9); + break; + default: + node = OPT_NewNode(0); + OPB_err(127); + break; + } + node->obj = obj; + node->typ = obj->typ; + return node; +} + +void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = OPT_notyp; + node->left = *x; + node->right = y; + *x = node; +} + +void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y) +{ + if (*x == NIL) { + *x = y; + } else { + (*last)->link = y; + } + while (y->link != NIL) { + y = y->link; + } + *last = y; +} + +static INT16 OPB_BoolToInt (BOOLEAN b) +{ + if (b) { + return 1; + } else { + return 0; + } + __RETCHK; +} + +static BOOLEAN OPB_IntToBool (INT64 i) +{ + return i != 0; +} + +OPT_Node OPB_NewBoolConst (BOOLEAN boolval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_booltyp; + x->conval = OPT_NewConst(); + x->conval->intval = OPB_BoolToInt(boolval); + return x; +} + +void OPB_OptIf (OPT_Node *x) +{ + OPT_Node if_ = NIL, pred = NIL; + if_ = (*x)->left; + while (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + *x = if_->right; + return; + } else if (if_->link == NIL) { + *x = (*x)->right; + return; + } else { + if_ = if_->link; + (*x)->left = if_; + } + } + pred = if_; + if_ = if_->link; + while (if_ != NIL) { + if (if_->left->class == 7) { + if (OPB_IntToBool(if_->left->conval->intval)) { + pred->link = NIL; + (*x)->right = if_->right; + return; + } else { + if_ = if_->link; + pred->link = if_; + } + } else { + pred = if_; + if_ = if_->link; + } + } +} + +OPT_Node OPB_Nil (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_niltyp; + x->conval = OPT_NewConst(); + x->conval->intval = 0; + return x; +} + +OPT_Node OPB_EmptySet (void) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->typ = OPT_settyp; + x->conval = OPT_NewConst(); + x->conval->setval = 0x0; + return x; +} + +static void OPB_SetIntType (OPT_Node node) +{ + node->typ = OPT_IntType(OPT_IntSize(node->conval->intval)); +} + +static void OPB_SetSetType (OPT_Node node) +{ + INT32 i32; + __GET((ADDRESS)&node->conval->setval + 4, i32, INT32); + if (i32 == 0) { + node->typ = OPT_set32typ; + } else { + node->typ = OPT_set64typ; + } +} + +OPT_Node OPB_NewIntConst (INT64 intval) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->intval = intval; + OPB_SetIntType(x); + return x; +} + +OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->conval->realval = realval; + x->typ = typ; + x->conval->intval = -1; + return x; +} + +OPT_Node OPB_NewString (OPS_String str, INT64 len) +{ + OPT_Node x = NIL; + x = OPT_NewNode(7); + x->conval = OPT_NewConst(); + x->typ = OPT_stringtyp; + x->conval->intval = -1; + x->conval->intval2 = OPM_Longint(len); + x->conval->ext = OPT_NewExt(); + __MOVE(str, *x->conval->ext, 256); + return x; +} + +static void OPB_CharToString (OPT_Node n) +{ + CHAR ch; + n->typ = OPT_stringtyp; + ch = __CHR(n->conval->intval); + n->conval->ext = OPT_NewExt(); + if (ch == 0x00) { + n->conval->intval2 = 1; + } else { + n->conval->intval2 = 2; + (*n->conval->ext)[1] = 0x00; + } + (*n->conval->ext)[0] = ch; + n->conval->intval = -1; + n->obj = NIL; +} + +static void OPB_BindNodes (INT8 class, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN OPB_NotVar (OPT_Node x) +{ + return (x->class >= 7 && ((x->class != 11 || x->subcl != 29) || x->left->class >= 7)); +} + +void OPB_DeRef (OPT_Node *x) +{ + OPT_Object strobj = NIL, bstrobj = NIL; + OPT_Struct typ = NIL, btyp = NIL; + typ = (*x)->typ; + if ((*x)->class >= 7) { + OPB_err(78); + } else if (typ->form == 11) { + if (typ == OPT_sysptrtyp) { + OPB_err(57); + } + btyp = typ->BaseTyp; + strobj = typ->strobj; + bstrobj = btyp->strobj; + if ((((((strobj != NIL && strobj->name[0] != 0x00)) && bstrobj != NIL)) && bstrobj->name[0] != 0x00)) { + btyp->pbused = 1; + } + OPB_BindNodes(3, btyp, &*x, NIL); + } else { + OPB_err(84); + } +} + +void OPB_Index (OPT_Node *x, OPT_Node y) +{ + INT16 f; + OPT_Struct typ = NIL; + f = y->typ->form; + if ((*x)->class >= 7) { + OPB_err(79); + } else if (f != 4 || __IN(y->class, 0x0300, 32)) { + OPB_err(80); + y->typ = OPT_inttyp; + } + if ((*x)->typ->comp == 2) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && (y->conval->intval < 0 || y->conval->intval >= (INT64)(*x)->typ->n))) { + OPB_err(81); + } + } else if ((*x)->typ->comp == 3) { + typ = (*x)->typ->BaseTyp; + if ((y->class == 7 && y->conval->intval < 0)) { + OPB_err(81); + } + } else { + OPB_err(82); + typ = OPT_undftyp; + } + OPB_BindNodes(4, typ, &*x, y); + (*x)->readonly = (*x)->left->readonly; +} + +void OPB_Field (OPT_Node *x, OPT_Object y) +{ + if ((*x)->class >= 7) { + OPB_err(77); + } + if ((y != NIL && __IN(y->mode, 0x2010, 32))) { + OPB_BindNodes(2, y->typ, &*x, NIL); + (*x)->obj = y; + (*x)->readonly = (*x)->left->readonly || (y->vis == 2 && y->mnolev < 0); + } else { + OPB_err(83); + (*x)->typ = OPT_undftyp; + } +} + +static struct TypTest__58 { + OPT_Node *x; + OPT_Object *obj; + BOOLEAN *guard; + struct TypTest__58 *lnk; +} *TypTest__58_s; + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1); + +static void GTT__59 (OPT_Struct t0, OPT_Struct t1) +{ + OPT_Node node = NIL; + OPT_Struct t = NIL; + t = t0; + while ((((t != NIL && t != t1)) && t != OPT_undftyp)) { + t = t->BaseTyp; + } + if (t != t1) { + while ((((t1 != NIL && t1 != t0)) && t1 != OPT_undftyp)) { + t1 = t1->BaseTyp; + } + if (t1 == t0 || t0->form == 0) { + if (*TypTest__58_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__58_s->x, NIL); + (*TypTest__58_s->x)->readonly = (*TypTest__58_s->x)->left->readonly; + } else { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } + } else { + OPB_err(85); + } + } else if (t0 != t1) { + OPB_err(85); + } else if (!*TypTest__58_s->guard) { + if ((*TypTest__58_s->x)->class == 5) { + node = OPT_NewNode(11); + node->subcl = 16; + node->left = *TypTest__58_s->x; + node->obj = *TypTest__58_s->obj; + *TypTest__58_s->x = node; + } else { + *TypTest__58_s->x = OPB_NewBoolConst(1); + } + } +} + +void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) +{ + struct TypTest__58 _s; + _s.x = x; + _s.obj = &obj; + _s.guard = &guard; + _s.lnk = TypTest__58_s; + TypTest__58_s = &_s; + if (OPB_NotVar(*x)) { + OPB_err(112); + } else if ((*x)->typ->form == 11) { + if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { + OPB_err(85); + } else if (obj->typ->form == 11) { + GTT__59((*x)->typ->BaseTyp, obj->typ->BaseTyp); + } else { + OPB_err(86); + } + } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { + GTT__59((*x)->typ, obj->typ); + } else { + OPB_err(87); + } + if (guard) { + (*x)->typ = obj->typ; + } else { + (*x)->typ = OPT_booltyp; + } + TypTest__58_s = _s.lnk; +} + +void OPB_In (OPT_Node *x, OPT_Node y) +{ + INT16 f; + INT64 k; + f = (*x)->typ->form; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((f == 4 && y->typ->form == 7)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (k < 0 || k >= (INT64)__ASHL(y->typ->size, 3)) { + OPB_err(202); + } else if (y->class == 7) { + (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval, 64)); + (*x)->obj = NIL; + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_BindNodes(12, OPT_booltyp, &*x, y); + (*x)->subcl = 15; + } + } else { + OPB_err(92); + } + (*x)->typ = OPT_booltyp; +} + +static INT64 OPB_log (INT64 x) +{ + OPB_exp = 0; + if (x > 0) { + while (!__ODD(x)) { + x = __ASHR(x, 1); + OPB_exp += 1; + } + } + return x; +} + +static void OPB_CheckRealType (INT16 f, INT16 nr, OPT_Const x) +{ + LONGREAL min, max, r; + if (f == 5) { + min = OPM_MinReal; + max = OPM_MaxReal; + } else { + min = OPM_MinLReal; + max = OPM_MaxLReal; + } + r = __ABS(x->realval); + if (r > max || r < min) { + OPB_err(nr); + x->realval = (LONGREAL)1; + } else if (f == 5) { + x->realval = x->realval; + } + x->intval = -1; +} + +static struct MOp__28 { + struct MOp__28 *lnk; +} *MOp__28_s; + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z); + +static OPT_Node NewOp__29 (INT8 op, OPT_Struct typ, OPT_Node z) +{ + OPT_Node node = NIL; + node = OPT_NewNode(11); + node->subcl = op; + node->typ = typ; + node->left = z; + return node; +} + +void OPB_MOp (INT8 op, OPT_Node *x) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node z = NIL; + struct MOp__28 _s; + _s.lnk = MOp__28_s; + MOp__28_s = &_s; + z = *x; + if (z->class == 8 || z->class == 9) { + OPB_err(126); + } else { + typ = z->typ; + f = typ->form; + switch (op) { + case 33: + if (f == 2) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(98); + } + break; + case 6: + if (!__IN(f, 0x70, 32)) { + OPB_err(96); + } + break; + case 7: + if (__IN(f, 0xf0, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = -z->conval->intval; + OPB_SetIntType(z); + } + } else if (__IN(f, 0x60, 32)) { + z->conval->realval = -z->conval->realval; + } else { + if (z->typ->size == 8) { + z->conval->setval = ~z->conval->setval; + } else { + z->conval->setval = z->conval->setval ^ 0xffffffff; + } + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(97); + } + break; + case 21: + if (__IN(f, 0x70, 32)) { + if (z->class == 7) { + if (f == 4) { + if (z->conval->intval == (-9223372036854775807LL-1)) { + OPB_err(203); + } else { + z->conval->intval = __ABS(z->conval->intval); + OPB_SetIntType(z); + } + } else { + z->conval->realval = __ABS(z->conval->realval); + } + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + break; + case 22: + if (f == 3) { + if (z->class == 7) { + z->conval->intval = (INT16)__CAP(__CHR(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + z->typ = OPT_chartyp; + } + break; + case 23: + if (f == 4) { + if (z->class == 7) { + z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); + z->obj = NIL; + } else { + z = NewOp__29(op, typ, z); + } + } else { + OPB_err(111); + } + z->typ = OPT_booltyp; + break; + case 24: + if ((((z->class == 7 && f == 3)) && z->conval->intval >= 32)) { + OPB_CharToString(z); + f = 8; + } + if (z->class < 7 || f == 8) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(127); + } + z->typ = OPT_adrtyp; + break; + case 25: + if ((f == 4 && z->class == 7)) { + if ((0 <= z->conval->intval && z->conval->intval <= -1)) { + z = NewOp__29(op, typ, z); + } else { + OPB_err(219); + } + } else { + OPB_err(69); + } + z->typ = OPT_booltyp; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.MOp, op = ", 33); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + MOp__28_s = _s.lnk; +} + +static void OPB_CheckPtr (OPT_Node x, OPT_Node y) +{ + INT16 g; + OPT_Struct p = NIL, q = NIL, t = NIL; + g = y->typ->form; + if (g == 11) { + p = x->typ->BaseTyp; + q = y->typ->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + if (p->extlev < q->extlev) { + t = p; + p = q; + q = t; + } + while ((((p != q && p != NIL)) && p != OPT_undftyp)) { + p = p->BaseTyp; + } + if (p == NIL) { + OPB_err(100); + } + } else { + OPB_err(100); + } + } else if (g != 9) { + OPB_err(100); + } +} + +void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames) +{ + OPT_Struct ft = NIL, at = NIL; + while (fp != NIL) { + if (ap != NIL) { + ft = fp->typ; + at = ap->typ; + while ((ft->comp == 3 && at->comp == 3)) { + ft = ft->BaseTyp; + at = at->BaseTyp; + } + if (ft != at) { + if ((ft->form == 12 && at->form == 12)) { + if (ft->BaseTyp == at->BaseTyp) { + OPB_CheckParameters(ft->link, at->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(115); + } + } + if (fp->mode != ap->mode || (checkNames && __STRCMP(fp->name, ap->name) != 0)) { + OPB_err(115); + } + ap = ap->link; + } else { + OPB_err(116); + } + fp = fp->link; + } + if (ap != NIL) { + OPB_err(116); + } +} + +static void OPB_CheckProc (OPT_Struct x, OPT_Object y) +{ + if (__IN(y->mode, 0x04c0, 32)) { + if (y->mode == 6) { + if (y->mnolev == 0) { + y->mode = 7; + } else { + OPB_err(73); + } + } + if (x->BaseTyp == y->typ) { + OPB_CheckParameters(x->link, y->link, 0); + } else { + OPB_err(117); + } + } else { + OPB_err(113); + } +} + +static struct ConstOp__13 { + OPT_Node *x; + INT16 *f; + OPT_Const *xval, *yval; + struct ConstOp__13 *lnk; +} *ConstOp__13_s; + +static INT16 ConstCmp__14 (void); + +static INT16 ConstCmp__14 (void) +{ + INT16 res; + switch (*ConstOp__13_s->f) { + case 0: + res = 9; + break; + case 1: case 3: case 4: + if ((*ConstOp__13_s->xval)->intval < (*ConstOp__13_s->yval)->intval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->intval > (*ConstOp__13_s->yval)->intval) { + res = 13; + } else { + res = 9; + } + break; + case 5: case 6: + if ((*ConstOp__13_s->xval)->realval < (*ConstOp__13_s->yval)->realval) { + res = 11; + } else if ((*ConstOp__13_s->xval)->realval > (*ConstOp__13_s->yval)->realval) { + res = 13; + } else { + res = 9; + } + break; + case 2: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + case 7: + if ((*ConstOp__13_s->xval)->setval != (*ConstOp__13_s->yval)->setval) { + res = 10; + } else { + res = 9; + } + break; + case 8: + if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) < 0) { + res = 11; + } else if (__STRCMP(*(*ConstOp__13_s->xval)->ext, *(*ConstOp__13_s->yval)->ext) > 0) { + res = 13; + } else { + res = 9; + } + break; + case 9: case 11: case 12: + if ((*ConstOp__13_s->xval)->intval != (*ConstOp__13_s->yval)->intval) { + res = 10; + } else { + res = 9; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstCmp, f = ", 37); + OPM_LogWNum(*ConstOp__13_s->f, 0); + OPM_LogWLn(); + break; + } + (*ConstOp__13_s->x)->typ = OPT_booltyp; + return res; +} + +static void OPB_ConstOp (INT16 op, OPT_Node x, OPT_Node y) +{ + INT16 f, g; + OPT_Const xval = NIL, yval = NIL; + INT64 xv, yv; + BOOLEAN temp; + struct ConstOp__13 _s; + _s.x = &x; + _s.f = &f; + _s.xval = &xval; + _s.yval = &yval; + _s.lnk = ConstOp__13_s; + ConstOp__13_s = &_s; + f = x->typ->form; + g = y->typ->form; + xval = x->conval; + yval = y->conval; + if (f != g) { + switch (f) { + case 3: + if (g == 8) { + OPB_CharToString(x); + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 4: + if (g == 4) { + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPT_IntType(x->typ->size); + } + } else if (g == 5) { + x->typ = OPT_realtyp; + xval->realval = xval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + xval->realval = xval->intval; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 5: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 6) { + x->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 6: + if (g == 4) { + y->typ = x->typ; + yval->realval = yval->intval; + } else if (g == 5) { + y->typ = OPT_lrltyp; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 8: + if (g == 3) { + OPB_CharToString(y); + g = 8; + } else { + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(x, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + default: + OPB_err(100); + y->typ = x->typ; + __GUARDEQP(yval, OPT_ConstDesc) = *xval; + break; + } + f = x->typ->form; + } + switch (op) { + case 1: + if (f == 4) { + xv = xval->intval; + yv = yval->intval; + if (((((xv == 0 || yv == 0) || (((xv > 0 && yv > 0)) && yv <= __DIV(9223372036854775807LL, xv))) || (((xv > 0 && yv < 0)) && yv >= __DIV((-9223372036854775807LL-1), xv))) || (((xv < 0 && yv > 0)) && xv >= __DIV((-9223372036854775807LL-1), yv))) || (((((((xv < 0 && yv < 0)) && xv != (-9223372036854775807LL-1))) && yv != (-9223372036854775807LL-1))) && -xv <= __DIV(9223372036854775807LL, -yv))) { + xval->intval = xv * yv; + OPB_SetIntType(x); + } else { + OPB_err(204); + } + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) <= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 / (LONGREAL)__ABS(yval->realval)) { + xval->realval = xval->realval * yval->realval; + OPB_CheckRealType(f, 204, xval); + } else { + OPB_err(204); + } + } else if (f == 7) { + xval->setval = (xval->setval & yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(101); + } + break; + case 2: + if (f == 4) { + if (yval->intval != 0) { + xval->realval = xval->intval / (REAL)yval->intval; + OPB_CheckRealType(5, 205, xval); + } else { + OPB_err(205); + xval->realval = (LONGREAL)1; + } + x->typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + temp = __ABS(yval->realval) >= (LONGREAL)1; + if (temp || __ABS(xval->realval) <= 1.79769296342094e+308 * __ABS(yval->realval)) { + xval->realval = xval->realval / yval->realval; + OPB_CheckRealType(f, 205, xval); + } else { + OPB_err(205); + } + } else if (f == 7) { + xval->setval = xval->setval ^ yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(102); + } + break; + case 3: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __DIV(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(103); + } + break; + case 4: + if (f == 4) { + if (yval->intval != 0) { + xval->intval = __MOD(xval->intval, yval->intval); + OPB_SetIntType(x); + } else { + OPB_err(205); + } + } else if (f != 0) { + OPB_err(104); + } + break; + case 5: + if (f == 2) { + xval->intval = OPB_BoolToInt((OPB_IntToBool(xval->intval) && OPB_IntToBool(yval->intval))); + } else { + OPB_err(94); + } + break; + case 6: + if (f == 4) { + temp = (yval->intval >= 0 && xval->intval <= 9223372036854775807LL - yval->intval); + if (temp || (yval->intval < 0 && xval->intval >= (-9223372036854775807LL-1) - yval->intval)) { + xval->intval += yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(206); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 - yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 - yval->realval)) { + xval->realval = xval->realval + yval->realval; + OPB_CheckRealType(f, 206, xval); + } else { + OPB_err(206); + } + } else if (f == 7) { + xval->setval = xval->setval | yval->setval; + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(105); + } + break; + case 7: + if (f == 4) { + if ((yval->intval >= 0 && xval->intval >= (-9223372036854775807LL-1) + yval->intval) || (yval->intval < 0 && xval->intval <= 9223372036854775807LL + yval->intval)) { + xval->intval -= yval->intval; + OPB_SetIntType(x); + } else { + OPB_err(207); + } + } else if (__IN(f, 0x60, 32)) { + temp = (yval->realval >= (LONGREAL)0 && xval->realval >= -1.79769296342094e+308 + yval->realval); + if (temp || (yval->realval < (LONGREAL)0 && xval->realval <= 1.79769296342094e+308 + yval->realval)) { + xval->realval = xval->realval - yval->realval; + OPB_CheckRealType(f, 207, xval); + } else { + OPB_err(207); + } + } else if (f == 7) { + xval->setval = (xval->setval & ~yval->setval); + OPB_SetSetType(x); + } else if (f != 0) { + OPB_err(106); + } + break; + case 8: + if (f == 2) { + xval->intval = OPB_BoolToInt(OPB_IntToBool(xval->intval) || OPB_IntToBool(yval->intval)); + } else { + OPB_err(95); + } + break; + case 9: + xval->intval = OPB_BoolToInt(ConstCmp__14() == 9); + break; + case 10: + xval->intval = OPB_BoolToInt(ConstCmp__14() != 9); + break; + case 11: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 11); + } + break; + case 12: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 13); + } + break; + case 13: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() == 13); + } + break; + case 14: + if (__IN(f, 0x0a84, 32)) { + OPB_err(108); + } else { + xval->intval = OPB_BoolToInt(ConstCmp__14() != 11); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.ConstOp, op = ", 37); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + ConstOp__13_s = _s.lnk; +} + +static void OPB_Convert (OPT_Node *x, OPT_Struct typ) +{ + OPT_Node node = NIL; + INT16 f, g; + INT64 k; + LONGREAL r; + f = (*x)->typ->form; + g = typ->form; + if ((*x)->class == 7) { + if ((((f == 7 && g == 7)) && (*x)->typ->size > typ->size)) { + OPB_SetSetType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->setval = 0x0; + } + } else if (f == 4) { + if (g == 4) { + if ((*x)->typ->size > typ->size) { + OPB_SetIntType(*x); + if ((*x)->typ->size > typ->size) { + OPB_err(203); + (*x)->conval->intval = 1; + } + } + } else if (__IN(g, 0x60, 32)) { + (*x)->conval->realval = (*x)->conval->intval; + (*x)->conval->intval = -1; + } else { + k = (*x)->conval->intval; + if (0 > k || k > 255) { + OPB_err(220); + } + } + } else if (__IN(f, 0x60, 32)) { + if (__IN(g, 0x60, 32)) { + OPB_CheckRealType(g, 203, (*x)->conval); + } else { + r = (*x)->conval->realval; + if (r < -9.22337203685478e+018 || r > 9.22337203685478e+018) { + OPB_err(203); + r = (LONGREAL)1; + } + (*x)->conval->intval = __SHORT(__ENTIER(r), 2147483648LL); + OPB_SetIntType(*x); + } + } + (*x)->obj = NIL; + } else if (((((*x)->class == 11 && (*x)->subcl == 20)) && ((INT16)(*x)->left->typ->form < f || f > g))) { + if ((*x)->left->typ == typ) { + *x = (*x)->left; + } + } else { + node = OPT_NewNode(11); + node->subcl = 20; + node->left = *x; + *x = node; + } + (*x)->typ = typ; +} + +static struct Op__38 { + INT16 *f, *g; + struct Op__38 *lnk; +} *Op__38_s; + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); + +static void NewOp__39 (INT8 op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +{ + OPT_Node node = NIL; + node = OPT_NewNode(12); + node->subcl = op; + node->typ = typ; + node->left = *x; + node->right = y; + *x = node; +} + +static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +{ + BOOLEAN ok, xCharArr, yCharArr; + xCharArr = (__IN((*x)->typ->comp, 0x0c, 32) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 8; + yCharArr = (__IN((*y)->typ->comp, 0x0c, 32) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 8; + if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + OPB_CharToString(*y); + *Op__38_s->g = 8; + yCharArr = 1; + } + if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + OPB_CharToString(*x); + *Op__38_s->f = 8; + xCharArr = 1; + } + ok = (xCharArr && yCharArr); + if (ok) { + if ((*Op__38_s->f == 8 && (*x)->conval->intval2 == 1)) { + (*x)->typ = OPT_chartyp; + (*x)->conval->intval = 0; + OPB_Index(&*y, OPB_NewIntConst(0)); + } else if ((*Op__38_s->g == 8 && (*y)->conval->intval2 == 1)) { + (*y)->typ = OPT_chartyp; + (*y)->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + } + return ok; +} + +void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y) +{ + INT16 f, g; + OPT_Node t = NIL, z = NIL; + OPT_Struct typ = NIL; + BOOLEAN do_; + INT64 val; + struct Op__38 _s; + _s.f = &f; + _s.g = &g; + _s.lnk = Op__38_s; + Op__38_s = &_s; + z = *x; + if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if ((z->class == 7 && y->class == 7)) { + OPB_ConstOp(op, z, y); + z->obj = NIL; + } else { + if (z->typ != y->typ) { + g = y->typ->form; + switch (z->typ->form) { + case 3: + if (z->class == 7) { + OPB_CharToString(z); + } else { + OPB_err(100); + } + break; + case 4: + if ((g == 4 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x70, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 7: + if ((g == 7 && y->typ->size < z->typ->size)) { + OPB_Convert(&y, z->typ); + } else if (g == 7) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 5: + if (g == 4) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&z, y->typ); + } else { + OPB_err(100); + } + break; + case 6: + if (__IN(g, 0x70, 32)) { + OPB_Convert(&y, z->typ); + } else if (__IN(g, 0x60, 32)) { + OPB_Convert(&y, z->typ); + } else { + OPB_err(100); + } + break; + case 9: + if (!__IN(g, 0x1800, 32)) { + OPB_err(100); + } + break; + case 11: + OPB_CheckPtr(z, y); + break; + case 12: + if (g != 9) { + OPB_err(100); + } + break; + case 8: + break; + case 13: + if (z->typ->comp == 4) { + OPB_err(100); + } + break; + default: + OPB_err(100); + break; + } + } + typ = z->typ; + f = typ->form; + g = y->typ->form; + switch (op) { + case 1: + do_ = 1; + if (f == 4) { + if (z->class == 7) { + val = z->conval->intval; + if (val == 1) { + do_ = 0; + z = y; + } else if (val == 0) { + do_ = 0; + } else if (OPB_log(val) == 1) { + t = y; + y = z; + z = t; + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } else if (y->class == 7) { + val = y->conval->intval; + if (val == 1) { + do_ = 0; + } else if (val == 0) { + do_ = 0; + z = y; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = OPB_exp; + y->obj = NIL; + } + } + } else if (!__IN(f, 0xe1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 2: + if (f == 4) { + if ((y->class == 7 && y->conval->intval == 0)) { + OPB_err(205); + } + OPB_Convert(&z, OPT_realtyp); + OPB_Convert(&y, OPT_realtyp); + typ = OPT_realtyp; + } else if (__IN(f, 0x60, 32)) { + if ((y->class == 7 && y->conval->realval == (LONGREAL)0)) { + OPB_err(205); + } + } else if ((f != 7 && f != 0)) { + OPB_err(102); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 3: + do_ = 1; + if (f == 4) { + if (y->class == 7) { + val = y->conval->intval; + if (val == 0) { + OPB_err(205); + } else if (val == 1) { + do_ = 0; + } else if (OPB_log(val) == 1) { + op = 17; + y->typ = OPT_sinttyp; + y->conval->intval = -OPB_exp; + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(103); + typ = OPT_undftyp; + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 4: + if (f == 4) { + if (y->class == 7) { + if (y->conval->intval == 0) { + OPB_err(205); + } else if (OPB_log(y->conval->intval) == 1) { + op = 18; + y->conval->intval = __ASH(-1, OPB_exp); + y->obj = NIL; + } + } + } else if (f != 0) { + OPB_err(104); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 5: + if (f == 2) { + if (z->class == 7) { + if (OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(94); + z->typ = OPT_undftyp; + } + break; + case 6: + if (!__IN(f, 0xf1, 32)) { + OPB_err(105); + typ = OPT_undftyp; + } + do_ = 1; + if (f == 4) { + if ((z->class == 7 && z->conval->intval == 0)) { + do_ = 0; + z = y; + } + if ((y->class == 7 && y->conval->intval == 0)) { + do_ = 0; + } + } + if (do_) { + NewOp__39(op, typ, &z, y); + } + break; + case 7: + if (!__IN(f, 0xf1, 32)) { + OPB_err(106); + typ = OPT_undftyp; + } + if ((f != 4 || y->class != 7) || y->conval->intval != 0) { + NewOp__39(op, typ, &z, y); + } + break; + case 8: + if (f == 2) { + if (z->class == 7) { + if (!OPB_IntToBool(z->conval->intval)) { + z = y; + } + } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { + } else { + NewOp__39(op, typ, &z, y); + } + } else if (f != 0) { + OPB_err(95); + z->typ = OPT_undftyp; + } + break; + case 9: case 10: + if (__IN(f, 0x1aff, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPB_err(107); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + case 11: case 12: case 13: case 14: + if (__IN(f, 0x79, 32) || strings__41(&z, &y)) { + typ = OPT_booltyp; + } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ELSE in Op()", 13); + OPM_LogWLn(); + OPB_err(108); + typ = OPT_undftyp; + } + NewOp__39(op, typ, &z, y); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", 32); + OPM_LogWNum(op, 0); + OPM_LogWLn(); + break; + } + } + *x = z; + Op__38_s = _s.lnk; +} + +void OPB_SetRange (OPT_Node *x, OPT_Node y) +{ + INT64 k, l; + if ((((*x)->class == 8 || (*x)->class == 9) || y->class == 8) || y->class == 9) { + OPB_err(126); + } else if (((*x)->typ->form == 4 && y->typ->form == 4)) { + if ((*x)->class == 7) { + k = (*x)->conval->intval; + if (0 > k || k > 63) { + OPB_err(202); + } + } + if (y->class == 7) { + l = y->conval->intval; + if (0 > l || l > 63) { + OPB_err(202); + } + } + if (((*x)->class == 7 && y->class == 7)) { + if (k <= l) { + (*x)->conval->setval = __SETRNG(k, l, 32); + OPB_SetSetType(*x); + } else { + OPB_err(201); + (*x)->conval->setval = __SETRNG(l, k, 32); + } + (*x)->obj = NIL; + } else { + OPB_BindNodes(10, OPT_settyp, &*x, y); + } + } else { + OPB_err(93); + } + (*x)->typ = OPT_settyp; +} + +void OPB_SetElem (OPT_Node *x) +{ + INT64 k; + if ((*x)->class == 8 || (*x)->class == 9) { + OPB_err(126); + } else if ((*x)->typ->form != 4) { + OPB_err(93); + } else if ((*x)->class == 7) { + k = (*x)->conval->intval; + if ((0 <= k && k <= 63)) { + (*x)->conval->setval = 0x0; + (*x)->conval->setval |= __SETOF(k,64); + } else { + OPB_err(202); + } + OPB_SetSetType(*x); + (*x)->obj = NIL; + } else { + OPB_Convert(&*x, OPT_settyp); + (*x)->typ = OPT_settyp; + } +} + +static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) +{ + OPT_Struct y = NIL; + INT16 f, g; + OPT_Struct p = NIL, q = NIL; + y = ynode->typ; + f = x->form; + g = y->form; + if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { + OPB_err(126); + } + switch (f) { + case 0: case 8: + break; + case 1: + if (!((__IN(g, 0x1a, 32) && y->size == 1))) { + OPB_err(113); + } + break; + case 2: case 3: + if (g != f) { + OPB_err(113); + } + break; + case 4: case 7: + if (g != f || x->size < y->size) { + OPB_err(113); + } + break; + case 5: + if (!__IN(g, 0x30, 32)) { + OPB_err(113); + } + break; + case 6: + if (!__IN(g, 0x70, 32)) { + OPB_err(113); + } + break; + case 11: + if ((x == y || g == 9) || (x == OPT_sysptrtyp && g == 11)) { + } else if (g == 11) { + p = x->BaseTyp; + q = y->BaseTyp; + if ((p->comp == 4 && q->comp == 4)) { + while ((((q != p && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + case 12: + if (ynode->class == 9) { + OPB_CheckProc(x, ynode->obj); + } else if (x == y || g == 9) { + } else { + OPB_err(113); + } + break; + case 10: case 9: + OPB_err(113); + break; + case 13: + x->pvused = 1; + if (x->comp == 2) { + if ((ynode->class == 7 && g == 3)) { + OPB_CharToString(ynode); + y = ynode->typ; + g = 8; + } + if (x == y) { + } else if ((((y->comp == 2 && y->BaseTyp == x->BaseTyp)) && y->n <= x->n)) { + } else if ((y->comp == 3 && y->BaseTyp == x->BaseTyp)) { + OPB_err(113); + } else if (x->BaseTyp == OPT_chartyp) { + if (g == 8) { + if (ynode->conval->intval2 > x->n) { + OPB_err(114); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else if (x->comp == 4) { + if (x == y) { + } else if (y->comp == 4) { + q = y->BaseTyp; + while ((((q != NIL && q != x)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(113); + } + } else { + OPB_err(113); + } + } else { + OPB_err(113); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.CheckAssign, f = ", 40); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } + if ((((((ynode->class == 7 && g < f)) && __IN(g, 0x30, 32))) && __IN(f, 0x70, 32))) { + OPB_Convert(&ynode, x); + } +} + +static void OPB_CheckLeaf (OPT_Node x, BOOLEAN dynArrToo) +{ +} + +void OPB_StPar0 (OPT_Node *par0, INT16 fctno) +{ + INT16 f; + OPT_Struct typ = NIL; + OPT_Node x = NIL; + x = *par0; + f = x->typ->form; + switch (fctno) { + case 0: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + x->typ = OPT_notyp; + break; + case 1: + typ = OPT_notyp; + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + if (x->readonly) { + OPB_err(76); + } + f = x->typ->BaseTyp->comp; + if (__IN(f, 0x1c, 32)) { + if (f == 3) { + typ = x->typ->BaseTyp; + } + OPB_BindNodes(19, OPT_notyp, &x, NIL); + x->subcl = 1; + } else { + OPB_err(111); + } + } else { + OPB_err(111); + } + x->typ = typ; + break; + case 2: + OPB_MOp(21, &x); + break; + case 3: + OPB_MOp(22, &x); + break; + case 4: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 3) { + OPB_Convert(&x, OPT_inttyp); + } else { + OPB_err(111); + } + x->typ = OPT_inttyp; + break; + case 5: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x60, 32)) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + x->typ = OPT_linttyp; + break; + case 6: + OPB_MOp(23, &x); + break; + case 7: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(0); + break; + case 3: + x = OPB_NewIntConst(0); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(0); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MinReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MinLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 8: + if (x->class == 8) { + switch (f) { + case 2: + x = OPB_NewBoolConst(1); + break; + case 3: + x = OPB_NewIntConst(255); + x->typ = OPT_chartyp; + break; + case 4: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); + break; + case 7: + x = OPB_NewIntConst(__ASHL(x->typ->size, 3) - 1); + x->typ = OPT_inttyp; + break; + case 5: + x = OPB_NewRealConst(OPM_MaxReal, OPT_realtyp); + break; + case 6: + x = OPB_NewRealConst(OPM_MaxLReal, OPT_lrltyp); + break; + default: + OPB_err(111); + break; + } + } else { + OPB_err(110); + } + break; + case 9: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x11, 32)) { + OPB_Convert(&x, OPT_chartyp); + } else { + OPB_err(111); + x->typ = OPT_chartyp; + } + break; + case 10: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, -1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 6) { + OPB_Convert(&x, OPT_realtyp); + } else { + OPB_err(111); + } + break; + case 11: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + typ = OPT_ShorterOrLongerType(x->typ, 1); + if (typ == NIL) { + OPB_err(111); + } else { + OPB_Convert(&x, typ); + } + } else if (f == 5) { + OPB_Convert(&x, OPT_lrltyp); + } else if (f == 3) { + OPB_Convert(&x, OPT_linttyp); + } else { + OPB_err(111); + } + break; + case 13: case 14: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f != 4) { + OPB_err(111); + } else if (x->readonly) { + OPB_err(76); + } + break; + case 15: case 16: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (x->typ->form != 7) { + OPB_err(111); + x->typ = OPT_settyp; + } else if (x->readonly) { + OPB_err(76); + } + break; + case 17: + if (!__IN(x->typ->comp, 0x0c, 32)) { + OPB_err(131); + } + break; + case 18: + if ((x->class == 7 && f == 3)) { + OPB_CharToString(x); + f = 8; + } + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (((!__IN(x->typ->comp, 0x0c, 32) || x->typ->BaseTyp->form != 3) && f != 8)) { + OPB_err(111); + } + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if (x->typ->size < OPT_linttyp->size) { + OPB_Convert(&x, OPT_linttyp); + } + } else { + OPB_err(111); + x->typ = OPT_linttyp; + } + break; + case 20: + OPB_CheckLeaf(x, 0); + OPB_MOp(24, &x); + break; + case 12: + if (x->class != 8) { + OPB_err(110); + x = OPB_NewIntConst(1); + } else if (__IN(f, 0x18fe, 32) || __IN(x->typ->comp, 0x14, 32)) { + OPT_TypSize(x->typ); + x->typ->pvused = 1; + x = OPB_NewIntConst(x->typ->size); + } else { + OPB_err(111); + x = OPB_NewIntConst(1); + } + break; + case 21: + OPB_MOp(25, &x); + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (!__IN(f, 0x9a, 32)) { + OPB_err(111); + } + break; + case 24: case 25: case 28: case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + break; + case 26: case 27: + if ((f == 4 && x->class == 7)) { + if (x->conval->intval < 0 || x->conval->intval > -1) { + OPB_err(220); + } + } else { + OPB_err(69); + } + break; + case 29: + if (x->class != 8) { + OPB_err(110); + } else if (__IN(f, 0x0501, 32) || x->typ->comp == 3) { + OPB_err(111); + } + break; + case 30: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if (f == 11) { + } else { + OPB_err(111); + } + break; + case 32: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + x = OPB_NewBoolConst(0); + } else if (f != 2) { + OPB_err(120); + x = OPB_NewBoolConst(0); + } else { + OPB_MOp(33, &x); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPB.StPar0, fctno = ", 39); + OPM_LogWNum(fctno, 0); + OPM_LogWLn(); + break; + } + *par0 = x; +} + +static struct StPar1__53 { + struct StPar1__53 *lnk; +} *StPar1__53_s; + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right); + +static OPT_Node NewOp__54 (INT8 class, INT8 subcl, OPT_Node left, OPT_Node right) +{ + OPT_Node node = NIL; + node = OPT_NewNode(class); + node->subcl = subcl; + node->left = left; + node->right = right; + return node; +} + +void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno) +{ + INT16 f, L; + OPT_Struct typ = NIL; + OPT_Node p = NIL, t = NIL; + struct StPar1__53 _s; + _s.lnk = StPar1__53_s; + StPar1__53_s = &_s; + p = *par0; + f = x->typ->form; + switch (fctno) { + case 13: case 14: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + p->typ = OPT_notyp; + } else { + if (x->typ != p->typ) { + if ((f == 4 && (x->class == 7 || (p->typ->form == 4 && x->typ->size <= p->typ->size)))) { + OPB_Convert(&x, p->typ); + } else { + OPB_err(111); + } + } + p = NewOp__54(19, fctno, p, x); + p->typ = OPT_notyp; + } + break; + case 15: case 16: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval >= (INT64)__ASHL(p->typ->size, 3)))) { + OPB_err(202); + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 17: + if (!(f == 4) || x->class != 7) { + OPB_err(69); + } else if (x->typ->size == 1) { + L = OPM_Integer(x->conval->intval); + typ = p->typ; + while ((L > 0 && __IN(typ->comp, 0x0c, 32))) { + typ = typ->BaseTyp; + L -= 1; + } + if (L != 0 || !__IN(typ->comp, 0x0c, 32)) { + OPB_err(132); + } else { + x->obj = NIL; + if (typ->comp == 3) { + while (p->class == 4) { + p = p->left; + x->conval->intval += 1; + } + p = NewOp__54(12, 19, p, x); + p->typ = OPT_linttyp; + } else { + p = x; + p->conval->intval = typ->n; + OPB_SetIntType(p); + } + } + } else { + OPB_err(132); + } + break; + case 18: + if (OPB_NotVar(x)) { + OPB_err(112); + } else if ((__IN(x->typ->comp, 0x0c, 32) && x->typ->BaseTyp->form == 3)) { + if (x->readonly) { + OPB_err(76); + } + t = x; + x = p; + p = t; + p = NewOp__54(19, 18, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 19: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + if ((p->class == 7 && x->class == 7)) { + if (-OPB_maxExp > x->conval->intval || x->conval->intval > OPB_maxExp) { + OPB_err(208); + p->conval->intval = 1; + } else if (x->conval->intval >= 0) { + if (__ABS(p->conval->intval) <= __DIV(9223372036854775807LL, (INT64)__ASH(1, x->conval->intval))) { + p->conval->intval = p->conval->intval * (INT64)__ASH(1, x->conval->intval); + } else { + OPB_err(208); + p->conval->intval = 1; + } + } else { + p->conval->intval = __ASH(p->conval->intval, x->conval->intval); + } + p->obj = NIL; + } else { + p = NewOp__54(12, 17, p, x); + p->typ = p->left->typ; + } + } else { + OPB_err(111); + } + break; + case 1: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp == 3) { + if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + } else { + OPB_err(111); + } + p->right = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(64); + } + break; + case 22: case 23: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f != 4) { + OPB_err(111); + } else { + if (fctno == 22) { + p = NewOp__54(12, 27, p, x); + } else { + p = NewOp__54(12, 28, p, x); + } + p->typ = p->left->typ; + } + break; + case 24: case 25: case 26: case 27: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (__IN(f, 0x18ff, 32)) { + if (fctno == 24 || fctno == 26) { + if (OPB_NotVar(x)) { + OPB_err(112); + } + t = x; + x = p; + p = t; + } + p = NewOp__54(19, fctno, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 28: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(12, 26, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_booltyp; + break; + case 29: + if (((x->class == 8 || x->class == 9) || __IN(f, 0x0501, 32)) || x->typ->comp == 3) { + OPB_err(126); + } + OPT_TypSize(x->typ); + OPT_TypSize(p->typ); + if ((x->class != 7 && x->typ->size < p->typ->size)) { + OPB_err(-308); + } + if ((((x->class == 7 && x->typ->form == 4)) && p->typ->form == 4)) { + OPB_Convert(&x, p->typ); + } else { + t = OPT_NewNode(11); + t->subcl = 29; + t->left = x; + x = t; + x->typ = p->typ; + } + p = x; + break; + case 30: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + p = NewOp__54(19, 30, p, x); + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + break; + case 31: + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if ((((x->class == 7 && f == 4)) && x->typ->size < OPT_adrtyp->size)) { + OPB_Convert(&x, OPT_adrtyp); + } else if (!((__IN(x->typ->form, 0x0810, 32) && x->typ->size == OPM_AddressSize))) { + OPB_err(111); + x->typ = OPT_adrtyp; + } + p->link = x; + break; + case 32: + if ((f == 4 && x->class == 7)) { + if ((0 <= x->conval->intval && x->conval->intval <= 255)) { + OPB_BindNodes(28, OPT_notyp, &x, x); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else { + OPB_err(218); + } + } else { + OPB_err(69); + } + break; + default: + OPB_err(64); + break; + } + *par0 = p; + StPar1__53_s = _s.lnk; +} + +void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n) +{ + OPT_Node node = NIL; + INT16 f; + OPT_Node p = NIL; + p = *par0; + f = x->typ->form; + if (fctno == 1) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (p->typ->comp != 3) { + OPB_err(64); + } else if (f == 4) { + if ((x->class == 7 && (x->conval->intval <= 0 || x->conval->intval > OPM_MaxIndex))) { + OPB_err(63); + } + node = p->right; + while (node->link != NIL) { + node = node->link; + } + node->link = x; + p->typ = p->typ->BaseTyp; + } else { + OPB_err(111); + } + } else if ((fctno == 31 && n == 2)) { + if (x->class == 8 || x->class == 9) { + OPB_err(126); + } else if (f == 4) { + node = OPT_NewNode(19); + node->subcl = 31; + node->right = p; + node->left = p->link; + p->link = x; + p = node; + } else { + OPB_err(111); + } + p->typ = OPT_notyp; + } else { + OPB_err(64); + } + *par0 = p; +} + +void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno) +{ + INT16 dim; + OPT_Node x = NIL, p = NIL; + p = *par0; + if (fctno <= 19) { + if ((fctno == 1 && p->typ != OPT_notyp)) { + if (p->typ->comp == 3) { + OPB_err(65); + } + p->typ = OPT_notyp; + } else if (fctno <= 12) { + if (parno < 1) { + OPB_err(65); + } + } else { + if (((fctno == 13 || fctno == 14) && parno == 1)) { + OPB_BindNodes(19, OPT_notyp, &p, OPB_NewIntConst(1)); + p->subcl = fctno; + p->right->typ = p->left->typ; + } else if ((fctno == 17 && parno == 1)) { + if (p->typ->comp == 3) { + dim = 0; + while (p->class == 4) { + p = p->left; + dim += 1; + } + OPB_BindNodes(12, OPT_linttyp, &p, OPB_NewIntConst(dim)); + p->subcl = 19; + } else { + p = OPB_NewIntConst(p->typ->n); + } + } else if (parno < 2) { + OPB_err(65); + } + } + } else if (fctno == 32) { + if (parno == 1) { + x = NIL; + OPB_BindNodes(28, OPT_notyp, &x, OPB_NewIntConst(0)); + x->conval = OPT_NewConst(); + x->conval->intval = OPM_errpos; + OPB_Construct(15, &p, x); + p->conval = OPT_NewConst(); + p->conval->intval = OPM_errpos; + OPB_Construct(20, &p, NIL); + OPB_OptIf(&p); + if (p == NIL) { + } else if (p->class == 28) { + OPB_err(99); + } else { + p->subcl = 32; + } + } else if (parno < 1) { + OPB_err(65); + } + } else { + if ((parno < 1 || (fctno > 21 && parno < 2)) || (fctno == 31 && parno < 3)) { + OPB_err(65); + } + } + *par0 = p; +} + +static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpar) +{ + INT16 f; + f = atyp->comp; + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((fvarpar && ftyp == OPT_bytetyp)) { + if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { + if (__IN(18, OPM_Options, 32)) { + OPB_err(-301); + } + } + } else if (__IN(f, 0x0c, 32)) { + if (ftyp->comp == 3) { + OPB_DynArrParCheck(ftyp, atyp, fvarpar); + } else if (ftyp != atyp) { + if ((((!fvarpar && ftyp->form == 11)) && atyp->form == 11)) { + ftyp = ftyp->BaseTyp; + atyp = atyp->BaseTyp; + if ((ftyp->comp == 4 && atyp->comp == 4)) { + while ((((ftyp != atyp && atyp != NIL)) && atyp != OPT_undftyp)) { + atyp = atyp->BaseTyp; + } + if (atyp == NIL) { + OPB_err(113); + } + } else { + OPB_err(66); + } + } else { + OPB_err(66); + } + } + } else { + OPB_err(67); + } +} + +static void OPB_CheckReceiver (OPT_Node *x, OPT_Object fp) +{ + if (fp->typ->form == 11) { + if ((*x)->class == 3) { + *x = (*x)->left; + } else { + OPB_err(71); + } + } +} + +void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar) +{ + if (((*x)->obj != NIL && __IN((*x)->obj->mode, 0x22c0, 32))) { + *fpar = (*x)->obj->link; + if ((*x)->obj->mode == 13) { + OPB_CheckReceiver(&(*x)->left, *fpar); + *fpar = (*fpar)->link; + } + } else if (((((*x)->class != 8 && (*x)->typ != NIL)) && (*x)->typ->form == 12)) { + *fpar = (*x)->typ->link; + } else { + OPB_err(121); + *fpar = NIL; + (*x)->typ = OPT_undftyp; + } +} + +void OPB_Param (OPT_Node ap, OPT_Object fp) +{ + OPT_Struct q = NIL; + if (fp->typ->form != 0) { + if (fp->mode == 2) { + if (OPB_NotVar(ap)) { + OPB_err(122); + } else { + OPB_CheckLeaf(ap, 0); + } + if (ap->readonly) { + OPB_err(76); + } + if (fp->typ->comp == 3) { + OPB_DynArrParCheck(fp->typ, ap->typ, 1); + } else if ((fp->typ->comp == 4 && ap->typ->comp == 4)) { + q = ap->typ; + while ((((q != fp->typ && q != NIL)) && q != OPT_undftyp)) { + q = q->BaseTyp; + } + if (q == NIL) { + OPB_err(111); + } + } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 11)) { + } else if ((ap->typ != fp->typ && !((((fp->typ->form == 1 && __IN(ap->typ->form, 0x1e, 32))) && ap->typ->size == 1)))) { + OPB_err(123); + } else if ((fp->typ->form == 11 && ap->class == 5)) { + OPB_err(123); + } + } else if (fp->typ->comp == 3) { + if ((ap->class == 7 && ap->typ->form == 3)) { + OPB_CharToString(ap); + } + if ((ap->typ->form == 8 && fp->typ->BaseTyp->form == 3)) { + } else if (ap->class >= 7) { + OPB_err(59); + } else { + OPB_DynArrParCheck(fp->typ, ap->typ, 0); + } + } else { + OPB_CheckAssign(fp->typ, ap); + } + } +} + +void OPB_StaticLink (INT8 dlev) +{ + OPT_Object scope = NIL; + scope = OPT_topScope; + while (dlev > 0) { + dlev -= 1; + scope->link->conval->setval |= __SETOF(3,64); + scope = scope->left; + } +} + +void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp) +{ + OPT_Struct typ = NIL; + OPT_Node p = NIL; + INT8 lev; + if ((*x)->class == 9) { + typ = (*x)->typ; + lev = (*x)->obj->mnolev; + if (lev > 0) { + OPB_StaticLink(OPT_topScope->mnolev - lev); + } + if ((*x)->obj->mode == 10) { + OPB_err(121); + } + } else if (((*x)->class == 2 && (*x)->obj->mode == 13)) { + typ = (*x)->typ; + (*x)->class = 9; + p = (*x)->left; + (*x)->left = NIL; + p->link = apar; + apar = p; + fp = (*x)->obj->link; + } else { + typ = (*x)->typ->BaseTyp; + } + OPB_BindNodes(13, typ, &*x, apar); + (*x)->obj = fp; +} + +void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc) +{ + OPT_Node x = NIL; + x = OPT_NewNode(18); + x->typ = OPT_notyp; + x->obj = proc; + x->left = *procdec; + x->right = stat; + *procdec = x; +} + +void OPB_Return (OPT_Node *x, OPT_Object proc) +{ + OPT_Node node = NIL; + if (proc == NIL) { + if (*x != NIL) { + OPB_err(124); + } + } else { + if (*x != NIL) { + OPB_CheckAssign(proc->typ, *x); + } else if (proc->typ != OPT_notyp) { + OPB_err(124); + } + } + node = OPT_NewNode(26); + node->typ = OPT_notyp; + node->obj = proc; + node->left = *x; + *x = node; +} + +void OPB_Assign (OPT_Node *x, OPT_Node y) +{ + OPT_Node z = NIL; + if ((*x)->class >= 7) { + OPB_err(56); + } + OPB_CheckAssign((*x)->typ, y); + if ((*x)->readonly) { + OPB_err(76); + } + if ((*x)->typ->comp == 4) { + if ((*x)->class == 5) { + z = (*x)->left; + } else { + z = *x; + } + if ((z->class == 3 && z->left->class == 5)) { + z->left = z->left->left; + } + if (((*x)->typ->strobj != NIL && (z->class == 3 || z->class == 1))) { + OPB_BindNodes(6, (*x)->typ, &z, NIL); + *x = z; + } + } else if (((((((*x)->typ->comp == 2 && (*x)->typ->BaseTyp == OPT_chartyp)) && y->typ->form == 8)) && y->conval->intval2 == 1)) { + y->typ = OPT_chartyp; + y->conval->intval = 0; + OPB_Index(&*x, OPB_NewIntConst(0)); + } + OPB_BindNodes(19, OPT_notyp, &*x, y); + (*x)->subcl = 0; +} + +void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ) +{ + OPT_Node node = NIL; + node = OPT_NewNode(14); + node->typ = typ; + node->conval = OPT_NewConst(); + node->conval->intval = typ->txtpos; + if (*inittd == NIL) { + *inittd = node; + } else { + (*last)->link = node; + } + *last = node; +} + + +export void *OPB__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPB", 0); +/* BEGIN */ + OPB_maxExp = OPB_log(4611686018427387904LL); + OPB_maxExp = OPB_exp; + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPB.h b/bootstrap/windows-88/OPB.h new file mode 100644 index 00000000..f66fcd66 --- /dev/null +++ b/bootstrap/windows-88/OPB.h @@ -0,0 +1,48 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPB__h +#define OPB__h + +#include "SYSTEM.h" +#include "OPS.h" +#include "OPT.h" + + + + +import void OPB_Assign (OPT_Node *x, OPT_Node y); +import void OPB_Call (OPT_Node *x, OPT_Node apar, OPT_Object fp); +import void OPB_CheckParameters (OPT_Object fp, OPT_Object ap, BOOLEAN checkNames); +import void OPB_Construct (INT8 class, OPT_Node *x, OPT_Node y); +import void OPB_DeRef (OPT_Node *x); +import OPT_Node OPB_EmptySet (void); +import void OPB_Enter (OPT_Node *procdec, OPT_Node stat, OPT_Object proc); +import void OPB_Field (OPT_Node *x, OPT_Object y); +import void OPB_In (OPT_Node *x, OPT_Node y); +import void OPB_Index (OPT_Node *x, OPT_Node y); +import void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); +import void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +import void OPB_MOp (INT8 op, OPT_Node *x); +import OPT_Node OPB_NewBoolConst (BOOLEAN boolval); +import OPT_Node OPB_NewIntConst (INT64 intval); +import OPT_Node OPB_NewLeaf (OPT_Object obj); +import OPT_Node OPB_NewRealConst (LONGREAL realval, OPT_Struct typ); +import OPT_Node OPB_NewString (OPS_String str, INT64 len); +import OPT_Node OPB_Nil (void); +import void OPB_Op (INT8 op, OPT_Node *x, OPT_Node y); +import void OPB_OptIf (OPT_Node *x); +import void OPB_Param (OPT_Node ap, OPT_Object fp); +import void OPB_PrepCall (OPT_Node *x, OPT_Object *fpar); +import void OPB_Return (OPT_Node *x, OPT_Object proc); +import void OPB_SetElem (OPT_Node *x); +import void OPB_SetRange (OPT_Node *x, OPT_Node y); +import void OPB_StFct (OPT_Node *par0, INT8 fctno, INT16 parno); +import void OPB_StPar0 (OPT_Node *par0, INT16 fctno); +import void OPB_StPar1 (OPT_Node *par0, OPT_Node x, INT8 fctno); +import void OPB_StParN (OPT_Node *par0, OPT_Node x, INT16 fctno, INT16 n); +import void OPB_StaticLink (INT8 dlev); +import void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard); +import void *OPB__init(void); + + +#endif // OPB diff --git a/bootstrap/windows-88/OPC.c b/bootstrap/windows-88/OPC.c new file mode 100644 index 00000000..7b92ccc1 --- /dev/null +++ b/bootstrap/windows-88/OPC.c @@ -0,0 +1,2025 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "OPM.h" +#include "OPT.h" + + +static INT16 OPC_indentLevel; +static INT8 OPC_hashtab[105]; +static CHAR OPC_keytab[50][9]; +static BOOLEAN OPC_GlbPtrs; +static CHAR OPC_BodyNameExt[13]; + + +export void OPC_Andent (OPT_Struct typ); +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); +export OPT_Object OPC_BaseTProc (OPT_Object obj); +export void OPC_BegBlk (void); +export void OPC_BegStat (void); +static void OPC_CProcDefs (OPT_Object obj, INT16 vis); +export void OPC_Case (INT64 caseVal, INT16 form); +static void OPC_CharacterLiteral (INT64 c); +export void OPC_Cmp (INT16 rel); +export void OPC_CompleteIdent (OPT_Object obj); +export void OPC_Constant (OPT_Const con, INT16 form); +static void OPC_DeclareBase (OPT_Object dcl); +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef); +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro); +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefAnonRecs (OPT_Node n); +export void OPC_DefineInter (OPT_Object proc); +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty); +static void OPC_DefineTProcTypes (OPT_Object obj); +static void OPC_DefineType (OPT_Struct str); +export void OPC_EndBlk (void); +export void OPC_EndBlk0 (void); +export void OPC_EndStat (void); +export void OPC_EnterBody (void); +export void OPC_EnterProc (OPT_Object proc); +export void OPC_ExitBody (void); +export void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign); +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign); +export void OPC_GenBdy (OPT_Node n); +static void OPC_GenDynTypes (OPT_Node n, INT16 vis); +export void OPC_GenEnumPtrs (OPT_Object var); +export void OPC_GenHdr (OPT_Node n); +export void OPC_GenHdrIncludes (void); +static void OPC_GenHeaderMsg (void); +export void OPC_Halt (INT32 n); +export void OPC_Ident (OPT_Object obj); +static void OPC_IdentList (OPT_Object obj, INT16 vis); +static void OPC_Include (CHAR *name, ADDRESS name__len); +static void OPC_IncludeImports (OPT_Object obj, INT16 vis); +export void OPC_Increment (BOOLEAN decrement); +export void OPC_Indent (INT16 count); +export void OPC_Init (void); +static void OPC_InitImports (OPT_Object obj); +static void OPC_InitKeywords (void); +export void OPC_InitTDesc (OPT_Struct typ); +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj); +export void OPC_IntLiteral (INT64 n, INT32 size); +export void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName); +static INT16 OPC_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN OPC_NeedsRetval (OPT_Object proc); +export INT32 OPC_NofPtrs (OPT_Struct typ); +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len); +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len); +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define); +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis); +static void OPC_PutBase (OPT_Struct typ); +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt); +static void OPC_RegCmds (OPT_Object obj); +export void OPC_SetInclude (BOOLEAN exclude); +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x); +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l); +export void OPC_TDescDecl (OPT_Struct typ); +export void OPC_TypeDefs (OPT_Object obj, INT16 vis); +export void OPC_TypeOf (OPT_Object ap); +static BOOLEAN OPC_Undefined (OPT_Object obj); + + +void OPC_Init (void) +{ + OPC_indentLevel = 0; + __MOVE("__init(void)", OPC_BodyNameExt, 13); +} + +void OPC_Indent (INT16 count) +{ + OPC_indentLevel += count; +} + +void OPC_BegStat (void) +{ + INT16 i; + i = OPC_indentLevel; + while (i > 0) { + OPM_Write(0x09); + i -= 1; + } +} + +void OPC_EndStat (void) +{ + OPM_Write(';'); + OPM_WriteLn(); +} + +void OPC_BegBlk (void) +{ + OPM_Write('{'); + OPM_WriteLn(); + OPC_indentLevel += 1; +} + +void OPC_EndBlk (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); + OPM_WriteLn(); +} + +void OPC_EndBlk0 (void) +{ + OPC_indentLevel -= 1; + OPC_BegStat(); + OPM_Write('}'); +} + +static void OPC_Str1 (CHAR *s, ADDRESS s__len, INT32 x) +{ + CHAR ch; + INT16 i; + __DUP(s, s__len, CHAR); + ch = s[0]; + i = 0; + while (ch != 0x00) { + if (ch == '#') { + OPM_WriteInt(x); + } else { + OPM_Write(ch); + } + i += 1; + ch = s[__X(i, s__len)]; + } + __DEL(s); +} + +static INT16 OPC_Length (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + return i; +} + +static INT16 OPC_PerfectHash (CHAR *s, ADDRESS s__len) +{ + INT16 i, h; + i = 0; + h = 0; + while ((s[__X(i, s__len)] != 0x00 && i < 5)) { + h = 3 * h + (INT16)s[__X(i, s__len)]; + i += 1; + } + return (int)__MOD(h, 105); +} + +void OPC_Ident (OPT_Object obj) +{ + INT16 mode, level, h; + mode = obj->mode; + level = obj->mnolev; + if ((__IN(mode, 0x62, 32) && level > 0) || __IN(mode, 0x14, 32)) { + OPM_WriteStringVar((void*)obj->name, 256); + h = OPC_PerfectHash((void*)obj->name, 256); + if (OPC_hashtab[__X(h, 105)] >= 0) { + if (__STRCMP(OPC_keytab[__X(OPC_hashtab[__X(h, 105)], 50)], obj->name) == 0) { + OPM_Write('_'); + } + } + } else if ((mode == 5 && __IN(obj->typ->form, 0x90, 32))) { + if (obj->typ == OPT_adrtyp) { + OPM_WriteString((CHAR*)"ADDRESS", 8); + } else { + if (obj->typ->form == 4) { + OPM_WriteString((CHAR*)"INT", 4); + } else { + OPM_WriteString((CHAR*)"UINT", 5); + } + OPM_WriteInt(__ASHL(obj->typ->size, 3)); + } + } else { + if (mode != 5 || obj->linkadr != 2) { + if (mode == 13) { + OPC_Ident(obj->link->typ->strobj); + } else if (level < 0) { + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-level, 64)]->name, 256); + if (OPM_currFile == 0) { + OPT_GlbMod[__X(-level, 64)]->vis = 1; + } + } else { + OPM_WriteStringVar((void*)OPM_modName, 32); + } + OPM_Write('_'); + } else if (obj == OPT_sysptrtyp->strobj || obj == OPT_bytetyp->strobj) { + OPM_WriteString((CHAR*)"SYSTEM_", 8); + } + OPM_WriteStringVar((void*)obj->name, 256); + } +} + +static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause) +{ + INT16 pointers; + *openClause = 0; + if (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->comp != 4)) { + if (__IN(typ->comp, 0x0c, 32)) { + OPC_Stars(typ->BaseTyp, &*openClause); + *openClause = typ->comp == 2; + } else if (typ->form == 12) { + OPM_Write('('); + OPM_Write('*'); + } else { + pointers = 0; + while (((typ->strobj == NIL || typ->strobj->name[0] == 0x00) && typ->form == 11)) { + pointers += 1; + typ = typ->BaseTyp; + } + if (pointers > 0) { + if (typ->comp != 3) { + OPC_Stars(typ, &*openClause); + } + if (*openClause) { + OPM_Write('('); + *openClause = 0; + } + while (pointers > 0) { + OPM_Write('*'); + pointers -= 1; + } + } + } + } +} + +static void OPC_DeclareObj (OPT_Object dcl, BOOLEAN scopeDef) +{ + OPT_Struct typ = NIL; + BOOLEAN varPar, openClause; + INT16 form, comp; + typ = dcl->typ; + varPar = ((dcl->mode == 2 && typ->comp != 2) || typ->comp == 3) || scopeDef; + OPC_Stars(typ, &openClause); + if (varPar) { + if (openClause) { + OPM_Write('('); + } + OPM_Write('*'); + } + if (dcl->name[0] != 0x00) { + OPC_Ident(dcl); + } + if ((varPar && openClause)) { + OPM_Write(')'); + } + openClause = 0; + for (;;) { + form = typ->form; + comp = typ->comp; + if (((typ->strobj != NIL && typ->strobj->name[0] != 0x00) || form == 10) || comp == 4) { + break; + } else if ((form == 11 && typ->BaseTyp->comp != 3)) { + openClause = 1; + } else if (form == 12 || __IN(comp, 0x0c, 32)) { + if (openClause) { + OPM_Write(')'); + openClause = 0; + } + if (form == 12) { + OPM_Write(')'); + OPC_AnsiParamList(typ->link, 0); + break; + } else if (comp == 2) { + OPM_Write('['); + OPM_WriteInt(typ->n); + OPM_Write(']'); + } + } else { + break; + } + typ = typ->BaseTyp; + } +} + +void OPC_Andent (OPT_Struct typ) +{ + if (typ->strobj == NIL || typ->align >= 65536) { + OPM_WriteStringVar((void*)OPM_modName, 32); + OPC_Str1((CHAR*)"__#", 4, __ASHR(typ->align, 16)); + } else { + OPC_Ident(typ->strobj); + } +} + +static BOOLEAN OPC_Undefined (OPT_Object obj) +{ + return obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (3 + OPM_currFile))) && obj->linkadr != 2); +} + +static void OPC_DeclareBase (OPT_Object dcl) +{ + OPT_Struct typ = NIL, prev = NIL; + OPT_Object obj = NIL; + INT16 nofdims; + INT32 off, n, dummy; + typ = dcl->typ; + prev = typ; + while ((((((((typ->strobj == NIL || typ->comp == 3) || OPC_Undefined(typ->strobj)) && typ->comp != 4)) && typ->form != 10)) && !((typ->form == 11 && typ->BaseTyp->comp == 3)))) { + prev = typ; + typ = typ->BaseTyp; + } + obj = typ->strobj; + if (typ->form == 10) { + OPM_WriteString((CHAR*)"void", 5); + } else if ((obj != NIL && !OPC_Undefined(obj))) { + OPC_Ident(obj); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"struct ", 8); + OPC_Andent(typ); + if ((prev->form != 11 && (obj != NIL || dcl->name[0] == 0x00))) { + if ((typ->BaseTyp != NIL && typ->BaseTyp->strobj->vis != 0)) { + OPM_WriteString((CHAR*)" { /* ", 7); + OPC_Ident(typ->BaseTyp->strobj); + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); + OPC_Indent(1); + } else { + OPM_Write(' '); + OPC_BegBlk(); + } + OPC_FieldList(typ, 1, &off, &n, &dummy); + OPC_EndBlk0(); + } + } else if ((typ->form == 11 && typ->BaseTyp->comp == 3)) { + typ = typ->BaseTyp->BaseTyp; + nofdims = 1; + while (typ->comp == 3) { + nofdims += 1; + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)"struct ", 8); + OPC_BegBlk(); + OPC_BegStat(); + OPC_Str1((CHAR*)"ADDRESS len[#]", 15, nofdims); + OPC_EndStat(); + OPC_BegStat(); + __NEW(obj, OPT_ObjDesc); + __NEW(obj->typ, OPT_StrDesc); + obj->typ->form = 13; + obj->typ->comp = 2; + obj->typ->n = 1; + obj->typ->BaseTyp = typ; + obj->mode = 4; + __MOVE("data", obj->name, 5); + obj->linkadr = 0; + OPC_DeclareBase(obj); + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + OPC_EndStat(); + OPC_EndBlk0(); + } +} + +INT32 OPC_NofPtrs (OPT_Struct typ) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n; + if ((typ->form == 11 && typ->sysflag == 0)) { + return 1; + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + n = OPC_NofPtrs(btyp); + } else { + n = 0; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + n = n + OPC_NofPtrs(fld->typ); + } else { + n += 1; + } + fld = fld->link; + } + return n; + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + return OPC_NofPtrs(btyp) * n; + } else { + return 0; + } + __RETCHK; +} + +static void OPC_PutPtrOffsets (OPT_Struct typ, INT32 adr, INT32 *cnt) +{ + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + INT32 n, i; + if ((typ->form == 11 && typ->sysflag == 0)) { + OPM_WriteInt(adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } else if ((typ->comp == 4 && __MASK(typ->sysflag, -256) == 0)) { + btyp = typ->BaseTyp; + if (btyp != NIL) { + OPC_PutPtrOffsets(btyp, adr, &*cnt); + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + if (__STRCMP(fld->name, "@ptr") != 0) { + OPC_PutPtrOffsets(fld->typ, adr + fld->adr, &*cnt); + } else { + OPM_WriteInt(adr + fld->adr); + OPM_WriteString((CHAR*)", ", 3); + *cnt += 1; + if (__MASK(*cnt, -16) == 0) { + OPM_WriteLn(); + OPM_Write(0x09); + } + } + fld = fld->link; + } + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (OPC_NofPtrs(btyp) > 0) { + i = 0; + while (i < n) { + OPC_PutPtrOffsets(btyp, adr + i * btyp->size, &*cnt); + i += 1; + } + } + } +} + +static void OPC_InitTProcs (OPT_Object typ, OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitTProcs(typ, obj->left); + if (obj->mode == 13) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITBP(", 10); + OPC_Ident(typ); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(obj); + OPC_Str1((CHAR*)", #)", 5, __ASHR(obj->adr, 16)); + OPC_EndStat(); + } + OPC_InitTProcs(typ, obj->right); + } +} + +static void OPC_PutBase (OPT_Struct typ) +{ + if (typ != NIL) { + OPC_PutBase(typ->BaseTyp); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)", ", 3); + } +} + +static void OPC_LenList (OPT_Object par, BOOLEAN ansiDefine, BOOLEAN showParamName) +{ + OPT_Struct typ = NIL; + INT16 dim; + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + } + dim = 1; + typ = par->typ->BaseTyp; + while (typ->comp == 3) { + if (ansiDefine) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + } else { + OPM_WriteString((CHAR*)", ", 3); + } + if (showParamName) { + OPC_Ident(par); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + dim += 1; + } +} + +static void OPC_DeclareParams (OPT_Object par, BOOLEAN macro) +{ + OPM_Write('('); + while (par != NIL) { + if (macro) { + OPM_WriteStringVar((void*)par->name, 256); + } else { + if ((par->mode == 1 && par->typ->form == 5)) { + OPM_Write('_'); + } + OPC_Ident(par); + } + if (par->typ->comp == 3) { + OPM_WriteString((CHAR*)", ", 3); + OPC_LenList(par, 0, 1); + } else if ((par->mode == 2 && par->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteStringVar((void*)par->name, 256); + OPM_WriteString((CHAR*)"__typ", 6); + } + par = par->link; + if (par != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static void OPC_DefineTProcTypes (OPT_Object obj) +{ + OPT_Object par = NIL; + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + par = obj->link; + while (par != NIL) { + OPC_DefineType(par->typ); + par = par->link; + } +} + +static void OPC_DeclareTProcs (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DeclareTProcs(obj->left, &*empty); + if (obj->mode == 13) { + if (obj->typ != OPT_notyp) { + OPC_DefineType(obj->typ); + } + if (OPM_currFile == 0) { + if (obj->vis == 1) { + OPC_DefineTProcTypes(obj); + OPM_WriteString((CHAR*)"import ", 8); + *empty = 0; + OPC_ProcHeader(obj, 0); + } + } else { + *empty = 0; + OPC_DefineTProcTypes(obj); + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + } + OPC_DeclareTProcs(obj->right, &*empty); + } +} + +OPT_Object OPC_BaseTProc (OPT_Object obj) +{ + OPT_Struct typ = NIL, base = NIL; + INT32 mno; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + base = typ->BaseTyp; + mno = __ASHR(obj->adr, 16); + while ((base != NIL && mno < base->n)) { + typ = base; + base = typ->BaseTyp; + } + OPT_FindField(obj->name, typ, &obj); + return obj; +} + +static void OPC_DefineTProcMacros (OPT_Object obj, BOOLEAN *empty) +{ + if (obj != NIL) { + OPC_DefineTProcMacros(obj->left, &*empty); + if ((obj->mode == 13 && obj == OPC_BaseTProc(obj))) { + if (OPM_currFile == 1 || (OPM_currFile == 0 && obj->vis == 1)) { + OPM_WriteString((CHAR*)"#define __", 11); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_WriteString((CHAR*)" __SEND(", 9); + if (obj->link->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPC_Ident(obj->link); + OPM_Write(')'); + } else { + OPC_Ident(obj->link); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_Str1((CHAR*)", #, ", 6, __ASHR(obj->adr, 16)); + if (obj->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(obj->typ->strobj); + } + OPM_WriteString((CHAR*)"(*)", 4); + OPC_AnsiParamList(obj->link, 0); + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareParams(obj->link, 1); + OPM_Write(')'); + OPM_WriteLn(); + } + } + OPC_DefineTProcMacros(obj->right, &*empty); + } +} + +static void OPC_DefineType (OPT_Struct str) +{ + OPT_Object obj = NIL, field = NIL, par = NIL; + BOOLEAN empty; + if ((OPM_currFile == 1 || str->ref < 255) || (((OPM_currFile == 0 && str->strobj != NIL)) && str->strobj->vis == 1)) { + obj = str->strobj; + if (obj == NIL || OPC_Undefined(obj)) { + if (obj != NIL) { + if (obj->linkadr == 1) { + if (str->form != 11) { + OPM_Mark(244, str->txtpos); + obj->linkadr = 2; + } + } else { + obj->linkadr = 1; + } + } + if (str->comp == 4) { + if (str->BaseTyp != NIL) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while ((field != NIL && field->mode == 4)) { + if (field->vis != 0 || OPM_currFile == 1) { + OPC_DefineType(field->typ); + } + field = field->link; + } + } else if (str->form == 11) { + if (str->BaseTyp->comp != 4) { + OPC_DefineType(str->BaseTyp); + } + } else if (__IN(str->comp, 0x0c, 32)) { + if ((str->BaseTyp->strobj != NIL && str->BaseTyp->strobj->linkadr == 1)) { + OPM_Mark(244, str->txtpos); + str->BaseTyp->strobj->linkadr = 2; + } + OPC_DefineType(str->BaseTyp); + } else if (str->form == 12) { + if (str->BaseTyp != OPT_notyp) { + OPC_DefineType(str->BaseTyp); + } + field = str->link; + while (field != NIL) { + OPC_DefineType(field->typ); + field = field->link; + } + } + } + if ((obj != NIL && OPC_Undefined(obj))) { + OPM_WriteString((CHAR*)"typedef", 8); + OPM_WriteLn(); + OPM_Write(0x09); + OPC_Indent(1); + obj->linkadr = 1; + OPC_DeclareBase(obj); + OPM_Write(' '); + obj->typ->strobj = NIL; + OPC_DeclareObj(obj, 0); + obj->typ->strobj = obj; + obj->linkadr = 3 + OPM_currFile; + OPC_EndStat(); + OPC_Indent(-1); + OPM_WriteLn(); + if (obj->typ->comp == 4) { + empty = 1; + OPC_DeclareTProcs(str->link, &empty); + OPC_DefineTProcMacros(str->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } else if ((obj->typ->form == 11 && obj->typ->BaseTyp->comp == 4)) { + empty = 1; + OPC_DeclareTProcs(obj->typ->BaseTyp->link, &empty); + OPC_DefineTProcMacros(obj->typ->BaseTyp->link, &empty); + if (!empty) { + OPM_WriteLn(); + } + } + } + } +} + +static BOOLEAN OPC_Prefixed (OPT_ConstExt x, CHAR *y, ADDRESS y__len) +{ + INT16 i; + __DUP(y, y__len, CHAR); + i = 0; + while ((*x)[__X(i + 1, 256)] == y[__X(i, y__len)]) { + i += 1; + } + __DEL(y); + return y[__X(i, y__len)] == 0x00; +} + +static void OPC_CProcDefs (OPT_Object obj, INT16 vis) +{ + INT16 i; + OPT_ConstExt ext = NIL; + INT16 _for__7; + if (obj != NIL) { + OPC_CProcDefs(obj->left, vis); + if ((((obj->mode == 9 && (INT16)obj->vis >= vis)) && obj->adr == 1)) { + ext = obj->conval->ext; + i = 1; + if (((*ext)[1] != '#' && !(OPC_Prefixed(ext, (CHAR*)"extern ", 8) || OPC_Prefixed(ext, (CHAR*)"import ", 8)))) { + OPM_WriteString((CHAR*)"#define ", 9); + OPC_Ident(obj); + OPC_DeclareParams(obj->link, 1); + OPM_Write(0x09); + } + _for__7 = (INT16)(*obj->conval->ext)[0]; + i = i; + while (i <= _for__7) { + OPM_Write((*obj->conval->ext)[__X(i, 256)]); + i += 1; + } + OPM_WriteLn(); + } + OPC_CProcDefs(obj->right, vis); + } +} + +void OPC_TypeDefs (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_TypeDefs(obj->left, vis); + if ((obj->mode == 5 && obj->typ->txtpos > 0)) { + OPC_DefineType(obj->typ); + } + OPC_TypeDefs(obj->right, vis); + } +} + +static void OPC_DefAnonRecs (OPT_Node n) +{ + OPT_Object o = NIL; + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if ((typ->strobj == NIL && (OPM_currFile == 1 || typ->ref < 255))) { + OPC_DefineType(typ); + __NEW(o, OPT_ObjDesc); + o->typ = typ; + o->name[0] = 0x00; + OPC_DeclareBase(o); + OPC_EndStat(); + OPM_WriteLn(); + } + n = n->link; + } +} + +void OPC_TDescDecl (OPT_Struct typ) +{ + INT32 nofptrs; + OPT_Object o = NIL; + OPC_BegStat(); + OPM_WriteString((CHAR*)"__TDESC(", 9); + OPC_Andent(typ); + OPC_Str1((CHAR*)", #", 4, typ->n + 1); + OPC_Str1((CHAR*)", #) = {__TDFLDS(", 18, OPC_NofPtrs(typ)); + OPM_Write('"'); + if (typ->strobj != NIL) { + OPM_WriteStringVar((void*)typ->strobj->name, 256); + } + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", 8, typ->size); + nofptrs = 0; + OPC_PutPtrOffsets(typ, 0, &nofptrs); + OPC_Str1((CHAR*)"#}}", 4, -((nofptrs + 1) * OPM_AddressSize)); + OPC_EndStat(); +} + +void OPC_InitTDesc (OPT_Struct typ) +{ + OPC_BegStat(); + OPM_WriteString((CHAR*)"__INITYP(", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + if (typ->BaseTyp != NIL) { + OPC_Andent(typ->BaseTyp); + } else { + OPC_Andent(typ); + } + OPC_Str1((CHAR*)", #)", 5, typ->extlev); + OPC_EndStat(); + if (typ->strobj != NIL) { + OPC_InitTProcs(typ->strobj, typ->link); + } +} + +static void OPC_FillGap (INT32 gap, INT32 off, INT32 align, INT32 *n, INT32 *curAlign) +{ + INT32 adr; + adr = off; + OPT_Align(&adr, align); + if ((*curAlign < align && gap - (adr - off) >= align)) { + gap -= (adr - off) + align; + OPC_BegStat(); + switch (align) { + case 2: + OPM_WriteString((CHAR*)"INT16", 6); + break; + case 4: + OPM_WriteString((CHAR*)"INT32", 6); + break; + case 8: + OPM_WriteString((CHAR*)"INT64", 6); + break; + default: + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected enclosing alignment in FillGap.", 43); + break; + } + OPC_Str1((CHAR*)" _prvt#", 8, *n); + *n += 1; + OPC_EndStat(); + *curAlign = align; + } + if (gap > 0) { + OPC_BegStat(); + OPC_Str1((CHAR*)"char _prvt#", 12, *n); + *n += 1; + OPC_Str1((CHAR*)"[#]", 4, gap); + OPC_EndStat(); + } +} + +static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, INT32 *off, INT32 *n, INT32 *curAlign) +{ + OPT_Object fld = NIL; + OPT_Struct base = NIL; + INT32 gap, adr, align, fldAlign; + fld = typ->link; + align = __MASK(typ->align, -65536); + if (typ->BaseTyp != NIL) { + OPC_FieldList(typ->BaseTyp, 0, &*off, &*n, &*curAlign); + } else { + *off = 0; + *n = 0; + *curAlign = 1; + } + while ((fld != NIL && fld->mode == 4)) { + if ((OPM_currFile == 0 && fld->vis == 0) || (((OPM_currFile == 1 && fld->vis == 0)) && typ->mno != 0)) { + fld = fld->link; + while ((((fld != NIL && fld->mode == 4)) && fld->vis == 0)) { + fld = fld->link; + } + } else { + adr = *off; + fldAlign = OPT_BaseAlignment(fld->typ); + OPT_Align(&adr, fldAlign); + gap = fld->adr - adr; + if (fldAlign > *curAlign) { + *curAlign = fldAlign; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + OPC_BegStat(); + OPC_DeclareBase(fld); + OPM_Write(' '); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + base = fld->typ; + fld = fld->link; + while ((((((((fld != NIL && fld->mode == 4)) && fld->typ == base)) && fld->adr == *off)) && ((OPM_currFile == 1 || fld->vis != 0) || fld->typ->strobj == NIL))) { + OPM_WriteString((CHAR*)", ", 3); + OPC_DeclareObj(fld, 0); + *off = fld->adr + fld->typ->size; + fld = fld->link; + } + OPC_EndStat(); + } + } + if (last) { + adr = typ->size - __ASHR(typ->sysflag, 8); + if (adr == 0) { + gap = 1; + } else { + gap = adr - *off; + } + if (gap > 0) { + OPC_FillGap(gap, *off, align, &*n, &*curAlign); + } + } +} + +static void OPC_IdentList (OPT_Object obj, INT16 vis) +{ + OPT_Struct base = NIL; + BOOLEAN first; + INT16 lastvis; + base = NIL; + first = 1; + while ((obj != NIL && obj->mode != 13)) { + if ((__IN(vis, 0x05, 32) || (vis == 1 && obj->vis != 0)) || (vis == 3 && !obj->leaf)) { + if (obj->typ != base || (INT16)obj->vis != lastvis) { + if (!first) { + OPC_EndStat(); + } + first = 0; + base = obj->typ; + lastvis = obj->vis; + OPC_BegStat(); + if ((vis == 1 && obj->vis != 0)) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((obj->mnolev == 0 && vis == 0)) { + if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + } + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_WriteString((CHAR*)"double", 7); + } else { + OPC_DeclareBase(obj); + } + } else { + OPM_Write(','); + } + OPM_Write(' '); + if ((((vis == 2 && obj->mode == 1)) && base->form == 5)) { + OPM_Write('_'); + } + OPC_DeclareObj(obj, vis == 3); + if (obj->typ->comp == 3) { + OPC_EndStat(); + OPC_BegStat(); + base = OPT_adrtyp; + OPM_WriteString((CHAR*)"ADDRESS ", 9); + OPC_LenList(obj, 0, 1); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + base = NIL; + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + OPM_WriteString((CHAR*)" = NIL", 7); + } + } + obj = obj->link; + } + if (!first) { + OPC_EndStat(); + } +} + +static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames) +{ + CHAR name[32]; + OPM_Write('('); + if (obj == NIL || obj->mode == 13) { + OPM_WriteString((CHAR*)"void", 5); + } else { + for (;;) { + OPC_DeclareBase(obj); + if (showParamNames) { + OPM_Write(' '); + OPC_DeclareObj(obj, 0); + } else { + __COPY(obj->name, name, 32); + obj->name[0] = 0x00; + OPC_DeclareObj(obj, 0); + __COPY(name, obj->name, 256); + } + if (obj->typ->comp == 3) { + OPM_WriteString((CHAR*)", ADDRESS ", 11); + OPC_LenList(obj, 1, showParamNames); + } else if ((obj->mode == 2 && obj->typ->comp == 4)) { + OPM_WriteString((CHAR*)", ADDRESS *", 12); + if (showParamNames) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__typ", 6); + } + } + if (obj->link == NIL || obj->link->mode == 13) { + break; + } + OPM_WriteString((CHAR*)", ", 3); + obj = obj->link; + } + } + OPM_Write(')'); +} + +static void OPC_ProcHeader (OPT_Object proc, BOOLEAN define) +{ + if (proc->typ == OPT_notyp) { + OPM_WriteString((CHAR*)"void", 5); + } else { + OPC_Ident(proc->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(proc); + OPM_Write(' '); + OPC_AnsiParamList(proc->link, 1); + if (!define) { + OPM_Write(';'); + } + OPM_WriteLn(); +} + +static void OPC_ProcPredefs (OPT_Object obj, INT8 vis) +{ + if (obj != NIL) { + OPC_ProcPredefs(obj->left, vis); + if ((((__IN(obj->mode, 0xc0, 32) && obj->vis >= vis)) && (obj->history != 4 || obj->mode == 6))) { + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if (obj->vis == 0) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPC_ProcHeader(obj, 0); + } + OPC_ProcPredefs(obj->right, vis); + } +} + +static void OPC_Include (CHAR *name, ADDRESS name__len) +{ + __DUP(name, name__len, CHAR); + OPM_WriteString((CHAR*)"#include ", 10); + OPM_Write('"'); + OPM_WriteStringVar((void*)name, name__len); + OPM_WriteString((CHAR*)".h", 3); + OPM_Write('"'); + OPM_WriteLn(); + __DEL(name); +} + +static void OPC_IncludeImports (OPT_Object obj, INT16 vis) +{ + if (obj != NIL) { + OPC_IncludeImports(obj->left, vis); + if ((((obj->mode == 11 && obj->mnolev != 0)) && (INT16)OPT_GlbMod[__X(-obj->mnolev, 64)]->vis >= vis)) { + OPC_Include(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + } + OPC_IncludeImports(obj->right, vis); + } +} + +static void OPC_GenDynTypes (OPT_Node n, INT16 vis) +{ + OPT_Struct typ = NIL; + while ((n != NIL && n->class == 14)) { + typ = n->typ; + if (vis == 0 || typ->ref < 255) { + OPC_BegStat(); + if (vis == 1) { + OPM_WriteString((CHAR*)"import ", 8); + } else if ((typ->strobj != NIL && typ->strobj->mnolev > 0)) { + OPM_WriteString((CHAR*)"static ", 8); + } else { + OPM_WriteString((CHAR*)"export ", 8); + } + OPM_WriteString((CHAR*)"ADDRESS *", 10); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_EndStat(); + } + n = n->link; + } +} + +void OPC_GenHdr (OPT_Node n) +{ + OPM_currFile = 0; + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 1); + OPM_WriteLn(); + OPC_GenDynTypes(n, 1); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 1); + OPM_WriteString((CHAR*)"import ", 8); + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPC_EndStat(); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 1); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#endif // ", 11); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteLn(); +} + +static void OPC_GenHeaderMsg (void) +{ + INT16 i; + OPM_WriteString((CHAR*)"/* ", 4); + OPM_WriteString((CHAR*)"voc", 4); + OPM_Write(' '); + OPM_WriteString(Configuration_versionLong, 76); + OPM_Write(' '); + i = 0; + while (i <= 31) { + if (__IN(i, OPM_Options, 32)) { + switch (i) { + case 0: + OPM_Write('x'); + break; + case 2: + OPM_Write('r'); + break; + case 3: + OPM_Write('t'); + break; + case 4: + OPM_Write('s'); + break; + case 5: + OPM_Write('p'); + break; + case 7: + OPM_Write('a'); + break; + case 9: + OPM_Write('e'); + break; + case 10: + OPM_Write('m'); + break; + case 13: + OPM_Write('S'); + break; + case 14: + OPM_Write('c'); + break; + case 15: + OPM_Write('M'); + break; + case 16: + OPM_Write('f'); + break; + case 17: + OPM_Write('F'); + break; + case 18: + OPM_Write('v'); + break; + default: + OPM_LogWStr((CHAR*)"( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg", 126); + OPM_LogWLn(); + break; + } + } + i += 1; + } + OPM_WriteString((CHAR*)" */", 4); + OPM_WriteLn(); +} + +void OPC_GenHdrIncludes (void) +{ + OPM_currFile = 2; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#ifndef ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define ", 9); + OPM_WriteStringVar((void*)OPM_modName, 32); + OPM_WriteString((CHAR*)"__h", 4); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 1); + OPM_WriteLn(); +} + +void OPC_GenBdy (OPT_Node n) +{ + OPM_currFile = 1; + OPC_GenHeaderMsg(); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SHORTINT INT", 21); + OPM_WriteInt(__ASHL(OPT_sinttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define INTEGER INT", 21); + OPM_WriteInt(__ASHL(OPT_inttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define LONGINT INT", 21); + OPM_WriteInt(__ASHL(OPT_linttyp->size, 3)); + OPM_WriteLn(); + OPM_WriteString((CHAR*)"#define SET UINT", 22); + OPM_WriteInt(__ASHL(OPT_settyp->size, 3)); + OPM_WriteLn(); + OPM_WriteLn(); + OPC_Include((CHAR*)"SYSTEM", 7); + OPC_IncludeImports(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_DefAnonRecs(n); + OPC_TypeDefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_IdentList(OPT_topScope->scope, 0); + OPM_WriteLn(); + OPC_GenDynTypes(n, 0); + OPM_WriteLn(); + OPC_ProcPredefs(OPT_topScope->right, 0); + OPM_WriteLn(); + OPC_CProcDefs(OPT_topScope->right, 0); + OPM_WriteLn(); +} + +static void OPC_RegCmds (OPT_Object obj) +{ + if (obj != NIL) { + OPC_RegCmds(obj->left); + if ((obj->mode == 7 && obj->history != 4)) { + if ((((obj->vis != 0 && obj->link == NIL)) && obj->typ == OPT_notyp)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__REGCMD(\"", 11); + OPM_WriteStringVar((void*)obj->name, 256); + OPM_WriteString((CHAR*)"\", ", 4); + OPC_Ident(obj); + OPM_Write(')'); + OPC_EndStat(); + } + } + OPC_RegCmds(obj->right); + } +} + +static void OPC_InitImports (OPT_Object obj) +{ + if (obj != NIL) { + OPC_InitImports(obj->left); + if ((obj->mode == 11 && obj->mnolev != 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"__MODULE_IMPORT(", 17); + OPM_WriteStringVar((void*)OPT_GlbMod[__X(-obj->mnolev, 64)]->name, 256); + OPM_Write(')'); + OPC_EndStat(); + } + OPC_InitImports(obj->right); + } +} + +void OPC_GenEnumPtrs (OPT_Object var) +{ + OPT_Struct typ = NIL; + INT32 n; + OPC_GlbPtrs = 0; + while (var != NIL) { + typ = var->typ; + if (OPC_NofPtrs(typ) > 0) { + if (!OPC_GlbPtrs) { + OPC_GlbPtrs = 1; + OPM_WriteString((CHAR*)"static void EnumPtrs(void (*P)(void*))", 39); + OPM_WriteLn(); + OPC_BegBlk(); + } + OPC_BegStat(); + if (typ->form == 11) { + OPM_WriteString((CHAR*)"P(", 3); + OPC_Ident(var); + OPM_Write(')'); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(&", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPM_WriteString((CHAR*)", 1, P)", 8); + } else if (typ->comp == 2) { + n = typ->n; + typ = typ->BaseTyp; + while (typ->comp == 2) { + n = n * typ->n; + typ = typ->BaseTyp; + } + if (typ->form == 11) { + OPM_WriteString((CHAR*)"__ENUMP(", 9); + OPC_Ident(var); + OPC_Str1((CHAR*)", #, P)", 8, n); + } else if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__ENUMR(", 9); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)"__typ", 6); + OPC_Str1((CHAR*)", #", 4, typ->size); + OPC_Str1((CHAR*)", #, P)", 8, n); + } + } + OPC_EndStat(); + } + var = var->link; + } + if (OPC_GlbPtrs) { + OPC_EndBlk(); + OPM_WriteLn(); + } +} + +void OPC_EnterBody (void) +{ + OPM_WriteLn(); + OPM_WriteString((CHAR*)"export ", 8); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); + OPM_WriteLn(); + } else { + OPM_WriteString((CHAR*)"void *", 7); + OPM_WriteString(OPM_modName, 32); + OPM_WriteString(OPC_BodyNameExt, 13); + OPM_WriteLn(); + } + OPC_BegBlk(); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); + } else { + OPM_WriteString((CHAR*)"__DEFMOD", 9); + } + OPC_EndStat(); + if ((__IN(10, OPM_Options, 32) && 0)) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); + OPC_EndStat(); + } + OPC_InitImports(OPT_topScope->right); + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); + } else { + OPM_WriteString((CHAR*)"__REGMOD(\"", 11); + } + OPM_WriteString(OPM_modName, 32); + if (OPC_GlbPtrs) { + OPM_WriteString((CHAR*)"\", EnumPtrs)", 13); + } else { + OPM_WriteString((CHAR*)"\", 0)", 6); + } + OPC_EndStat(); + if (__STRCMP(OPM_modName, "SYSTEM") != 0) { + OPC_RegCmds(OPT_topScope); + } +} + +void OPC_ExitBody (void) +{ + OPC_BegStat(); + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI;", 8); + } else { + OPM_WriteString((CHAR*)"__ENDMOD;", 10); + } + OPM_WriteLn(); + OPC_EndBlk(); +} + +void OPC_DefineInter (OPT_Object proc) +{ + OPT_Object scope = NIL; + scope = proc->scope; + OPM_WriteString((CHAR*)"static ", 8); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPC_BegBlk(); + OPC_IdentList(proc->link, 3); + OPC_IdentList(scope->scope, 3); + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + OPC_EndBlk0(); + OPM_Write(' '); + OPM_Write('*'); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPM_WriteLn(); + OPC_ProcPredefs(scope->right, 0); + OPM_WriteLn(); +} + +BOOLEAN OPC_NeedsRetval (OPT_Object proc) +{ + return (proc->typ != OPT_notyp && !proc->scope->leaf); +} + +void OPC_EnterProc (OPT_Object proc) +{ + OPT_Object var = NIL, scope = NIL; + OPT_Struct typ = NIL; + INT16 dim; + if (proc->vis != 1) { + OPM_WriteString((CHAR*)"static ", 8); + } + OPC_ProcHeader(proc, 1); + OPC_BegBlk(); + scope = proc->scope; + OPC_IdentList(scope->scope, 0); + if (!scope->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"struct ", 8); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_Write(' '); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } + if (OPC_NeedsRetval(proc)) { + OPC_BegStat(); + OPC_Ident(proc->typ->strobj); + OPM_WriteString((CHAR*)" __retval", 10); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((var->typ->comp == 2 && var->mode == 1)) { + OPC_BegStat(); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + OPM_Write(' '); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__copy", 7); + OPC_EndStat(); + } + var = var->link; + } + var = proc->link; + while (var != NIL) { + if ((((__IN(var->typ->comp, 0x0c, 32) && var->mode == 1)) && var->typ->sysflag == 0)) { + OPC_BegStat(); + if (var->typ->comp == 2) { + OPM_WriteString((CHAR*)"__DUPARR(", 10); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + if (var->typ->strobj == NIL) { + OPM_Mark(200, var->typ->txtpos); + } else { + OPC_Ident(var->typ->strobj); + } + } else { + OPM_WriteString((CHAR*)"__DUP(", 7); + OPC_Ident(var); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + typ = var->typ->BaseTyp; + dim = 1; + while (typ->comp == 3) { + OPM_WriteString((CHAR*)" * ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + OPM_WriteInt(dim); + typ = typ->BaseTyp; + dim += 1; + } + OPM_WriteString((CHAR*)", ", 3); + if (typ->strobj == NIL) { + OPM_Mark(200, typ->txtpos); + } else { + OPC_Ident(typ->strobj); + } + } + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + if (!scope->leaf) { + var = proc->link; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (__IN(var->typ->comp, 0x0c, 32)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } else if (var->mode != 2) { + OPM_Write('&'); + } + OPC_Ident(var); + if (var->typ->comp == 3) { + typ = var->typ; + dim = 0; + do { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + typ = typ->BaseTyp; + } while (!(typ->comp != 3)); + } else if ((var->mode == 2 && var->typ->comp == 4)) { + OPM_WriteString((CHAR*)"; ", 3); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + OPM_WriteString((CHAR*)" = ", 4); + OPC_Ident(var); + OPM_WriteString((CHAR*)"__typ", 6); + } + OPC_EndStat(); + } + var = var->link; + } + var = scope->scope; + while (var != NIL) { + if (!var->leaf) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPC_Ident(var); + OPM_WriteString((CHAR*)" = ", 4); + if (var->typ->comp != 2) { + OPM_Write('&'); + } else { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPC_Ident(var); + OPC_EndStat(); + } + var = var->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteStringVar((void*)scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_Write('&'); + OPM_WriteString((CHAR*)"_s", 3); + OPC_EndStat(); + } +} + +void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet) +{ + OPT_Object var = NIL; + BOOLEAN indent; + indent = eoBlock; + if ((implicitRet && proc->typ != OPT_notyp)) { + OPM_Write(0x09); + OPM_WriteString((CHAR*)"__RETCHK;", 10); + OPM_WriteLn(); + } else if (!eoBlock || implicitRet) { + if (!proc->scope->leaf) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteStringVar((void*)proc->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)" = ", 4); + OPM_WriteString((CHAR*)"_s", 3); + OPM_Write('.'); + OPM_WriteString((CHAR*)"lnk", 4); + OPC_EndStat(); + } + var = proc->link; + while (var != NIL) { + if ((((var->typ->comp == 3 && var->mode == 1)) && var->typ->sysflag == 0)) { + if (indent) { + OPC_BegStat(); + } else { + indent = 1; + } + OPM_WriteString((CHAR*)"__DEL(", 7); + OPC_Ident(var); + OPM_Write(')'); + OPC_EndStat(); + } + var = var->link; + } + } + if (eoBlock) { + OPC_EndBlk(); + OPM_WriteLn(); + } else if (indent) { + OPC_BegStat(); + } +} + +void OPC_CompleteIdent (OPT_Object obj) +{ + INT16 comp, level; + level = obj->mnolev; + if (obj->adr == 1) { + if (obj->typ->comp == 4) { + OPC_Ident(obj); + OPM_WriteString((CHAR*)"__", 3); + } else { + OPM_WriteString((CHAR*)"(*(", 4); + OPC_Ident(obj->typ->strobj); + OPM_WriteString((CHAR*)"*)&", 4); + OPC_Ident(obj); + OPM_Write(')'); + } + } else if ((level != OPM_level && level > 0)) { + comp = obj->typ->comp; + if ((obj->mode != 2 && comp != 3)) { + OPM_Write('*'); + } + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"_s", 3); + OPM_WriteString((CHAR*)"->", 3); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } +} + +void OPC_TypeOf (OPT_Object ap) +{ + INT16 i; + __ASSERT(ap->typ->comp == 4, 0); + if (ap->mode == 2) { + if ((INT16)ap->mnolev != OPM_level) { + OPM_WriteStringVar((void*)ap->scope->name, 256); + OPM_WriteString((CHAR*)"_s->", 5); + OPC_Ident(ap); + } else { + OPC_Ident(ap); + } + OPM_WriteString((CHAR*)"__typ", 6); + } else if (ap->typ->strobj != NIL) { + OPC_Ident(ap->typ->strobj); + OPM_WriteString((CHAR*)"__typ", 6); + } else { + OPC_Andent(ap->typ); + } +} + +void OPC_Cmp (INT16 rel) +{ + switch (rel) { + case 9: + OPM_WriteString((CHAR*)" == ", 5); + break; + case 10: + OPM_WriteString((CHAR*)" != ", 5); + break; + case 11: + OPM_WriteString((CHAR*)" < ", 4); + break; + case 12: + OPM_WriteString((CHAR*)" <= ", 5); + break; + case 13: + OPM_WriteString((CHAR*)" > ", 4); + break; + case 14: + OPM_WriteString((CHAR*)" >= ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Cmp, rel = ", 34); + OPM_LogWNum(rel, 0); + OPM_LogWLn(); + break; + } +} + +static void OPC_CharacterLiteral (INT64 c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", 3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, ADDRESS s__len, INT32 l) +{ + INT32 i; + INT16 c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (INT16)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write(__CHR(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write(__CHR(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write(__CHR(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write(__CHR(c)); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + +void OPC_Case (INT64 caseVal, INT16 form) +{ + CHAR ch; + OPM_WriteString((CHAR*)"case ", 6); + switch (form) { + case 3: + OPC_CharacterLiteral(caseVal); + break; + case 4: + OPM_WriteInt(caseVal); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Case, form = ", 36); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } + OPM_WriteString((CHAR*)": ", 3); +} + +void OPC_SetInclude (BOOLEAN exclude) +{ + if (exclude) { + OPM_WriteString((CHAR*)" &= ~", 6); + } else { + OPM_WriteString((CHAR*)" |= ", 5); + } +} + +void OPC_Increment (BOOLEAN decrement) +{ + if (decrement) { + OPM_WriteString((CHAR*)" -= ", 5); + } else { + OPM_WriteString((CHAR*)" += ", 5); + } +} + +void OPC_Halt (INT32 n) +{ + OPC_Str1((CHAR*)"__HALT(#)", 10, n); +} + +void OPC_IntLiteral (INT64 n, INT32 size) +{ + if ((((size > 4 && n <= 2147483647)) && n > (-2147483647-1))) { + OPM_WriteString((CHAR*)"((INT", 6); + OPM_WriteInt(__ASHL(size, 3)); + OPM_WriteString((CHAR*)")(", 3); + OPM_WriteInt(n); + OPM_WriteString((CHAR*)"))", 3); + } else { + OPM_WriteInt(n); + } +} + +void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim) +{ + INT64 d; + d = dim; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPC_CompleteIdent(obj); + OPM_WriteString((CHAR*)"__len", 6); + if (dim != 0) { + OPM_WriteInt(dim); + } + } else { + OPM_WriteInt(array->n); + } +} + +void OPC_Constant (OPT_Const con, INT16 form) +{ + INT16 i; + UINT64 s; + INT64 hex; + BOOLEAN skipLeading; + switch (form) { + case 1: + OPM_WriteInt(con->intval); + break; + case 2: + OPM_WriteInt(con->intval); + break; + case 3: + OPC_CharacterLiteral(con->intval); + break; + case 4: + OPM_WriteInt(con->intval); + break; + case 5: + OPM_WriteReal(con->realval, 'f'); + break; + case 6: + OPM_WriteReal(con->realval, 0x00); + break; + case 7: + OPM_WriteString((CHAR*)"0x", 3); + skipLeading = 1; + s = con->setval; + i = 64; + do { + hex = 0; + do { + i -= 1; + hex = __ASHL(hex, 1); + if (__IN(i, s, 64)) { + hex += 1; + } + } while (!(__MASK(i, -8) == 0)); + if (hex != 0 || !skipLeading) { + OPM_WriteHex(hex); + skipLeading = 0; + } + } while (!(i == 0)); + if (skipLeading) { + OPM_Write('0'); + } + break; + case 8: + OPC_StringLiteral(*con->ext, 256, con->intval2 - 1); + break; + case 9: + OPM_WriteString((CHAR*)"NIL", 4); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPC.Constant, form = ", 40); + OPM_LogWNum(form, 0); + OPM_LogWLn(); + break; + } +} + +static struct InitKeywords__46 { + INT8 *n; + struct InitKeywords__46 *lnk; +} *InitKeywords__46_s; + +static void Enter__47 (CHAR *s, ADDRESS s__len); + +static void Enter__47 (CHAR *s, ADDRESS s__len) +{ + INT16 h; + __DUP(s, s__len, CHAR); + h = OPC_PerfectHash((void*)s, s__len); + OPC_hashtab[__X(h, 105)] = *InitKeywords__46_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__46_s->n, 50)], 9); + *InitKeywords__46_s->n += 1; + __DEL(s); +} + +static void OPC_InitKeywords (void) +{ + INT8 n, i; + struct InitKeywords__46 _s; + _s.n = &n; + _s.lnk = InitKeywords__46_s; + InitKeywords__46_s = &_s; + n = 0; + i = 0; + while (i <= 104) { + OPC_hashtab[__X(i, 105)] = -1; + i += 1; + } + Enter__47((CHAR*)"ADDRESS", 8); + Enter__47((CHAR*)"INT16", 6); + Enter__47((CHAR*)"INT32", 6); + Enter__47((CHAR*)"INT64", 6); + Enter__47((CHAR*)"INT8", 5); + Enter__47((CHAR*)"UINT16", 7); + Enter__47((CHAR*)"UINT32", 7); + Enter__47((CHAR*)"UINT64", 7); + Enter__47((CHAR*)"UINT8", 6); + Enter__47((CHAR*)"asm", 4); + Enter__47((CHAR*)"auto", 5); + Enter__47((CHAR*)"break", 6); + Enter__47((CHAR*)"case", 5); + Enter__47((CHAR*)"char", 5); + Enter__47((CHAR*)"const", 6); + Enter__47((CHAR*)"continue", 9); + Enter__47((CHAR*)"default", 8); + Enter__47((CHAR*)"do", 3); + Enter__47((CHAR*)"double", 7); + Enter__47((CHAR*)"else", 5); + Enter__47((CHAR*)"enum", 5); + Enter__47((CHAR*)"extern", 7); + Enter__47((CHAR*)"export", 7); + Enter__47((CHAR*)"float", 6); + Enter__47((CHAR*)"for", 4); + Enter__47((CHAR*)"fortran", 8); + Enter__47((CHAR*)"goto", 5); + Enter__47((CHAR*)"if", 3); + Enter__47((CHAR*)"import", 7); + Enter__47((CHAR*)"int", 4); + Enter__47((CHAR*)"long", 5); + Enter__47((CHAR*)"register", 9); + Enter__47((CHAR*)"return", 7); + Enter__47((CHAR*)"short", 6); + Enter__47((CHAR*)"signed", 7); + Enter__47((CHAR*)"sizeof", 7); + Enter__47((CHAR*)"size_t", 7); + Enter__47((CHAR*)"static", 7); + Enter__47((CHAR*)"struct", 7); + Enter__47((CHAR*)"switch", 7); + Enter__47((CHAR*)"typedef", 8); + Enter__47((CHAR*)"union", 6); + Enter__47((CHAR*)"unsigned", 9); + Enter__47((CHAR*)"void", 5); + Enter__47((CHAR*)"volatile", 9); + Enter__47((CHAR*)"while", 6); + InitKeywords__46_s = _s.lnk; +} + + +export void *OPC__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPT); + __REGMOD("OPC", 0); + __REGCMD("BegBlk", OPC_BegBlk); + __REGCMD("BegStat", OPC_BegStat); + __REGCMD("EndBlk", OPC_EndBlk); + __REGCMD("EndBlk0", OPC_EndBlk0); + __REGCMD("EndStat", OPC_EndStat); + __REGCMD("EnterBody", OPC_EnterBody); + __REGCMD("ExitBody", OPC_ExitBody); + __REGCMD("GenHdrIncludes", OPC_GenHdrIncludes); + __REGCMD("Init", OPC_Init); +/* BEGIN */ + OPC_InitKeywords(); + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPC.h b/bootstrap/windows-88/OPC.h new file mode 100644 index 00000000..3bfd88b8 --- /dev/null +++ b/bootstrap/windows-88/OPC.h @@ -0,0 +1,49 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPC__h +#define OPC__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPC_Andent (OPT_Struct typ); +import OPT_Object OPC_BaseTProc (OPT_Object obj); +import void OPC_BegBlk (void); +import void OPC_BegStat (void); +import void OPC_Case (INT64 caseVal, INT16 form); +import void OPC_Cmp (INT16 rel); +import void OPC_CompleteIdent (OPT_Object obj); +import void OPC_Constant (OPT_Const con, INT16 form); +import void OPC_DefineInter (OPT_Object proc); +import void OPC_EndBlk (void); +import void OPC_EndBlk0 (void); +import void OPC_EndStat (void); +import void OPC_EnterBody (void); +import void OPC_EnterProc (OPT_Object proc); +import void OPC_ExitBody (void); +import void OPC_ExitProc (OPT_Object proc, BOOLEAN eoBlock, BOOLEAN implicitRet); +import void OPC_GenBdy (OPT_Node n); +import void OPC_GenEnumPtrs (OPT_Object var); +import void OPC_GenHdr (OPT_Node n); +import void OPC_GenHdrIncludes (void); +import void OPC_Halt (INT32 n); +import void OPC_Ident (OPT_Object obj); +import void OPC_Increment (BOOLEAN decrement); +import void OPC_Indent (INT16 count); +import void OPC_Init (void); +import void OPC_InitTDesc (OPT_Struct typ); +import void OPC_IntLiteral (INT64 n, INT32 size); +import void OPC_Len (OPT_Object obj, OPT_Struct array, INT64 dim); +import BOOLEAN OPC_NeedsRetval (OPT_Object proc); +import INT32 OPC_NofPtrs (OPT_Struct typ); +import void OPC_SetInclude (BOOLEAN exclude); +import void OPC_TDescDecl (OPT_Struct typ); +import void OPC_TypeDefs (OPT_Object obj, INT16 vis); +import void OPC_TypeOf (OPT_Object ap); +import void *OPC__init(void); + + +#endif // OPC diff --git a/bootstrap/windows-88/OPM.c b/bootstrap/windows-88/OPM.c new file mode 100644 index 00000000..b486b3b9 --- /dev/null +++ b/bootstrap/windows-88/OPM.c @@ -0,0 +1,1183 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Files.h" +#include "Modules.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" +#include "Texts.h" +#include "VT100.h" + +typedef + CHAR OPM_FileName[32]; + + +static CHAR OPM_currentComment[256]; +static BOOLEAN OPM_hasComment; +static CHAR OPM_SourceFileName[256]; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static INT16 OPM_GlobalAddressSize; +export INT16 OPM_AddressSize; +static INT16 OPM_GlobalAlignment; +export INT16 OPM_Alignment; +export UINT32 OPM_GlobalOptions, OPM_Options; +export INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +export INT64 OPM_MaxIndex; +export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +export BOOLEAN OPM_noerr; +export INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +export INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +export CHAR OPM_modName[32]; +export CHAR OPM_objname[64]; +static INT32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; +static Texts_Reader OPM_inR; +static Texts_Text OPM_Log, OPM_Errors; +static Files_Rider OPM_oldSF, OPM_newSF; +static Files_Rider OPM_R[3]; +static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; +static INT16 OPM_S; +export CHAR OPM_InstallDir[1024]; +export CHAR OPM_ResourceDir[1024]; + + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F); +export void OPM_CloseFiles (void); +export void OPM_CloseOldSym (void); +export void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +export void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +export void OPM_FPrint (INT32 *fp, INT64 val); +export void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +export void OPM_FPrintReal (INT32 *fp, REAL val); +export void OPM_FPrintSet (INT32 *fp, UINT64 val); +static void OPM_FindInstallDir (void); +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos); +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len); +export void OPM_Get (CHAR *ch); +export void OPM_GetComment (CHAR *text, ADDRESS text__len); +export void OPM_Init (BOOLEAN *done); +export void OPM_InitOptions (void); +export INT16 OPM_Integer (INT64 n); +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len); +export void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +static void OPM_LogErrMsg (INT16 n); +export void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +export void OPM_LogW (CHAR ch); +export void OPM_LogWLn (void); +export void OPM_LogWNum (INT64 i, INT64 len); +export void OPM_LogWStr (CHAR *s, ADDRESS s__len); +export INT32 OPM_Longint (INT64 n); +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len); +export void OPM_Mark (INT16 n, INT32 pos); +export void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +export void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +export void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +export BOOLEAN OPM_OpenPar (void); +export void OPM_RegisterNewSym (void); +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len); +static void OPM_ShowLine (INT64 pos); +export INT64 OPM_SignedMaximum (INT32 bytecount); +export INT64 OPM_SignedMinimum (INT32 bytecount); +export void OPM_StoreComment (CHAR *text, ADDRESS text__len); +export void OPM_SymRCh (CHAR *ch); +export INT32 OPM_SymRInt (void); +export INT64 OPM_SymRInt64 (void); +export void OPM_SymRLReal (LONGREAL *lr); +export void OPM_SymRReal (REAL *r); +export void OPM_SymRSet (UINT64 *s); +export void OPM_SymWCh (CHAR ch); +export void OPM_SymWInt (INT64 i); +export void OPM_SymWLReal (LONGREAL lr); +export void OPM_SymWReal (REAL r); +export void OPM_SymWSet (UINT64 s); +export void OPM_Write (CHAR ch); +export void OPM_WriteHex (INT64 i); +export void OPM_WriteInt (INT64 i); +export void OPM_WriteLn (void); +export void OPM_WriteReal (LONGREAL r, CHAR suffx); +export void OPM_WriteString (CHAR *s, ADDRESS s__len); +export void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +export BOOLEAN OPM_eofSF (void); +export void OPM_err (INT16 n); + +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s + +void OPM_LogW (CHAR ch) +{ + Out_Char(ch); +} + +void OPM_LogWStr (CHAR *s, ADDRESS s__len) +{ + __DUP(s, s__len, CHAR); + Out_String(s, s__len); + __DEL(s); +} + +void OPM_LogWNum (INT64 i, INT64 len) +{ + Out_Int(i, len); +} + +void OPM_LogWLn (void) +{ + Out_Ln(); +} + +void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len) +{ + __DUP(vt100code, vt100code__len, CHAR); + if ((Out_IsConsole && !__IN(16, OPM_Options, 32))) { + VT100_SetAttr(vt100code, vt100code__len); + } + __DEL(vt100code); +} + +void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len) +{ + __DUP(modname, modname__len, CHAR); + OPM_LogWStr((CHAR*)"Compiling ", 11); + OPM_LogWStr(modname, modname__len); + if (__IN(18, OPM_Options, 32)) { + OPM_LogWStr((CHAR*)", s:", 5); + OPM_LogWNum(__ASHL(OPM_ShortintSize, 3), 1); + OPM_LogWStr((CHAR*)" i:", 4); + OPM_LogWNum(__ASHL(OPM_IntegerSize, 3), 1); + OPM_LogWStr((CHAR*)" l:", 4); + OPM_LogWNum(__ASHL(OPM_LongintSize, 3), 1); + OPM_LogWStr((CHAR*)" adr:", 6); + OPM_LogWNum(__ASHL(OPM_AddressSize, 3), 1); + OPM_LogWStr((CHAR*)" algn:", 7); + OPM_LogWNum(__ASHL(OPM_Alignment, 3), 1); + } + OPM_LogW('.'); + __DEL(modname); +} + +void OPM_StoreComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_currentComment[__X(i, 256)] = text[__X(i, text__len)]; + i += 1; + } + OPM_currentComment[__X(i, 256)] = 0x00; + OPM_hasComment = 1; + __DEL(text); +} + +void OPM_GetComment (CHAR *text, ADDRESS text__len) +{ + INT16 i; + if (OPM_hasComment) { + i = 0; + while ((((i < text__len && i < 256)) && OPM_currentComment[__X(i, 256)] != 0x00)) { + text[__X(i, text__len)] = OPM_currentComment[__X(i, 256)]; + i += 1; + } + text[__X(i, text__len)] = 0x00; + OPM_hasComment = 0; + } else { + text[0] = 0x00; + } +} + +INT64 OPM_SignedMaximum (INT32 bytecount) +{ + INT64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + return result - 1; +} + +INT64 OPM_SignedMinimum (INT32 bytecount) +{ + return -OPM_SignedMaximum(bytecount) - 1; +} + +INT32 OPM_Longint (INT64 n) +{ + return __VAL(INT32, n); +} + +INT16 OPM_Integer (INT64 n) +{ + return __VAL(INT16, n); +} + +static void OPM_ScanOptions (CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 1; + while (s[__X(i, s__len)] != 0x00) { + switch (s[__X(i, s__len)]) { + case 'p': + OPM_Options = OPM_Options ^ 0x20; + break; + case 'a': + OPM_Options = OPM_Options ^ 0x80; + break; + case 'r': + OPM_Options = OPM_Options ^ 0x04; + break; + case 't': + OPM_Options = OPM_Options ^ 0x08; + break; + case 'x': + OPM_Options = OPM_Options ^ 0x01; + break; + case 'e': + OPM_Options = OPM_Options ^ 0x0200; + break; + case 's': + OPM_Options = OPM_Options ^ 0x10; + break; + case 'F': + OPM_Options = OPM_Options ^ 0x020000; + break; + case 'm': + OPM_Options = OPM_Options ^ 0x0400; + break; + case 'M': + OPM_Options = OPM_Options ^ 0x8000; + break; + case 'S': + OPM_Options = OPM_Options ^ 0x2000; + break; + case 'c': + OPM_Options = OPM_Options ^ 0x4000; + break; + case 'f': + OPM_Options = OPM_Options ^ 0x010000; + break; + case 'V': + OPM_Options = OPM_Options ^ 0x040000; + break; + case 'O': + if (i + 1 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); + OPM_LogWLn(); + } else { + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); + } + i += 1; + } + break; + case 'A': + if (i + 2 >= Strings_Length(s, s__len)) { + OPM_LogWStr((CHAR*)"-M option requires two following digits.", 41); + OPM_LogWLn(); + } else { + OPM_AddressSize = (INT16)s[__X(i + 1, s__len)] - 48; + OPM_Alignment = (INT16)s[__X(i + 2, s__len)] - 48; + i += 2; + } + break; + default: + OPM_LogWStr((CHAR*)" warning: option ", 19); + OPM_LogW('-'); + OPM_LogW(s[__X(i, s__len)]); + OPM_LogWStr((CHAR*)" ignored", 9); + OPM_LogWLn(); + break; + } + i += 1; + } + __DEL(s); +} + +BOOLEAN OPM_OpenPar (void) +{ + CHAR s[256]; + if (Modules_ArgCount == 1) { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Oberon-2 compiler v", 20); + OPM_LogWStr(Configuration_versionLong, 76); + OPM_LogW('.'); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Based on Ofront by J. Templ and Software Templ OEG.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Further development by Norayr Chilingarian, David Brown and others.", 68); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Loaded from ", 13); + OPM_LogWStr(Modules_BinaryDir, 1024); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Usage:", 7); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWStr((CHAR*)"voc", 4); + OPM_LogWStr((CHAR*)" options {files {options}}.", 28); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options:", 9); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Run time safety", 18); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -p Initialise pointers to NIL. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -a Halt on assertion failures. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -r Halt on range check failures.", 39); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -t Halt on type guard failure. On by default.", 52); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -x Halt on index out of range. On by default.", 52); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Symbol file management", 25); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -e Allow extension of old symbol file.", 45); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -s Allow generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -F Force generation of new symbol file.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" C compiler and linker control", 32); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -m This module is main. Link dynamically.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -M This module is main. Link statically.", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -S Don't call C compiler", 31); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -c Don't link.", 21); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Miscellaneous", 16); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -f Disable VT100 control characters in status output.", 60); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -V Display compiler debugging messages.", 46); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Size model for elementary types (default O2)", 47); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT.", 95); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET.", 95); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" Target machine address size and alignment (default is that of the running compiler binary)", 93); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86).", 79); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm).", 97); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms).", 71); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"All options are off by default, except where noted above.", 58); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Initial options specify defaults for all files.", 48); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Options following a filename are specific to that file.", 56); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Repeating an option toggles its value.", 39); + OPM_LogWLn(); + return 0; + } else { + OPM_AddressSize = 8; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; + OPM_S = 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __MOVE(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; + return 1; + } + __RETCHK; +} + +void OPM_InitOptions (void) +{ + CHAR s[256]; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __MOVE(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + while (s[0] == '-') { + OPM_ScanOptions(s, 256); + OPM_S += 1; + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + } + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); + } + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 4; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + __MOVE(OPM_InstallDir, OPM_ResourceDir, 1024); + if (OPM_ResourceDir[0] != 0x00) { + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + } + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); +} + +void OPM_Init (BOOLEAN *done) +{ + Texts_Text T = NIL; + INT32 beg, end, time; + CHAR s[256]; + *done = 0; + OPM_curpos = 0; + if (OPM_S >= Modules_ArgCount) { + return; + } + s[0] = 0x00; + Modules_GetArg(OPM_S, (void*)s, 256); + __NEW(T, Texts_TextDesc); + Texts_Open(T, s, 256); + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" ", 3); + __COPY(s, OPM_SourceFileName, 256); + if (T->len == 0) { + OPM_LogWStr(s, 256); + OPM_LogWStr((CHAR*)" not found.", 12); + OPM_LogWLn(); + } else { + Texts_OpenReader(&OPM_inR, Texts_Reader__typ, T, 0); + *done = 1; + } + OPM_S += 1; + OPM_level = 0; + OPM_noerr = 1; + OPM_errpos = OPM_curpos; + OPM_lasterrpos = OPM_curpos - 10; + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; +} + +void OPM_Get (CHAR *ch) +{ + OPM_curpos = Texts_Pos(&OPM_inR, Texts_Reader__typ); + Texts_Read(&OPM_inR, Texts_Reader__typ, &*ch); + if ((*ch < 0x09 && !OPM_inR.eot)) { + *ch = ' '; + } +} + +static void OPM_MakeFileName (CHAR *name, ADDRESS name__len, CHAR *FName, ADDRESS FName__len, CHAR *ext, ADDRESS ext__len) +{ + INT16 i, j; + CHAR ch; + __DUP(ext, ext__len, CHAR); + i = 0; + for (;;) { + ch = name[__X(i, name__len)]; + if (ch == 0x00) { + break; + } + FName[__X(i, FName__len)] = ch; + i += 1; + } + j = 0; + do { + ch = ext[__X(j, ext__len)]; + FName[__X(i, FName__len)] = ch; + i += 1; + j += 1; + } while (!(ch == 0x00)); + __DEL(ext); +} + +static void OPM_LogErrMsg (INT16 n) +{ + INT16 l; + Texts_Scanner S; + CHAR c; + if (n >= 0) { + OPM_LogVT100((CHAR*)"31m", 4); + OPM_LogWStr((CHAR*)" err ", 7); + OPM_LogVT100((CHAR*)"0m", 3); + } else { + OPM_LogVT100((CHAR*)"35m", 4); + OPM_LogWStr((CHAR*)" warning ", 11); + n = -n; + OPM_LogVT100((CHAR*)"0m", 3); + } + OPM_LogWNum(n, 1); + OPM_LogWStr((CHAR*)" ", 3); + if (OPM_Errors == NIL) { + __NEW(OPM_Errors, Texts_TextDesc); + Texts_Open(OPM_Errors, (CHAR*)"Errors.Txt", 11); + } + Texts_OpenScanner(&S, Texts_Scanner__typ, OPM_Errors, 0); + do { + l = S.line; + Texts_Scan(&S, Texts_Scanner__typ); + } while (!((((l != S.line && S.class == 3)) && S.i == n) || S.eot)); + if (!S.eot) { + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + while ((!S.eot && c >= ' ')) { + Out_Char(c); + Texts_Read((void*)&S, Texts_Scanner__typ, &c); + } + } +} + +static void OPM_FindLine (Files_File f, Files_Rider *r, ADDRESS *r__typ, INT64 pos) +{ + CHAR ch, cheol; + if (pos < (INT64)OPM_ErrorLineStartPos) { + OPM_ErrorLineStartPos = 0; + OPM_ErrorLineLimitPos = 0; + OPM_ErrorLineNumber = 0; + } + if (pos < (INT64)OPM_ErrorLineLimitPos) { + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); + return; + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineLimitPos); + Files_Read(&*r, r__typ, (void*)&ch); + while (((INT64)OPM_ErrorLineLimitPos < pos && !(*r).eof)) { + OPM_ErrorLineStartPos = OPM_ErrorLineLimitPos; + OPM_ErrorLineNumber += 1; + while ((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) { + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + } + cheol = ch; + Files_Read(&*r, r__typ, (void*)&ch); + OPM_ErrorLineLimitPos += 1; + if ((cheol == 0x0d && ch == 0x0a)) { + OPM_ErrorLineLimitPos += 1; + Files_Read(&*r, r__typ, (void*)&ch); + } + } + Files_Set(&*r, r__typ, f, OPM_ErrorLineStartPos); +} + +static void OPM_ShowLine (INT64 pos) +{ + Files_File f = NIL; + Files_Rider r; + CHAR line[1023]; + INT16 i; + CHAR ch; + f = Files_Old(OPM_SourceFileName, 256); + OPM_FindLine(f, &r, Files_Rider__typ, pos); + i = 0; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + while ((((((ch != 0x00 && ch != 0x0d)) && ch != 0x0a)) && i < 1022)) { + line[__X(i, 1023)] = ch; + i += 1; + Files_Read(&r, Files_Rider__typ, (void*)&ch); + } + line[__X(i, 1023)] = 0x00; + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWNum(OPM_ErrorLineNumber, 4); + OPM_LogWStr((CHAR*)": ", 3); + OPM_LogWStr(line, 1023); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 7); + if (pos >= (INT64)OPM_ErrorLineLimitPos) { + pos = OPM_ErrorLineLimitPos - 1; + } + i = __SHORTF(OPM_Longint(pos - (INT64)OPM_ErrorLineStartPos), 32768); + while (i > 0) { + OPM_LogW(' '); + i -= 1; + } + OPM_LogVT100((CHAR*)"32m", 4); + OPM_LogW('^'); + OPM_LogVT100((CHAR*)"0m", 3); +} + +void OPM_Mark (INT16 n, INT32 pos) +{ + if (pos == -1) { + pos = 0; + } + if (n >= 0) { + OPM_noerr = 0; + if (pos < OPM_lasterrpos || OPM_lasterrpos + 9 < pos) { + OPM_lasterrpos = pos; + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" ", 3); + if (n < 249) { + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + OPM_LogErrMsg(n); + } else if (n == 255) { + OPM_LogWStr((CHAR*)"pos", 4); + OPM_LogWNum(pos, 6); + OPM_LogWStr((CHAR*)" pc ", 6); + OPM_LogWNum(OPM_breakpc, 1); + } else if (n == 254) { + OPM_LogWStr((CHAR*)"pc not found", 13); + } else { + OPM_LogWStr(OPM_objname, 64); + if (n == 253) { + OPM_LogWStr((CHAR*)" is new, compile with option e", 31); + } else if (n == 252) { + OPM_LogWStr((CHAR*)" is redefined, compile with option s", 37); + } else if (n == 251) { + OPM_LogWStr((CHAR*)" is redefined (private part only), compile with option s", 57); + } else if (n == 250) { + OPM_LogWStr((CHAR*)" is no longer visible, compile with option s", 45); + } else if (n == 249) { + OPM_LogWStr((CHAR*)" is not consistently imported, recompile imports", 49); + } + } + } + } else { + if (pos >= 0) { + OPM_ShowLine(pos); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" pos", 6); + OPM_LogWNum(pos, 6); + } + OPM_LogErrMsg(n); + if (pos < 0) { + OPM_LogWLn(); + } + } +} + +void OPM_err (INT16 n) +{ + OPM_Mark(n, OPM_errpos); +} + +static void OPM_FingerprintBytes (INT32 *fp, SYSTEM_BYTE *bytes, ADDRESS bytes__len) +{ + INT16 i; + INT32 l; + __ASSERT(__MASK(bytes__len, -4) == 0, 0); + i = 0; + while (i < bytes__len) { + __GET((ADDRESS)&bytes[__X(i, bytes__len)], l, INT32); + *fp = __ROTL((INT32)((UINT32)*fp ^ (UINT32)l), 1, 32); + i += 4; + } +} + +void OPM_FPrint (INT32 *fp, INT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintSet (INT32 *fp, UINT64 val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_FPrintReal (INT32 *fp, REAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 4); +} + +void OPM_FPrintLReal (INT32 *fp, LONGREAL val) +{ + OPM_FingerprintBytes(&*fp, (void*)&val, 8); +} + +void OPM_SymRCh (CHAR *ch) +{ + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); +} + +INT32 OPM_SymRInt (void) +{ + INT32 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 4); + return k; +} + +INT64 OPM_SymRInt64 (void) +{ + INT64 k; + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&k, 8); + return k; +} + +void OPM_SymRSet (UINT64 *s) +{ + Files_ReadNum(&OPM_oldSF, Files_Rider__typ, (void*)&*s, 8); +} + +void OPM_SymRReal (REAL *r) +{ + Files_ReadReal(&OPM_oldSF, Files_Rider__typ, &*r); +} + +void OPM_SymRLReal (LONGREAL *lr) +{ + Files_ReadLReal(&OPM_oldSF, Files_Rider__typ, &*lr); +} + +void OPM_CloseOldSym (void) +{ + Files_Close(Files_Base(&OPM_oldSF, Files_Rider__typ)); +} + +void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done) +{ + CHAR tag, ver; + OPM_FileName fileName; + INT16 res; + OPM_oldSFile = NIL; + *done = 0; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_oldSFile = Files_Old(fileName, 32); + *done = OPM_oldSFile != NIL; + if (*done) { + Files_Set(&OPM_oldSF, Files_Rider__typ, OPM_oldSFile, 0); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&tag); + Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&ver); + if (tag != 0xf7 || ver != 0x84) { + if (!__IN(4, OPM_Options, 32)) { + OPM_err(-306); + } + OPM_CloseOldSym(); + *done = 0; + } + } +} + +BOOLEAN OPM_eofSF (void) +{ + return OPM_oldSF.eof; +} + +void OPM_SymWCh (CHAR ch) +{ + Files_Write(&OPM_newSF, Files_Rider__typ, ch); +} + +void OPM_SymWInt (INT64 i) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, i); +} + +void OPM_SymWSet (UINT64 s) +{ + Files_WriteNum(&OPM_newSF, Files_Rider__typ, (INT64)s); +} + +void OPM_SymWReal (REAL r) +{ + Files_WriteReal(&OPM_newSF, Files_Rider__typ, r); +} + +void OPM_SymWLReal (LONGREAL lr) +{ + Files_WriteLReal(&OPM_newSF, Files_Rider__typ, lr); +} + +void OPM_RegisterNewSym (void) +{ + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { + Files_Register(OPM_newSFile); + } +} + +void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".sym", 5); + Files_Delete(fn, 32, &res); +} + +void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len) +{ + OPM_FileName fn; + INT16 res; + OPM_MakeFileName((void*)modulename, modulename__len, (void*)fn, 32, (CHAR*)".o", 3); + Files_Delete(fn, 32, &res); +} + +void OPM_NewSym (CHAR *modName, ADDRESS modName__len) +{ + OPM_FileName fileName; + OPM_MakeFileName((void*)modName, modName__len, (void*)fileName, 32, (CHAR*)".sym", 5); + OPM_newSFile = Files_New(fileName, 32); + if (OPM_newSFile != NIL) { + Files_Set(&OPM_newSF, Files_Rider__typ, OPM_newSFile, 0); + Files_Write(&OPM_newSF, Files_Rider__typ, 0xf7); + Files_Write(&OPM_newSF, Files_Rider__typ, 0x84); + } else { + OPM_err(153); + } +} + +void OPM_Write (CHAR ch) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, ch); +} + +void OPM_WriteString (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteStringVar (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + i += 1; + } + Files_WriteBytes(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, (void*)s, s__len * 1, i); +} + +void OPM_WriteHex (INT64 i) +{ + CHAR s[3]; + INT32 digit; + digit = __ASHR(__SHORT(i, 2147483648LL), 4); + if (digit < 10) { + s[0] = __CHR(48 + digit); + } else { + s[0] = __CHR(87 + digit); + } + digit = __MASK(__SHORT(i, 2147483648LL), -16); + if (digit < 10) { + s[1] = __CHR(48 + digit); + } else { + s[1] = __CHR(87 + digit); + } + s[2] = 0x00; + OPM_WriteString(s, 3); +} + +void OPM_WriteInt (INT64 i) +{ + CHAR s[26]; + INT64 i1, k; + if ((i == OPM_SignedMinimum(2) || i == OPM_SignedMinimum(4)) || i == OPM_SignedMinimum(8)) { + OPM_Write('('); + OPM_WriteInt(i + 1); + OPM_WriteString((CHAR*)"-1)", 4); + } else { + i1 = __ABS(i); + if (i1 <= 2147483647) { + k = 0; + } else { + __MOVE("LL", s, 3); + k = 2; + } + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + while (i1 > 0) { + s[__X(k, 26)] = __CHR(__MOD(i1, 10) + 48); + i1 = __DIV(i1, 10); + k += 1; + } + if (i < 0) { + s[__X(k, 26)] = '-'; + k += 1; + } + while (k > 0) { + k -= 1; + OPM_Write(s[__X(k, 26)]); + } + } +} + +void OPM_WriteReal (LONGREAL r, CHAR suffx) +{ + Texts_Writer W; + Texts_Text T = NIL; + Texts_Reader R; + CHAR s[32]; + CHAR ch; + INT16 i; + if ((((r < OPM_SignedMaximum(OPM_LongintSize) && r > OPM_SignedMinimum(OPM_LongintSize))) && r == (__SHORT(__ENTIER(r), 2147483648LL)))) { + if (suffx == 'f') { + OPM_WriteString((CHAR*)"(REAL)", 7); + } else { + OPM_WriteString((CHAR*)"(LONGREAL)", 11); + } + OPM_WriteInt(__SHORT(__ENTIER(r), 2147483648LL)); + } else { + Texts_OpenWriter(&W, Texts_Writer__typ); + if (suffx == 'f') { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 16); + } else { + Texts_WriteLongReal(&W, Texts_Writer__typ, r, 23); + } + __NEW(T, Texts_TextDesc); + Texts_Open(T, (CHAR*)"", 1); + Texts_Append(T, W.buf); + Texts_OpenReader(&R, Texts_Reader__typ, T, 0); + i = 0; + Texts_Read(&R, Texts_Reader__typ, &ch); + while (ch != 0x00) { + s[__X(i, 32)] = ch; + i += 1; + Texts_Read(&R, Texts_Reader__typ, &ch); + } + s[__X(i, 32)] = 0x00; + i = 0; + ch = s[0]; + while ((ch != 'D' && ch != 0x00)) { + i += 1; + ch = s[__X(i, 32)]; + } + if (ch == 'D') { + s[__X(i, 32)] = 'e'; + } + OPM_WriteString(s, 32); + } +} + +void OPM_WriteLn (void) +{ + Files_Write(&OPM_R[__X(OPM_currFile, 3)], Files_Rider__typ, 0x0a); +} + +static void OPM_Append (Files_Rider *R, ADDRESS *R__typ, Files_File F) +{ + Files_Rider R1; + CHAR buffer[4096]; + if (F != NIL) { + Files_Set(&R1, Files_Rider__typ, F, 0); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + while (4096 - R1.res > 0) { + Files_WriteBytes(&*R, R__typ, (void*)buffer, 4096, 4096 - R1.res); + Files_ReadBytes(&R1, Files_Rider__typ, (void*)buffer, 4096, 4096); + } + } +} + +void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len) +{ + OPM_FileName FName; + __COPY(moduleName, OPM_modName, 32); + OPM_HFile = Files_New((CHAR*)"", 1); + if (OPM_HFile != NIL) { + Files_Set(&OPM_R[0], Files_Rider__typ, OPM_HFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".c", 3); + OPM_BFile = Files_New(FName, 32); + if (OPM_BFile != NIL) { + Files_Set(&OPM_R[1], Files_Rider__typ, OPM_BFile, 0); + } else { + OPM_err(153); + } + OPM_MakeFileName((void*)moduleName, moduleName__len, (void*)FName, 32, (CHAR*)".h", 3); + OPM_HIFile = Files_New(FName, 32); + if (OPM_HIFile != NIL) { + Files_Set(&OPM_R[2], Files_Rider__typ, OPM_HIFile, 0); + } else { + OPM_err(153); + } +} + +void OPM_CloseFiles (void) +{ + OPM_FileName FName; + INT16 res; + if (OPM_noerr) { + OPM_LogWStr((CHAR*)" ", 3); + OPM_LogWNum(Files_Pos(&OPM_R[1], Files_Rider__typ), 0); + OPM_LogWStr((CHAR*)" chars.", 8); + } + if (OPM_noerr) { + if (__STRCMP(OPM_modName, "SYSTEM") == 0) { + if (!__IN(10, OPM_Options, 32)) { + Files_Register(OPM_BFile); + } + } else if (!__IN(10, OPM_Options, 32)) { + OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); + Files_Register(OPM_HIFile); + Files_Register(OPM_BFile); + } else { + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".h", 3); + Files_Delete(FName, 32, &res); + OPM_MakeFileName((void*)OPM_modName, 32, (void*)FName, 32, (CHAR*)".sym", 5); + Files_Delete(FName, 32, &res); + Files_Register(OPM_BFile); + } + } + OPM_HFile = NIL; + OPM_BFile = NIL; + OPM_HIFile = NIL; + OPM_newSFile = NIL; + OPM_oldSFile = NIL; + Files_Set(&OPM_R[0], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[1], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_R[2], Files_Rider__typ, NIL, 0); + Files_Set(&OPM_newSF, Files_Rider__typ, NIL, 0); + Files_Set(&OPM_oldSF, Files_Rider__typ, NIL, 0); +} + +static BOOLEAN OPM_IsProbablyInstallDir (CHAR *s, ADDRESS s__len) +{ + CHAR testpath[4096]; + Platform_FileIdentity identity; + __DUP(s, s__len, CHAR); + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/lib/lib", 9, (void*)testpath, 4096); + Strings_Append((CHAR*)"voc", 4, (void*)testpath, 4096); + Strings_Append((CHAR*)"-O2.a", 6, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/include/Oberon.h", 20, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __COPY(OPM_InstallDir, testpath, 4096); + Strings_Append((CHAR*)"/2/sym/Files.sym", 17, (void*)testpath, 4096); + if (Platform_IdentifyByName(testpath, 4096, &identity, Platform_FileIdentity__typ) != 0) { + __DEL(s); + return 0; + } + __DEL(s); + return 1; +} + +static void OPM_FindInstallDir (void) +{ + INT16 i; + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + Strings_Append((CHAR*)"/", 2, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)"voc", 4, (void*)OPM_InstallDir, 1024); + Strings_Append((CHAR*)".d", 3, (void*)OPM_InstallDir, 1024); + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + __COPY(Modules_BinaryDir, OPM_InstallDir, 1024); + i = Strings_Length(OPM_InstallDir, 1024); + while ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] != '/')) { + i -= 1; + } + if ((i > 0 && OPM_InstallDir[__X(i - 1, 1024)] == '/')) { + OPM_InstallDir[__X(i - 1, 1024)] = 0x00; + if (OPM_IsProbablyInstallDir(OPM_InstallDir, 1024)) { + return; + } + } + __COPY("", OPM_InstallDir, 1024); +} + +static void EnumPtrs(void (*P)(void*)) +{ + __ENUMR(&OPM_inR, Texts_Reader__typ, 72, 1, P); + P(OPM_Log); + P(OPM_Errors); + __ENUMR(&OPM_oldSF, Files_Rider__typ, 24, 1, P); + __ENUMR(&OPM_newSF, Files_Rider__typ, 24, 1, P); + __ENUMR(OPM_R, Files_Rider__typ, 24, 3, P); + P(OPM_oldSFile); + P(OPM_newSFile); + P(OPM_HFile); + P(OPM_BFile); + P(OPM_HIFile); +} + + +export void *OPM__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __MODULE_IMPORT(Texts); + __MODULE_IMPORT(VT100); + __REGMOD("OPM", EnumPtrs); + __REGCMD("CloseFiles", OPM_CloseFiles); + __REGCMD("CloseOldSym", OPM_CloseOldSym); + __REGCMD("InitOptions", OPM_InitOptions); + __REGCMD("LogWLn", OPM_LogWLn); + __REGCMD("RegisterNewSym", OPM_RegisterNewSym); + __REGCMD("WriteLn", OPM_WriteLn); +/* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; + OPM_FindInstallDir(); + OPM_hasComment = 0; + OPM_currentComment[0] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPM.h b/bootstrap/windows-88/OPM.h new file mode 100644 index 00000000..64c15a28 --- /dev/null +++ b/bootstrap/windows-88/OPM.h @@ -0,0 +1,76 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPM__h +#define OPM__h + +#include "SYSTEM.h" + + +import CHAR OPM_Model[10]; +import INT16 OPM_AddressSize, OPM_Alignment; +import UINT32 OPM_GlobalOptions, OPM_Options; +import INT16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize; +import INT64 OPM_MaxIndex; +import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; +import BOOLEAN OPM_noerr; +import INT32 OPM_curpos, OPM_errpos, OPM_breakpc; +import INT16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; +import CHAR OPM_modName[32]; +import CHAR OPM_objname[64]; +import CHAR OPM_InstallDir[1024]; +import CHAR OPM_ResourceDir[1024]; + + +import void OPM_CloseFiles (void); +import void OPM_CloseOldSym (void); +import void OPM_DeleteObj (CHAR *modulename, ADDRESS modulename__len); +import void OPM_DeleteSym (CHAR *modulename, ADDRESS modulename__len); +import void OPM_FPrint (INT32 *fp, INT64 val); +import void OPM_FPrintLReal (INT32 *fp, LONGREAL val); +import void OPM_FPrintReal (INT32 *fp, REAL val); +import void OPM_FPrintSet (INT32 *fp, UINT64 val); +import void OPM_Get (CHAR *ch); +import void OPM_GetComment (CHAR *text, ADDRESS text__len); +import void OPM_Init (BOOLEAN *done); +import void OPM_InitOptions (void); +import INT16 OPM_Integer (INT64 n); +import void OPM_LogCompiling (CHAR *modname, ADDRESS modname__len); +import void OPM_LogVT100 (CHAR *vt100code, ADDRESS vt100code__len); +import void OPM_LogW (CHAR ch); +import void OPM_LogWLn (void); +import void OPM_LogWNum (INT64 i, INT64 len); +import void OPM_LogWStr (CHAR *s, ADDRESS s__len); +import INT32 OPM_Longint (INT64 n); +import void OPM_Mark (INT16 n, INT32 pos); +import void OPM_NewSym (CHAR *modName, ADDRESS modName__len); +import void OPM_OldSym (CHAR *modName, ADDRESS modName__len, BOOLEAN *done); +import void OPM_OpenFiles (CHAR *moduleName, ADDRESS moduleName__len); +import BOOLEAN OPM_OpenPar (void); +import void OPM_RegisterNewSym (void); +import INT64 OPM_SignedMaximum (INT32 bytecount); +import INT64 OPM_SignedMinimum (INT32 bytecount); +import void OPM_StoreComment (CHAR *text, ADDRESS text__len); +import void OPM_SymRCh (CHAR *ch); +import INT32 OPM_SymRInt (void); +import INT64 OPM_SymRInt64 (void); +import void OPM_SymRLReal (LONGREAL *lr); +import void OPM_SymRReal (REAL *r); +import void OPM_SymRSet (UINT64 *s); +import void OPM_SymWCh (CHAR ch); +import void OPM_SymWInt (INT64 i); +import void OPM_SymWLReal (LONGREAL lr); +import void OPM_SymWReal (REAL r); +import void OPM_SymWSet (UINT64 s); +import void OPM_Write (CHAR ch); +import void OPM_WriteHex (INT64 i); +import void OPM_WriteInt (INT64 i); +import void OPM_WriteLn (void); +import void OPM_WriteReal (LONGREAL r, CHAR suffx); +import void OPM_WriteString (CHAR *s, ADDRESS s__len); +import void OPM_WriteStringVar (CHAR *s, ADDRESS s__len); +import BOOLEAN OPM_eofSF (void); +import void OPM_err (INT16 n); +import void *OPM__init(void); + + +#endif // OPM diff --git a/bootstrap/windows-88/OPP.c b/bootstrap/windows-88/OPP.c new file mode 100644 index 00000000..3fed2e31 --- /dev/null +++ b/bootstrap/windows-88/OPP.c @@ -0,0 +1,1881 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPB.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +struct OPP__1 { + INT32 low, high; +}; + +typedef + struct OPP__1 OPP_CaseTable[128]; + + +static INT8 OPP_sym, OPP_level; +static INT16 OPP_LoopLevel; +static OPT_Node OPP_TDinit, OPP_lastTDinit; +static INT16 OPP_nofFwdPtr; +static OPT_Struct OPP_FwdPtr[64]; + +export ADDRESS *OPP__1__typ; + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar); +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq); +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab); +static void OPP_CheckMark (INT8 *vis); +static void OPP_CheckSym (INT16 s); +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_); +static void OPP_ConstExpression (OPT_Node *x); +static void OPP_Element (OPT_Node *x); +static void OPP_Expression (OPT_Node *x); +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b); +static void OPP_Factor (OPT_Node *x); +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp); +export void OPP_Module (OPT_Node *prog, UINT32 opt); +static void OPP_PointerType (OPT_Struct *typ); +static void OPP_ProcedureDeclaration (OPT_Node *x); +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec); +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_Sets (OPT_Node *x); +static void OPP_SimpleExpression (OPT_Node *x); +static void OPP_StandProcCall (OPT_Node *x); +static void OPP_StatSeq (OPT_Node *stat); +static void OPP_Term (OPT_Node *x); +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned); +static void OPP_err (INT16 n); +static void OPP_qualident (OPT_Object *id); +static void OPP_selector (OPT_Node *x); + + +static void OPP_err (INT16 n) +{ + OPM_err(n); +} + +static void OPP_CheckSym (INT16 s) +{ + if ((INT16)OPP_sym == s) { + OPS_Get(&OPP_sym); + } else { + OPM_err(s); + } +} + +static void OPP_qualident (OPT_Object *id) +{ + OPT_Object obj = NIL; + INT8 lev; + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if ((((OPP_sym == 18 && obj != NIL)) && obj->mode == 11)) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPT_FindImport(obj, &obj); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + obj = NIL; + } + } + if (obj == NIL) { + OPP_err(0); + obj = OPT_NewObj(); + obj->mode = 1; + obj->typ = OPT_undftyp; + obj->adr = 0; + } else { + lev = obj->mnolev; + if ((__IN(obj->mode, 0x06, 32) && lev != OPP_level)) { + obj->leaf = 0; + if (lev > 0) { + OPB_StaticLink(OPP_level - lev); + } + } + } + *id = obj; +} + +static void OPP_ConstExpression (OPT_Node *x) +{ + OPP_Expression(&*x); + if ((*x)->class != 7) { + OPP_err(50); + *x = OPB_NewIntConst(1); + } +} + +static void OPP_CheckMark (INT8 *vis) +{ + OPS_Get(&OPP_sym); + if (OPP_sym == 1 || OPP_sym == 7) { + if (OPP_level > 0) { + OPP_err(47); + } + if (OPP_sym == 1) { + *vis = 1; + } else { + *vis = 2; + } + OPS_Get(&OPP_sym); + } else { + *vis = 0; + } +} + +static void OPP_CheckSysFlag (INT16 *sysflag, INT16 default_) +{ + OPT_Node x = NIL; + INT64 sf; + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + if (!OPT_SYSimported) { + OPP_err(135); + } + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + sf = x->conval->intval; + if (sf < 0 || sf > 1) { + OPP_err(220); + sf = 0; + } + } else { + OPP_err(51); + sf = 0; + } + *sysflag = OPM_Integer(sf); + OPP_CheckSym(23); + } else { + *sysflag = default_; + } +} + +static void OPP_RecordType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object fld = NIL, first = NIL, last = NIL, base = NIL; + OPT_Struct ftyp = NIL; + INT16 sysflag; + *typ = OPT_NewStr(13, 4); + (*typ)->BaseTyp = NIL; + OPP_CheckSysFlag(&sysflag, -1); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&base); + if ((base->mode == 5 && base->typ->comp == 4)) { + if (base->typ == *banned) { + OPP_err(58); + } else { + base->typ->pvused = 1; + (*typ)->BaseTyp = base->typ; + (*typ)->extlev = base->typ->extlev + 1; + (*typ)->sysflag = base->typ->sysflag; + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } + if (sysflag >= 0) { + (*typ)->sysflag = sysflag; + } + OPT_OpenScope(0, NIL); + first = NIL; + last = NIL; + for (;;) { + if (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + if ((*typ)->BaseTyp != NIL) { + OPT_FindField(OPS_name, (*typ)->BaseTyp, &fld); + if (fld != NIL) { + OPP_err(1); + } + } + OPT_Insert(OPS_name, &fld); + OPP_CheckMark(&fld->vis); + fld->mode = 4; + fld->link = NIL; + fld->typ = OPT_undftyp; + if (first == NIL) { + first = fld; + } + if (last == NIL) { + (*typ)->link = fld; + } else { + last->link = fld; + } + last = fld; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&ftyp, &*banned); + ftyp->pvused = 1; + if (ftyp->comp == 3) { + ftyp = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = ftyp; + first = first->link; + } + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + OPT_CloseScope(); +} + +static void OPP_ArrayType (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Node x = NIL; + INT64 n; + INT16 sysflag; + OPP_CheckSysFlag(&sysflag, 0); + if (OPP_sym == 25) { + *typ = OPT_NewStr(13, 3); + (*typ)->mno = 0; + (*typ)->sysflag = sysflag; + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + } else { + *typ = OPT_NewStr(13, 2); + (*typ)->sysflag = sysflag; + OPP_ConstExpression(&x); + if (x->typ->form == 4) { + n = x->conval->intval; + if (n <= 0 || n > OPM_MaxIndex) { + OPP_err(63); + n = 1; + } + } else { + OPP_err(51); + n = 1; + } + (*typ)->n = OPM_Longint(n); + if (OPP_sym == 25) { + OPS_Get(&OPP_sym); + OPP_Type(&(*typ)->BaseTyp, &*banned); + (*typ)->BaseTyp->pvused = 1; + } else if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + if (OPP_sym != 25) { + OPP_ArrayType(&(*typ)->BaseTyp, &*banned); + } + } else { + OPP_err(35); + } + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(88); + } + } +} + +static void OPP_PointerType (OPT_Struct *typ) +{ + OPT_Object id = NIL; + *typ = OPT_NewStr(11, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + OPP_CheckSym(28); + if (OPP_sym == 38) { + OPT_Find(&id); + if (id == NIL) { + if (OPP_nofFwdPtr < 64) { + OPP_FwdPtr[__X(OPP_nofFwdPtr, 64)] = *typ; + OPP_nofFwdPtr += 1; + } else { + OPP_err(224); + } + (*typ)->link = OPT_NewObj(); + __COPY(OPS_name, (*typ)->link->name, 256); + (*typ)->BaseTyp = OPT_undftyp; + OPS_Get(&OPP_sym); + } else { + OPP_qualident(&id); + if (id->mode == 5) { + if (__IN(id->typ->comp, 0x1c, 32)) { + (*typ)->BaseTyp = id->typ; + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } else { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(52); + } + } + } else { + OPP_Type(&(*typ)->BaseTyp, &OPT_notyp); + if (!__IN((*typ)->BaseTyp->comp, 0x1c, 32)) { + (*typ)->BaseTyp = OPT_undftyp; + OPP_err(57); + } + } +} + +static void OPP_FormalParameters (OPT_Object *firstPar, OPT_Struct *resTyp) +{ + INT8 mode; + OPT_Object par = NIL, first = NIL, last = NIL, res = NIL; + OPT_Struct typ = NIL; + first = NIL; + last = *firstPar; + if (OPP_sym == 38 || OPP_sym == 60) { + for (;;) { + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + mode = 2; + } else { + mode = 1; + } + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &par); + OPS_Get(&OPP_sym); + par->mode = mode; + par->link = NIL; + if (first == NIL) { + first = par; + } + if (*firstPar == NIL) { + *firstPar = par; + } else { + last->link = par; + } + last = par; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else if (OPP_sym == 60) { + OPP_err(19); + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + if (((typ->comp == 2 || typ->comp == 4) && typ->strobj == NIL)) { + OPP_err(-309); + } + if (mode == 1) { + typ->pvused = 1; + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(39); + } else { + break; + } + } + } + OPP_CheckSym(22); + if (OPP_sym == 20) { + OPS_Get(&OPP_sym); + *resTyp = OPT_undftyp; + if (OPP_sym == 38) { + OPP_qualident(&res); + if (res->mode == 5) { + if (res->typ->form < 13) { + *resTyp = res->typ; + } else { + OPP_err(54); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + *resTyp = OPT_notyp; + } +} + +static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) +{ + OPT_Object id = NIL; + *typ = OPT_undftyp; + if (OPP_sym < 30) { + OPP_err(12); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + if (id->mode == 5) { + if (id->typ == *banned) { + OPP_err(58); + } else { + *typ = id->typ; + } + } else { + OPP_err(52); + } + } else if (OPP_sym == 54) { + OPS_Get(&OPP_sym); + OPP_ArrayType(&*typ, &*banned); + } else if (OPP_sym == 55) { + OPS_Get(&OPP_sym); + OPP_RecordType(&*typ, &*banned); + OPB_Inittd(&OPP_TDinit, &OPP_lastTDinit, *typ); + OPP_CheckSym(41); + } else if (OPP_sym == 56) { + OPS_Get(&OPP_sym); + OPP_PointerType(&*typ); + } else if (OPP_sym == 61) { + OPS_Get(&OPP_sym); + *typ = OPT_NewStr(12, 1); + OPP_CheckSysFlag(&(*typ)->sysflag, 0); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPT_OpenScope(OPP_level, NIL); + OPP_FormalParameters(&(*typ)->link, &(*typ)->BaseTyp); + OPT_CloseScope(); + } else { + (*typ)->BaseTyp = OPT_notyp; + (*typ)->link = NIL; + } + } else { + OPP_err(12); + } + for (;;) { + if (((OPP_sym >= 39 && OPP_sym <= 42) || OPP_sym == 22) || OPP_sym == 64) { + break; + } + OPP_err(15); + if (OPP_sym == 38) { + break; + } + OPS_Get(&OPP_sym); + } +} + +static void OPP_Type (OPT_Struct *typ, OPT_Struct *banned) +{ + OPP_TypeDecl(&*typ, &*banned); + if (((((*typ)->form == 11 && (*typ)->BaseTyp == OPT_undftyp)) && (*typ)->strobj == NIL)) { + OPP_err(0); + } +} + +static void OPP_selector (OPT_Node *x) +{ + OPT_Object obj = NIL, proc = NIL; + OPT_Node y = NIL; + OPT_Struct typ = NIL; + OPS_Name name; + for (;;) { + if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + for (;;) { + if (((*x)->typ != NIL && (*x)->typ->form == 11)) { + OPB_DeRef(&*x); + } + OPP_Expression(&y); + OPB_Index(&*x, y); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + OPP_CheckSym(23); + } else if (OPP_sym == 18) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __MOVE(OPS_name, name, 256); + OPS_Get(&OPP_sym); + if ((*x)->typ != NIL) { + if ((*x)->typ->form == 11) { + OPB_DeRef(&*x); + } + if ((*x)->typ->comp == 4) { + OPT_FindField(name, (*x)->typ, &obj); + OPB_Field(&*x, obj); + if ((obj != NIL && obj->mode == 13)) { + if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + y = (*x)->left; + if (y->class == 3) { + y = y->left; + } + if (y->obj != NIL) { + proc = OPT_topScope; + while ((proc->link != NIL && proc->link->mode != 13)) { + proc = proc->left; + } + if (proc->link == NIL || proc->link->link != y->obj) { + OPP_err(75); + } + typ = y->obj->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField((*x)->obj->name, typ->BaseTyp, &proc); + if (proc != NIL) { + (*x)->subcl = 1; + } else { + OPP_err(74); + } + } else { + OPP_err(75); + } + } + if ((obj->typ != OPT_notyp && OPP_sym != 30)) { + OPP_err(30); + } + } + } else { + OPP_err(53); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else if (OPP_sym == 17) { + OPS_Get(&OPP_sym); + OPB_DeRef(&*x); + } else if ((((((OPP_sym == 30 && (*x)->class < 7)) && (*x)->typ->form != 12)) && ((*x)->obj == NIL || (*x)->obj->mode != 13))) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 1); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + } else { + break; + } + } +} + +static void OPP_ActualParameters (OPT_Node *aparlist, OPT_Object fpar) +{ + OPT_Node apar = NIL, last = NIL; + *aparlist = NIL; + last = NIL; + if (OPP_sym != 22) { + for (;;) { + OPP_Expression(&apar); + if (fpar != NIL) { + OPB_Param(apar, fpar); + OPB_Link(&*aparlist, &last, apar); + fpar = fpar->link; + } else { + OPP_err(64); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + } + if (fpar != NIL) { + OPP_err(65); + } +} + +static void OPP_StandProcCall (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 m; + INT16 n; + m = __SHORT(__SHORT((*x)->obj->adr, 32768), 128); + n = 0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + if (OPP_sym != 22) { + for (;;) { + if (n == 0) { + OPP_Expression(&*x); + OPB_StPar0(&*x, m); + n = 1; + } else if (n == 1) { + OPP_Expression(&y); + OPB_StPar1(&*x, y, m); + n = 2; + } else { + OPP_Expression(&y); + OPB_StParN(&*x, y, m, n); + n += 1; + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(22); + } else { + OPS_Get(&OPP_sym); + } + OPB_StFct(&*x, m, n); + } else { + OPP_err(30); + } + if ((OPP_level > 0 && (m == 1 || m == 30))) { + OPT_topScope->link->leaf = 0; + } +} + +static void OPP_Element (OPT_Node *x) +{ + OPT_Node y = NIL; + OPP_Expression(&*x); + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_SetRange(&*x, y); + } else { + OPB_SetElem(&*x); + } +} + +static void OPP_Sets (OPT_Node *x) +{ + OPT_Node y = NIL; + if (OPP_sym != 24) { + OPP_Element(&*x); + for (;;) { + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if ((30 <= OPP_sym && OPP_sym <= 38)) { + OPP_err(19); + } else { + break; + } + OPP_Element(&y); + OPB_Op(6, &*x, y); + } + } else { + *x = OPB_EmptySet(); + } + OPP_CheckSym(24); +} + +static void OPP_Factor (OPT_Node *x) +{ + OPT_Object fpar = NIL, id = NIL; + OPT_Node apar = NIL; + if (OPP_sym < 30) { + OPP_err(13); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 30)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + *x = OPB_NewLeaf(id); + OPP_selector(&*x); + if (((*x)->class == 9 && (*x)->obj->mode == 8)) { + OPP_StandProcCall(&*x); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPB_PrepCall(&*x, &fpar); + OPP_ActualParameters(&apar, fpar); + OPB_Call(&*x, apar, fpar); + OPP_CheckSym(22); + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + } else if (OPP_sym == 35) { + switch (OPS_numtyp) { + case 1: + *x = OPB_NewIntConst(OPS_intval); + (*x)->typ = OPT_chartyp; + break; + case 2: + *x = OPB_NewIntConst(OPS_intval); + break; + case 3: + *x = OPB_NewRealConst(OPS_realval, OPT_realtyp); + break; + case 4: + *x = OPB_NewRealConst(OPS_lrlval, OPT_lrltyp); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPP.Factor, OPS.numtyp = ", 44); + OPM_LogWNum(OPS_numtyp, 0); + OPM_LogWLn(); + break; + } + OPS_Get(&OPP_sym); + } else if (OPP_sym == 37) { + *x = OPB_NewString(OPS_str, OPS_intval); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 36) { + *x = OPB_Nil(); + OPS_Get(&OPP_sym); + } else if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 31) { + OPS_Get(&OPP_sym); + OPP_err(30); + OPP_Expression(&*x); + OPP_CheckSym(22); + } else if (OPP_sym == 32) { + OPS_Get(&OPP_sym); + OPP_Sets(&*x); + } else if (OPP_sym == 33) { + OPS_Get(&OPP_sym); + OPP_Factor(&*x); + OPB_MOp(33, &*x); + } else { + OPP_err(13); + OPS_Get(&OPP_sym); + *x = NIL; + } + if (*x == NIL) { + *x = OPB_NewIntConst(1); + (*x)->typ = OPT_undftyp; + } +} + +static void OPP_Term (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 mulop; + OPP_Factor(&*x); + while ((1 <= OPP_sym && OPP_sym <= 5)) { + mulop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Factor(&y); + OPB_Op(mulop, &*x, y); + } +} + +static void OPP_SimpleExpression (OPT_Node *x) +{ + OPT_Node y = NIL; + INT8 addop; + if (OPP_sym == 7) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(7, &*x); + } else if (OPP_sym == 6) { + OPS_Get(&OPP_sym); + OPP_Term(&*x); + OPB_MOp(6, &*x); + } else { + OPP_Term(&*x); + } + while ((6 <= OPP_sym && OPP_sym <= 8)) { + addop = OPP_sym; + OPS_Get(&OPP_sym); + OPP_Term(&y); + OPB_Op(addop, &*x, y); + } +} + +static void OPP_Expression (OPT_Node *x) +{ + OPT_Node y = NIL; + OPT_Object obj = NIL; + INT8 relation; + OPP_SimpleExpression(&*x); + if ((9 <= OPP_sym && OPP_sym <= 14)) { + relation = OPP_sym; + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_Op(relation, &*x, y); + } else if (OPP_sym == 15) { + OPS_Get(&OPP_sym); + OPP_SimpleExpression(&y); + OPB_In(&*x, y); + } else if (OPP_sym == 16) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&obj); + if (obj->mode == 5) { + OPB_TypTest(&*x, obj, 0); + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } +} + +static void OPP_Receiver (INT8 *mode, OPS_Name name, OPT_Struct *typ, OPT_Struct *rec) +{ + OPT_Object obj = NIL; + *typ = OPT_undftyp; + *rec = NIL; + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + *mode = 2; + } else { + *mode = 1; + } + __MOVE(OPS_name, name, 256); + OPP_CheckSym(38); + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPT_Find(&obj); + OPS_Get(&OPP_sym); + if (obj == NIL) { + OPP_err(0); + } else if (obj->mode != 5) { + OPP_err(72); + } else { + *typ = obj->typ; + *rec = *typ; + if ((*rec)->form == 11) { + *rec = (*rec)->BaseTyp; + } + if (!((((*mode == 1 && (*typ)->form == 11)) && (*rec)->comp == 4) || (*mode == 2 && (*typ)->comp == 4))) { + OPP_err(70); + *rec = NIL; + } + if ((*rec != NIL && (*rec)->mno != OPP_level)) { + OPP_err(72); + *rec = NIL; + } + } + } else { + OPP_err(38); + } + OPP_CheckSym(22); + if (*rec == NIL) { + *rec = OPT_NewStr(13, 4); + (*rec)->BaseTyp = NIL; + } +} + +static BOOLEAN OPP_Extends (OPT_Struct x, OPT_Struct b) +{ + if ((b->form == 11 && x->form == 11)) { + b = b->BaseTyp; + x = x->BaseTyp; + } + if ((b->comp == 4 && x->comp == 4)) { + do { + x = x->BaseTyp; + } while (!(x == NIL || x == b)); + } + return x == b; +} + +static struct ProcedureDeclaration__16 { + OPT_Node *x; + OPT_Object *proc, *fwd; + OPS_Name *name; + INT8 *mode, *vis; + BOOLEAN *forward; + struct ProcedureDeclaration__16 *lnk; +} *ProcedureDeclaration__16_s; + +static void Body__17 (void); +static void GetCode__19 (void); +static void GetParams__21 (void); +static void TProcDecl__23 (void); + +static void GetCode__19 (void) +{ + OPT_ConstExt ext = NIL; + INT16 n; + INT64 c; + ext = OPT_NewExt(); + (*ProcedureDeclaration__16_s->proc)->conval->ext = ext; + n = 0; + if (OPP_sym == 37) { + while (OPS_str[__X(n, 256)] != 0x00) { + (*ext)[__X(n + 1, 256)] = OPS_str[__X(n, 256)]; + n += 1; + } + (*ext)[0] = __CHR(n); + OPS_Get(&OPP_sym); + } else { + for (;;) { + if (OPP_sym == 35) { + c = OPS_intval; + n += 1; + if ((c < 0 || c > 255) || n == 256) { + OPP_err(64); + c = 1; + n = 1; + } + OPS_Get(&OPP_sym); + (*ext)[__X(n, 256)] = __CHR(c); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35) { + OPP_err(19); + } else { + (*ext)[0] = __CHR(n); + break; + } + } + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); +} + +static void GetParams__21 (void) +{ + (*ProcedureDeclaration__16_s->proc)->vis = *ProcedureDeclaration__16_s->vis; + (*ProcedureDeclaration__16_s->proc)->mode = *ProcedureDeclaration__16_s->mode; + (*ProcedureDeclaration__16_s->proc)->typ = OPT_notyp; + (*ProcedureDeclaration__16_s->proc)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->proc)->conval->setval = 0x0; + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_FormalParameters(&(*ProcedureDeclaration__16_s->proc)->link, &(*ProcedureDeclaration__16_s->proc)->typ); + } + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link, (*ProcedureDeclaration__16_s->fwd)->link, 1); + if ((*ProcedureDeclaration__16_s->proc)->typ != (*ProcedureDeclaration__16_s->fwd)->typ) { + OPP_err(117); + } + *ProcedureDeclaration__16_s->proc = *ProcedureDeclaration__16_s->fwd; + OPT_topScope = (*ProcedureDeclaration__16_s->proc)->scope; + if (*ProcedureDeclaration__16_s->mode == 10) { + (*ProcedureDeclaration__16_s->proc)->mode = 10; + } + } +} + +static void Body__17 (void) +{ + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + c = OPM_errpos; + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(1,64); + OPP_CheckSym(39); + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, *ProcedureDeclaration__16_s->proc); + *ProcedureDeclaration__16_s->x = procdec; + (*ProcedureDeclaration__16_s->x)->conval = OPT_NewConst(); + (*ProcedureDeclaration__16_s->x)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, (*ProcedureDeclaration__16_s->proc)->name) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } +} + +static void TProcDecl__23 (void) +{ + OPT_Object baseProc = NIL; + OPT_Struct objTyp = NIL, recTyp = NIL; + INT8 objMode; + OPS_Name objName; + OPS_Get(&OPP_sym); + *ProcedureDeclaration__16_s->mode = 13; + if (OPP_level > 0) { + OPP_err(73); + } + OPP_Receiver(&objMode, objName, &objTyp, &recTyp); + if (OPP_sym == 38) { + __MOVE(OPS_name, *ProcedureDeclaration__16_s->name, 256); + OPP_CheckMark(&*ProcedureDeclaration__16_s->vis); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp, &*ProcedureDeclaration__16_s->fwd); + OPT_FindField(*ProcedureDeclaration__16_s->name, recTyp->BaseTyp, &baseProc); + if ((baseProc != NIL && baseProc->mode != 13)) { + baseProc = NIL; + } + if (*ProcedureDeclaration__16_s->fwd == baseProc) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mnolev != OPP_level)) { + *ProcedureDeclaration__16_s->fwd = NIL; + } + if ((((*ProcedureDeclaration__16_s->fwd != NIL && (*ProcedureDeclaration__16_s->fwd)->mode == 13)) && !__IN(1, (*ProcedureDeclaration__16_s->fwd)->conval->setval, 64))) { + *ProcedureDeclaration__16_s->proc = OPT_NewObj(); + (*ProcedureDeclaration__16_s->proc)->leaf = 1; + if ((*ProcedureDeclaration__16_s->fwd)->vis != *ProcedureDeclaration__16_s->vis) { + OPP_err(118); + } + } else { + if (*ProcedureDeclaration__16_s->fwd != NIL) { + OPP_err(1); + *ProcedureDeclaration__16_s->fwd = NIL; + } + OPT_OpenScope(0, NIL); + OPT_topScope->right = recTyp->link; + OPT_Insert(*ProcedureDeclaration__16_s->name, &*ProcedureDeclaration__16_s->proc); + recTyp->link = OPT_topScope->right; + OPT_CloseScope(); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, *ProcedureDeclaration__16_s->proc); + OPT_Insert(objName, &(*ProcedureDeclaration__16_s->proc)->link); + (*ProcedureDeclaration__16_s->proc)->link->mode = objMode; + (*ProcedureDeclaration__16_s->proc)->link->typ = objTyp; + GetParams__21(); + if (baseProc != NIL) { + if (objMode != baseProc->link->mode || !OPP_Extends(objTyp, baseProc->link->typ)) { + OPP_err(115); + } + OPB_CheckParameters((*ProcedureDeclaration__16_s->proc)->link->link, baseProc->link->link, 0); + if ((*ProcedureDeclaration__16_s->proc)->typ != baseProc->typ) { + OPP_err(117); + } + if ((((((baseProc->vis == 1 && (*ProcedureDeclaration__16_s->proc)->vis == 0)) && recTyp->strobj != NIL)) && recTyp->strobj->vis == 1)) { + OPP_err(109); + } + (*ProcedureDeclaration__16_s->proc)->conval->setval |= __SETOF(2,64); + } + if (!*ProcedureDeclaration__16_s->forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } +} + +static void OPP_ProcedureDeclaration (OPT_Node *x) +{ + OPT_Object proc = NIL, fwd = NIL; + OPS_Name name; + INT8 mode, vis; + BOOLEAN forward; + struct ProcedureDeclaration__16 _s; + _s.x = x; + _s.proc = &proc; + _s.fwd = &fwd; + _s.name = (void*)name; + _s.mode = &mode; + _s.vis = &vis; + _s.forward = &forward; + _s.lnk = ProcedureDeclaration__16_s; + ProcedureDeclaration__16_s = &_s; + proc = NIL; + forward = 0; + *x = NIL; + mode = 6; + if ((OPP_sym != 38 && OPP_sym != 30)) { + if (OPP_sym == 1) { + } else if (OPP_sym == 17) { + forward = 1; + } else if (OPP_sym == 6) { + mode = 10; + } else if (OPP_sym == 7) { + mode = 9; + } else { + OPP_err(38); + } + if ((__IN(mode, 0x0600, 32) && !OPT_SYSimported)) { + OPP_err(135); + } + OPS_Get(&OPP_sym); + } + if (OPP_sym == 30) { + TProcDecl__23(); + } else if (OPP_sym == 38) { + OPT_Find(&fwd); + __MOVE(OPS_name, name, 256); + OPP_CheckMark(&vis); + if ((vis != 0 && mode == 6)) { + mode = 7; + } + if ((fwd != NIL && (fwd->mnolev != OPP_level || fwd->mode == 8))) { + fwd = NIL; + } + if ((((fwd != NIL && __IN(fwd->mode, 0xc0, 32))) && !__IN(1, fwd->conval->setval, 64))) { + proc = OPT_NewObj(); + proc->leaf = 1; + if (fwd->vis != vis) { + OPP_err(118); + } + } else { + if (fwd != NIL) { + OPP_err(1); + fwd = NIL; + } + OPT_Insert(name, &proc); + } + if ((mode != 6 && OPP_level > 0)) { + OPP_err(73); + } + OPP_level += 1; + OPT_OpenScope(OPP_level, proc); + proc->link = NIL; + GetParams__21(); + if (mode == 9) { + GetCode__19(); + } else if (!forward) { + Body__17(); + } + OPP_level -= 1; + OPT_CloseScope(); + } else { + OPP_err(38); + } + ProcedureDeclaration__16_s = _s.lnk; +} + +static void OPP_CaseLabelList (OPT_Node *lab, OPT_Struct LabelTyp, INT16 *n, OPP_CaseTable tab) +{ + OPT_Node x = NIL, y = NIL, lastlab = NIL; + INT16 i, f; + INT32 xval, yval; + *lab = NIL; + lastlab = NIL; + for (;;) { + OPP_ConstExpression(&x); + f = x->typ->form; + if (__IN(f, 0x18, 32)) { + xval = OPM_Longint(x->conval->intval); + } else { + OPP_err(61); + xval = 1; + } + if (f == 4) { + if (!(LabelTyp->form == 4) || LabelTyp->size < x->typ->size) { + OPP_err(60); + } + } else if ((INT16)LabelTyp->form != f) { + OPP_err(60); + } + if (OPP_sym == 21) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&y); + yval = OPM_Longint(y->conval->intval); + if (((INT16)y->typ->form != f && !((f == 4 && y->typ->form == 4)))) { + OPP_err(60); + } + if (yval < xval) { + OPP_err(63); + yval = xval; + } + } else { + yval = xval; + } + x->conval->intval2 = yval; + i = *n; + if (i < 128) { + for (;;) { + if (i == 0) { + break; + } + if (tab[__X(i - 1, 128)].low <= yval) { + if (tab[__X(i - 1, 128)].high >= xval) { + OPP_err(62); + } + break; + } + tab[__X(i, 128)] = tab[__X(i - 1, 128)]; + i -= 1; + } + tab[__X(i, 128)].low = xval; + tab[__X(i, 128)].high = yval; + *n += 1; + } else { + OPP_err(213); + } + OPB_Link(&*lab, &lastlab, x); + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 35 || OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } +} + +static struct StatSeq__30 { + INT32 *pos; + struct StatSeq__30 *lnk; +} *StatSeq__30_s; + +static void CasePart__31 (OPT_Node *x); +static void CheckBool__33 (OPT_Node *x); +static void SetPos__35 (OPT_Node x); + +static void CasePart__31 (OPT_Node *x) +{ + INT16 n; + INT32 low, high; + BOOLEAN e; + OPP_CaseTable tab; + OPT_Node cases = NIL, lab = NIL, y = NIL, lastcase = NIL; + OPP_Expression(&*x); + *StatSeq__30_s->pos = OPM_errpos; + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + } else if (!__IN((*x)->typ->form, 0x18, 32)) { + OPP_err(125); + } + OPP_CheckSym(25); + cases = NIL; + lastcase = NIL; + n = 0; + for (;;) { + if (OPP_sym < 40) { + OPP_CaseLabelList(&lab, (*x)->typ, &n, tab); + OPP_CheckSym(20); + OPP_StatSeq(&y); + OPB_Construct(17, &lab, y); + OPB_Link(&cases, &lastcase, lab); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + if (n > 0) { + low = tab[0].low; + high = tab[__X(n - 1, 128)].high; + if (high - low > 512) { + OPP_err(209); + } + } else { + low = 1; + high = 0; + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + OPM_Mark(-307, OPM_curpos); + } + OPB_Construct(16, &cases, y); + OPB_Construct(21, &*x, cases); + cases->conval = OPT_NewConst(); + cases->conval->intval = low; + cases->conval->intval2 = high; + if (e) { + cases->conval->setval = 0x02; + } else { + cases->conval->setval = 0x0; + } +} + +static void SetPos__35 (OPT_Node x) +{ + x->conval = OPT_NewConst(); + x->conval->intval = *StatSeq__30_s->pos; +} + +static void CheckBool__33 (OPT_Node *x) +{ + if ((*x)->class == 8 || (*x)->class == 9) { + OPP_err(126); + *x = OPB_NewBoolConst(0); + } else if ((*x)->typ->form != 2) { + OPP_err(120); + *x = OPB_NewBoolConst(0); + } + *StatSeq__30_s->pos = OPM_errpos; +} + +static void OPP_StatSeq (OPT_Node *stat) +{ + OPT_Object fpar = NIL, id = NIL, t = NIL, obj = NIL; + OPT_Struct idtyp = NIL; + BOOLEAN e; + OPT_Node s = NIL, x = NIL, y = NIL, z = NIL, apar = NIL, last = NIL, lastif = NIL; + INT32 pos; + OPS_Name name; + struct StatSeq__30 _s; + _s.pos = &pos; + _s.lnk = StatSeq__30_s; + StatSeq__30_s = &_s; + *stat = NIL; + last = NIL; + for (;;) { + x = NIL; + if (OPP_sym < 38) { + OPP_err(14); + do { + OPS_Get(&OPP_sym); + } while (!(OPP_sym >= 38)); + } + if (OPP_sym == 38) { + OPP_qualident(&id); + x = OPB_NewLeaf(id); + OPP_selector(&x); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if (OPP_sym == 9) { + OPP_err(34); + OPS_Get(&OPP_sym); + OPP_Expression(&y); + OPB_Assign(&x, y); + } else if ((x->class == 9 && x->obj->mode == 8)) { + OPP_StandProcCall(&x); + if ((x != NIL && x->typ != OPT_notyp)) { + OPP_err(55); + } + } else { + OPB_PrepCall(&x, &fpar); + if (OPP_sym == 30) { + OPS_Get(&OPP_sym); + OPP_ActualParameters(&apar, fpar); + OPP_CheckSym(22); + } else { + apar = NIL; + if (fpar != NIL) { + OPP_err(65); + } + } + OPB_Call(&x, apar, fpar); + if (x->typ != OPT_notyp) { + OPP_err(55); + } + if (OPP_level > 0) { + OPT_topScope->link->leaf = 0; + } + } + pos = OPM_errpos; + } else if (OPP_sym == 45) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(26); + OPP_StatSeq(&y); + OPB_Construct(15, &x, y); + SetPos__35(x); + lastif = x; + while (OPP_sym == 43) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + OPP_CheckSym(26); + OPP_StatSeq(&z); + OPB_Construct(15, &y, z); + SetPos__35(y); + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 42) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&y); + } else { + y = NIL; + } + OPB_Construct(20, &x, y); + OPP_CheckSym(41); + OPB_OptIf(&x); + pos = OPM_errpos; + } else if (OPP_sym == 46) { + OPS_Get(&OPP_sym); + CasePart__31(&x); + OPP_CheckSym(41); + } else if (OPP_sym == 47) { + OPS_Get(&OPP_sym); + OPP_Expression(&x); + CheckBool__33(&x); + OPP_CheckSym(27); + OPP_StatSeq(&y); + OPB_Construct(22, &x, y); + OPP_CheckSym(41); + } else if (OPP_sym == 48) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&x); + if (OPP_sym == 44) { + OPS_Get(&OPP_sym); + OPP_Expression(&y); + CheckBool__33(&y); + } else { + OPP_err(44); + } + OPB_Construct(23, &x, y); + } else if (OPP_sym == 49) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + OPP_qualident(&id); + if (!(id->typ->form == 4)) { + OPP_err(68); + } + OPP_CheckSym(34); + OPP_Expression(&y); + pos = OPM_errpos; + x = OPB_NewLeaf(id); + OPB_Assign(&x, y); + SetPos__35(x); + OPP_CheckSym(28); + OPP_Expression(&y); + pos = OPM_errpos; + if (y->class != 7) { + __MOVE("@@", name, 3); + OPT_Insert(name, &t); + __MOVE("@for", t->name, 5); + t->mode = 1; + t->typ = x->left->typ; + obj = OPT_topScope->scope; + if (obj == NIL) { + OPT_topScope->scope = t; + } else { + while (obj->link != NIL) { + obj = obj->link; + } + obj->link = t; + } + z = OPB_NewLeaf(t); + OPB_Assign(&z, y); + SetPos__35(z); + OPB_Link(&*stat, &last, z); + y = OPB_NewLeaf(t); + } else if (!(y->typ->form == 4) || y->typ->size > x->left->typ->size) { + OPP_err(113); + } + OPB_Link(&*stat, &last, x); + if (OPP_sym == 29) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&z); + } else { + z = OPB_NewIntConst(1); + } + pos = OPM_errpos; + x = OPB_NewLeaf(id); + if (z->conval->intval > 0) { + OPB_Op(12, &x, y); + } else if (z->conval->intval < 0) { + OPB_Op(14, &x, y); + } else { + OPP_err(63); + OPB_Op(14, &x, y); + } + OPP_CheckSym(27); + OPP_StatSeq(&s); + y = OPB_NewLeaf(id); + OPB_StPar1(&y, z, 13); + SetPos__35(y); + if (s == NIL) { + s = y; + } else { + z = s; + while (z->link != NIL) { + z = z->link; + } + z->link = y; + } + OPP_CheckSym(41); + OPB_Construct(22, &x, s); + } else { + OPP_err(38); + } + } else if (OPP_sym == 50) { + OPS_Get(&OPP_sym); + OPP_LoopLevel += 1; + OPP_StatSeq(&x); + OPP_LoopLevel -= 1; + OPB_Construct(24, &x, NIL); + OPP_CheckSym(41); + pos = OPM_errpos; + } else if (OPP_sym == 51) { + OPS_Get(&OPP_sym); + idtyp = NIL; + x = NIL; + for (;;) { + if (OPP_sym == 38) { + OPP_qualident(&id); + y = OPB_NewLeaf(id); + if ((((id != NIL && id->typ->form == 11)) && (id->mode == 2 || !id->leaf))) { + OPP_err(245); + } + OPP_CheckSym(20); + if (OPP_sym == 38) { + OPP_qualident(&t); + if (t->mode == 5) { + if (id != NIL) { + idtyp = id->typ; + OPB_TypTest(&y, t, 0); + id->typ = t->typ; + } else { + OPP_err(130); + } + } else { + OPP_err(52); + } + } else { + OPP_err(38); + } + } else { + OPP_err(38); + } + pos = OPM_errpos; + OPP_CheckSym(27); + OPP_StatSeq(&s); + OPB_Construct(15, &y, s); + SetPos__35(y); + if (idtyp != NIL) { + id->typ = idtyp; + idtyp = NIL; + } + if (x == NIL) { + x = y; + lastif = x; + } else { + OPB_Link(&x, &lastif, y); + } + if (OPP_sym == 40) { + OPS_Get(&OPP_sym); + } else { + break; + } + } + e = OPP_sym == 42; + if (e) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&s); + } else { + s = NIL; + } + OPB_Construct(27, &x, s); + OPP_CheckSym(41); + if (e) { + x->subcl = 1; + } + } else if (OPP_sym == 52) { + OPS_Get(&OPP_sym); + if (OPP_LoopLevel == 0) { + OPP_err(46); + } + OPB_Construct(25, &x, NIL); + pos = OPM_errpos; + } else if (OPP_sym == 53) { + OPS_Get(&OPP_sym); + if (OPP_sym < 39) { + OPP_Expression(&x); + } + if (OPP_level > 0) { + OPB_Return(&x, OPT_topScope->link); + } else { + OPB_Return(&x, NIL); + } + pos = OPM_errpos; + } + if (x != NIL) { + SetPos__35(x); + OPB_Link(&*stat, &last, x); + } + if (OPP_sym == 39) { + OPS_Get(&OPP_sym); + } else if (OPP_sym <= 38 || (45 <= OPP_sym && OPP_sym <= 53)) { + OPP_err(39); + } else { + break; + } + } + StatSeq__30_s = _s.lnk; +} + +static void OPP_Block (OPT_Node *procdec, OPT_Node *statseq) +{ + OPT_Struct typ = NIL; + OPT_Object obj = NIL, first = NIL, last = NIL; + OPT_Node x = NIL, lastdec = NIL; + INT16 i; + first = NIL; + last = NIL; + OPP_nofFwdPtr = 0; + for (;;) { + if (OPP_sym == 58) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->typ = OPT_sinttyp; + obj->mode = 1; + if (OPP_sym == 9) { + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else if (OPP_sym == 34) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_ConstExpression(&x); + } else { + OPP_err(9); + x = OPB_NewIntConst(1); + } + obj->mode = 3; + obj->typ = x->typ; + obj->conval = x->conval; + OPP_CheckSym(39); + } + } + if (OPP_sym == 59) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + obj->mode = 5; + obj->typ = OPT_undftyp; + OPP_CheckMark(&obj->vis); + if (OPP_sym == 9) { + if (((((((((__STRCMP(obj->name, "SHORTINT") == 0 || __STRCMP(obj->name, "INTEGER") == 0) || __STRCMP(obj->name, "LONGINT") == 0) || __STRCMP(obj->name, "HUGEINT") == 0) || __STRCMP(obj->name, "REAL") == 0) || __STRCMP(obj->name, "LONGREAL") == 0) || __STRCMP(obj->name, "SET") == 0) || __STRCMP(obj->name, "CHAR") == 0) || __STRCMP(obj->name, "TRUE") == 0) || __STRCMP(obj->name, "FALSE") == 0) { + OPM_Mark(-310, OPM_curpos); + } + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else if (OPP_sym == 34 || OPP_sym == 20) { + OPP_err(9); + OPS_Get(&OPP_sym); + OPP_TypeDecl(&obj->typ, &obj->typ); + } else { + OPP_err(9); + } + if (obj->typ->strobj == NIL) { + obj->typ->strobj = obj; + } + if (__IN(obj->typ->comp, 0x1c, 32)) { + i = 0; + while (i < OPP_nofFwdPtr) { + typ = OPP_FwdPtr[__X(i, 64)]; + i += 1; + if (__STRCMP(typ->link->name, obj->name) == 0) { + typ->BaseTyp = obj->typ; + typ->link->name[0] = 0x00; + } + } + } + OPP_CheckSym(39); + } + } + if (OPP_sym == 60) { + OPS_Get(&OPP_sym); + while (OPP_sym == 38) { + for (;;) { + if (OPP_sym == 38) { + OPT_Insert(OPS_name, &obj); + OPP_CheckMark(&obj->vis); + obj->mode = 1; + obj->link = NIL; + obj->leaf = obj->vis == 0; + obj->typ = OPT_undftyp; + if (first == NIL) { + first = obj; + } + if (last == NIL) { + OPT_topScope->scope = obj; + } else { + last->link = obj; + } + last = obj; + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(20); + OPP_Type(&typ, &OPT_notyp); + typ->pvused = 1; + if (typ->comp == 3) { + typ = OPT_undftyp; + OPP_err(88); + } + while (first != NIL) { + first->typ = typ; + first = first->link; + } + OPP_CheckSym(39); + } + } + if (OPP_sym < 58 || OPP_sym > 60) { + break; + } + } + i = 0; + while (i < OPP_nofFwdPtr) { + if (OPP_FwdPtr[__X(i, 64)]->link->name[0] != 0x00) { + OPP_err(128); + } + OPP_FwdPtr[__X(i, 64)] = NIL; + i += 1; + } + OPT_topScope->adr = OPM_errpos; + *procdec = NIL; + lastdec = NIL; + while (OPP_sym == 61) { + OPS_Get(&OPP_sym); + OPP_ProcedureDeclaration(&x); + if (x != NIL) { + if (lastdec == NIL) { + *procdec = x; + } else { + lastdec->link = x; + } + lastdec = x; + } + OPP_CheckSym(39); + } + if (OPP_sym == 57) { + OPS_Get(&OPP_sym); + OPP_StatSeq(&*statseq); + } else { + *statseq = NIL; + } + if ((OPP_level == 0 && OPP_TDinit != NIL)) { + OPP_lastTDinit->link = *statseq; + *statseq = OPP_TDinit; + } + OPP_CheckSym(41); +} + +void OPP_Module (OPT_Node *prog, UINT32 opt) +{ + OPS_Name impName, aliasName; + OPT_Node procdec = NIL, statseq = NIL; + INT32 c; + BOOLEAN done; + OPS_Init(); + OPP_LoopLevel = 0; + OPP_level = 0; + OPS_Get(&OPP_sym); + if (OPP_sym == 63) { + OPS_Get(&OPP_sym); + } else { + OPP_err(16); + } + if (OPP_sym == 38) { + OPM_LogCompiling(OPS_name, 256); + OPT_Init(OPS_name, opt); + OPS_Get(&OPP_sym); + OPP_CheckSym(39); + if (OPP_sym == 62) { + OPS_Get(&OPP_sym); + for (;;) { + if (OPP_sym == 38) { + __COPY(OPS_name, aliasName, 256); + __COPY(aliasName, impName, 256); + OPS_Get(&OPP_sym); + if (OPP_sym == 34) { + OPS_Get(&OPP_sym); + if (OPP_sym == 38) { + __COPY(OPS_name, impName, 256); + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + } + OPT_Import(aliasName, impName, &done); + } else { + OPP_err(38); + } + if (OPP_sym == 19) { + OPS_Get(&OPP_sym); + } else if (OPP_sym == 38) { + OPP_err(19); + } else { + break; + } + } + OPP_CheckSym(39); + } + if (OPM_noerr) { + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; + c = OPM_errpos; + OPP_Block(&procdec, &statseq); + OPB_Enter(&procdec, statseq, NIL); + *prog = procdec; + (*prog)->conval = OPT_NewConst(); + (*prog)->conval->intval = c; + if (OPP_sym == 38) { + if (__STRCMP(OPS_name, OPT_SelfName) != 0) { + OPP_err(4); + } + OPS_Get(&OPP_sym); + } else { + OPP_err(38); + } + if (OPP_sym != 18) { + OPP_err(18); + } + } + } else { + OPP_err(38); + } + OPP_TDinit = NIL; + OPP_lastTDinit = NIL; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPP_TDinit); + P(OPP_lastTDinit); + __ENUMP(OPP_FwdPtr, 64, P); +} + +__TDESC(OPP__1, 1, 0) = {__TDFLDS("", 8), {-8}}; + +export void *OPP__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPB); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPP", EnumPtrs); + __INITYP(OPP__1, OPP__1, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPP.h b/bootstrap/windows-88/OPP.h new file mode 100644 index 00000000..3d8cefe8 --- /dev/null +++ b/bootstrap/windows-88/OPP.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPP__h +#define OPP__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPP_Module (OPT_Node *prog, UINT32 opt); +import void *OPP__init(void); + + +#endif // OPP diff --git a/bootstrap/windows-88/OPS.c b/bootstrap/windows-88/OPS.c new file mode 100644 index 00000000..a25a2c12 --- /dev/null +++ b/bootstrap/windows-88/OPS.c @@ -0,0 +1,666 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +export OPS_Name OPS_name; +export OPS_String OPS_str; +export INT16 OPS_numtyp; +export INT64 OPS_intval; +export REAL OPS_realval; +export LONGREAL OPS_lrlval; +static CHAR OPS_ch; + + +export void OPS_Get (INT8 *sym); +static void OPS_Identifier (INT8 *sym); +export void OPS_Init (void); +static void OPS_Number (void); +static void OPS_Str (INT8 *sym); +static void OPS_err (INT16 n); + + +static void OPS_err (INT16 n) +{ + OPM_err(n); +} + +static void OPS_Str (INT8 *sym) +{ + INT16 i; + CHAR och; + i = 0; + och = OPS_ch; + for (;;) { + OPM_Get(&OPS_ch); + if (OPS_ch == och) { + break; + } + if (OPS_ch < ' ') { + OPS_err(3); + break; + } + if (i == 255) { + OPS_err(241); + break; + } + OPS_str[__X(i, 256)] = OPS_ch; + i += 1; + } + OPM_Get(&OPS_ch); + OPS_str[__X(i, 256)] = 0x00; + OPS_intval = i + 1; + if (OPS_intval == 2) { + *sym = 35; + OPS_numtyp = 1; + OPS_intval = (INT16)OPS_str[0]; + } else { + *sym = 37; + } +} + +static void OPS_Identifier (INT8 *sym) +{ + INT16 i; + i = 0; + do { + OPS_name[__X(i, 256)] = OPS_ch; + i += 1; + OPM_Get(&OPS_ch); + } while (!(((OPS_ch < '0' || ('9' < OPS_ch && __CAP(OPS_ch) < 'A')) || 'Z' < __CAP(OPS_ch)) || i == 256)); + if (i == 256) { + OPS_err(240); + i -= 1; + } + OPS_name[__X(i, 256)] = 0x00; + *sym = 38; +} + +static struct Number__6 { + struct Number__6 *lnk; +} *Number__6_s; + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex); +static LONGREAL Ten__9 (INT16 e); + +static LONGREAL Ten__9 (INT16 e) +{ + LONGREAL x, p; + x = (LONGREAL)1; + p = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + x = x * p; + } + e = __ASHR(e, 1); + if (e > 0) { + p = p * p; + } + } + return x; +} + +static INT16 Ord__7 (CHAR ch, BOOLEAN hex) +{ + if (ch <= '9') { + return (INT16)ch - 48; + } else if (hex) { + return ((INT16)ch - 65) + 10; + } else { + OPS_err(2); + return 0; + } + __RETCHK; +} + +static void OPS_Number (void) +{ + INT16 i, m, n, d, e; + CHAR dig[24]; + LONGREAL f; + CHAR expCh; + BOOLEAN neg; + struct Number__6 _s; + _s.lnk = Number__6_s; + Number__6_s = &_s; + i = 0; + m = 0; + n = 0; + d = 0; + for (;;) { + if (('0' <= OPS_ch && OPS_ch <= '9') || (((d == 0 && 'A' <= OPS_ch)) && OPS_ch <= 'F')) { + if (m > 0 || OPS_ch != '0') { + if (n < 24) { + dig[__X(n, 24)] = OPS_ch; + n += 1; + } + m += 1; + } + OPM_Get(&OPS_ch); + i += 1; + } else if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPS_ch = 0x7f; + break; + } else if (d == 0) { + d = i; + } else { + OPS_err(2); + } + } else { + break; + } + } + if (d == 0) { + if (n == m) { + OPS_intval = 0; + i = 0; + if (OPS_ch == 'X') { + OPM_Get(&OPS_ch); + OPS_numtyp = 1; + if (n <= 2) { + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else if (OPS_ch == 'H') { + OPM_Get(&OPS_ch); + OPS_numtyp = 2; + if (n <= 16) { + if ((n == 16 && dig[0] > '7')) { + OPS_intval = -1; + } + while (i < n) { + OPS_intval = __ASHL(OPS_intval, 4) + (INT64)Ord__7(dig[__X(i, 24)], 1); + i += 1; + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 2; + while (i < n) { + d = Ord__7(dig[__X(i, 24)], 0); + i += 1; + if (OPS_intval <= __DIV(9223372036854775807LL - (INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (INT64)d; + } else { + OPS_err(203); + } + } + } + } else { + OPS_err(203); + } + } else { + f = (LONGREAL)0; + e = 0; + expCh = 'E'; + while (n > 0) { + n -= 1; + f = (Ord__7(dig[__X(n, 24)], 0) + f) / (LONGREAL)(LONGREAL)10; + } + if (OPS_ch == 'E' || OPS_ch == 'D') { + expCh = OPS_ch; + OPM_Get(&OPS_ch); + neg = 0; + if (OPS_ch == '-') { + neg = 1; + OPM_Get(&OPS_ch); + } else if (OPS_ch == '+') { + OPM_Get(&OPS_ch); + } + if (('0' <= OPS_ch && OPS_ch <= '9')) { + do { + n = Ord__7(OPS_ch, 0); + OPM_Get(&OPS_ch); + if (e <= __DIV(32767 - n, 10)) { + e = e * 10 + n; + } else { + OPS_err(203); + } + } while (!(OPS_ch < '0' || '9' < OPS_ch)); + if (neg) { + e = -e; + } + } else { + OPS_err(2); + } + } + e -= (i - d) - m; + if (expCh == 'E') { + OPS_numtyp = 3; + if ((-37 < e && e <= 38)) { + if (e < 0) { + OPS_realval = (f / (LONGREAL)Ten__9(-e)); + } else { + OPS_realval = (f * Ten__9(e)); + } + } else { + OPS_err(203); + } + } else { + OPS_numtyp = 4; + if ((-307 < e && e <= 308)) { + if (e < 0) { + OPS_lrlval = f / (LONGREAL)Ten__9(-e); + } else { + OPS_lrlval = f * Ten__9(e); + } + } else { + OPS_err(203); + } + } + } + Number__6_s = _s.lnk; +} + +static struct Get__1 { + struct Get__1 *lnk; +} *Get__1_s; + +static void Comment__2 (void); + +static void Comment__2 (void) +{ + BOOLEAN isExported; + CHAR commentText[256]; + INT16 i, nestLevel; + CHAR prevCh, nextCh; + i = 0; + while (i <= 255) { + commentText[__X(i, 256)] = 0x00; + i += 1; + } + isExported = 0; + i = 0; + nestLevel = 1; + prevCh = 0x00; + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + isExported = 1; + OPM_Get(&OPS_ch); + if (OPS_ch == ')') { + commentText[0] = 0x00; + OPM_StoreComment(commentText, 256); + OPM_Get(&OPS_ch); + return; + } + } + while ((nestLevel > 0 && OPS_ch != 0x00)) { + if ((prevCh == '(' && OPS_ch == '*')) { + nestLevel += 1; + prevCh = 0x00; + } else if ((prevCh == '*' && OPS_ch == ')')) { + nestLevel -= 1; + if (nestLevel == 0) { + OPM_Get(&OPS_ch); + } else { + prevCh = 0x00; + } + } else { + if ((((isExported && nestLevel == 1)) && prevCh != 0x00)) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } + } + prevCh = OPS_ch; + } + if (nestLevel > 0) { + OPM_Get(&OPS_ch); + } + } + if (OPS_ch == 0x00) { + OPS_err(5); + } + if ((((((isExported && nestLevel == 0)) && prevCh != 0x00)) && prevCh != '*')) { + if (i < 255) { + commentText[__X(i, 256)] = prevCh; + i += 1; + } else { + OPM_LogWStr((CHAR*)"Truncating final comment character", 35); + OPM_LogWLn(); + } + } + if (isExported) { + if (i >= 256) { + OPM_LogWStr((CHAR*)"Warning: commentText overflow", 30); + OPM_LogWLn(); + i = 255; + } + commentText[__X(i, 256)] = 0x00; + OPM_StoreComment(commentText, 256); + } +} + +void OPS_Get (INT8 *sym) +{ + INT8 s; + struct Get__1 _s; + _s.lnk = Get__1_s; + Get__1_s = &_s; + OPM_errpos = OPM_curpos - 1; + while (OPS_ch <= ' ') { + if (OPS_ch == 0x00) { + *sym = 64; + Get__1_s = _s.lnk; + return; + } else { + OPM_Get(&OPS_ch); + } + } + switch (OPS_ch) { + case '"': case '\'': + OPS_Str(&s); + break; + case '#': + s = 10; + OPM_Get(&OPS_ch); + break; + case '&': + s = 5; + OPM_Get(&OPS_ch); + break; + case '(': + OPM_Get(&OPS_ch); + if (OPS_ch == '*') { + Comment__2(); + OPS_Get(&s); + } else { + s = 30; + } + break; + case ')': + s = 22; + OPM_Get(&OPS_ch); + break; + case '*': + s = 1; + OPM_Get(&OPS_ch); + break; + case '+': + s = 6; + OPM_Get(&OPS_ch); + break; + case ',': + s = 19; + OPM_Get(&OPS_ch); + break; + case '-': + s = 7; + OPM_Get(&OPS_ch); + break; + case '.': + OPM_Get(&OPS_ch); + if (OPS_ch == '.') { + OPM_Get(&OPS_ch); + s = 21; + } else { + s = 18; + } + break; + case '/': + s = 2; + OPM_Get(&OPS_ch); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + OPS_Number(); + s = 35; + break; + case ':': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 34; + } else { + s = 20; + } + break; + case ';': + s = 39; + OPM_Get(&OPS_ch); + break; + case '<': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 12; + } else { + s = 11; + } + break; + case '=': + s = 9; + OPM_Get(&OPS_ch); + break; + case '>': + OPM_Get(&OPS_ch); + if (OPS_ch == '=') { + OPM_Get(&OPS_ch); + s = 14; + } else { + s = 13; + } + break; + case 'A': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "ARRAY") == 0) { + s = 54; + } + break; + case 'B': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "BEGIN") == 0) { + s = 57; + } else if (__STRCMP(OPS_name, "BY") == 0) { + s = 29; + } + break; + case 'C': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "CASE") == 0) { + s = 46; + } else if (__STRCMP(OPS_name, "CONST") == 0) { + s = 58; + } + break; + case 'D': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "DO") == 0) { + s = 27; + } else if (__STRCMP(OPS_name, "DIV") == 0) { + s = 3; + } + break; + case 'E': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "END") == 0) { + s = 41; + } else if (__STRCMP(OPS_name, "ELSE") == 0) { + s = 42; + } else if (__STRCMP(OPS_name, "ELSIF") == 0) { + s = 43; + } else if (__STRCMP(OPS_name, "EXIT") == 0) { + s = 52; + } + break; + case 'F': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "FOR") == 0) { + s = 49; + } + break; + case 'I': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "IF") == 0) { + s = 45; + } else if (__STRCMP(OPS_name, "IN") == 0) { + s = 15; + } else if (__STRCMP(OPS_name, "IS") == 0) { + s = 16; + } else if (__STRCMP(OPS_name, "IMPORT") == 0) { + s = 62; + } + break; + case 'L': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "LOOP") == 0) { + s = 50; + } + break; + case 'M': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "MOD") == 0) { + s = 4; + } else if (__STRCMP(OPS_name, "MODULE") == 0) { + s = 63; + } + break; + case 'N': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "NIL") == 0) { + s = 36; + } + break; + case 'O': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "OR") == 0) { + s = 8; + } else if (__STRCMP(OPS_name, "OF") == 0) { + s = 25; + } + break; + case 'P': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "PROCEDURE") == 0) { + s = 61; + } else if (__STRCMP(OPS_name, "POINTER") == 0) { + s = 56; + } + break; + case 'R': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "RECORD") == 0) { + s = 55; + } else if (__STRCMP(OPS_name, "REPEAT") == 0) { + s = 48; + } else if (__STRCMP(OPS_name, "RETURN") == 0) { + s = 53; + } + break; + case 'T': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "THEN") == 0) { + s = 26; + } else if (__STRCMP(OPS_name, "TO") == 0) { + s = 28; + } else if (__STRCMP(OPS_name, "TYPE") == 0) { + s = 59; + } + break; + case 'U': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "UNTIL") == 0) { + s = 44; + } + break; + case 'V': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "VAR") == 0) { + s = 60; + } + break; + case 'W': + OPS_Identifier(&s); + if (__STRCMP(OPS_name, "WHILE") == 0) { + s = 47; + } else if (__STRCMP(OPS_name, "WITH") == 0) { + s = 51; + } + break; + case 'G': case 'H': case 'J': case 'K': case 'Q': + case 'S': case 'X': case 'Y': case 'Z': + OPS_Identifier(&s); + break; + case '[': + s = 31; + OPM_Get(&OPS_ch); + break; + case ']': + s = 23; + OPM_Get(&OPS_ch); + break; + case '^': + s = 17; + OPM_Get(&OPS_ch); + break; + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + OPS_Identifier(&s); + break; + case '{': + s = 32; + OPM_Get(&OPS_ch); + break; + case '|': + s = 40; + OPM_Get(&OPS_ch); + break; + case '}': + s = 24; + OPM_Get(&OPS_ch); + break; + case '~': + s = 33; + OPM_Get(&OPS_ch); + break; + case 0x7f: + s = 21; + OPM_Get(&OPS_ch); + break; + default: + s = 0; + OPM_Get(&OPS_ch); + break; + } + *sym = s; + Get__1_s = _s.lnk; +} + +void OPS_Init (void) +{ + OPS_ch = ' '; +} + + +export void *OPS__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __REGMOD("OPS", 0); + __REGCMD("Init", OPS_Init); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPS.h b/bootstrap/windows-88/OPS.h new file mode 100644 index 00000000..19e222ac --- /dev/null +++ b/bootstrap/windows-88/OPS.h @@ -0,0 +1,28 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPS__h +#define OPS__h + +#include "SYSTEM.h" + +typedef + CHAR OPS_Name[256]; + +typedef + CHAR OPS_String[256]; + + +import OPS_Name OPS_name; +import OPS_String OPS_str; +import INT16 OPS_numtyp; +import INT64 OPS_intval; +import REAL OPS_realval; +import LONGREAL OPS_lrlval; + + +import void OPS_Get (INT8 *sym); +import void OPS_Init (void); +import void *OPS__init(void); + + +#endif // OPS diff --git a/bootstrap/windows-88/OPT.c b/bootstrap/windows-88/OPT.c new file mode 100644 index 00000000..c3999981 --- /dev/null +++ b/bootstrap/windows-88/OPT.c @@ -0,0 +1,2261 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_ExpCtxt { + INT32 reffp; + INT16 ref; + INT8 nofm; + INT8 locmno[64]; + } OPT_ExpCtxt; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_ImpCtxt { + INT32 nextTag, reffp; + INT16 nofr, minr, nofm; + BOOLEAN self; + OPT_Struct ref[255]; + OPT_Object old[255]; + INT32 pvfp[255]; + INT8 glbmno[64]; + } OPT_ImpCtxt; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused, fpdone, idfpdone; + INT32 idfp, pbfp, pvfp; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +export OPT_Object OPT_topScope; +export OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +export OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +export INT8 OPT_nofGmod; +export OPT_Object OPT_GlbMod[64]; +export OPS_Name OPT_SelfName; +export BOOLEAN OPT_SYSimported; +static OPT_Object OPT_universe, OPT_syslink; +static OPT_ImpCtxt OPT_impCtxt; +static OPT_ExpCtxt OPT_expCtxt; +static INT32 OPT_nofhdfld; +static BOOLEAN OPT_newsf, OPT_findpc, OPT_extsf, OPT_sfpresent, OPT_symExtended, OPT_symNew; +static INT32 OPT_recno; +export OPT_Link OPT_Links; + +export ADDRESS *OPT_ConstDesc__typ; +export ADDRESS *OPT_ObjDesc__typ; +export ADDRESS *OPT_StrDesc__typ; +export ADDRESS *OPT_NodeDesc__typ; +export ADDRESS *OPT_ImpCtxt__typ; +export ADDRESS *OPT_ExpCtxt__typ; +export ADDRESS *OPT_LinkDesc__typ; + +export void OPT_Align (INT32 *adr, INT32 base); +export INT32 OPT_BaseAlignment (OPT_Struct typ); +export void OPT_Close (void); +export void OPT_CloseScope (void); +static void OPT_DebugStruct (OPT_Struct btyp); +static void OPT_EnterBoolConst (OPS_Name name, INT32 value); +static void OPT_EnterProc (OPS_Name name, INT16 num); +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res); +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res); +export void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +export void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len); +export void OPT_FPrintObj (OPT_Object obj); +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par); +export void OPT_FPrintStr (OPT_Struct typ); +export void OPT_Find (OPT_Object *res); +export void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +export void OPT_FindImport (OPT_Object mod, OPT_Object *res); +export void OPT_IdFPrint (OPT_Struct typ); +export void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +static void OPT_InConstant (INT32 f, OPT_Const conval); +static OPT_Object OPT_InFld (void); +static void OPT_InLinks (void); +static void OPT_InMod (INT8 *mno); +static void OPT_InName (CHAR *name, ADDRESS name__len); +static OPT_Object OPT_InObj (INT8 mno); +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par); +static void OPT_InStruct (OPT_Struct *typ); +static OPT_Object OPT_InTProc (INT8 mno); +static OPT_Struct OPT_InTyp (INT32 tag); +export void OPT_Init (OPS_Name name, UINT32 opt); +export void OPT_InitRecno (void); +static void OPT_InitStruct (OPT_Struct *typ, INT8 form); +export void OPT_Insert (OPS_Name name, OPT_Object *obj); +export void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +export INT16 OPT_IntSize (INT64 n); +export OPT_Struct OPT_IntType (INT32 size); +export OPT_Const OPT_NewConst (void); +export OPT_ConstExt OPT_NewExt (void); +export OPT_Node OPT_NewNode (INT8 class); +export OPT_Object OPT_NewObj (void); +export OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +export void OPT_OpenScope (INT8 level, OPT_Object owner); +static void OPT_OutConstant (OPT_Object obj); +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void OPT_OutLinks (void); +static void OPT_OutMod (INT16 mno); +static void OPT_OutName (CHAR *name, ADDRESS name__len); +static void OPT_OutObj (OPT_Object obj); +static void OPT_OutSign (OPT_Struct result, OPT_Object par); +static void OPT_OutStr (OPT_Struct typ); +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj); +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len); +export OPT_Struct OPT_SetType (INT32 size); +export OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +export INT32 OPT_SizeAlignment (INT32 size); +export void OPT_TypSize (OPT_Struct typ); +static void OPT_err (INT16 n); + + +void OPT_InitRecno (void) +{ + OPT_recno = 0; +} + +static void OPT_err (INT16 n) +{ + OPM_err(n); +} + +INT16 OPT_IntSize (INT64 n) +{ + INT16 bytes; + if (n < 0) { + n = -(n + 1); + } + bytes = 1; + while ((bytes < 8 && __ASH(n, -(__ASHL(bytes, 3) - 1)) != 0)) { + bytes += 1; + } + return bytes; +} + +OPT_Struct OPT_IntType (INT32 size) +{ + if (size <= OPT_int8typ->size) { + return OPT_int8typ; + } + if (size <= OPT_int16typ->size) { + return OPT_int16typ; + } + if (size <= OPT_int32typ->size) { + return OPT_int32typ; + } + return OPT_int64typ; +} + +OPT_Struct OPT_SetType (INT32 size) +{ + if (size == OPT_set32typ->size) { + return OPT_set32typ; + } + return OPT_set64typ; +} + +OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir) +{ + INT16 i; + __ASSERT(x->form == 4, 0); + __ASSERT(x->BaseTyp == OPT_undftyp, 0); + __ASSERT(dir == 1 || dir == -1, 0); + if (dir > 0) { + if (x->size < OPT_sinttyp->size) { + return OPT_sinttyp; + } + if (x->size < OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size < OPT_linttyp->size) { + return OPT_linttyp; + } + return OPT_int64typ; + } else { + if (x->size > OPT_linttyp->size) { + return OPT_linttyp; + } + if (x->size > OPT_inttyp->size) { + return OPT_inttyp; + } + if (x->size > OPT_sinttyp->size) { + return OPT_sinttyp; + } + return OPT_int8typ; + } + __RETCHK; +} + +void OPT_Align (INT32 *adr, INT32 base) +{ + switch (base) { + case 2: + *adr += __MASK(*adr, -2); + break; + case 4: + *adr += __MASK(-*adr, -4); + break; + case 8: + *adr += __MASK(-*adr, -8); + break; + case 16: + *adr += __MASK(-*adr, -16); + break; + default: + break; + } +} + +INT32 OPT_SizeAlignment (INT32 size) +{ + INT32 alignment; + if (size < OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; + } + return alignment; +} + +INT32 OPT_BaseAlignment (OPT_Struct typ) +{ + INT32 alignment; + if (typ->form == 13) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPT_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPT_SizeAlignment(typ->size); + } + return alignment; +} + +void OPT_TypSize (OPT_Struct typ) +{ + INT16 f, c; + INT32 offset, size, base, fbase, off0; + OPT_Object fld = NIL; + OPT_Struct btyp = NIL; + if (typ == OPT_undftyp) { + OPM_err(58); + } else if (typ->size == -1) { + f = typ->form; + c = typ->comp; + if (c == 4) { + btyp = typ->BaseTyp; + if (btyp == NIL) { + offset = 0; + base = 1; + } else { + OPT_TypSize(btyp); + offset = btyp->size - __ASHR(btyp->sysflag, 8); + base = btyp->align; + } + fld = typ->link; + while ((fld != NIL && fld->mode == 4)) { + btyp = fld->typ; + OPT_TypSize(btyp); + size = btyp->size; + fbase = OPT_BaseAlignment(btyp); + OPT_Align(&offset, fbase); + fld->adr = offset; + offset += size; + if (fbase > base) { + base = fbase; + } + fld = fld->link; + } + off0 = offset; + if (offset == 0) { + offset = 1; + } + OPT_Align(&offset, base); + if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { + OPT_recno += 1; + base += __ASHL(OPT_recno, 16); + } + typ->size = offset; + typ->align = base; + typ->sysflag = __MASK(typ->sysflag, -256) + __SHORT(__ASHL(offset - off0, 8), 32768); + } else if (c == 2) { + OPT_TypSize(typ->BaseTyp); + typ->size = typ->n * typ->BaseTyp->size; + } else if (f == 11) { + typ->size = OPM_AddressSize; + if (typ->BaseTyp == OPT_undftyp) { + OPM_Mark(128, typ->n); + } else { + OPT_TypSize(typ->BaseTyp); + } + } else if (f == 12) { + typ->size = OPM_AddressSize; + } else if (c == 3) { + btyp = typ->BaseTyp; + OPT_TypSize(btyp); + if (btyp->comp == 3) { + typ->size = btyp->size + 4; + } else { + typ->size = 8; + } + } + } +} + +OPT_Const OPT_NewConst (void) +{ + OPT_Const const_ = NIL; + __NEW(const_, OPT_ConstDesc); + return const_; +} + +OPT_Object OPT_NewObj (void) +{ + OPT_Object obj = NIL; + __NEW(obj, OPT_ObjDesc); + obj->typ = NIL; + obj->conval = NIL; + obj->comment = NIL; + obj->name[0] = 0x00; + return obj; +} + +OPT_Struct OPT_NewStr (INT8 form, INT8 comp) +{ + OPT_Struct typ = NIL; + __NEW(typ, OPT_StrDesc); + typ->form = form; + typ->comp = comp; + typ->ref = 255; + if (form != 0) { + typ->txtpos = OPM_errpos; + } + typ->size = -1; + typ->BaseTyp = OPT_undftyp; + return typ; +} + +OPT_Node OPT_NewNode (INT8 class) +{ + OPT_Node node = NIL; + __NEW(node, OPT_NodeDesc); + node->class = class; + return node; +} + +OPT_ConstExt OPT_NewExt (void) +{ + OPT_ConstExt ext = NIL; + ext = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + return ext; +} + +void OPT_OpenScope (INT8 level, OPT_Object owner) +{ + OPT_Object head = NIL; + head = OPT_NewObj(); + head->mode = 12; + head->mnolev = level; + head->link = owner; + if (owner != NIL) { + owner->scope = head; + } + head->left = OPT_topScope; + head->right = NIL; + head->scope = NIL; + OPT_topScope = head; +} + +void OPT_CloseScope (void) +{ + OPT_topScope = OPT_topScope->left; +} + +void OPT_Init (OPS_Name name, UINT32 opt) +{ + OPT_topScope = OPT_universe; + OPT_OpenScope(0, NIL); + OPT_SYSimported = 0; + __MOVE(name, OPT_SelfName, 256); + __MOVE(name, OPT_topScope->name, 256); + OPT_GlbMod[0] = OPT_topScope; + OPT_nofGmod = 1; + OPT_newsf = __IN(4, opt, 32); + OPT_findpc = __IN(8, opt, 32); + OPT_extsf = OPT_newsf || __IN(9, opt, 32); + OPT_sfpresent = 1; + __NEW(OPT_Links, OPT_LinkDesc); + __MOVE(name, OPT_Links->name, 256); +} + +void OPT_Close (void) +{ + INT16 i; + OPT_CloseScope(); + i = 0; + while (i < 64) { + OPT_GlbMod[__X(i, 64)] = NIL; + i += 1; + } + i = 14; + while (i < 255) { + OPT_impCtxt.ref[__X(i, 255)] = NIL; + OPT_impCtxt.old[__X(i, 255)] = NIL; + i += 1; + } +} + +void OPT_FindImport (OPT_Object mod, OPT_Object *res) +{ + OPT_Object obj = NIL; + obj = mod->scope; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + if ((obj->mode == 5 && obj->vis == 0)) { + obj = NIL; + } else { + obj->used = 1; + } + break; + } + } + *res = obj; +} + +void OPT_Find (OPT_Object *res) +{ + OPT_Object obj = NIL, head = NIL; + head = OPT_topScope; + for (;;) { + obj = head->right; + for (;;) { + if (obj == NIL) { + break; + } + if (__STRCMP(OPS_name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(OPS_name, obj->name) > 0) { + obj = obj->right; + } else { + break; + } + } + if (obj != NIL) { + break; + } + head = head->left; + if (head == NIL) { + break; + } + } + *res = obj; +} + +void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res) +{ + OPT_Object obj = NIL; + while (typ != NIL) { + obj = typ->link; + while (obj != NIL) { + if (__STRCMP(name, obj->name) < 0) { + obj = obj->left; + } else if (__STRCMP(name, obj->name) > 0) { + obj = obj->right; + } else { + *res = obj; + return; + } + } + typ = typ->BaseTyp; + } + *res = NIL; +} + +void OPT_Insert (OPS_Name name, OPT_Object *obj) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + INT8 mnolev; + CHAR commentText[256]; + INT16 j; + ob0 = OPT_topScope; + ob1 = ob0->right; + left = 0; + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob0->right; + left = 0; + } else { + OPT_err(1); + ob0 = ob1; + ob1 = ob0->right; + } + } else { + ob1 = OPT_NewObj(); + ob1->leaf = 1; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + __COPY(name, ob1->name, 256); + mnolev = OPT_topScope->mnolev; + ob1->mnolev = mnolev; + OPM_GetComment((void*)commentText, 256); + if (commentText[0] != 0x00) { + ob1->comment = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + j = 0; + while ((j < 255 && commentText[__X(j, 256)] != 0x00)) { + (*ob1->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*ob1->comment)[__X(j, 256)] = 0x00; + } + break; + } + } + *obj = ob1; +} + +static void OPT_FPrintName (INT32 *fp, CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_FPrint(&*fp, (INT16)ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_DebugStruct (OPT_Struct btyp) +{ + OPM_LogWLn(); + if (btyp == NIL) { + OPM_LogWStr((CHAR*)"btyp is nil", 12); + OPM_LogWLn(); + } + OPM_LogWStr((CHAR*)"btyp^.strobji^.name = ", 23); + OPM_LogWStr(btyp->strobj->name, 256); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.form = ", 14); + OPM_LogWNum(btyp->form, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.comp = ", 14); + OPM_LogWNum(btyp->comp, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.mno = ", 13); + OPM_LogWNum(btyp->mno, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.extlev = ", 16); + OPM_LogWNum(btyp->extlev, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.size = ", 14); + OPM_LogWNum(btyp->size, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.align = ", 15); + OPM_LogWNum(btyp->align, 0); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"btyp^.txtpos = ", 16); + OPM_LogWNum(btyp->txtpos, 0); + OPM_LogWLn(); +} + +static void OPT_FPrintSign (INT32 *fp, OPT_Struct result, OPT_Object par) +{ + OPT_IdFPrint(result); + OPM_FPrint(&*fp, result->idfp); + while (par != NIL) { + OPM_FPrint(&*fp, par->mode); + OPT_IdFPrint(par->typ); + OPM_FPrint(&*fp, par->typ->idfp); + par = par->link; + } +} + +void OPT_IdFPrint (OPT_Struct typ) +{ + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL; + INT32 idfp; + INT16 f, c; + if (!typ->idfpdone) { + typ->idfpdone = 1; + idfp = 0; + f = typ->form; + OPM_FPrint(&idfp, f); + if (__IN(f, 0x90, 32)) { + OPM_FPrint(&idfp, typ->size); + } + c = typ->comp; + OPM_FPrint(&idfp, c); + btyp = typ->BaseTyp; + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_FPrintName(&idfp, (void*)OPT_GlbMod[__X(typ->mno, 64)]->name, 256); + OPT_FPrintName(&idfp, (void*)strobj->name, 256); + } + if ((f == 11 || (c == 4 && btyp != NIL)) || c == 3) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + } else if (c == 2) { + OPT_IdFPrint(btyp); + OPM_FPrint(&idfp, btyp->idfp); + OPM_FPrint(&idfp, typ->n); + } else if (f == 12) { + OPT_FPrintSign(&idfp, btyp, typ->link); + } + typ->idfp = idfp; + } +} + +static struct FPrintStr__15 { + INT32 *pbfp, *pvfp; + struct FPrintStr__15 *lnk; +} *FPrintStr__15_s; + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible); +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr); +static void FPrintTProcs__20 (OPT_Object obj); + +static void FPrintHdFld__18 (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + FPrintFlds__16(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + FPrintHdFld__18(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + FPrintHdFld__18(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_FPrint(&*FPrintStr__15_s->pvfp, 11); + OPM_FPrint(&*FPrintStr__15_s->pvfp, adr); + OPT_nofhdfld += 1; + } +} + +static void FPrintFlds__16 (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->vis); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)fld->name, 256); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->adr); + OPT_FPrintStr(fld->typ); + OPM_FPrint(&*FPrintStr__15_s->pbfp, fld->typ->pbfp); + OPM_FPrint(&*FPrintStr__15_s->pvfp, fld->typ->pvfp); + } else { + FPrintHdFld__18(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void FPrintTProcs__20 (OPT_Object obj) +{ + if (obj != NIL) { + FPrintTProcs__20(obj->left); + if (obj->mode == 13) { + if (obj->vis != 0) { + OPM_FPrint(&*FPrintStr__15_s->pbfp, 13); + OPM_FPrint(&*FPrintStr__15_s->pbfp, __ASHR(obj->adr, 16)); + OPT_FPrintSign(&*FPrintStr__15_s->pbfp, obj->typ, obj->link); + OPT_FPrintName(&*FPrintStr__15_s->pbfp, (void*)obj->name, 256); + } + } + FPrintTProcs__20(obj->right); + } +} + +void OPT_FPrintStr (OPT_Struct typ) +{ + INT16 f, c; + OPT_Struct btyp = NIL; + OPT_Object strobj = NIL, bstrobj = NIL; + INT32 pbfp, pvfp; + struct FPrintStr__15 _s; + _s.pbfp = &pbfp; + _s.pvfp = &pvfp; + _s.lnk = FPrintStr__15_s; + FPrintStr__15_s = &_s; + if (!typ->fpdone) { + OPT_IdFPrint(typ); + pbfp = typ->idfp; + if (typ->sysflag != 0) { + OPM_FPrint(&pbfp, typ->sysflag); + } + pvfp = pbfp; + typ->pbfp = pbfp; + typ->pvfp = pvfp; + typ->fpdone = 1; + f = typ->form; + c = typ->comp; + btyp = typ->BaseTyp; + if (f == 11) { + strobj = typ->strobj; + bstrobj = btyp->strobj; + if (((strobj == NIL || strobj->name[0] == 0x00) || bstrobj == NIL) || bstrobj->name[0] == 0x00) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + pvfp = pbfp; + } + } else if (f == 12) { + } else if (__IN(c, 0x0c, 32)) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pvfp); + pvfp = pbfp; + } else { + if (btyp != NIL) { + OPT_FPrintStr(btyp); + OPM_FPrint(&pbfp, btyp->pbfp); + OPM_FPrint(&pvfp, btyp->pvfp); + } + OPM_FPrint(&pvfp, typ->size); + OPM_FPrint(&pvfp, typ->align); + OPM_FPrint(&pvfp, typ->n); + OPT_nofhdfld = 0; + FPrintFlds__16(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(225, typ->txtpos); + } + FPrintTProcs__20(typ->link); + OPM_FPrint(&pvfp, pbfp); + strobj = typ->strobj; + if (strobj == NIL || strobj->name[0] == 0x00) { + pbfp = pvfp; + } + } + typ->pbfp = pbfp; + typ->pvfp = pvfp; + } + FPrintStr__15_s = _s.lnk; +} + +void OPT_FPrintObj (OPT_Object obj) +{ + INT32 fprint; + INT16 f, m; + REAL rval; + OPT_ConstExt ext = NIL; + if (!obj->fpdone) { + fprint = 0; + obj->fpdone = 1; + OPM_FPrint(&fprint, obj->mode); + if (obj->mode == 3) { + f = obj->typ->form; + OPM_FPrint(&fprint, f); + switch (f) { + case 2: case 3: case 4: + OPM_FPrint(&fprint, obj->conval->intval); + break; + case 7: + OPM_FPrintSet(&fprint, obj->conval->setval); + break; + case 5: + rval = obj->conval->realval; + OPM_FPrintReal(&fprint, rval); + break; + case 6: + OPM_FPrintLReal(&fprint, obj->conval->realval); + break; + case 8: + OPT_FPrintName(&fprint, (void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } + } else if (obj->mode == 1) { + OPM_FPrint(&fprint, obj->vis); + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } else if (__IN(obj->mode, 0x0480, 32)) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + } else if (obj->mode == 9) { + OPT_FPrintSign(&fprint, obj->typ, obj->link); + ext = obj->conval->ext; + m = (INT16)(*ext)[0]; + f = 1; + OPM_FPrint(&fprint, m); + while (f <= m) { + OPM_FPrint(&fprint, (INT16)(*ext)[__X(f, 256)]); + f += 1; + } + } else if (obj->mode == 5) { + OPT_FPrintStr(obj->typ); + OPM_FPrint(&fprint, obj->typ->pbfp); + } + obj->fprint = fprint; + } +} + +void OPT_FPrintErr (OPT_Object obj, INT16 errcode) +{ + INT16 i, j; + CHAR ch; + if (obj->mnolev != 0) { + __COPY(OPT_GlbMod[__X(-obj->mnolev, 64)]->name, OPM_objname, 64); + i = 0; + while (OPM_objname[__X(i, 64)] != 0x00) { + i += 1; + } + OPM_objname[__X(i, 64)] = '.'; + j = 0; + i += 1; + do { + ch = obj->name[__X(j, 256)]; + OPM_objname[__X(i, 64)] = ch; + j += 1; + i += 1; + } while (!(ch == 0x00)); + } else { + __COPY(obj->name, OPM_objname, 64); + } + if (errcode == 249) { + if (OPM_noerr) { + OPT_err(errcode); + } + } else if (errcode == 253) { + if ((((!OPT_symNew && !OPT_symExtended)) && !OPT_extsf)) { + OPT_err(errcode); + } + OPT_symExtended = 1; + } else { + if ((!OPT_symNew && !OPT_newsf)) { + OPT_err(errcode); + } + OPT_symNew = 1; + } +} + +void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old) +{ + OPT_Object ob0 = NIL, ob1 = NIL; + BOOLEAN left; + if (*root == NIL) { + *root = obj; + *old = NIL; + } else { + ob0 = *root; + ob1 = ob0->right; + left = 0; + if (__STRCMP(obj->name, ob0->name) < 0) { + ob1 = ob0->left; + left = 1; + } else if (__STRCMP(obj->name, ob0->name) > 0) { + ob1 = ob0->right; + left = 0; + } else { + *old = ob0; + return; + } + for (;;) { + if (ob1 != NIL) { + if (__STRCMP(obj->name, ob1->name) < 0) { + ob0 = ob1; + ob1 = ob1->left; + left = 1; + } else if (__STRCMP(obj->name, ob1->name) > 0) { + ob0 = ob1; + ob1 = ob1->right; + left = 0; + } else { + *old = ob1; + break; + } + } else { + ob1 = obj; + if (left) { + ob0->left = ob1; + } else { + ob0->right = ob1; + } + ob1->left = NIL; + ob1->right = NIL; + *old = NIL; + break; + } + } + } +} + +static void OPT_InName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + OPM_SymRCh(&ch); + name[__X(i, name__len)] = ch; + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_InMod (INT8 *mno) +{ + OPT_Object head = NIL; + OPS_Name name; + INT32 mn; + INT8 i; + mn = OPM_SymRInt(); + if (mn == 0) { + *mno = OPT_impCtxt.glbmno[0]; + } else { + if (mn == 16) { + OPT_InName((void*)name, 256); + if ((__STRCMP(name, OPT_SelfName) == 0 && !OPT_impCtxt.self)) { + OPT_err(154); + } + i = 0; + while ((i < OPT_nofGmod && __STRCMP(name, OPT_GlbMod[__X(i, 64)]->name) != 0)) { + i += 1; + } + if (i < OPT_nofGmod) { + *mno = i; + } else { + head = OPT_NewObj(); + head->mode = 12; + __COPY(name, head->name, 256); + *mno = OPT_nofGmod; + head->mnolev = -*mno; + if (OPT_nofGmod < 64) { + OPT_GlbMod[__X(*mno, 64)] = head; + OPT_nofGmod += 1; + } else { + OPT_err(227); + } + } + OPT_impCtxt.glbmno[__X(OPT_impCtxt.nofm, 64)] = *mno; + OPT_impCtxt.nofm += 1; + } else { + *mno = OPT_impCtxt.glbmno[__X(-mn, 64)]; + } + } +} + +static void OPT_InLinks (void) +{ + OPS_Name linkname; + OPT_Link l = NIL; + OPT_InName((void*)linkname, 256); + while (linkname[0] != 0x00) { + l = OPT_Links; + while ((l != NIL && __STRCMP(l->name, linkname) != 0)) { + l = l->next; + } + if (l == NIL) { + l = OPT_Links; + __NEW(OPT_Links, OPT_LinkDesc); + OPT_Links->next = l; + __MOVE(linkname, OPT_Links->name, 256); + } + OPT_InName((void*)linkname, 256); + } +} + +static void OPT_InConstant (INT32 f, OPT_Const conval) +{ + CHAR ch; + INT16 i; + OPT_ConstExt ext = NIL; + REAL rval; + switch (f) { + case 1: case 3: case 2: + OPM_SymRCh(&ch); + conval->intval = (INT16)ch; + break; + case 4: + conval->intval = OPM_SymRInt(); + break; + case 7: + OPM_SymRSet(&conval->setval); + break; + case 5: + OPM_SymRReal(&rval); + conval->realval = rval; + conval->intval = -1; + break; + case 6: + OPM_SymRLReal(&conval->realval); + conval->intval = -1; + break; + case 8: + ext = OPT_NewExt(); + conval->ext = ext; + i = 0; + do { + OPM_SymRCh(&ch); + (*ext)[__X(i, 256)] = ch; + i += 1; + } while (!(ch == 0x00)); + conval->intval2 = i; + conval->intval = -1; + break; + case 9: + conval->intval = 0; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", 37); + OPM_LogWNum(f, 0); + OPM_LogWLn(); + break; + } +} + +static void OPT_InSign (INT8 mno, OPT_Struct *res, OPT_Object *par) +{ + OPT_Object last = NIL, new = NIL; + INT32 tag; + OPT_InStruct(&*res); + tag = OPM_SymRInt(); + last = NIL; + while (tag != 18) { + if (tag < 0 || tag > 100) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag value in InSign: ", 37); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return; + } + new = OPT_NewObj(); + new->mnolev = -mno; + if (last == NIL) { + *par = new; + } else { + last->link = new; + } + if (tag == 23) { + new->mode = 1; + } else { + new->mode = 2; + } + OPT_InStruct(&new->typ); + new->adr = OPM_SymRInt(); + OPT_InName((void*)new->name, 256); + last = new; + tag = OPM_SymRInt(); + } +} + +static OPT_Object OPT_InFld (void) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + if (tag <= 26) { + obj->mode = 4; + if (tag == 26) { + obj->vis = 2; + } else { + obj->vis = 1; + } + OPT_InStruct(&obj->typ); + OPT_InName((void*)obj->name, 256); + obj->adr = OPM_SymRInt(); + } else { + obj->mode = 4; + if (tag == 27) { + __MOVE("@ptr", obj->name, 5); + } else { + __MOVE("@proc", obj->name, 6); + } + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = OPM_SymRInt(); + } + return obj; +} + +static OPT_Object OPT_InTProc (INT8 mno) +{ + INT32 tag; + OPT_Object obj = NIL; + tag = OPT_impCtxt.nextTag; + obj = OPT_NewObj(); + obj->mnolev = -mno; + if (tag == 29) { + obj->mode = 13; + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + obj->vis = 1; + OPT_InName((void*)obj->name, 256); + obj->adr = __ASHL(OPM_SymRInt(), 16); + } else { + obj->mode = 13; + __MOVE("@tproc", obj->name, 7); + obj->link = OPT_NewObj(); + obj->typ = OPT_undftyp; + obj->vis = 0; + obj->adr = __ASHL(OPM_SymRInt(), 16); + } + return obj; +} + +static OPT_Struct OPT_InTyp (INT32 tag) +{ + if (tag == 4) { + return OPT_IntType(OPM_SymRInt()); + } else if (tag == 7) { + return OPT_SetType(OPM_SymRInt()); + } else { + return OPT_impCtxt.ref[__X(tag, 255)]; + } + __RETCHK; +} + +static void OPT_InStruct (OPT_Struct *typ) +{ + INT8 mno; + INT16 ref; + INT32 tag; + OPS_Name name; + OPT_Struct t = NIL; + OPT_Object obj = NIL, last = NIL, fld = NIL, old = NIL, dummy = NIL; + tag = OPM_SymRInt(); + if (tag != 34) { + *typ = OPT_InTyp(-tag); + } else { + ref = OPT_impCtxt.nofr; + OPT_impCtxt.nofr += 1; + if (ref < OPT_impCtxt.minr) { + OPT_impCtxt.minr = ref; + } + OPT_InMod(&mno); + OPT_InName((void*)name, 256); + obj = OPT_NewObj(); + if (name[0] == 0x00) { + if (OPT_impCtxt.self) { + old = NIL; + } else { + __MOVE("@", obj->name, 2); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + obj->name[0] = 0x00; + } + *typ = OPT_NewStr(0, 1); + } else { + __MOVE(name, obj->name, 256); + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (old != NIL) { + OPT_FPrintObj(old); + OPT_impCtxt.pvfp[__X(ref, 255)] = old->typ->pvfp; + if (OPT_impCtxt.self) { + *typ = OPT_NewStr(0, 1); + } else { + *typ = old->typ; + (*typ)->link = NIL; + (*typ)->sysflag = 0; + (*typ)->fpdone = 0; + (*typ)->idfpdone = 0; + } + } else { + *typ = OPT_NewStr(0, 1); + } + } + OPT_impCtxt.ref[__X(ref, 255)] = *typ; + OPT_impCtxt.old[__X(ref, 255)] = old; + (*typ)->ref = ref + 255; + (*typ)->mno = mno; + (*typ)->allocated = 1; + (*typ)->strobj = obj; + obj->mode = 5; + obj->typ = *typ; + obj->mnolev = -mno; + obj->vis = 0; + tag = OPM_SymRInt(); + if (tag == 35) { + (*typ)->sysflag = __SHORTF(OPM_SymRInt(), 32768); + tag = OPM_SymRInt(); + } + switch (tag) { + case 36: + (*typ)->form = 11; + (*typ)->size = OPM_AddressSize; + (*typ)->n = 0; + OPT_InStruct(&(*typ)->BaseTyp); + break; + case 37: + (*typ)->form = 13; + (*typ)->comp = 2; + OPT_InStruct(&(*typ)->BaseTyp); + (*typ)->n = OPM_SymRInt(); + OPT_TypSize(*typ); + break; + case 38: + (*typ)->form = 13; + (*typ)->comp = 3; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp->comp == 3) { + (*typ)->n = (*typ)->BaseTyp->n + 1; + } else { + (*typ)->n = 0; + } + OPT_TypSize(*typ); + break; + case 39: + (*typ)->form = 13; + (*typ)->comp = 4; + OPT_InStruct(&(*typ)->BaseTyp); + if ((*typ)->BaseTyp == OPT_notyp) { + (*typ)->BaseTyp = NIL; + } + (*typ)->extlev = 0; + t = (*typ)->BaseTyp; + while (t != NIL) { + (*typ)->extlev += 1; + t = t->BaseTyp; + } + (*typ)->size = OPM_SymRInt(); + (*typ)->align = OPM_SymRInt(); + (*typ)->n = OPM_SymRInt(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + last = NIL; + while ((OPT_impCtxt.nextTag >= 25 && OPT_impCtxt.nextTag <= 28)) { + fld = OPT_InFld(); + fld->mnolev = -mno; + if (last != NIL) { + last->link = fld; + } + last = fld; + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + while (OPT_impCtxt.nextTag != 18) { + fld = OPT_InTProc(mno); + OPT_InsertImport(fld, &(*typ)->link, &dummy); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + break; + case 40: + (*typ)->form = 12; + (*typ)->size = OPM_AddressSize; + OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", 35); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + break; + } + if (ref == OPT_impCtxt.minr) { + while (ref < OPT_impCtxt.nofr) { + t = OPT_InTyp(ref); + OPT_FPrintStr(t); + obj = t->strobj; + if (obj->name[0] != 0x00) { + OPT_FPrintObj(obj); + } + old = OPT_impCtxt.old[__X(ref, 255)]; + if (old != NIL) { + t->strobj = old; + if (OPT_impCtxt.self) { + if (old->mnolev < 0) { + if (old->history != 5) { + if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } + } + } else if (old->fprint != obj->fprint) { + old->history = 2; + } else if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 3; + } else if (old->vis == 0) { + old->history = 1; + } else { + old->history = 0; + } + } else { + if (OPT_impCtxt.pvfp[__X(ref, 255)] != t->pvfp) { + old->history = 5; + } + if (old->fprint != obj->fprint) { + OPT_FPrintErr(old, 249); + } + } + } else if (OPT_impCtxt.self) { + obj->history = 4; + } else { + obj->history = 1; + } + ref += 1; + } + OPT_impCtxt.minr = 255; + } + } +} + +static OPT_Object OPT_InObj (INT8 mno) +{ + INT16 i, s; + CHAR ch; + OPT_Object obj = NIL, old = NIL; + OPT_Struct typ = NIL; + INT32 tag; + OPT_ConstExt ext = NIL; + OPS_Name commentText; + BOOLEAN hasComment; + INT16 j; + INT32 len; + tag = OPT_impCtxt.nextTag; + hasComment = 0; + while (tag == 41) { + len = OPM_SymRInt(); + if (len < 0) { + len = 0; + } + if (len > 255) { + len = 255; + } + i = 0; + while (i < len) { + OPM_SymRCh(&commentText[__X(i, 256)]); + i += 1; + } + commentText[__X(i, 256)] = 0x00; + hasComment = 1; + tag = OPM_SymRInt(); + } + OPT_impCtxt.nextTag = tag; + if (tag < 0 || tag > 50) { + OPM_LogWStr((CHAR*)"ERROR: Invalid tag in InObj: ", 30); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + if (tag == 19) { + OPT_InStruct(&typ); + obj = typ->strobj; + if (!OPT_impCtxt.self) { + obj->vis = 1; + } + } else { + obj = OPT_NewObj(); + obj->mnolev = -mno; + obj->vis = 1; + if (tag <= 11) { + obj->mode = 3; + obj->conval = OPT_NewConst(); + OPT_InConstant(tag, obj->conval); + obj->typ = OPT_InTyp(tag); + } else if ((tag >= 31 && tag <= 33)) { + obj->conval = OPT_NewConst(); + obj->conval->intval = -1; + OPT_InSign(mno, &obj->typ, &obj->link); + switch (tag) { + case 31: + obj->mode = 7; + break; + case 32: + obj->mode = 10; + break; + case 33: + obj->mode = 9; + ext = OPT_NewExt(); + obj->conval->ext = ext; + s = __SHORTF(OPM_SymRInt(), 32768); + (*ext)[0] = __CHR(s); + i = 1; + while (i <= s) { + OPM_SymRCh(&(*ext)[__X(i, 256)]); + i += 1; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", 32); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + break; + } + } else if (tag == 20) { + obj->mode = 5; + OPT_InStruct(&obj->typ); + } else if (tag == 21 || tag == 22) { + obj->mode = 1; + if (tag == 22) { + obj->vis = 2; + } + OPT_InStruct(&obj->typ); + } else { + OPM_LogWStr((CHAR*)"ERROR: Unexpected tag in InObj: ", 33); + OPM_LogWNum(tag, 0); + OPM_LogWLn(); + OPM_err(155); + return NIL; + } + OPT_InName((void*)obj->name, 256); + } + if ((hasComment && obj != NIL)) { + obj->comment = __NEWARR(NIL, 1, 1, 1, 0, ((INT64)(256))); + j = 0; + while ((((j < 255 && j < len)) && commentText[__X(j, 256)] != 0x00)) { + (*obj->comment)[__X(j, 256)] = commentText[__X(j, 256)]; + j += 1; + } + (*obj->comment)[__X(j, 256)] = 0x00; + } + OPT_FPrintObj(obj); + if ((obj->mode == 1 && (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00))) { + OPM_FPrint(&OPT_impCtxt.reffp, obj->typ->ref - 255); + } + if (tag != 19) { + OPT_InsertImport(obj, &OPT_GlbMod[__X(mno, 64)]->right, &old); + if (OPT_impCtxt.self) { + if (old != NIL) { + if (old->vis == 0) { + old->history = 4; + } else { + OPT_FPrintObj(old); + if (obj->fprint != old->fprint) { + old->history = 2; + } else if (obj->typ->pvfp != old->typ->pvfp) { + old->history = 3; + } else { + old->history = 1; + } + } + } else { + obj->history = 4; + } + } + } else { + if (OPT_impCtxt.self) { + if (obj->vis == 0) { + obj->history = 4; + } else if (obj->history == 0) { + obj->history = 1; + } + } + } + return obj; +} + +void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done) +{ + OPT_Object obj = NIL; + INT8 mno; + OPS_Name aliasName__copy; + __DUPARR(aliasName, OPS_Name); + if (__STRCMP(name, "SYSTEM") == 0) { + OPT_SYSimported = 1; + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->mnolev = 0; + obj->scope = OPT_syslink; + obj->typ = OPT_notyp; + } else { + OPT_impCtxt.nofr = 14; + OPT_impCtxt.minr = 255; + OPT_impCtxt.nofm = 0; + OPT_impCtxt.self = __STRCMP(aliasName, "@self") == 0; + OPT_impCtxt.reffp = 0; + if ((OPT_impCtxt.self && __IN(17, OPM_Options, 32))) { + OPM_DeleteSym((void*)name, 256); + *done = 0; + } else { + OPM_OldSym((void*)name, 256, &*done); + } + if (*done) { + OPT_InMod(&mno); + OPT_InLinks(); + OPT_impCtxt.nextTag = OPM_SymRInt(); + while (!OPM_eofSF()) { + obj = OPT_InObj(mno); + OPT_impCtxt.nextTag = OPM_SymRInt(); + } + OPT_Insert(aliasName, &obj); + obj->mode = 11; + obj->scope = OPT_GlbMod[__X(mno, 64)]->right; + OPT_GlbMod[__X(mno, 64)]->link = obj; + obj->mnolev = -mno; + obj->typ = OPT_notyp; + OPM_CloseOldSym(); + } else if (OPT_impCtxt.self) { + OPT_newsf = 1; + OPT_extsf = 1; + OPT_sfpresent = 0; + } else { + OPT_err(152); + } + } +} + +static void OPT_OutName (CHAR *name, ADDRESS name__len) +{ + INT16 i; + CHAR ch; + i = 0; + do { + ch = name[__X(i, name__len)]; + OPM_SymWCh(ch); + i += 1; + } while (!(ch == 0x00)); +} + +static void OPT_OutMod (INT16 mno) +{ + if (OPT_expCtxt.locmno[__X(mno, 64)] < 0) { + OPM_SymWInt(16); + OPT_expCtxt.locmno[__X(mno, 64)] = OPT_expCtxt.nofm; + OPT_expCtxt.nofm += 1; + OPT_OutName((void*)OPT_GlbMod[__X(mno, 64)]->name, 256); + } else { + OPM_SymWInt(-OPT_expCtxt.locmno[__X(mno, 64)]); + } +} + +static void OPT_OutLinks (void) +{ + OPT_Link l = NIL; + l = OPT_Links; + while (l != NIL) { + OPT_OutName((void*)l->name, 256); + l = l->next; + } + OPM_SymWCh(0x00); +} + +static void OPT_OutHdFld (OPT_Struct typ, OPT_Object fld, INT32 adr) +{ + INT32 i, j, n; + OPT_Struct btyp = NIL; + if (typ->comp == 4) { + OPT_OutFlds(typ->link, adr, 0); + } else if (typ->comp == 2) { + btyp = typ->BaseTyp; + n = typ->n; + while (btyp->comp == 2) { + n = btyp->n * n; + btyp = btyp->BaseTyp; + } + if (btyp->form == 11 || btyp->comp == 4) { + j = OPT_nofhdfld; + OPT_OutHdFld(btyp, fld, adr); + if (j != OPT_nofhdfld) { + i = 1; + while ((i < n && OPT_nofhdfld <= 2048)) { + adr += btyp->size; + OPT_OutHdFld(btyp, fld, adr); + i += 1; + } + } + } + } else if (typ->form == 11 || __STRCMP(fld->name, "@ptr") == 0) { + OPM_SymWInt(27); + OPM_SymWInt(adr); + OPT_nofhdfld += 1; + } +} + +static void OPT_OutFlds (OPT_Object fld, INT32 adr, BOOLEAN visible) +{ + while ((fld != NIL && fld->mode == 4)) { + if ((fld->vis != 0 && visible)) { + if (fld->vis == 2) { + OPM_SymWInt(26); + } else { + OPM_SymWInt(25); + } + OPT_OutStr(fld->typ); + OPT_OutName((void*)fld->name, 256); + OPM_SymWInt(fld->adr); + } else { + OPT_OutHdFld(fld->typ, fld, fld->adr + adr); + } + fld = fld->link; + } +} + +static void OPT_OutSign (OPT_Struct result, OPT_Object par) +{ + OPT_OutStr(result); + while (par != NIL) { + if (par->mode == 1) { + OPM_SymWInt(23); + } else { + OPM_SymWInt(24); + } + OPT_OutStr(par->typ); + OPM_SymWInt(par->adr); + OPT_OutName((void*)par->name, 256); + par = par->link; + } + OPM_SymWInt(18); +} + +static void OPT_OutTProcs (OPT_Struct typ, OPT_Object obj) +{ + if (obj != NIL) { + OPT_OutTProcs(typ, obj->left); + if (obj->mode == 13) { + if ((((typ->BaseTyp != NIL && __ASHR(obj->adr, 16) < typ->BaseTyp->n)) && obj->vis == 0)) { + OPM_Mark(109, typ->txtpos); + } + if (obj->vis != 0) { + if (obj->vis != 0) { + OPM_SymWInt(29); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } else { + OPM_SymWInt(30); + OPM_SymWInt(__ASHR(obj->adr, 16)); + } + } + } + OPT_OutTProcs(typ, obj->right); + } +} + +static void OPT_OutStr (OPT_Struct typ) +{ + OPT_Object strobj = NIL; + if (typ->ref < OPT_expCtxt.ref) { + OPM_SymWInt(-typ->ref); + if (__IN(typ->ref, 0x90, 32)) { + OPM_SymWInt(typ->size); + } + } else { + OPM_SymWInt(34); + typ->ref = OPT_expCtxt.ref; + OPT_expCtxt.ref += 1; + if (OPT_expCtxt.ref >= 255) { + OPT_err(228); + } + OPT_OutMod(typ->mno); + strobj = typ->strobj; + if ((strobj != NIL && strobj->name[0] != 0x00)) { + OPT_OutName((void*)strobj->name, 256); + switch (strobj->history) { + case 2: + OPT_FPrintErr(strobj, 252); + break; + case 3: + OPT_FPrintErr(strobj, 251); + break; + case 5: + OPT_FPrintErr(strobj, 249); + break; + default: + break; + } + } else { + OPM_SymWCh(0x00); + } + if (typ->sysflag != 0) { + OPM_SymWInt(35); + OPM_SymWInt(typ->sysflag); + } + switch (typ->form) { + case 11: + OPM_SymWInt(36); + OPT_OutStr(typ->BaseTyp); + break; + case 12: + OPM_SymWInt(40); + OPT_OutSign(typ->BaseTyp, typ->link); + break; + case 13: + switch (typ->comp) { + case 2: + OPM_SymWInt(37); + OPT_OutStr(typ->BaseTyp); + OPM_SymWInt(typ->n); + break; + case 3: + OPM_SymWInt(38); + OPT_OutStr(typ->BaseTyp); + break; + case 4: + OPM_SymWInt(39); + if (typ->BaseTyp == NIL) { + OPT_OutStr(OPT_notyp); + } else { + OPT_OutStr(typ->BaseTyp); + } + OPM_SymWInt(typ->size); + OPM_SymWInt(typ->align); + OPM_SymWInt(typ->n); + OPT_nofhdfld = 0; + OPT_OutFlds(typ->link, 0, 1); + if (OPT_nofhdfld > 2048) { + OPM_Mark(223, typ->txtpos); + } + OPT_OutTProcs(typ, typ->link); + OPM_SymWInt(18); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", 39); + OPM_LogWNum(typ->comp, 0); + OPM_LogWLn(); + break; + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", 39); + OPM_LogWNum(typ->form, 0); + OPM_LogWLn(); + break; + } + } +} + +static void OPT_OutConstant (OPT_Object obj) +{ + INT16 f; + REAL rval; + f = obj->typ->form; + OPM_SymWInt(f); + switch (f) { + case 2: case 3: + OPM_SymWCh(__CHR(obj->conval->intval)); + break; + case 4: + OPM_SymWInt(obj->conval->intval); + OPM_SymWInt(obj->typ->size); + break; + case 7: + OPM_SymWSet(obj->conval->setval); + OPM_SymWInt(obj->typ->size); + break; + case 5: + rval = obj->conval->realval; + OPM_SymWReal(rval); + break; + case 6: + OPM_SymWLReal(obj->conval->realval); + break; + case 8: + OPT_OutName((void*)*obj->conval->ext, 256); + break; + case 9: + break; + default: + OPT_err(127); + break; + } +} + +static void OPT_OutTruncatedName (CHAR *text, ADDRESS text__len) +{ + INT16 i; + __DUP(text, text__len, CHAR); + i = 0; + while ((i < 255 && text[__X(i, text__len)] != 0x00)) { + OPM_SymWCh(text[__X(i, text__len)]); + i += 1; + } + OPM_SymWCh(0x00); + __DEL(text); +} + +static void OPT_OutObj (OPT_Object obj) +{ + INT16 i, j; + OPT_ConstExt ext = NIL; + INT16 k, l; + if (obj != NIL) { + OPT_OutObj(obj->left); + if (__IN(obj->mode, 0x06ea, 32)) { + if (obj->comment != NIL) { + OPM_SymWInt(41); + k = 0; + while ((k < 255 && (*obj->comment)[__X(k, 256)] != 0x00)) { + k += 1; + } + OPM_SymWInt(k); + l = 0; + while (l < k) { + OPM_SymWCh((*obj->comment)[__X(l, 256)]); + l += 1; + } + } + if (obj->history == 4) { + OPT_FPrintErr(obj, 250); + } else if (obj->vis != 0) { + switch (obj->history) { + case 0: + OPT_FPrintErr(obj, 253); + break; + case 1: + break; + case 2: + OPT_FPrintErr(obj, 252); + break; + case 3: + OPT_FPrintErr(obj, 251); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", 42); + OPM_LogWNum(obj->history, 0); + OPM_LogWLn(); + break; + } + switch (obj->mode) { + case 3: + OPT_OutConstant(obj); + OPT_OutName((void*)obj->name, 256); + break; + case 5: + if (obj->typ->strobj == obj) { + OPM_SymWInt(19); + OPT_OutStr(obj->typ); + } else { + OPM_SymWInt(20); + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + } + break; + case 1: + if (obj->vis == 2) { + OPM_SymWInt(22); + } else { + OPM_SymWInt(21); + } + OPT_OutStr(obj->typ); + OPT_OutName((void*)obj->name, 256); + if (obj->typ->strobj == NIL || obj->typ->strobj->name[0] == 0x00) { + OPM_FPrint(&OPT_expCtxt.reffp, obj->typ->ref); + } + break; + case 7: + OPM_SymWInt(31); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 10: + OPM_SymWInt(32); + OPT_OutSign(obj->typ, obj->link); + OPT_OutName((void*)obj->name, 256); + break; + case 9: + OPM_SymWInt(33); + OPT_OutSign(obj->typ, obj->link); + ext = obj->conval->ext; + j = (INT16)(*ext)[0]; + i = 1; + OPM_SymWInt(j); + while (i <= j) { + OPM_SymWCh((*ext)[__X(i, 256)]); + i += 1; + } + OPT_OutName((void*)obj->name, 256); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", 38); + OPM_LogWNum(obj->mode, 0); + OPM_LogWLn(); + break; + } + } + } + OPT_OutObj(obj->right); + } +} + +void OPT_Export (BOOLEAN *ext, BOOLEAN *new) +{ + INT16 i; + INT8 nofmod; + BOOLEAN done; + OPT_symExtended = 0; + OPT_symNew = 0; + nofmod = OPT_nofGmod; + OPT_Import((CHAR*)"@self", OPT_SelfName, &done); + OPT_nofGmod = nofmod; + if (OPM_noerr) { + OPM_NewSym((void*)OPT_SelfName, 256); + if (OPM_noerr) { + OPM_SymWInt(16); + OPT_OutName((void*)OPT_SelfName, 256); + OPT_OutLinks(); + OPT_expCtxt.reffp = 0; + OPT_expCtxt.ref = 14; + OPT_expCtxt.nofm = 1; + OPT_expCtxt.locmno[0] = 0; + i = 1; + while (i < 64) { + OPT_expCtxt.locmno[__X(i, 64)] = -1; + i += 1; + } + OPT_OutObj(OPT_topScope->right); + *ext = (OPT_sfpresent && OPT_symExtended); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); + if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { + *new = 1; + if (!OPT_extsf) { + OPT_err(155); + } + } + OPT_newsf = 0; + OPT_symNew = 0; + if (!OPM_noerr || OPT_findpc) { + OPM_DeleteSym((void*)OPT_SelfName, 256); + } + } + } +} + +static void OPT_InitStruct (OPT_Struct *typ, INT8 form) +{ + *typ = OPT_NewStr(form, 1); + (*typ)->ref = form; + (*typ)->size = 1; + (*typ)->allocated = 1; + (*typ)->strobj = OPT_NewObj(); + (*typ)->pbfp = form; + (*typ)->pvfp = form; + (*typ)->fpdone = 1; + (*typ)->idfp = form; + (*typ)->idfpdone = 1; +} + +static void OPT_EnterBoolConst (OPS_Name name, INT32 value) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->conval = OPT_NewConst(); + obj->mode = 3; + obj->typ = OPT_booltyp; + obj->conval->intval = value; +} + +static void OPT_EnterTyp (OPS_Name name, INT8 form, INT16 size, OPT_Struct *res) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + typ = OPT_NewStr(form, 1); + obj->mode = 5; + obj->typ = typ; + obj->vis = 1; + typ->strobj = obj; + typ->size = size; + typ->ref = form; + typ->allocated = 1; + typ->pbfp = form; + typ->pvfp = form; + typ->fpdone = 1; + typ->idfp = form; + typ->idfpdone = 1; + if (__IN(form, 0x90, 32)) { + OPM_FPrint(&typ->idfp, typ->size); + } + *res = typ; +} + +static void OPT_EnterTypeAlias (OPS_Name name, OPT_Object *res) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 5; + obj->typ = NIL; + obj->vis = 1; + *res = obj; +} + +static void OPT_EnterProc (OPS_Name name, INT16 num) +{ + OPT_Object obj = NIL; + OPS_Name name__copy; + __DUPARR(name, OPS_Name); + OPT_Insert(name, &obj); + obj->mode = 8; + obj->typ = OPT_notyp; + obj->adr = num; +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(OPT_topScope); + P(OPT_undftyp); + P(OPT_niltyp); + P(OPT_notyp); + P(OPT_bytetyp); + P(OPT_cpbytetyp); + P(OPT_booltyp); + P(OPT_chartyp); + P(OPT_sinttyp); + P(OPT_inttyp); + P(OPT_linttyp); + P(OPT_hinttyp); + P(OPT_int8typ); + P(OPT_int16typ); + P(OPT_int32typ); + P(OPT_int64typ); + P(OPT_settyp); + P(OPT_set32typ); + P(OPT_set64typ); + P(OPT_realtyp); + P(OPT_lrltyp); + P(OPT_stringtyp); + P(OPT_adrtyp); + P(OPT_sysptrtyp); + P(OPT_sintobj); + P(OPT_intobj); + P(OPT_lintobj); + P(OPT_setobj); + __ENUMP(OPT_GlbMod, 64, P); + P(OPT_universe); + P(OPT_syslink); + __ENUMR(&OPT_impCtxt, OPT_ImpCtxt__typ, 5184, 1, P); + P(OPT_Links); +} + +__TDESC(OPT_ConstDesc, 1, 1) = {__TDFLDS("ConstDesc", 40), {0, -16}}; +__TDESC(OPT_ObjDesc, 1, 7) = {__TDFLDS("ObjDesc", 344), {0, 8, 16, 24, 304, 312, 336, -64}}; +__TDESC(OPT_StrDesc, 1, 3) = {__TDFLDS("StrDesc", 72), {48, 56, 64, -32}}; +__TDESC(OPT_NodeDesc, 1, 6) = {__TDFLDS("NodeDesc", 56), {0, 8, 16, 32, 40, 48, -56}}; +__TDESC(OPT_ImpCtxt, 1, 510) = {__TDFLDS("ImpCtxt", 5184), {16, 24, 32, 40, 48, 56, 64, 72, 80, 88, 96, 104, 112, 120, 128, 136, + 144, 152, 160, 168, 176, 184, 192, 200, 208, 216, 224, 232, 240, 248, 256, 264, + 272, 280, 288, 296, 304, 312, 320, 328, 336, 344, 352, 360, 368, 376, 384, 392, + 400, 408, 416, 424, 432, 440, 448, 456, 464, 472, 480, 488, 496, 504, 512, 520, + 528, 536, 544, 552, 560, 568, 576, 584, 592, 600, 608, 616, 624, 632, 640, 648, + 656, 664, 672, 680, 688, 696, 704, 712, 720, 728, 736, 744, 752, 760, 768, 776, + 784, 792, 800, 808, 816, 824, 832, 840, 848, 856, 864, 872, 880, 888, 896, 904, + 912, 920, 928, 936, 944, 952, 960, 968, 976, 984, 992, 1000, 1008, 1016, 1024, 1032, + 1040, 1048, 1056, 1064, 1072, 1080, 1088, 1096, 1104, 1112, 1120, 1128, 1136, 1144, 1152, 1160, + 1168, 1176, 1184, 1192, 1200, 1208, 1216, 1224, 1232, 1240, 1248, 1256, 1264, 1272, 1280, 1288, + 1296, 1304, 1312, 1320, 1328, 1336, 1344, 1352, 1360, 1368, 1376, 1384, 1392, 1400, 1408, 1416, + 1424, 1432, 1440, 1448, 1456, 1464, 1472, 1480, 1488, 1496, 1504, 1512, 1520, 1528, 1536, 1544, + 1552, 1560, 1568, 1576, 1584, 1592, 1600, 1608, 1616, 1624, 1632, 1640, 1648, 1656, 1664, 1672, + 1680, 1688, 1696, 1704, 1712, 1720, 1728, 1736, 1744, 1752, 1760, 1768, 1776, 1784, 1792, 1800, + 1808, 1816, 1824, 1832, 1840, 1848, 1856, 1864, 1872, 1880, 1888, 1896, 1904, 1912, 1920, 1928, + 1936, 1944, 1952, 1960, 1968, 1976, 1984, 1992, 2000, 2008, 2016, 2024, 2032, 2040, 2048, 2056, + 2064, 2072, 2080, 2088, 2096, 2104, 2112, 2120, 2128, 2136, 2144, 2152, 2160, 2168, 2176, 2184, + 2192, 2200, 2208, 2216, 2224, 2232, 2240, 2248, 2256, 2264, 2272, 2280, 2288, 2296, 2304, 2312, + 2320, 2328, 2336, 2344, 2352, 2360, 2368, 2376, 2384, 2392, 2400, 2408, 2416, 2424, 2432, 2440, + 2448, 2456, 2464, 2472, 2480, 2488, 2496, 2504, 2512, 2520, 2528, 2536, 2544, 2552, 2560, 2568, + 2576, 2584, 2592, 2600, 2608, 2616, 2624, 2632, 2640, 2648, 2656, 2664, 2672, 2680, 2688, 2696, + 2704, 2712, 2720, 2728, 2736, 2744, 2752, 2760, 2768, 2776, 2784, 2792, 2800, 2808, 2816, 2824, + 2832, 2840, 2848, 2856, 2864, 2872, 2880, 2888, 2896, 2904, 2912, 2920, 2928, 2936, 2944, 2952, + 2960, 2968, 2976, 2984, 2992, 3000, 3008, 3016, 3024, 3032, 3040, 3048, 3056, 3064, 3072, 3080, + 3088, 3096, 3104, 3112, 3120, 3128, 3136, 3144, 3152, 3160, 3168, 3176, 3184, 3192, 3200, 3208, + 3216, 3224, 3232, 3240, 3248, 3256, 3264, 3272, 3280, 3288, 3296, 3304, 3312, 3320, 3328, 3336, + 3344, 3352, 3360, 3368, 3376, 3384, 3392, 3400, 3408, 3416, 3424, 3432, 3440, 3448, 3456, 3464, + 3472, 3480, 3488, 3496, 3504, 3512, 3520, 3528, 3536, 3544, 3552, 3560, 3568, 3576, 3584, 3592, + 3600, 3608, 3616, 3624, 3632, 3640, 3648, 3656, 3664, 3672, 3680, 3688, 3696, 3704, 3712, 3720, + 3728, 3736, 3744, 3752, 3760, 3768, 3776, 3784, 3792, 3800, 3808, 3816, 3824, 3832, 3840, 3848, + 3856, 3864, 3872, 3880, 3888, 3896, 3904, 3912, 3920, 3928, 3936, 3944, 3952, 3960, 3968, 3976, + 3984, 3992, 4000, 4008, 4016, 4024, 4032, 4040, 4048, 4056, 4064, 4072, 4080, 4088, -4088}}; +__TDESC(OPT_ExpCtxt, 1, 0) = {__TDFLDS("ExpCtxt", 72), {-8}}; +__TDESC(OPT_LinkDesc, 1, 1) = {__TDFLDS("LinkDesc", 264), {256, -16}}; + +export void *OPT__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __REGMOD("OPT", EnumPtrs); + __REGCMD("Close", OPT_Close); + __REGCMD("CloseScope", OPT_CloseScope); + __REGCMD("InitRecno", OPT_InitRecno); + __INITYP(OPT_ConstDesc, OPT_ConstDesc, 0); + __INITYP(OPT_ObjDesc, OPT_ObjDesc, 0); + __INITYP(OPT_StrDesc, OPT_StrDesc, 0); + __INITYP(OPT_NodeDesc, OPT_NodeDesc, 0); + __INITYP(OPT_ImpCtxt, OPT_ImpCtxt, 0); + __INITYP(OPT_ExpCtxt, OPT_ExpCtxt, 0); + __INITYP(OPT_LinkDesc, OPT_LinkDesc, 0); +/* BEGIN */ + OPT_topScope = NIL; + OPT_OpenScope(0, NIL); + OPM_errpos = 0; + OPT_InitStruct(&OPT_undftyp, 0); + OPT_undftyp->BaseTyp = OPT_undftyp; + OPT_InitStruct(&OPT_notyp, 10); + OPT_InitStruct(&OPT_stringtyp, 8); + OPT_InitStruct(&OPT_niltyp, 9); + OPT_EnterTyp((CHAR*)"BYTE", 1, 1, &OPT_bytetyp); + OPT_EnterTyp((CHAR*)"PTR", 11, -1, &OPT_sysptrtyp); + OPT_EnterTyp((CHAR*)"ADDRESS", 4, -1, &OPT_adrtyp); + OPT_EnterTyp((CHAR*)"INT8", 4, 1, &OPT_int8typ); + OPT_EnterTyp((CHAR*)"INT16", 4, 2, &OPT_int16typ); + OPT_EnterTyp((CHAR*)"INT32", 4, 4, &OPT_int32typ); + OPT_EnterTyp((CHAR*)"INT64", 4, 8, &OPT_int64typ); + OPT_EnterTyp((CHAR*)"SET32", 7, 4, &OPT_set32typ); + OPT_EnterTyp((CHAR*)"SET64", 7, 8, &OPT_set64typ); + OPT_EnterProc((CHAR*)"ADR", 20); + OPT_EnterProc((CHAR*)"CC", 21); + OPT_EnterProc((CHAR*)"LSH", 22); + OPT_EnterProc((CHAR*)"ROT", 23); + OPT_EnterProc((CHAR*)"GET", 24); + OPT_EnterProc((CHAR*)"PUT", 25); + OPT_EnterProc((CHAR*)"GETREG", 26); + OPT_EnterProc((CHAR*)"PUTREG", 27); + OPT_EnterProc((CHAR*)"BIT", 28); + OPT_EnterProc((CHAR*)"VAL", 29); + OPT_EnterProc((CHAR*)"NEW", 30); + OPT_EnterProc((CHAR*)"MOVE", 31); + OPT_syslink = OPT_topScope->right; + OPT_universe = OPT_topScope; + OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, 1, &OPT_booltyp); + OPT_EnterTyp((CHAR*)"CHAR", 3, 1, &OPT_chartyp); + OPT_EnterTyp((CHAR*)"REAL", 5, 4, &OPT_realtyp); + OPT_EnterTyp((CHAR*)"LONGREAL", 6, 8, &OPT_lrltyp); + OPT_EnterTyp((CHAR*)"HUGEINT", 4, 8, &OPT_hinttyp); + OPT_EnterTyp((CHAR*)"BYTE@", 4, 1, &OPT_cpbytetyp); + OPT_EnterTypeAlias((CHAR*)"SHORTINT", &OPT_sintobj); + OPT_EnterTypeAlias((CHAR*)"INTEGER", &OPT_intobj); + OPT_EnterTypeAlias((CHAR*)"LONGINT", &OPT_lintobj); + OPT_EnterTypeAlias((CHAR*)"SET", &OPT_setobj); + OPT_EnterBoolConst((CHAR*)"FALSE", 0); + OPT_EnterBoolConst((CHAR*)"TRUE", 1); + OPT_EnterProc((CHAR*)"HALT", 0); + OPT_EnterProc((CHAR*)"NEW", 1); + OPT_EnterProc((CHAR*)"ABS", 2); + OPT_EnterProc((CHAR*)"CAP", 3); + OPT_EnterProc((CHAR*)"ORD", 4); + OPT_EnterProc((CHAR*)"ENTIER", 5); + OPT_EnterProc((CHAR*)"ODD", 6); + OPT_EnterProc((CHAR*)"MIN", 7); + OPT_EnterProc((CHAR*)"MAX", 8); + OPT_EnterProc((CHAR*)"CHR", 9); + OPT_EnterProc((CHAR*)"SHORT", 10); + OPT_EnterProc((CHAR*)"LONG", 11); + OPT_EnterProc((CHAR*)"SIZE", 12); + OPT_EnterProc((CHAR*)"INC", 13); + OPT_EnterProc((CHAR*)"DEC", 14); + OPT_EnterProc((CHAR*)"INCL", 15); + OPT_EnterProc((CHAR*)"EXCL", 16); + OPT_EnterProc((CHAR*)"LEN", 17); + OPT_EnterProc((CHAR*)"COPY", 18); + OPT_EnterProc((CHAR*)"ASH", 19); + OPT_EnterProc((CHAR*)"ASSERT", 32); + OPT_impCtxt.ref[0] = OPT_undftyp; + OPT_impCtxt.ref[1] = OPT_bytetyp; + OPT_impCtxt.ref[2] = OPT_booltyp; + OPT_impCtxt.ref[3] = OPT_chartyp; + OPT_impCtxt.ref[4] = OPT_int32typ; + OPT_impCtxt.ref[5] = OPT_realtyp; + OPT_impCtxt.ref[6] = OPT_lrltyp; + OPT_impCtxt.ref[7] = OPT_settyp; + OPT_impCtxt.ref[8] = OPT_stringtyp; + OPT_impCtxt.ref[9] = OPT_niltyp; + OPT_impCtxt.ref[10] = OPT_notyp; + OPT_impCtxt.ref[11] = OPT_sysptrtyp; + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPT.h b/bootstrap/windows-88/OPT.h new file mode 100644 index 00000000..cf456af5 --- /dev/null +++ b/bootstrap/windows-88/OPT.h @@ -0,0 +1,128 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPT__h +#define OPT__h + +#include "SYSTEM.h" +#include "OPS.h" + +typedef + struct OPT_ConstDesc *OPT_Const; + +typedef + OPS_String *OPT_ConstExt; + +typedef + struct OPT_ConstDesc { + OPT_ConstExt ext; + INT64 intval; + INT32 intval2; + UINT64 setval; + LONGREAL realval; + } OPT_ConstDesc; + +typedef + struct OPT_LinkDesc *OPT_Link; + +typedef + struct OPT_LinkDesc { + OPS_Name name; + OPT_Link next; + } OPT_LinkDesc; + +typedef + struct OPT_NodeDesc *OPT_Node; + +typedef + struct OPT_StrDesc *OPT_Struct; + +typedef + struct OPT_ObjDesc *OPT_Object; + +typedef + struct OPT_NodeDesc { + OPT_Node left, right, link; + INT8 class, subcl; + BOOLEAN readonly; + OPT_Struct typ; + OPT_Object obj; + OPT_Const conval; + } OPT_NodeDesc; + +typedef + struct OPT_ObjDesc { + OPT_Object left, right, link, scope; + OPS_Name name; + BOOLEAN leaf; + INT8 mode, mnolev, vis, history; + BOOLEAN used, fpdone; + INT32 fprint; + OPT_Struct typ; + OPT_Const conval; + INT32 adr, linkadr; + INT16 x; + OPT_ConstExt comment; + } OPT_ObjDesc; + +typedef + struct OPT_StrDesc { + INT8 form, comp, mno, extlev; + INT16 ref, sysflag; + INT32 n, size, align, txtpos; + BOOLEAN allocated, pbused, pvused; + char _prvt0[4]; + INT32 idfp; + char _prvt1[8]; + OPT_Struct BaseTyp; + OPT_Object link, strobj; + } OPT_StrDesc; + + +import OPT_Object OPT_topScope; +import OPT_Struct OPT_undftyp, OPT_niltyp, OPT_notyp, OPT_bytetyp, OPT_cpbytetyp, OPT_booltyp, OPT_chartyp, OPT_sinttyp, OPT_inttyp, OPT_linttyp, OPT_hinttyp, OPT_int8typ, OPT_int16typ, OPT_int32typ, OPT_int64typ, OPT_settyp, OPT_set32typ, OPT_set64typ, OPT_realtyp, OPT_lrltyp, OPT_stringtyp, OPT_adrtyp, OPT_sysptrtyp; +import OPT_Object OPT_sintobj, OPT_intobj, OPT_lintobj, OPT_setobj; +import INT8 OPT_nofGmod; +import OPT_Object OPT_GlbMod[64]; +import OPS_Name OPT_SelfName; +import BOOLEAN OPT_SYSimported; +import OPT_Link OPT_Links; + +import ADDRESS *OPT_ConstDesc__typ; +import ADDRESS *OPT_ObjDesc__typ; +import ADDRESS *OPT_StrDesc__typ; +import ADDRESS *OPT_NodeDesc__typ; +import ADDRESS *OPT_LinkDesc__typ; + +import void OPT_Align (INT32 *adr, INT32 base); +import INT32 OPT_BaseAlignment (OPT_Struct typ); +import void OPT_Close (void); +import void OPT_CloseScope (void); +import void OPT_Export (BOOLEAN *ext, BOOLEAN *new); +import void OPT_FPrintErr (OPT_Object obj, INT16 errcode); +import void OPT_FPrintObj (OPT_Object obj); +import void OPT_FPrintStr (OPT_Struct typ); +import void OPT_Find (OPT_Object *res); +import void OPT_FindField (OPS_Name name, OPT_Struct typ, OPT_Object *res); +import void OPT_FindImport (OPT_Object mod, OPT_Object *res); +import void OPT_IdFPrint (OPT_Struct typ); +import void OPT_Import (OPS_Name aliasName, OPS_Name name, BOOLEAN *done); +import void OPT_Init (OPS_Name name, UINT32 opt); +import void OPT_InitRecno (void); +import void OPT_Insert (OPS_Name name, OPT_Object *obj); +import void OPT_InsertImport (OPT_Object obj, OPT_Object *root, OPT_Object *old); +import INT16 OPT_IntSize (INT64 n); +import OPT_Struct OPT_IntType (INT32 size); +import OPT_Const OPT_NewConst (void); +import OPT_ConstExt OPT_NewExt (void); +import OPT_Node OPT_NewNode (INT8 class); +import OPT_Object OPT_NewObj (void); +import OPT_Struct OPT_NewStr (INT8 form, INT8 comp); +import void OPT_OpenScope (INT8 level, OPT_Object owner); +import OPT_Struct OPT_SetType (INT32 size); +import OPT_Struct OPT_ShorterOrLongerType (OPT_Struct x, INT16 dir); +import INT32 OPT_SizeAlignment (INT32 size); +import void OPT_TypSize (OPT_Struct typ); +import void *OPT__init(void); + + +#endif // OPT diff --git a/bootstrap/windows-88/OPV.c b/bootstrap/windows-88/OPV.c new file mode 100644 index 00000000..26c1c715 --- /dev/null +++ b/bootstrap/windows-88/OPV.c @@ -0,0 +1,1585 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "OPC.h" +#include "OPM.h" +#include "OPS.h" +#include "OPT.h" + +typedef + struct OPV_ExitInfo { + INT16 level, label; + } OPV_ExitInfo; + + +static INT16 OPV_stamp; +static OPV_ExitInfo OPV_exit; +static INT16 OPV_nofExitLabels; + +export ADDRESS *OPV_ExitInfo__typ; + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp); +export void OPV_AdrAndSize (OPT_Object topScope); +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec); +static void OPV_DefineTDescs (OPT_Node n); +static void OPV_Entier (OPT_Node n, INT16 prec); +static void OPV_GetTProcNum (OPT_Object obj); +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc); +static BOOLEAN OPV_ImplicitReturn (OPT_Node n); +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim); +export void OPV_Init (void); +static void OPV_InitTDescs (OPT_Node n); +static void OPV_Len (OPT_Node n, INT64 dim); +export void OPV_Module (OPT_Node prog); +static void OPV_NewArr (OPT_Node d, OPT_Node x); +static void OPV_ParIntLiteral (INT64 n, INT32 size); +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp); +static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (OPT_Node n, INT32 to); +static void OPV_Stamp (OPS_Name s); +static OPT_Object OPV_SuperProc (OPT_Node n); +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); +static void OPV_TraverseRecord (OPT_Struct typ); +static void OPV_TypeOf (OPT_Node n); +static void OPV_design (OPT_Node n, INT16 prec); +static void OPV_expr (OPT_Node n, INT16 prec); +static void OPV_stat (OPT_Node n, OPT_Object outerProc); + + +void OPV_Init (void) +{ + OPV_stamp = 0; + OPV_nofExitLabels = 0; +} + +static void OPV_GetTProcNum (OPT_Object obj) +{ + INT32 oldPos; + OPT_Struct typ = NIL; + OPT_Object redef = NIL; + oldPos = OPM_errpos; + OPM_errpos = obj->scope->adr; + typ = obj->link->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(obj->name, typ->BaseTyp, &redef); + if (redef != NIL) { + obj->adr = __ASHL(__ASHR(redef->adr, 16), 16); + if (!__IN(2, obj->conval->setval, 64)) { + OPM_err(119); + } + } else { + obj->adr += __ASHL(typ->n, 16); + typ->n += 1; + } + OPM_errpos = oldPos; +} + +static void OPV_TraverseRecord (OPT_Struct typ) +{ + if (!typ->allocated) { + if (typ->BaseTyp != NIL) { + OPV_TraverseRecord(typ->BaseTyp); + typ->n = typ->BaseTyp->n; + } + typ->allocated = 1; + OPV_Traverse(typ->link, typ->strobj, 0); + } +} + +static void OPV_Stamp (OPS_Name s) +{ + INT16 i, j, k; + CHAR n[10]; + OPV_stamp += 1; + i = 0; + j = OPV_stamp; + while (s[__X(i, 256)] != 0x00) { + i += 1; + } + if (i > 25) { + i = 25; + } + s[__X(i, 256)] = '_'; + s[__X(i + 1, 256)] = '_'; + i += 2; + k = 0; + do { + n[__X(k, 10)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } while (!(j == 0)); + do { + k -= 1; + s[__X(i, 256)] = n[__X(k, 10)]; + i += 1; + } while (!(k == 0)); + s[__X(i, 256)] = 0x00; +} + +static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported) +{ + INT16 mode; + OPT_Object scope = NIL; + OPT_Struct typ = NIL; + if (obj != NIL) { + OPV_Traverse(obj->left, outerScope, exported); + if (obj->name[0] == '@') { + obj->name[0] = '_'; + OPV_Stamp(obj->name); + } + obj->linkadr = 0; + mode = obj->mode; + if ((mode == 5 && (obj->vis != 0) == exported)) { + typ = obj->typ; + OPT_TypSize(obj->typ); + if (typ->form == 11) { + typ = typ->BaseTyp; + } + if (typ->comp == 4) { + OPV_TraverseRecord(typ); + } + } else if (mode == 13) { + OPV_GetTProcNum(obj); + } else if (mode == 1) { + OPT_TypSize(obj->typ); + } + if (!exported) { + if ((__IN(mode, 0x60, 32) && obj->mnolev > 0)) { + OPV_Stamp(obj->name); + } + if (__IN(mode, 0x26, 32)) { + obj->scope = outerScope; + } else if (__IN(mode, 0x26c0, 32)) { + if (obj->conval->setval == 0x0) { + OPM_err(129); + } + scope = obj->scope; + scope->leaf = 1; + __MOVE(obj->name, scope->name, 256); + OPV_Stamp(scope->name); + if (mode == 9) { + obj->adr = 1; + } + if (scope->mnolev > 1) { + outerScope->leaf = 0; + } + OPV_Traverse(obj->scope->right, obj->scope, 0); + } + } + OPV_Traverse(obj->right, outerScope, exported); + } +} + +void OPV_AdrAndSize (OPT_Object topScope) +{ + __ASSERT(OPT_sinttyp != NIL, 0); + __ASSERT(OPT_inttyp != NIL, 0); + __ASSERT(OPT_linttyp != NIL, 0); + OPM_errpos = topScope->adr; + topScope->leaf = 1; + OPV_Traverse(topScope->right, topScope, 1); + OPV_Traverse(topScope->right, topScope, 0); + OPT_chartyp->strobj->linkadr = 2; + OPT_cpbytetyp->strobj->linkadr = 2; + OPT_settyp->strobj->linkadr = 2; + OPT_realtyp->strobj->linkadr = 2; + OPT_adrtyp->strobj->linkadr = 2; + OPT_int8typ->strobj->linkadr = 2; + OPT_int16typ->strobj->linkadr = 2; + OPT_int32typ->strobj->linkadr = 2; + OPT_int64typ->strobj->linkadr = 2; + OPT_set32typ->strobj->linkadr = 2; + OPT_set64typ->strobj->linkadr = 2; + OPT_hinttyp->strobj->linkadr = 2; + OPT_lrltyp->strobj->linkadr = 2; + OPT_booltyp->strobj->linkadr = 2; + OPT_bytetyp->strobj->linkadr = 2; + OPT_sysptrtyp->strobj->linkadr = 2; +} + +static INT16 OPV_Precedence (INT16 class, INT16 subclass, INT16 form, INT16 comp) +{ + switch (class) { + case 7: case 0: case 2: case 4: case 9: + case 13: + return 10; + break; + case 5: + if (__IN(3, OPM_Options, 32)) { + return 10; + } else { + return 9; + } + break; + case 1: + if (__IN(comp, 0x0c, 32)) { + return 10; + } else { + return 9; + } + break; + case 3: + return 9; + break; + case 11: + switch (subclass) { + case 33: case 7: case 24: case 29: case 20: + return 9; + break; + case 16: case 21: case 22: case 23: case 25: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 12: + switch (subclass) { + case 1: + if (form == 7) { + return 4; + } else { + return 8; + } + break; + case 2: + if (form == 7) { + return 3; + } else { + return 8; + } + break; + case 3: case 4: + return 10; + break; + case 6: + if (form == 7) { + return 2; + } else { + return 7; + } + break; + case 7: + if (form == 7) { + return 4; + } else { + return 7; + } + break; + case 11: case 12: case 13: case 14: + return 6; + break; + case 9: case 10: + return 5; + break; + case 5: + return 1; + break; + case 8: + return 0; + break; + case 19: case 15: case 17: case 18: case 26: + case 27: case 28: + return 10; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", 55); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + break; + case 10: + return 10; + break; + case 8: case 6: + return 12; + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence, class = ", 43); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + __RETCHK; +} + +static void OPV_Len (OPT_Node n, INT64 dim) +{ + INT64 d; + OPT_Struct array = NIL; + while ((n->class == 4 && n->typ->comp == 3)) { + dim += 1; + n = n->left; + } + if ((n->class == 3 && n->typ->comp == 3)) { + d = dim; + array = n->typ; + while (d > 0) { + array = array->BaseTyp; + d -= 1; + } + if (array->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->len[", 7); + OPM_WriteInt(dim); + OPM_Write(']'); + } else { + OPM_WriteInt(array->n); + } + } else { + OPC_Len(n->obj, n->typ, dim); + } +} + +static BOOLEAN OPV_SideEffects (OPT_Node n) +{ + if (n != NIL) { + return (n->class == 13 || OPV_SideEffects(n->left)) || OPV_SideEffects(n->right); + } else { + return 0; + } + __RETCHK; +} + +static void OPV_Entier (OPT_Node n, INT16 prec) +{ + if (__IN(n->typ->form, 0x60, 32)) { + OPM_WriteString((CHAR*)"__ENTIER(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else { + OPV_expr(n, prec); + } +} + +static void OPV_SizeCast (OPT_Node n, INT32 to) +{ + if ((to < n->typ->size && __IN(2, OPM_Options, 32))) { + OPM_WriteString((CHAR*)"__SHORT", 8); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPM_SignedMaximum(to) + 1); + OPM_Write(')'); + } else { + if ((n->typ->size != to && (n->typ->size > 4 || to != 4))) { + OPM_WriteString((CHAR*)"(INT", 5); + OPM_WriteInt(__ASHL(to, 3)); + OPM_WriteString((CHAR*)")", 2); + } + OPV_Entier(n, 9); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INT16 prec) +{ + INT16 from, to; + from = n->typ->form; + to = newtype->form; + if (to == 7) { + if (from == 7) { + OPV_SizeCast(n, newtype->size); + } else { + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_Entier(n, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(newtype->size, 3)); + OPM_Write(')'); + } + } else if (to == 4) { + OPV_SizeCast(n, newtype->size); + } else if (to == 3) { + if (__IN(2, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__CHR", 6); + if (OPV_SideEffects(n)) { + OPM_Write('F'); + } + OPM_Write('('); + OPV_Entier(n, -1); + OPM_Write(')'); + } else { + OPM_WriteString((CHAR*)"(CHAR)", 7); + OPV_Entier(n, 9); + } + } else { + OPV_expr(n, prec); + } +} + +static void OPV_TypeOf (OPT_Node n) +{ + if (n->typ->form == 11) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n, -1); + OPM_Write(')'); + } else if (__IN(n->class, 0x15, 32)) { + OPC_Andent(n->typ); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (n->class == 3) { + OPM_WriteString((CHAR*)"__TYPEOF(", 10); + OPV_expr(n->left, -1); + OPM_Write(')'); + } else if (n->class == 5) { + OPV_TypeOf(n->left); + } else if ((n->class == 11 && n->subcl == 29)) { + OPC_TypeOf(n->left->obj); + } else { + OPC_TypeOf(n->obj); + } +} + +static void OPV_Index (OPT_Node n, OPT_Node d, INT16 prec, INT16 dim) +{ + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + OPV_expr(n->right, prec); + } else { + if (OPV_SideEffects(n->right)) { + OPM_WriteString((CHAR*)"__XF(", 6); + } else { + OPM_WriteString((CHAR*)"__X(", 5); + } + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(d, dim); + OPM_Write(')'); + } +} + +static void OPV_design (OPT_Node n, INT16 prec) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT16 class, designPrec, comp; + OPT_Node d = NIL, x = NIL; + INT16 dims, i, _for__26; + comp = n->typ->comp; + obj = n->obj; + class = n->class; + designPrec = OPV_Precedence(class, n->subcl, n->typ->form, comp); + if ((((((class == 0 && obj->mnolev > 0)) && (INT16)obj->mnolev != OPM_level)) && prec == 10)) { + designPrec = 9; + } + if (prec > designPrec) { + OPM_Write('('); + } + if (prec == 11) { + OPM_Write('*'); + } + switch (class) { + case 9: + OPC_Ident(n->obj); + break; + case 0: + OPC_CompleteIdent(n->obj); + break; + case 1: + if (!__IN(comp, 0x0c, 32)) { + OPM_Write('*'); + } + OPC_CompleteIdent(n->obj); + break; + case 2: + if (n->left->class == 3) { + OPV_design(n->left->left, designPrec); + OPM_WriteString((CHAR*)"->", 3); + } else { + OPV_design(n->left, designPrec); + OPM_Write('.'); + } + OPC_Ident(n->obj); + break; + case 3: + if (n->typ->comp == 3) { + OPV_design(n->left, 10); + OPM_WriteString((CHAR*)"->data", 7); + } else { + OPM_Write('*'); + OPV_design(n->left, designPrec); + } + break; + case 4: + d = n->left; + if (d->typ->comp == 3) { + dims = 0; + while (d->class == 4) { + d = d->left; + dims += 1; + } + if (n->typ->comp == 3) { + OPM_Write('&'); + } + OPV_design(d, designPrec); + OPM_Write('['); + if (n->typ->comp == 3) { + OPM_Write('('); + } + i = dims; + x = n; + while (x != d) { + if (x->left != d) { + OPV_Index(x, d, 7, i); + OPM_WriteString((CHAR*)" + ", 4); + OPV_Len(d, i); + OPM_WriteString((CHAR*)" * (", 5); + i -= 1; + } else { + OPV_Index(x, d, -1, i); + } + x = x->left; + } + _for__26 = dims; + i = 1; + while (i <= _for__26) { + OPM_Write(')'); + i += 1; + } + if (n->typ->comp == 3) { + OPM_Write(')'); + while (i < __ASHR(d->typ->size - 4, 2)) { + OPM_WriteString((CHAR*)" * ", 4); + OPV_Len(d, i); + i += 1; + } + } + OPM_Write(']'); + } else { + OPV_design(n->left, designPrec); + OPM_Write('['); + OPV_Index(n, n->left, -1, 0); + OPM_Write(']'); + } + break; + case 5: + typ = n->typ; + obj = n->left->obj; + if (__IN(3, OPM_Options, 32)) { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"__GUARDR(", 10); + if ((INT16)obj->mnolev != OPM_level) { + OPM_WriteStringVar((void*)obj->scope->name, 256); + OPM_WriteString((CHAR*)"__curr->", 9); + OPC_Ident(obj); + } else { + OPC_Ident(obj); + } + } else { + if (typ->BaseTyp->strobj == NIL) { + OPM_WriteString((CHAR*)"__GUARDA(", 10); + } else { + OPM_WriteString((CHAR*)"__GUARDP(", 10); + } + OPV_expr(n->left, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + } else { + if (typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Ident(typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + OPC_CompleteIdent(obj); + } else { + OPM_Write('('); + OPC_Ident(typ->strobj); + OPM_Write(')'); + OPV_expr(n->left, designPrec); + } + } + break; + case 6: + if (__IN(3, OPM_Options, 32)) { + if (n->left->class == 1) { + OPM_WriteString((CHAR*)"__GUARDEQR(", 12); + OPC_CompleteIdent(n->left->obj); + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n->left); + } else { + OPM_WriteString((CHAR*)"__GUARDEQP(", 12); + OPV_expr(n->left->left, -1); + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + } else { + OPV_expr(n->left, -1); + } + break; + case 11: + if (n->subcl == 29) { + OPV_design(n->left, prec); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.design, class = ", 39); + OPM_LogWNum(class, 0); + OPM_LogWLn(); + break; + } + if (prec > designPrec) { + OPM_Write(')'); + } +} + +static void OPV_ParIntLiteral (INT64 n, INT32 size) +{ + OPM_WriteInt(n); +} + +static void OPV_ActualPar (OPT_Node n, OPT_Object fp) +{ + OPT_Struct typ = NIL, aptyp = NIL; + INT16 comp, form, mode, prec, dim; + OPM_Write('('); + while (n != NIL) { + typ = fp->typ; + comp = typ->comp; + form = typ->form; + mode = fp->mode; + prec = -1; + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)"*)", 3); + prec = 10; + } + if (!__IN(n->typ->comp, 0x0c, 32)) { + if (mode == 2) { + if (typ != n->typ) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + OPM_Write('&'); + prec = 9; + } else { + if ((__IN(comp, 0x0c, 32) && n->class == 7)) { + OPM_WriteString((CHAR*)"(CHAR*)", 8); + } else if ((((form == 11 && typ != n->typ)) && n->typ != OPT_niltyp)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + } else { + if ((((mode == 2 && typ != n->typ)) && prec == -1)) { + OPM_WriteString((CHAR*)"(void*)", 8); + } + } + if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { + OPV_expr(n->left, prec); + } else if ((form == 4 && n->class == 7)) { + OPV_ParIntLiteral(n->conval->intval, n->typ->size); + } else { + OPV_expr(n, prec); + } + if ((comp == 4 && mode == 2)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_TypeOf(n); + } else if (comp == 3) { + if (n->class == 7) { + OPM_WriteString((CHAR*)", ", 3); + OPV_ParIntLiteral(n->conval->intval2, OPM_AddressSize); + } else { + aptyp = n->typ; + dim = 0; + while ((typ->comp == 3 && typ->BaseTyp->form != 1)) { + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n, dim); + typ = typ->BaseTyp; + aptyp = aptyp->BaseTyp; + dim += 1; + } + if ((typ->comp == 3 && typ->BaseTyp->form == 1)) { + OPM_WriteString((CHAR*)", ", 3); + while (aptyp->comp == 3) { + OPV_Len(n, dim); + OPM_WriteString((CHAR*)" * ", 4); + dim += 1; + aptyp = aptyp->BaseTyp; + } + OPV_ParIntLiteral(aptyp->size, OPM_AddressSize); + } + } + } + n = n->link; + fp = fp->link; + if (n != NIL) { + OPM_WriteString((CHAR*)", ", 3); + } + } + OPM_Write(')'); +} + +static OPT_Object OPV_SuperProc (OPT_Node n) +{ + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + typ = n->right->typ; + if (typ->form == 11) { + typ = typ->BaseTyp; + } + OPT_FindField(n->left->obj->name, typ->BaseTyp, &obj); + return obj; +} + +static void OPV_expr (OPT_Node n, INT16 prec) +{ + INT16 class, subclass, form, exprPrec; + OPT_Struct typ = NIL; + OPT_Node l = NIL, r = NIL; + OPT_Object proc = NIL; + class = n->class; + subclass = n->subcl; + form = n->typ->form; + l = n->left; + r = n->right; + exprPrec = OPV_Precedence(class, subclass, form, n->typ->comp); + if ((exprPrec <= prec && __IN(class, 0x3ce0, 32))) { + OPM_Write('('); + } + switch (class) { + case 7: + OPC_Constant(n->conval, form); + break; + case 10: + OPM_WriteString((CHAR*)"__SETRNG(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(__ASHL(n->typ->size, 3)); + OPM_Write(')'); + break; + case 11: + switch (subclass) { + case 33: + OPM_Write('!'); + OPV_expr(l, exprPrec); + break; + case 7: + if (form == 7) { + OPM_Write('~'); + } else { + OPM_Write('-'); + } + OPV_expr(l, exprPrec); + break; + case 16: + typ = n->obj->typ; + if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"__IS(", 6); + OPC_TypeOf(l->obj); + } else { + OPM_WriteString((CHAR*)"__ISP(", 7); + OPV_expr(l, -1); + typ = typ->BaseTyp; + } + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(typ); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(typ->extlev); + OPM_Write(')'); + break; + case 20: + OPV_Convert(l, n->typ, exprPrec); + break; + case 21: + if (OPV_SideEffects(l)) { + if (l->typ->form < 5) { + if (l->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__ABSF(", 8); + } else { + OPM_WriteString((CHAR*)"__ABSFD(", 9); + } + } else { + OPM_WriteString((CHAR*)"__ABS(", 7); + } + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 22: + OPM_WriteString((CHAR*)"__CAP(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 23: + OPM_WriteString((CHAR*)"__ODD(", 7); + OPV_expr(l, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + if (l->class == 1) { + OPC_CompleteIdent(l->obj); + } else { + if ((l->typ->form != 8 && !__IN(l->typ->comp, 0x0c, 32))) { + OPM_Write('&'); + } + OPV_expr(l, exprPrec); + } + break; + case 29: + if (!__IN(l->class, 0x17, 32) || (((__IN(n->typ->form, 0x1890, 32) && __IN(l->typ->form, 0x1890, 32))) && n->typ->size == l->typ->size)) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + if (__IN(n->typ->form, 0x1800, 32) || __IN(l->typ->form, 0x1800, 32)) { + OPM_WriteString((CHAR*)"(ADDRESS)", 10); + } + OPV_expr(l, exprPrec); + } else { + OPM_WriteString((CHAR*)"__VAL(", 7); + OPC_Ident(n->typ->strobj); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_Write(')'); + } + break; + default: + OPM_err(200); + break; + } + break; + case 12: + switch (subclass) { + case 19: + OPV_Len(l, r->conval->intval); + break; + case 15: case 17: case 18: case 26: case 27: + case 28: case 3: case 4: + switch (subclass) { + case 15: + OPM_WriteString((CHAR*)"__IN(", 6); + break; + case 17: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ASHL(", 8); + } else { + OPM_WriteString((CHAR*)"__ASHR(", 8); + } + } else if (OPV_SideEffects(r)) { + OPM_WriteString((CHAR*)"__ASHF(", 8); + } else { + OPM_WriteString((CHAR*)"__ASH(", 7); + } + break; + case 18: + OPM_WriteString((CHAR*)"__MASK(", 8); + break; + case 26: + OPM_WriteString((CHAR*)"__BIT(", 7); + break; + case 27: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__LSHL(", 8); + } else { + OPM_WriteString((CHAR*)"__LSHR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__LSH(", 7); + } + break; + case 28: + if (r->class == 7) { + if (r->conval->intval >= 0) { + OPM_WriteString((CHAR*)"__ROTL(", 8); + } else { + OPM_WriteString((CHAR*)"__ROTR(", 8); + } + } else { + OPM_WriteString((CHAR*)"__ROT(", 7); + } + break; + case 3: + if (OPV_SideEffects(n)) { + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + OPM_WriteString((CHAR*)"__DIVF(", 8); + } else { + OPM_WriteString((CHAR*)"__DIV(", 7); + } + break; + case 4: + if (n->typ->size <= 4) { + OPM_WriteString((CHAR*)"(int)", 6); + } + if (OPV_SideEffects(n)) { + OPM_WriteString((CHAR*)"__MODF(", 8); + } else { + OPM_WriteString((CHAR*)"__MOD(", 7); + } + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if ((((__IN(subclass, 0x18020000, 32) && r->class == 7)) && r->conval->intval < 0)) { + OPM_WriteInt(-r->conval->intval); + } else { + OPV_expr(r, -1); + } + if (__IN(subclass, 0x18008000, 32)) { + OPM_WriteString((CHAR*)", ", 3); + if (subclass == 15) { + OPM_WriteInt(__ASHL(r->typ->size, 3)); + } else { + OPM_WriteInt(__ASHL(l->typ->size, 3)); + } + } + OPM_Write(')'); + break; + case 9: case 10: case 11: case 12: case 13: + case 14: + if (__IN(l->typ->form, 0x2100, 32)) { + OPM_WriteString((CHAR*)"__STRCMP(", 10); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(r, -1); + OPM_Write(')'); + OPC_Cmp(subclass); + OPM_Write('0'); + } else { + OPV_expr(l, exprPrec); + OPC_Cmp(subclass); + typ = l->typ; + if ((((((typ->form == 11 && r->typ->form != 9)) && r->typ != typ)) && r->typ != OPT_sysptrtyp)) { + OPM_WriteString((CHAR*)"(void *) ", 10); + } + OPV_expr(r, exprPrec); + } + break; + default: + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write('('); + } + OPV_expr(l, exprPrec); + switch (subclass) { + case 1: + if (form == 7) { + OPM_WriteString((CHAR*)" & ", 4); + } else { + OPM_WriteString((CHAR*)" * ", 4); + } + break; + case 2: + if (form == 7) { + OPM_WriteString((CHAR*)" ^ ", 4); + } else { + OPM_WriteString((CHAR*)" / ", 4); + if (r->obj == NIL || r->obj->typ->form == 4) { + OPM_Write('('); + OPC_Ident(n->typ->strobj); + OPM_Write(')'); + } + } + break; + case 5: + OPM_WriteString((CHAR*)" && ", 5); + break; + case 6: + if (form == 7) { + OPM_WriteString((CHAR*)" | ", 4); + } else { + OPM_WriteString((CHAR*)" + ", 4); + } + break; + case 7: + if (form == 7) { + OPM_WriteString((CHAR*)" & ~", 5); + } else { + OPM_WriteString((CHAR*)" - ", 4); + } + break; + case 8: + OPM_WriteString((CHAR*)" || ", 5); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, subclass = ", 40); + OPM_LogWNum(subclass, 0); + OPM_LogWLn(); + break; + } + OPV_expr(r, exprPrec); + if (subclass == 5 || (form == 7 && (subclass == 1 || subclass == 7))) { + OPM_Write(')'); + } + break; + } + break; + case 13: + if ((l->obj != NIL && l->obj->mode == 13)) { + if (l->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(l->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (l->class == 9) { + OPV_design(l, 10); + } else { + OPV_design(l, 11); + } + OPV_ActualPar(r, n->obj); + break; + default: + OPV_design(n, prec); + break; + } + if ((exprPrec <= prec && __IN(class, 0x3ca0, 32))) { + OPM_Write(')'); + } +} + +static void OPV_IfStat (OPT_Node n, BOOLEAN withtrap, OPT_Object outerProc) +{ + OPT_Node if_ = NIL; + OPT_Object obj = NIL; + OPT_Struct typ = NIL; + INT32 adr; + if_ = n->left; + while (if_ != NIL) { + OPM_WriteString((CHAR*)"if ", 4); + OPV_expr(if_->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + if ((n->class == 27 && if_->left->left != NIL)) { + obj = if_->left->left->obj; + typ = obj->typ; + adr = obj->adr; + if (typ->comp == 4) { + OPC_BegStat(); + OPC_Ident(if_->left->obj); + OPM_WriteString((CHAR*)" *", 3); + OPM_WriteString(obj->name, 256); + OPM_WriteString((CHAR*)"__ = (void*)", 13); + obj->adr = 0; + OPC_CompleteIdent(obj); + OPC_EndStat(); + } + obj->adr = 1; + obj->typ = if_->left->obj->typ; + OPV_stat(if_->right, outerProc); + obj->typ = typ; + obj->adr = adr; + } else { + OPV_stat(if_->right, outerProc); + } + if_ = if_->link; + if ((if_ != NIL || n->right != NIL) || withtrap) { + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" else ", 7); + } else { + OPC_EndBlk(); + } + } + if (withtrap) { + OPM_WriteString((CHAR*)"__WITHCHK", 10); + OPC_EndStat(); + } else if (n->right != NIL) { + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + } +} + +static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Node switchCase = NIL, label = NIL; + INT64 low, high; + INT16 form, i; + OPM_WriteString((CHAR*)"switch ", 8); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + form = n->left->typ->form; + switchCase = n->right->left; + while (switchCase != NIL) { + label = switchCase->left; + i = 0; + while (label != NIL) { + low = label->conval->intval; + high = label->conval->intval2; + while (low <= high) { + if (i == 0) { + OPC_BegStat(); + } + OPC_Case(low, form); + low += 1; + i += 1; + if (i == 5) { + OPM_WriteLn(); + i = 0; + } + } + label = label->link; + } + if (i > 0) { + OPM_WriteLn(); + } + OPC_Indent(1); + OPV_stat(switchCase->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_EndStat(); + OPC_Indent(-1); + switchCase = switchCase->link; + } + OPC_BegStat(); + OPM_WriteString((CHAR*)"default: ", 10); + if (n->right->conval->setval != 0x0) { + OPC_Indent(1); + OPM_WriteLn(); + OPV_stat(n->right->right, outerProc); + OPC_BegStat(); + OPM_WriteString((CHAR*)"break", 6); + OPC_Indent(-1); + } else { + OPM_WriteString((CHAR*)"__CASECHK", 10); + } + OPC_EndStat(); + OPC_EndBlk(); +} + +static BOOLEAN OPV_ImplicitReturn (OPT_Node n) +{ + while ((n != NIL && n->class != 26)) { + n = n->link; + } + return n == NIL; +} + +static void OPV_NewArr (OPT_Node d, OPT_Node x) +{ + OPT_Struct typ = NIL, base = NIL; + INT16 nofdim, nofdyn; + typ = d->typ->BaseTyp; + base = typ; + nofdim = 0; + nofdyn = 0; + while (base->comp == 3) { + nofdim += 1; + nofdyn += 1; + base = base->BaseTyp; + } + OPV_design(d, -1); + OPM_WriteString((CHAR*)" = __NEWARR(", 13); + while (base->comp == 2) { + nofdim += 1; + base = base->BaseTyp; + } + if ((base->comp == 4 && OPC_NofPtrs(base) != 0)) { + OPC_Andent(base); + OPM_WriteString((CHAR*)"__typ", 6); + } else if (base->form == 11) { + OPM_WriteString((CHAR*)"POINTER__typ", 13); + } else { + OPM_WriteString((CHAR*)"NIL", 4); + } + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(base->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(OPT_BaseAlignment(base)); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdim); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(nofdyn); + while (typ != base) { + OPM_WriteString((CHAR*)", ", 3); + if (typ->comp == 3) { + if (x->class == 7) { + OPC_IntLiteral(x->conval->intval, OPM_AddressSize); + } else { + OPM_WriteString((CHAR*)"((ADDRESS)(", 12); + OPV_expr(x, 10); + OPM_WriteString((CHAR*)"))", 3); + } + x = x->link; + } else { + OPC_IntLiteral(typ->n, OPM_AddressSize); + } + typ = typ->BaseTyp; + } + OPM_Write(')'); +} + +static void OPV_DefineTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_TDescDecl(n->typ); + n = n->link; + } +} + +static void OPV_InitTDescs (OPT_Node n) +{ + while ((n != NIL && n->class == 14)) { + OPC_InitTDesc(n->typ); + n = n->link; + } +} + +static void OPV_stat (OPT_Node n, OPT_Object outerProc) +{ + OPT_Object proc = NIL; + OPV_ExitInfo saved; + OPT_Node l = NIL, r = NIL; + while ((n != NIL && OPM_noerr)) { + OPM_errpos = OPM_Longint(n->conval->intval); + if (n->class != 14) { + OPC_BegStat(); + } + switch (n->class) { + case 18: + if (n->obj == NIL) { + OPM_level += 1; + OPV_stat(n->left, outerProc); + OPM_level -= 1; + OPC_GenEnumPtrs(OPT_topScope->scope); + OPV_DefineTDescs(n->right); + OPC_EnterBody(); + OPV_InitTDescs(n->right); + OPM_WriteString((CHAR*)"/* BEGIN */", 12); + OPM_WriteLn(); + OPV_stat(n->right, outerProc); + OPC_ExitBody(); + } else { + proc = n->obj; + OPC_TypeDefs(proc->scope->right, 0); + if (!proc->scope->leaf) { + OPC_DefineInter(proc); + } + OPM_level += 1; + OPV_stat(n->left, proc); + OPM_level -= 1; + OPC_EnterProc(proc); + OPV_stat(n->right, proc); + OPC_ExitProc(proc, 1, OPV_ImplicitReturn(n->right)); + } + break; + case 14: + break; + case 19: + switch (n->subcl) { + case 0: + l = n->left; + r = n->right; + if (l->typ->comp == 2) { + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(r, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(l, -1); + OPM_WriteString((CHAR*)", ", 3); + if (r->typ == OPT_stringtyp) { + OPM_WriteInt(r->conval->intval2); + } else if (r->typ->comp == 3) { + OPM_WriteString((CHAR*)"__X(", 5); + OPC_Len(r->obj, r->typ, 0); + OPM_WriteString((CHAR*)" * ", 4); + OPM_WriteInt(r->typ->BaseTyp->size); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(l->typ->size + 1); + OPM_Write(')'); + } else { + __ASSERT(r->typ->comp == 2, 0); + __ASSERT(r->typ->size <= l->typ->size, 0); + OPM_WriteInt(r->typ->size); + } + OPM_Write(')'); + } else { + if ((((((l->typ->form == 11 && l->obj != NIL)) && l->obj->adr == 1)) && l->obj->mode == 1)) { + l->obj->adr = 0; + OPV_design(l, -1); + l->obj->adr = 1; + if (r->typ->form != 9) { + OPM_WriteString((CHAR*)" = (void*)", 11); + } else { + OPM_WriteString((CHAR*)" = ", 4); + } + } else { + OPV_design(l, -1); + OPM_WriteString((CHAR*)" = ", 4); + } + if (l->typ == r->typ) { + OPV_expr(r, -1); + } else if ((((l->typ->form == 11 && r->typ->form != 9)) && l->typ->strobj != NIL)) { + OPM_Write('('); + OPC_Ident(l->typ->strobj); + OPM_Write(')'); + OPV_expr(r, -1); + } else if (l->typ->comp == 4) { + OPM_WriteString((CHAR*)"*(", 3); + OPC_Andent(l->typ); + OPM_WriteString((CHAR*)"*)&", 4); + OPV_expr(r, 9); + } else { + OPV_expr(r, -1); + } + } + break; + case 1: + if (n->left->typ->BaseTyp->comp == 4) { + OPM_WriteString((CHAR*)"__NEW(", 7); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Andent(n->left->typ->BaseTyp); + OPM_WriteString((CHAR*)")", 2); + } else if (__IN(n->left->typ->BaseTyp->comp, 0x0c, 32)) { + OPV_NewArr(n->left, n->right); + } + break; + case 13: case 14: + OPV_expr(n->left, -1); + OPC_Increment(n->subcl == 14); + OPV_expr(n->right, -1); + break; + case 15: case 16: + OPV_expr(n->left, -1); + OPC_SetInclude(n->subcl == 16); + OPM_WriteString((CHAR*)"__SETOF(", 9); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)",", 2); + OPM_WriteInt(__ASHL(n->left->typ->size, 3)); + OPM_Write(')'); + break; + case 18: + OPM_WriteString((CHAR*)"__COPY(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_Len(n->left, 0); + OPM_Write(')'); + break; + case 31: + OPM_WriteString((CHAR*)"__MOVE(", 8); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right->link, -1); + OPM_Write(')'); + break; + case 24: + OPM_WriteString((CHAR*)"__GET(", 7); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->left->typ->strobj); + OPM_Write(')'); + break; + case 25: + OPM_WriteString((CHAR*)"__PUT(", 7); + OPV_expr(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_WriteString((CHAR*)", ", 3); + OPC_Ident(n->right->typ->strobj); + OPM_Write(')'); + break; + case 26: case 27: + OPM_err(200); + break; + case 30: + OPM_WriteString((CHAR*)"__SYSNEW(", 10); + OPV_design(n->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPV_expr(n->right, -1); + OPM_Write(')'); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.subcl = ", 40); + OPM_LogWNum(n->subcl, 0); + OPM_LogWLn(); + break; + } + break; + case 13: + if ((n->left->obj != NIL && n->left->obj->mode == 13)) { + if (n->left->subcl == 1) { + proc = OPV_SuperProc(n); + } else { + OPM_WriteString((CHAR*)"__", 3); + proc = OPC_BaseTProc(n->left->obj); + } + OPC_Ident(proc); + n->obj = proc->link; + } else if (n->left->class == 9) { + OPV_design(n->left, 10); + } else { + OPV_design(n->left, 11); + } + OPV_ActualPar(n->right, n->obj); + break; + case 20: + if (n->subcl != 32) { + OPV_IfStat(n, 0, outerProc); + } else if (__IN(7, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__ASSERT(", 10); + OPV_expr(n->left->left->left, -1); + OPM_WriteString((CHAR*)", ", 3); + OPM_WriteInt(n->left->right->right->conval->intval); + OPM_Write(')'); + OPC_EndStat(); + } + break; + case 21: + OPV_exit.level += 1; + OPV_CaseStat(n, outerProc); + OPV_exit.level -= 1; + break; + case 22: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"while ", 7); + OPV_expr(n->left, 12); + OPM_Write(' '); + OPC_BegBlk(); + OPV_stat(n->right, outerProc); + OPC_EndBlk(); + OPV_exit.level -= 1; + break; + case 23: + OPV_exit.level += 1; + OPM_WriteString((CHAR*)"do ", 4); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk0(); + OPM_WriteString((CHAR*)" while (!", 10); + OPV_expr(n->right, 9); + OPM_Write(')'); + OPV_exit.level -= 1; + break; + case 24: + saved = OPV_exit; + OPV_exit.level = 0; + OPV_exit.label = -1; + OPM_WriteString((CHAR*)"for (;;) ", 10); + OPC_BegBlk(); + OPV_stat(n->left, outerProc); + OPC_EndBlk(); + if (OPV_exit.label != -1) { + OPC_BegStat(); + OPM_WriteString((CHAR*)"exit__", 7); + OPM_WriteInt(OPV_exit.label); + OPM_Write(':'); + OPC_EndStat(); + } + OPV_exit = saved; + break; + case 25: + if (OPV_exit.level == 0) { + OPM_WriteString((CHAR*)"break", 6); + } else { + if (OPV_exit.label == -1) { + OPV_exit.label = OPV_nofExitLabels; + OPV_nofExitLabels += 1; + } + OPM_WriteString((CHAR*)"goto exit__", 12); + OPM_WriteInt(OPV_exit.label); + } + break; + case 26: + if (OPM_level == 0) { + if (__IN(10, OPM_Options, 32)) { + OPM_WriteString((CHAR*)"__FINI", 7); + } else { + OPM_WriteString((CHAR*)"__ENDMOD", 9); + } + } else if (OPC_NeedsRetval(outerProc)) { + OPM_WriteString((CHAR*)"__retval = ", 12); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + OPC_EndStat(); + OPC_BegStat(); + OPC_ExitProc(outerProc, 0, 0); + OPC_EndStat(); + OPC_BegStat(); + OPM_WriteString((CHAR*)"return __retval", 16); + } else { + OPC_ExitProc(outerProc, 0, 0); + OPM_WriteString((CHAR*)"return", 7); + if (n->left != NIL) { + OPM_Write(' '); + if ((n->left->typ->form == 11 && n->obj->typ != n->left->typ)) { + OPM_WriteString((CHAR*)"(void*)", 8); + OPV_expr(n->left, 10); + } else { + OPV_expr(n->left, -1); + } + } + } + break; + case 27: + OPV_IfStat(n, n->subcl == 0, outerProc); + break; + case 28: + OPC_Halt(OPM_Longint(n->right->conval->intval)); + break; + default: + OPM_LogWStr((CHAR*)"unhandled case in OPV.expr, n^.class = ", 40); + OPM_LogWNum(n->class, 0); + OPM_LogWLn(); + break; + } + if (!__IN(n->class, 0x09744000, 32)) { + OPC_EndStat(); + } + n = n->link; + } +} + +void OPV_Module (OPT_Node prog) +{ + if (!__IN(10, OPM_Options, 32)) { + OPC_GenHdr(prog->right); + OPC_GenHdrIncludes(); + } + OPC_GenBdy(prog->right); + OPV_stat(prog, NIL); +} + +__TDESC(OPV_ExitInfo, 1, 0) = {__TDFLDS("ExitInfo", 4), {-8}}; + +export void *OPV__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(OPC); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(OPS); + __MODULE_IMPORT(OPT); + __REGMOD("OPV", 0); + __REGCMD("Init", OPV_Init); + __INITYP(OPV_ExitInfo, OPV_ExitInfo, 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/OPV.h b/bootstrap/windows-88/OPV.h new file mode 100644 index 00000000..fbabd8f4 --- /dev/null +++ b/bootstrap/windows-88/OPV.h @@ -0,0 +1,18 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef OPV__h +#define OPV__h + +#include "SYSTEM.h" +#include "OPT.h" + + + + +import void OPV_AdrAndSize (OPT_Object topScope); +import void OPV_Init (void); +import void OPV_Module (OPT_Node prog); +import void *OPV__init(void); + + +#endif // OPV diff --git a/bootstrap/windows-88/Out.c b/bootstrap/windows-88/Out.c new file mode 100644 index 00000000..b43e55f1 --- /dev/null +++ b/bootstrap/windows-88/Out.c @@ -0,0 +1,345 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Heap.h" +#include "Platform.h" + + +export BOOLEAN Out_IsConsole; +static CHAR Out_buf[128]; +static INT16 Out_in; + + +export void Out_Char (CHAR ch); +export void Out_Flush (void); +export void Out_Hex (INT64 x, INT64 n); +export void Out_Int (INT64 x, INT64 n); +static INT32 Out_Length (CHAR *s, ADDRESS s__len); +export void Out_Ln (void); +export void Out_LongReal (LONGREAL x, INT16 n); +export void Out_Open (void); +export void Out_Real (REAL x, INT16 n); +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_); +export void Out_String (CHAR *str, ADDRESS str__len); +export LONGREAL Out_Ten (INT16 e); +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i); +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i); + +#define Out_Entier64(x) (INT64)(x) + +void Out_Flush (void) +{ + INT16 error; + if (Out_in > 0) { + error = Platform_Write(Platform_StdOut, (ADDRESS)Out_buf, Out_in); + } + Out_in = 0; +} + +void Out_Open (void) +{ +} + +void Out_Char (CHAR ch) +{ + if (Out_in >= 128) { + Out_Flush(); + } + Out_buf[__X(Out_in, 128)] = ch; + Out_in += 1; + if (ch == 0x0a) { + Out_Flush(); + } +} + +static INT32 Out_Length (CHAR *s, ADDRESS s__len) +{ + INT32 l; + l = 0; + while ((l < s__len && s[__X(l, s__len)] != 0x00)) { + l += 1; + } + return l; +} + +void Out_String (CHAR *str, ADDRESS str__len) +{ + INT32 l; + INT16 error; + __DUP(str, str__len, CHAR); + l = Out_Length((void*)str, str__len); + if (Out_in + l > 128) { + Out_Flush(); + } + if (l > 128) { + error = Platform_Write(Platform_StdOut, (ADDRESS)str, l); + } else { + __MOVE((ADDRESS)str, (ADDRESS)&Out_buf[__X(Out_in, 128)], l); + Out_in += __SHORT(l, 32768); + } + __DEL(str); +} + +void Out_Int (INT64 x, INT64 n) +{ + CHAR s[22]; + INT16 i; + BOOLEAN negative; + negative = x < 0; + if (x == (-9223372036854775807LL-1)) { + __MOVE("8085774586302733229", s, 20); + i = 19; + } else { + if (x < 0) { + x = -x; + } + s[0] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i = 1; + while (x != 0) { + s[__X(i, 22)] = __CHR(48 + __MOD(x, 10)); + x = __DIV(x, 10); + i += 1; + } + } + if (negative) { + s[__X(i, 22)] = '-'; + i += 1; + } + while (n > (INT64)i) { + Out_Char(' '); + n -= 1; + } + while (i > 0) { + i -= 1; + Out_Char(s[__X(i, 22)]); + } +} + +void Out_Hex (INT64 x, INT64 n) +{ + if (n < 1) { + n = 1; + } else if (n > 16) { + n = 16; + } + if (x >= 0) { + while ((n < 16 && __LSH(x, -__ASHL(n, 2), 64) != 0)) { + n += 1; + } + } + x = __ROT(x, __ASHL(16 - n, 2), 64); + while (n > 0) { + x = __ROTL(x, 4, 64); + n -= 1; + if (__MASK(x, -16) < 10) { + Out_Char(__CHR(__MASK(x, -16) + 48)); + } else { + Out_Char(__CHR((__MASK(x, -16) - 10) + 65)); + } + } +} + +void Out_Ln (void) +{ + Out_String(Platform_NL, 3); + Out_Flush(); +} + +static void Out_digit (INT64 n, CHAR *s, ADDRESS s__len, INT16 *i) +{ + *i -= 1; + s[__X(*i, s__len)] = __CHR(__MOD(n, 10) + 48); +} + +static void Out_prepend (CHAR *t, ADDRESS t__len, CHAR *s, ADDRESS s__len, INT16 *i) +{ + INT16 j; + INT32 l; + __DUP(t, t__len, CHAR); + l = Out_Length((void*)t, t__len); + if (l > *i) { + l = *i; + } + *i -= __SHORT(l, 32768); + j = 0; + while (j < l) { + s[__X(*i + j, s__len)] = t[__X(j, t__len)]; + j += 1; + } + __DEL(t); +} + +LONGREAL Out_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +static void Out_RealP (LONGREAL x, INT16 n, BOOLEAN long_) +{ + INT16 e; + INT64 f; + CHAR s[30]; + INT16 i, el; + LONGREAL x0; + BOOLEAN nn, en; + INT64 m; + INT16 d, dr; + e = (INT16)__MASK(__ASHR((__VAL(INT64, x)), 52), -2048); + f = __MASK((__VAL(INT64, x)), -4503599627370496LL); + nn = (__VAL(INT64, x) < 0 && !((e == 2047 && f != 0))); + if (nn) { + n -= 1; + } + i = 30; + if (e == 2047) { + if (f == 0) { + Out_prepend((CHAR*)"Infinity", 9, (void*)s, 30, &i); + } else { + Out_prepend((CHAR*)"NaN", 4, (void*)s, 30, &i); + } + } else { + if (long_) { + el = 3; + dr = n - 6; + if (dr > 17) { + dr = 17; + } + d = dr; + if (d < 15) { + d = 15; + } + } else { + el = 2; + dr = n - 5; + if (dr > 9) { + dr = 9; + } + d = dr; + if (d < 6) { + d = 6; + } + } + if (e == 0) { + while (el > 0) { + i -= 1; + s[__X(i, 30)] = '0'; + el -= 1; + } + i -= 1; + s[__X(i, 30)] = '+'; + m = 0; + } else { + if (nn) { + x = -x; + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Out_Ten(e); + } else { + x = Out_Ten(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + en = e < 0; + if (en) { + e = -e; + } + while (el > 0) { + Out_digit(e, (void*)s, 30, &i); + e = __DIV(e, 10); + el -= 1; + } + i -= 1; + if (en) { + s[__X(i, 30)] = '-'; + } else { + s[__X(i, 30)] = '+'; + } + x0 = Out_Ten(d - 1); + x = x0 * x; + x = x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + m = Out_Entier64(x); + } + i -= 1; + if (long_) { + s[__X(i, 30)] = 'D'; + } else { + s[__X(i, 30)] = 'E'; + } + if (dr < 2) { + dr = 2; + } + while ((d > dr && __MOD(m, 10) == 0)) { + m = __DIV(m, 10); + d -= 1; + } + while (d > 1) { + Out_digit(m, (void*)s, 30, &i); + m = __DIV(m, 10); + d -= 1; + } + i -= 1; + s[__X(i, 30)] = '.'; + Out_digit(m, (void*)s, 30, &i); + } + n -= 30 - i; + while (n > 0) { + Out_Char(' '); + n -= 1; + } + if (nn) { + Out_Char('-'); + } + while (i < 30) { + Out_Char(s[__X(i, 30)]); + i += 1; + } +} + +void Out_Real (REAL x, INT16 n) +{ + Out_RealP(x, n, 0); +} + +void Out_LongReal (LONGREAL x, INT16 n) +{ + Out_RealP(x, n, 1); +} + + +export void *Out__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Platform); + __REGMOD("Out", 0); + __REGCMD("Flush", Out_Flush); + __REGCMD("Ln", Out_Ln); + __REGCMD("Open", Out_Open); +/* BEGIN */ + Out_IsConsole = Platform_IsConsole(Platform_StdOut); + Out_in = 0; + __ENDMOD; +} diff --git a/bootstrap/windows-88/Out.h b/bootstrap/windows-88/Out.h new file mode 100644 index 00000000..a72547f4 --- /dev/null +++ b/bootstrap/windows-88/Out.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Out__h +#define Out__h + +#include "SYSTEM.h" + + +import BOOLEAN Out_IsConsole; + + +import void Out_Char (CHAR ch); +import void Out_Flush (void); +import void Out_Hex (INT64 x, INT64 n); +import void Out_Int (INT64 x, INT64 n); +import void Out_Ln (void); +import void Out_LongReal (LONGREAL x, INT16 n); +import void Out_Open (void); +import void Out_Real (REAL x, INT16 n); +import void Out_String (CHAR *str, ADDRESS str__len); +import LONGREAL Out_Ten (INT16 e); +import void *Out__init(void); + + +#endif // Out diff --git a/bootstrap/windows-88/Platform.c b/bootstrap/windows-88/Platform.c new file mode 100644 index 00000000..563f6417 --- /dev/null +++ b/bootstrap/windows-88/Platform.c @@ -0,0 +1,590 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 volume, indexhigh, indexlow, mtimehigh, mtimelow; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +export BOOLEAN Platform_LittleEndian; +export INT16 Platform_PID; +export CHAR Platform_CWD[4096]; +static INT32 Platform_TimeStart; +export INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +export INT64 Platform_StdIn, Platform_StdOut, Platform_StdErr; +export CHAR Platform_NL[3]; + +export ADDRESS *Platform_FileIdentity__typ; + +export BOOLEAN Platform_Absent (INT16 e); +export INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +export INT16 Platform_Close (INT64 h); +export BOOLEAN Platform_ConnectionFailed (INT16 e); +export void Platform_Delay (INT32 ms); +export BOOLEAN Platform_DifferentFilesystems (INT16 e); +static void Platform_EnableVT100 (void); +export INT16 Platform_Error (void); +export void Platform_Exit (INT32 code); +export void Platform_GetClock (INT32 *t, INT32 *d); +export void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +export void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +export INT16 Platform_Identify (INT64 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +export BOOLEAN Platform_Inaccessible (INT16 e); +export BOOLEAN Platform_Interrupted (INT16 e); +export BOOLEAN Platform_IsConsole (INT64 h); +export void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +export INT16 Platform_MaxNameLength (void); +export INT16 Platform_MaxPathLength (void); +export INT16 Platform_New (CHAR *n, ADDRESS n__len, INT64 *h); +export BOOLEAN Platform_NoSuchDirectory (INT16 e); +export INT64 Platform_OSAllocate (INT64 size); +export void Platform_OSFree (INT64 address); +export INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT64 *h); +export INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT64 *h); +export INT16 Platform_Read (INT64 h, INT64 p, INT32 l, INT32 *n); +export INT16 Platform_ReadBuf (INT64 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +export INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +export BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +export BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +export INT16 Platform_Seek (INT64 h, INT32 o, INT16 r); +export void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +export void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +export INT16 Platform_Size (INT64 h, INT32 *l); +export INT16 Platform_Sync (INT64 h); +export INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +static void Platform_TestLittleEndian (void); +export INT32 Platform_Time (void); +export BOOLEAN Platform_TimedOut (INT16 e); +export BOOLEAN Platform_TooManyFiles (INT16 e); +export INT16 Platform_Truncate (INT64 h, INT32 limit); +export INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +export INT16 Platform_Write (INT64 h, INT64 p, INT32 l); +static void Platform_YMDHMStoClock (INT16 ye, INT16 mo, INT16 da, INT16 ho, INT16 mi, INT16 se, INT32 *t, INT32 *d); +export BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); + +#include "WindowsWrapper.h" +#define Platform_ECONNABORTED() WSAECONNABORTED +#define Platform_ECONNREFUSED() WSAECONNREFUSED +#define Platform_EHOSTUNREACH() WSAEHOSTUNREACH +#define Platform_EINTR() WSAEINTR +#define Platform_ENETUNREACH() WSAENETUNREACH +#define Platform_ERRORACCESSDENIED() ERROR_ACCESS_DENIED +#define Platform_ERRORFILENOTFOUND() ERROR_FILE_NOT_FOUND +#define Platform_ERRORNOTREADY() ERROR_NOT_READY +#define Platform_ERRORNOTSAMEDEVICE() ERROR_NOT_SAME_DEVICE +#define Platform_ERRORPATHNOTFOUND() ERROR_PATH_NOT_FOUND +#define Platform_ERRORSHARINGVIOLATION() ERROR_SHARING_VIOLATION +#define Platform_ERRORTOOMANYOPENFILES() ERROR_TOO_MANY_OPEN_FILES +#define Platform_ERRORWRITEPROTECT() ERROR_WRITE_PROTECT +#define Platform_ETIMEDOUT() WSAETIMEDOUT +#define Platform_GetConsoleMode(h, m) GetConsoleMode((HANDLE)h, (DWORD*)m) +#define Platform_GetTickCount() (LONGINT)(UINT32)GetTickCount() +#define Platform_MAXPATH() MAX_PATH +#define Platform_SetConsoleMode(h, m) SetConsoleMode((HANDLE)h, (DWORD)m) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((ADDRESS)h) +#define Platform_allocate(size) (ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) +#define Platform_bhfiIndexHigh() (LONGINT)bhfi.nFileIndexHigh +#define Platform_bhfiIndexLow() (LONGINT)bhfi.nFileIndexLow +#define Platform_bhfiMtimeHigh() (LONGINT)bhfi.ftLastWriteTime.dwHighDateTime +#define Platform_bhfiMtimeLow() (LONGINT)bhfi.ftLastWriteTime.dwLowDateTime +#define Platform_bhfiVsn() (LONGINT)bhfi.dwVolumeSerialNumber +#define Platform_byHandleFileInformation() BY_HANDLE_FILE_INFORMATION bhfi +#define Platform_cleanupProcess() CloseHandle(pi.hProcess); CloseHandle(pi.hThread); +#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)h) +#define Platform_createProcess(str, str__len) (INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi) +#define Platform_deleteFile(n, n__len) (INTEGER)DeleteFile((char*)n) +#define Platform_err() (INTEGER)GetLastError() +#define Platform_exit(code) ExitProcess((UINT)code) +#define Platform_fileTimeToSysTime() SYSTEMTIME st; FileTimeToSystemTime(&ft, &st) +#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)h) +#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)address) +#define Platform_ftToUli() ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime +#define Platform_getCurrentDirectory(n, n__len) GetCurrentDirectory(n__len, (char*)n) +#define Platform_getExitCodeProcess(exitcode) GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode); +#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)h, &bhfi) +#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart +#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)h, &li) +#define Platform_getLocalTime() SYSTEMTIME st; GetLocalTime(&st) +#define Platform_getenv(name, name__len, buf, buf__len) (INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len) +#define Platform_getpid() (INTEGER)GetCurrentProcessId() +#define Platform_getstderrhandle() (ADDRESS)GetStdHandle(STD_ERROR_HANDLE) +#define Platform_getstdinhandle() (ADDRESS)GetStdHandle(STD_INPUT_HANDLE) +#define Platform_getstdouthandle() (ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE) +#define Platform_identityToFileTime(i) FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow +#define Platform_invalidHandleValue() ((ADDRESS)INVALID_HANDLE_VALUE) +#define Platform_largeInteger() LARGE_INTEGER li +#define Platform_liLongint() (LONGINT)li.QuadPart +#define Platform_moveFile(o, o__len, n, n__len) (INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING) +#define Platform_opennew(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openro(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openrw(n, n__len) (ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_processInfo() PROCESS_INFORMATION pi = {0}; +#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile((HANDLE)fd, (void*)p, (DWORD)l, (DWORD*)n, 0) +#define Platform_seekcur() FILE_CURRENT +#define Platform_seekend() FILE_END +#define Platform_seekset() FILE_BEGIN +#define Platform_setCurrentDirectory(n, n__len) (INTEGER)SetCurrentDirectory((char*)n) +#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)h) +#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, li, 0, (DWORD)r) +#define Platform_sleep(ms) Sleep((DWORD)ms) +#define Platform_stToFt() FILETIME ft; SystemTimeToFileTime(&st, &ft) +#define Platform_startupInfo() STARTUPINFO si = {0}; si.cb = sizeof(si); +#define Platform_sthour() (INTEGER)st.wHour +#define Platform_stmday() (INTEGER)st.wDay +#define Platform_stmin() (INTEGER)st.wMinute +#define Platform_stmon() (INTEGER)st.wMonth +#define Platform_stmsec() (INTEGER)st.wMilliseconds +#define Platform_stsec() (INTEGER)st.wSecond +#define Platform_styear() (INTEGER)st.wYear +#define Platform_tous1970() ul.QuadPart = (ul.QuadPart - 116444736000000000ULL)/10LL +#define Platform_ulSec() (LONGINT)(ul.QuadPart / 1000000LL) +#define Platform_uluSec() (LONGINT)(ul.QuadPart % 1000000LL) +#define Platform_waitForProcess() (INTEGER)WaitForSingleObject(pi.hProcess, INFINITE) +#define Platform_writefile(fd, p, l, n) (INTEGER)WriteFile((HANDLE)fd, (void*)(p), (DWORD)l, (DWORD*)n, 0) + +BOOLEAN Platform_TooManyFiles (INT16 e) +{ + return e == Platform_ERRORTOOMANYOPENFILES(); +} + +BOOLEAN Platform_NoSuchDirectory (INT16 e) +{ + return e == Platform_ERRORPATHNOTFOUND(); +} + +BOOLEAN Platform_DifferentFilesystems (INT16 e) +{ + return e == Platform_ERRORNOTSAMEDEVICE(); +} + +BOOLEAN Platform_Inaccessible (INT16 e) +{ + return ((e == Platform_ERRORACCESSDENIED() || e == Platform_ERRORWRITEPROTECT()) || e == Platform_ERRORNOTREADY()) || e == Platform_ERRORSHARINGVIOLATION(); +} + +BOOLEAN Platform_Absent (INT16 e) +{ + return e == Platform_ERRORFILENOTFOUND() || e == Platform_ERRORPATHNOTFOUND(); +} + +BOOLEAN Platform_TimedOut (INT16 e) +{ + return e == Platform_ETIMEDOUT(); +} + +BOOLEAN Platform_ConnectionFailed (INT16 e) +{ + return ((e == Platform_ECONNREFUSED() || e == Platform_ECONNABORTED()) || e == Platform_ENETUNREACH()) || e == Platform_EHOSTUNREACH(); +} + +BOOLEAN Platform_Interrupted (INT16 e) +{ + return e == Platform_EINTR(); +} + +INT16 Platform_MaxNameLength (void) +{ + return Platform_MAXPATH(); +} + +INT16 Platform_MaxPathLength (void) +{ + return Platform_MAXPATH(); +} + +INT64 Platform_OSAllocate (INT64 size) +{ + return Platform_allocate(size); +} + +void Platform_OSFree (INT64 address) +{ + Platform_free(address); +} + +BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + CHAR buf[4096]; + INT16 res; + __DUP(var, var__len, CHAR); + res = Platform_getenv(var, var__len, (void*)buf, 4096); + if ((res > 0 && res < 4096)) { + __COPY(buf, val, val__len); + __DEL(var); + return 1; + } else { + __DEL(var); + return 0; + } + __RETCHK; +} + +void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len) +{ + __DUP(var, var__len, CHAR); + if (!Platform_getEnv(var, var__len, (void*)val, val__len)) { + val[0] = 0x00; + } + __DEL(var); +} + +void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) +{ +} + +static void Platform_YMDHMStoClock (INT16 ye, INT16 mo, INT16 da, INT16 ho, INT16 mi, INT16 se, INT32 *t, INT32 *d) +{ + *d = (__ASHL((int)__MOD(ye, 100), 9) + __ASHL((mo + 1), 5)) + da; + *t = (__ASHL(ho, 12) + __ASHL(mi, 6)) + se; +} + +void Platform_GetClock (INT32 *t, INT32 *d) +{ + Platform_getLocalTime(); + Platform_YMDHMStoClock(Platform_styear(), Platform_stmon(), Platform_stmday(), Platform_sthour(), Platform_stmin(), Platform_stsec(), &*t, &*d); +} + +INT32 Platform_Time (void) +{ + INT32 ms; + ms = Platform_GetTickCount(); + return (int)__MOD(ms - Platform_TimeStart, 2147483647); +} + +void Platform_Delay (INT32 ms) +{ + while (ms > 30000) { + Platform_sleep(30000); + ms = ms - 30000; + } + if (ms > 0) { + Platform_sleep(ms); + } +} + +void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec) +{ + Platform_getLocalTime(); + Platform_stToFt(); + Platform_ftToUli(); + Platform_tous1970(); + *sec = Platform_ulSec(); + *usec = Platform_uluSec(); +} + +INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len) +{ + INT16 result; + __DUP(cmd, cmd__len, CHAR); + result = 127; + Platform_startupInfo(); + Platform_processInfo(); + if (Platform_createProcess(cmd, cmd__len) != 0) { + if (Platform_waitForProcess() == 0) { + Platform_getExitCodeProcess(&result); + } + Platform_cleanupProcess(); + } + __DEL(cmd); + return __ASHL(result, 8); +} + +INT16 Platform_Error (void) +{ + return Platform_err(); +} + +INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT64 *h) +{ + INT64 fd; + fd = Platform_openro(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT64 *h) +{ + INT64 fd; + fd = Platform_openrw(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_New (CHAR *n, ADDRESS n__len, INT64 *h) +{ + INT64 fd; + fd = Platform_opennew(n, n__len); + if (fd == Platform_invalidHandleValue()) { + return Platform_err(); + } else { + *h = fd; + return 0; + } + __RETCHK; +} + +INT16 Platform_Close (INT64 h) +{ + if (Platform_closeHandle(h) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Identify (INT64 h, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + Platform_byHandleFileInformation(); + if (Platform_getFileInformationByHandle(h) == 0) { + return Platform_err(); + } + (*identity).volume = Platform_bhfiVsn(); + (*identity).indexhigh = Platform_bhfiIndexHigh(); + (*identity).indexlow = Platform_bhfiIndexLow(); + (*identity).mtimehigh = Platform_bhfiMtimeHigh(); + (*identity).mtimelow = Platform_bhfiMtimeLow(); + return 0; +} + +INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ) +{ + INT64 h; + INT16 e, i; + __DUP(n, n__len, CHAR); + e = Platform_OldRO((void*)n, n__len, &h); + if (e != 0) { + __DEL(n); + return e; + } + e = Platform_Identify(h, &*identity, identity__typ); + i = Platform_Close(h); + __DEL(n); + return e; +} + +BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (((i1.indexhigh == i2.indexhigh && i1.indexlow == i2.indexlow)) && i1.volume == i2.volume); +} + +BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2) +{ + return (i1.mtimehigh == i2.mtimehigh && i1.mtimelow == i2.mtimelow); +} + +void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source) +{ + (*target).mtimehigh = source.mtimehigh; + (*target).mtimelow = source.mtimelow; +} + +void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d) +{ + Platform_identityToFileTime(i); + Platform_fileTimeToSysTime(); + Platform_YMDHMStoClock(Platform_styear(), Platform_stmon(), Platform_stmday(), Platform_sthour(), Platform_stmin(), Platform_stsec(), &*t, &*d); +} + +INT16 Platform_Size (INT64 h, INT32 *l) +{ + Platform_largeInteger(); + if (Platform_getFileSize(h) == 0) { + return Platform_err(); + } + *l = Platform_liLongint(); + return 0; +} + +INT16 Platform_Read (INT64 h, INT64 p, INT32 l, INT32 *n) +{ + INT16 result; + INT32 lengthread; + result = Platform_readfile(h, p, l, &lengthread); + if (result == 0) { + *n = 0; + return Platform_err(); + } else { + *n = lengthread; + return 0; + } + __RETCHK; +} + +INT16 Platform_ReadBuf (INT64 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n) +{ + INT16 result; + INT32 lengthread; + result = Platform_readfile(h, (ADDRESS)b, b__len, &lengthread); + if (result == 0) { + *n = 0; + return Platform_err(); + } else { + *n = lengthread; + return 0; + } + __RETCHK; +} + +INT16 Platform_Write (INT64 h, INT64 p, INT32 l) +{ + INT32 n; + if (Platform_writefile(h, p, l, &n) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Sync (INT64 h) +{ + if (Platform_flushFileBuffers(h) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Seek (INT64 h, INT32 o, INT16 r) +{ + INT16 rc; + Platform_largeInteger(); + Platform_setFilePointerEx(h, o, r, &rc); + if (rc == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Truncate (INT64 h, INT32 limit) +{ + INT16 rc; + INT32 oldpos; + Platform_largeInteger(); + Platform_getFilePos(h, &oldpos, &rc); + if (rc == 0) { + return Platform_err(); + } + Platform_setFilePointerEx(h, limit, Platform_seekset(), &rc); + if (rc == 0) { + return Platform_err(); + } + if (Platform_setEndOfFile(h) == 0) { + return Platform_err(); + } + Platform_setFilePointerEx(h, oldpos, Platform_seekset(), &rc); + if (rc == 0) { + return Platform_err(); + } + return 0; +} + +INT16 Platform_Unlink (CHAR *n, ADDRESS n__len) +{ + if (Platform_deleteFile(n, n__len) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +INT16 Platform_Chdir (CHAR *n, ADDRESS n__len) +{ + INT16 r; + r = Platform_setCurrentDirectory(n, n__len); + if (r == 0) { + return Platform_err(); + } + Platform_getCurrentDirectory((void*)Platform_CWD, 4096); + return 0; +} + +INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len) +{ + if (Platform_moveFile(o, o__len, n, n__len) == 0) { + return Platform_err(); + } else { + return 0; + } + __RETCHK; +} + +void Platform_Exit (INT32 code) +{ + Platform_exit(code); +} + +static void Platform_EnableVT100 (void) +{ + INT32 mode; + if (Platform_GetConsoleMode(Platform_StdOut, &mode)) { + Platform_SetConsoleMode(Platform_StdOut, mode + 4); + } +} + +BOOLEAN Platform_IsConsole (INT64 h) +{ + INT32 mode; + return Platform_GetConsoleMode(Platform_StdOut, &mode); +} + +static void Platform_TestLittleEndian (void) +{ + INT16 i; + i = 1; + __GET((ADDRESS)&i, Platform_LittleEndian, BOOLEAN); +} + +__TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 20), {-8}}; + +export void *Platform__init(void) +{ + __DEFMOD; + __REGMOD("Platform", 0); + __INITYP(Platform_FileIdentity, Platform_FileIdentity, 0); +/* BEGIN */ + Platform_TestLittleEndian(); + Platform_TimeStart = 0; + Platform_TimeStart = Platform_Time(); + Platform_CWD[0] = 0x00; + Platform_getCurrentDirectory((void*)Platform_CWD, 4096); + Platform_PID = Platform_getpid(); + Platform_SeekSet = Platform_seekset(); + Platform_SeekCur = Platform_seekcur(); + Platform_SeekEnd = Platform_seekend(); + Platform_StdIn = Platform_getstdinhandle(); + Platform_StdOut = Platform_getstdouthandle(); + Platform_StdErr = Platform_getstderrhandle(); + Platform_EnableVT100(); + Platform_NL[0] = 0x0d; + Platform_NL[1] = 0x0a; + Platform_NL[2] = 0x00; + __ENDMOD; +} diff --git a/bootstrap/windows-88/Platform.h b/bootstrap/windows-88/Platform.h new file mode 100644 index 00000000..1259a228 --- /dev/null +++ b/bootstrap/windows-88/Platform.h @@ -0,0 +1,75 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Platform__h +#define Platform__h + +#include "SYSTEM.h" + +typedef + struct Platform_FileIdentity { + INT32 _prvt0; + char _prvt1[16]; + } Platform_FileIdentity; + +typedef + void (*Platform_SignalHandler)(INT32); + + +import BOOLEAN Platform_LittleEndian; +import INT16 Platform_PID; +import CHAR Platform_CWD[4096]; +import INT16 Platform_SeekSet, Platform_SeekCur, Platform_SeekEnd; +import INT64 Platform_StdIn, Platform_StdOut, Platform_StdErr; +import CHAR Platform_NL[3]; + +import ADDRESS *Platform_FileIdentity__typ; + +import BOOLEAN Platform_Absent (INT16 e); +import INT16 Platform_Chdir (CHAR *n, ADDRESS n__len); +import INT16 Platform_Close (INT64 h); +import BOOLEAN Platform_ConnectionFailed (INT16 e); +import void Platform_Delay (INT32 ms); +import BOOLEAN Platform_DifferentFilesystems (INT16 e); +import INT16 Platform_Error (void); +import void Platform_Exit (INT32 code); +import void Platform_GetClock (INT32 *t, INT32 *d); +import void Platform_GetEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void Platform_GetTimeOfDay (INT32 *sec, INT32 *usec); +import INT16 Platform_Identify (INT64 h, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import INT16 Platform_IdentifyByName (CHAR *n, ADDRESS n__len, Platform_FileIdentity *identity, ADDRESS *identity__typ); +import BOOLEAN Platform_Inaccessible (INT16 e); +import BOOLEAN Platform_Interrupted (INT16 e); +import BOOLEAN Platform_IsConsole (INT64 h); +import void Platform_MTimeAsClock (Platform_FileIdentity i, INT32 *t, INT32 *d); +import INT16 Platform_MaxNameLength (void); +import INT16 Platform_MaxPathLength (void); +import INT16 Platform_New (CHAR *n, ADDRESS n__len, INT64 *h); +import BOOLEAN Platform_NoSuchDirectory (INT16 e); +import INT64 Platform_OSAllocate (INT64 size); +import void Platform_OSFree (INT64 address); +import INT16 Platform_OldRO (CHAR *n, ADDRESS n__len, INT64 *h); +import INT16 Platform_OldRW (CHAR *n, ADDRESS n__len, INT64 *h); +import INT16 Platform_Read (INT64 h, INT64 p, INT32 l, INT32 *n); +import INT16 Platform_ReadBuf (INT64 h, SYSTEM_BYTE *b, ADDRESS b__len, INT32 *n); +import INT16 Platform_Rename (CHAR *o, ADDRESS o__len, CHAR *n, ADDRESS n__len); +import BOOLEAN Platform_SameFile (Platform_FileIdentity i1, Platform_FileIdentity i2); +import BOOLEAN Platform_SameFileTime (Platform_FileIdentity i1, Platform_FileIdentity i2); +import INT16 Platform_Seek (INT64 h, INT32 o, INT16 r); +import void Platform_SetBadInstructionHandler (Platform_SignalHandler handler); +import void Platform_SetMTime (Platform_FileIdentity *target, ADDRESS *target__typ, Platform_FileIdentity source); +import INT16 Platform_Size (INT64 h, INT32 *l); +import INT16 Platform_Sync (INT64 h); +import INT16 Platform_System (CHAR *cmd, ADDRESS cmd__len); +import INT32 Platform_Time (void); +import BOOLEAN Platform_TimedOut (INT16 e); +import BOOLEAN Platform_TooManyFiles (INT16 e); +import INT16 Platform_Truncate (INT64 h, INT32 limit); +import INT16 Platform_Unlink (CHAR *n, ADDRESS n__len); +import INT16 Platform_Write (INT64 h, INT64 p, INT32 l); +import BOOLEAN Platform_getEnv (CHAR *var, ADDRESS var__len, CHAR *val, ADDRESS val__len); +import void *Platform__init(void); + +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((ADDRESS)h) + +#endif // Platform diff --git a/bootstrap/windows-88/Reals.c b/bootstrap/windows-88/Reals.c new file mode 100644 index 00000000..512ec2c4 --- /dev/null +++ b/bootstrap/windows-88/Reals.c @@ -0,0 +1,157 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" + + + + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len); +export void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +export void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +export void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +export void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +export INT16 Reals_Expo (REAL x); +export INT16 Reals_ExpoL (LONGREAL x); +export void Reals_SetExpo (REAL *x, INT16 ex); +export REAL Reals_Ten (INT16 e); +export LONGREAL Reals_TenL (INT16 e); +static CHAR Reals_ToHex (INT16 i); + + +REAL Reals_Ten (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + while (e > 0) { + if (__ODD(e)) { + r = r * power; + } + power = power * power; + e = __ASHR(e, 1); + } + return r; +} + +LONGREAL Reals_TenL (INT16 e) +{ + LONGREAL r, power; + r = (LONGREAL)1; + power = (LONGREAL)10; + for (;;) { + if (__ODD(e)) { + r = r * power; + } + e = __ASHR(e, 1); + if (e <= 0) { + return r; + } + power = power * power; + } + __RETCHK; +} + +INT16 Reals_Expo (REAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 2, i, INT16); + return __MASK(__ASHR(i, 7), -256); +} + +void Reals_SetExpo (REAL *x, INT16 ex) +{ + CHAR c; + __GET((ADDRESS)x + 3, c, CHAR); + __PUT((ADDRESS)x + 3, __CHR(__ASHL(__ASHR((INT16)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((ADDRESS)x + 2, c, CHAR); + __PUT((ADDRESS)x + 2, __CHR(__MASK((INT16)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); +} + +INT16 Reals_ExpoL (LONGREAL x) +{ + INT16 i; + __GET((ADDRESS)&x + 6, i, INT16); + return __MASK(__ASHR(i, 4), -2048); +} + +void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + INT32 i, j, k; + if (x < (LONGREAL)0) { + x = -x; + } + k = 0; + if (n > 9) { + i = __SHORT(__ENTIER(x / (LONGREAL)(LONGREAL)1000000000), 2147483648LL); + j = __SHORT(__ENTIER(x - i * (LONGREAL)1000000000), 2147483648LL); + if (j < 0) { + j = 0; + } + while (k < 9) { + d[__X(k, d__len)] = __CHR((int)__MOD(j, 10) + 48); + j = __DIV(j, 10); + k += 1; + } + } else { + i = __SHORT(__ENTIER(x), 2147483648LL); + } + while (k < n) { + d[__X(k, d__len)] = __CHR((int)__MOD(i, 10) + 48); + i = __DIV(i, 10); + k += 1; + } +} + +void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len) +{ + Reals_ConvertL(x, n, (void*)d, d__len); +} + +static CHAR Reals_ToHex (INT16 i) +{ + if (i < 10) { + return __CHR(i + 48); + } else { + return __CHR(i + 55); + } + __RETCHK; +} + +static void Reals_BytesToHex (SYSTEM_BYTE *b, ADDRESS b__len, SYSTEM_BYTE *d, ADDRESS d__len) +{ + INT16 i; + INT32 l; + CHAR by; + i = 0; + l = b__len; + while (i < l) { + by = __VAL(CHAR, b[__X(i, b__len)]); + d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((INT16)by, 4)); + d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((INT16)by, -16)); + i += 1; + } +} + +void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&y, 4, (void*)d, d__len * 1); +} + +void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len) +{ + Reals_BytesToHex((void*)&x, 8, (void*)d, d__len * 1); +} + + +export void *Reals__init(void) +{ + __DEFMOD; + __REGMOD("Reals", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/Reals.h b/bootstrap/windows-88/Reals.h new file mode 100644 index 00000000..93e7fa75 --- /dev/null +++ b/bootstrap/windows-88/Reals.h @@ -0,0 +1,23 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Reals__h +#define Reals__h + +#include "SYSTEM.h" + + + + +import void Reals_Convert (REAL x, INT16 n, CHAR *d, ADDRESS d__len); +import void Reals_ConvertH (REAL y, CHAR *d, ADDRESS d__len); +import void Reals_ConvertHL (LONGREAL x, CHAR *d, ADDRESS d__len); +import void Reals_ConvertL (LONGREAL x, INT16 n, CHAR *d, ADDRESS d__len); +import INT16 Reals_Expo (REAL x); +import INT16 Reals_ExpoL (LONGREAL x); +import void Reals_SetExpo (REAL *x, INT16 ex); +import REAL Reals_Ten (INT16 e); +import LONGREAL Reals_TenL (INT16 e); +import void *Reals__init(void); + + +#endif // Reals diff --git a/bootstrap/windows-88/Strings.c b/bootstrap/windows-88/Strings.c new file mode 100644 index 00000000..4b18812f --- /dev/null +++ b/bootstrap/windows-88/Strings.c @@ -0,0 +1,374 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Reals.h" + + + + +export void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +export void Strings_Cap (CHAR *s, ADDRESS s__len); +export void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +export void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +export void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export INT16 Strings_Length (CHAR *s, ADDRESS s__len); +export BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +export INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +export void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +export void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +export void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); + + +INT16 Strings_Length (CHAR *s, ADDRESS s__len) +{ + INT32 i; + __DUP(s, s__len, CHAR); + i = 0; + while ((i < s__len && s[__X(i, s__len)] != 0x00)) { + i += 1; + } + if (i <= 32767) { + __DEL(s); + return __SHORT(i, 32768); + } else { + __DEL(s); + return 32767; + } + __RETCHK; +} + +void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(extra, extra__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(extra, extra__len); + i = 0; + while ((i < n2 && (i + n1) < dest__len)) { + dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; + i += 1; + } + if ((i + n1) < dest__len) { + dest[__X(i + n1, dest__len)] = 0x00; + } + __DEL(extra); +} + +void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + INT16 n1, n2, i; + __DUP(source, source__len, CHAR); + n1 = Strings_Length(dest, dest__len); + n2 = Strings_Length(source, source__len); + if (pos < 0) { + pos = 0; + } + if (pos > n1) { + Strings_Append(dest, dest__len, (void*)source, source__len); + __DEL(source); + return; + } + if ((pos + n2) < dest__len) { + i = n1; + while (i >= pos) { + if ((i + n2) < dest__len) { + dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; + } + i -= 1; + } + } + i = 0; + while (i < n2) { + dest[__X(pos + i, dest__len)] = source[__X(i, source__len)]; + i += 1; + } + __DEL(source); +} + +void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n) +{ + INT16 len, i; + len = Strings_Length(s, s__len); + if (pos < 0) { + pos = 0; + } else if (pos >= len) { + return; + } + if (pos + n < len) { + i = pos + n; + while (i < len) { + s[__X(i - n, s__len)] = s[__X(i, s__len)]; + i += 1; + } + if ((i - n) < s__len) { + s[__X(i - n, s__len)] = 0x00; + } + } else { + s[__X(pos, s__len)] = 0x00; + } +} + +void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len) +{ + __DUP(source, source__len, CHAR); + Strings_Delete((void*)dest, dest__len, pos, pos + Strings_Length(source, source__len)); + Strings_Insert(source, source__len, pos, (void*)dest, dest__len); + __DEL(source); +} + +void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len) +{ + INT16 len, destLen, i; + __DUP(source, source__len, CHAR); + len = Strings_Length(source, source__len); + destLen = __SHORT(dest__len, 32768) - 1; + if (pos < 0) { + pos = 0; + } + if (pos >= len) { + dest[0] = 0x00; + __DEL(source); + return; + } + i = 0; + while (((((pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + if (i < destLen) { + dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; + } + i += 1; + } + dest[__X(i, dest__len)] = 0x00; + __DEL(source); +} + +INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos) +{ + INT16 n1, n2, i, j; + __DUP(pattern, pattern__len, CHAR); + __DUP(s, s__len, CHAR); + n1 = Strings_Length(s, s__len); + n2 = Strings_Length(pattern, pattern__len); + if (n2 == 0) { + __DEL(pattern); + __DEL(s); + return 0; + } + i = pos; + while (i <= n1 - n2) { + if (s[__X(i, s__len)] == pattern[0]) { + j = 1; + while ((j < n2 && s[__X(i + j, s__len)] == pattern[__X(j, pattern__len)])) { + j += 1; + } + if (j == n2) { + __DEL(pattern); + __DEL(s); + return i; + } + } + i += 1; + } + __DEL(pattern); + __DEL(s); + return -1; +} + +void Strings_Cap (CHAR *s, ADDRESS s__len) +{ + INT16 i; + i = 0; + while (s[__X(i, s__len)] != 0x00) { + if (('a' <= s[__X(i, s__len)] && s[__X(i, s__len)] <= 'z')) { + s[__X(i, s__len)] = __CAP(s[__X(i, s__len)]); + } + i += 1; + } +} + +static struct Match__7 { + struct Match__7 *lnk; +} *Match__7_s; + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m); + +static BOOLEAN M__8 (CHAR *name, ADDRESS name__len, CHAR *mask, ADDRESS mask__len, INT16 n, INT16 m) +{ + while ((((n >= 0 && m >= 0)) && mask[__X(m, mask__len)] != '*')) { + if (name[__X(n, name__len)] != mask[__X(m, mask__len)]) { + return 0; + } + n -= 1; + m -= 1; + } + if (m < 0) { + return n < 0; + } + while ((m >= 0 && mask[__X(m, mask__len)] == '*')) { + m -= 1; + } + if (m < 0) { + return 1; + } + while (n >= 0) { + if (M__8(name, name__len, mask, mask__len, n, m)) { + return 1; + } + n -= 1; + } + return 0; +} + +BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len) +{ + struct Match__7 _s; + BOOLEAN __retval; + __DUP(string, string__len, CHAR); + __DUP(pattern, pattern__len, CHAR); + _s.lnk = Match__7_s; + Match__7_s = &_s; + __retval = M__8((void*)string, string__len, (void*)pattern, pattern__len, Strings_Length(string, string__len) - 1, Strings_Length(pattern, pattern__len) - 1); + Match__7_s = _s.lnk; + __DEL(string); + __DEL(pattern); + ; + return __retval; +} + +void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r) +{ + INT16 p, e; + REAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (REAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (REAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (REAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (REAL)(REAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (REAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + +void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r) +{ + INT16 p, e; + LONGREAL y, g; + BOOLEAN neg, negE; + __DUP(s, s__len, CHAR); + p = 0; + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + if (s[__X(p, s__len)] == '-') { + neg = 1; + p += 1; + } else { + neg = 0; + } + while (s[__X(p, s__len)] == ' ' || s[__X(p, s__len)] == '0') { + p += 1; + } + y = (LONGREAL)0; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + y = y * (LONGREAL)10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (s[__X(p, s__len)] == '.') { + p += 1; + g = (LONGREAL)1; + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + g = g / (LONGREAL)(LONGREAL)10; + y = y + g * ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + } + if (s[__X(p, s__len)] == 'D' || s[__X(p, s__len)] == 'E') { + p += 1; + e = 0; + if (s[__X(p, s__len)] == '-') { + negE = 1; + p += 1; + } else { + negE = 0; + } + while (s[__X(p, s__len)] == '0') { + p += 1; + } + while (('0' <= s[__X(p, s__len)] && s[__X(p, s__len)] <= '9')) { + e = e * 10 + ((INT16)s[__X(p, s__len)] - 48); + p += 1; + } + if (negE) { + y = y / (LONGREAL)Reals_Ten(e); + } else { + y = y * Reals_Ten(e); + } + } + if (neg) { + y = -y; + } + *r = y; + __DEL(s); +} + + +export void *Strings__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Reals); + __REGMOD("Strings", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/Strings.h b/bootstrap/windows-88/Strings.h new file mode 100644 index 00000000..f0e3ae34 --- /dev/null +++ b/bootstrap/windows-88/Strings.h @@ -0,0 +1,25 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Strings__h +#define Strings__h + +#include "SYSTEM.h" + + + + +import void Strings_Append (CHAR *extra, ADDRESS extra__len, CHAR *dest, ADDRESS dest__len); +import void Strings_Cap (CHAR *s, ADDRESS s__len); +import void Strings_Delete (CHAR *s, ADDRESS s__len, INT16 pos, INT16 n); +import void Strings_Extract (CHAR *source, ADDRESS source__len, INT16 pos, INT16 n, CHAR *dest, ADDRESS dest__len); +import void Strings_Insert (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import INT16 Strings_Length (CHAR *s, ADDRESS s__len); +import BOOLEAN Strings_Match (CHAR *string, ADDRESS string__len, CHAR *pattern, ADDRESS pattern__len); +import INT16 Strings_Pos (CHAR *pattern, ADDRESS pattern__len, CHAR *s, ADDRESS s__len, INT16 pos); +import void Strings_Replace (CHAR *source, ADDRESS source__len, INT16 pos, CHAR *dest, ADDRESS dest__len); +import void Strings_StrToLongReal (CHAR *s, ADDRESS s__len, LONGREAL *r); +import void Strings_StrToReal (CHAR *s, ADDRESS s__len, REAL *r); +import void *Strings__init(void); + + +#endif // Strings diff --git a/bootstrap/windows-88/Texts.c b/bootstrap/windows-88/Texts.c new file mode 100644 index 00000000..77dc1bac --- /dev/null +++ b/bootstrap/windows-88/Texts.c @@ -0,0 +1,1833 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Files.h" +#include "Modules.h" +#include "Reals.h" + +typedef + struct Texts_RunDesc *Texts_Run; + +typedef + struct Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_RunDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + } Texts_RunDesc; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + struct Texts_ElemDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + } Texts_ElemDesc; + +struct Texts__1 { /* Texts_ElemDesc */ + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + INT32 W, H; + Texts_Handler handle; + Texts_Text base; + Files_File file; + INT32 org, span; + CHAR mod[32], proc[32]; +}; + +typedef + struct Texts__1 *Texts_Alien; + +typedef + struct Texts_BufDesc { + INT32 len; + Texts_Run head; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + CHAR name[32]; + } Texts_FontDesc; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_PieceDesc *Texts_Piece; + +typedef + struct Texts_PieceDesc { + Texts_Run prev, next; + INT32 len; + Texts_FontsFont fnt; + INT8 col, voff; + BOOLEAN ascii; + Files_File file; + INT32 org; + } Texts_PieceDesc; + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + Files_Rider rider; + Texts_Run run; + INT32 org, off; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + Texts_Run head, cache; + INT32 corg; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + Files_Rider rider; + Files_File file; + } Texts_Writer; + + +export Texts_Elem Texts_new; +static Texts_Buffer Texts_del; +static Texts_FontsFont Texts_FontsDefault; + +export ADDRESS *Texts_FontDesc__typ; +export ADDRESS *Texts_RunDesc__typ; +export ADDRESS *Texts_PieceDesc__typ; +export ADDRESS *Texts_ElemMsg__typ; +export ADDRESS *Texts_ElemDesc__typ; +export ADDRESS *Texts_FileMsg__typ; +export ADDRESS *Texts_CopyMsg__typ; +export ADDRESS *Texts_IdentifyMsg__typ; +export ADDRESS *Texts_BufDesc__typ; +export ADDRESS *Texts_TextDesc__typ; +export ADDRESS *Texts_Reader__typ; +export ADDRESS *Texts_Scanner__typ; +export ADDRESS *Texts_Writer__typ; +export ADDRESS *Texts__1__typ; + +export void Texts_Append (Texts_Text T, Texts_Buffer B); +export void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +static Texts_Elem Texts_CloneElem (Texts_Elem e); +static Texts_Piece Texts_ClonePiece (Texts_Piece p); +export void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +export void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +export void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +export Texts_Text Texts_ElemBase (Texts_Elem E); +export INT32 Texts_ElemPos (Texts_Elem E); +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off); +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len); +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ); +export void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +export void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v); +export void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +export void Texts_OpenBuf (Texts_Buffer B); +export void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +export void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +export void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +export INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +export void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +export void Texts_Recall (Texts_Buffer *B); +export void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +export void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +export void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +export void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +export void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base); +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un); +export void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +export void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +export void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +export void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +export void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +export void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +export void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +export void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +export void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +export void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +export void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +export void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +export void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); + + +static Texts_FontsFont Texts_FontsThis (CHAR *name, ADDRESS name__len) +{ + Texts_FontsFont F = NIL; + __NEW(F, Texts_FontDesc); + __COPY(name, F->name, 32); + return F; +} + +static void Texts_Find (Texts_Text T, INT32 *pos, Texts_Run *u, INT32 *org, INT32 *off) +{ + Texts_Run v = NIL; + INT32 m; + if (*pos >= T->len) { + *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) { + while (m >= v->len) { + m -= v->len; + v = v->next; + } + } else { + while (m < 0) { + v = v->prev; + m += v->len; + } + } + *u = v; + *org = *pos - m; + *off = m; + T->cache = v->prev; + T->corg = *org; + } +} + +static void Texts_Split (INT32 off, Texts_Run *u, Texts_Run *un) +{ + Texts_Piece p = NIL, U = NIL; + if (off == 0) { + *un = *u; + *u = (*un)->prev; + } else if (off >= (*u)->len) { + *un = (*u)->next; + } else { + __NEW(p, Texts_PieceDesc); + *un = (Texts_Run)p; + U = __GUARDP(*u, Texts_PieceDesc, 1); + __GUARDEQP(p, Texts_PieceDesc) = *U; + p->org += off; + p->len -= off; + U->len -= p->len; + p->ascii = (*u)->ascii; + p->prev = (Texts_Run)U; + p->next = U->next; + p->next->prev = (Texts_Run)p; + U->next = (Texts_Run)p; + } +} + +static void Texts_Merge (Texts_Text T, Texts_Run u, Texts_Run *v) +{ + Texts_Piece p = NIL, q = NIL; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __ISP(*v, Texts_PieceDesc, 1))) && __STRCMP(u->fnt->name, (*v)->fnt->name) == 0)) && u->col == (*v)->col)) && u->voff == (*v)->voff)) && __GUARDP(u, Texts_PieceDesc, 1)->ascii == __GUARDP(*v, Texts_PieceDesc, 1)->ascii)) { + p = __GUARDP(u, Texts_PieceDesc, 1); + q = __GUARDP(*v, Texts_PieceDesc, 1); + if ((p->file == q->file && p->org + p->len == q->org)) { + if (T->cache == u) { + T->corg += q->len; + } else if (T->cache == *v) { + T->cache = T->head; + T->corg = 0; + } + p->len += q->len; + *v = (*v)->next; + } + } +} + +static void Texts_Splice (Texts_Run un, Texts_Run v, Texts_Run w, Texts_Text base) +{ + Texts_Run u = NIL; + if (v != w->next) { + u = un->prev; + u->next = v; + v->prev = u; + un->prev = w; + w->next = un; + do { + if (__ISP(v, Texts_ElemDesc, 1)) { + __GUARDP(v, Texts_ElemDesc, 1)->base = base; + } + v = v->next; + } while (!(v == un)); + } +} + +static Texts_Piece Texts_ClonePiece (Texts_Piece p) +{ + Texts_Piece q = NIL; + __NEW(q, Texts_PieceDesc); + __GUARDEQP(q, Texts_PieceDesc) = *p; + return q; +} + +static Texts_Elem Texts_CloneElem (Texts_Elem e) +{ + Texts_CopyMsg msg; + msg.e = NIL; + (*e->handle)(e, (void*)&msg, Texts_CopyMsg__typ); + return msg.e; +} + +void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE) +{ + 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; +} + +Texts_Text Texts_ElemBase (Texts_Elem E) +{ + return E->base; +} + +INT32 Texts_ElemPos (Texts_Elem E) +{ + Texts_Run u = NIL; + INT32 pos; + u = E->base->head->next; + pos = 0; + while (u != (void *) E) { + pos = pos + u->len; + u = u->next; + } + return pos; +} + +static void Texts_HandleAlien (Texts_Elem E, Texts_ElemMsg *msg, ADDRESS *msg__typ) +{ + Texts_Alien e = NIL; + Files_Rider r; + INT32 i; + CHAR ch; + if (__ISP(E, Texts__1, 2)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + if (__IS(msg__typ, Texts_CopyMsg, 1)) { + Texts_CopyMsg *msg__ = (void*)msg; + __NEW(e, Texts__1); + Texts_CopyElem((void*)(*(Texts_Alien*)&E), (void*)e); + e->file = (*(Texts_Alien*)&E)->file; + e->org = (*(Texts_Alien*)&E)->org; + e->span = (*(Texts_Alien*)&E)->span; + __MOVE((*(Texts_Alien*)&E)->mod, e->mod, 32); + __MOVE((*(Texts_Alien*)&E)->proc, e->proc, 32); + (*msg__).e = (Texts_Elem)e; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + if (__IS(msg__typ, Texts_IdentifyMsg, 1)) { + Texts_IdentifyMsg *msg__ = (void*)msg; + __COPY((*(Texts_Alien*)&E)->mod, (*msg__).mod, 32); + __COPY((*(Texts_Alien*)&E)->proc, (*msg__).proc, 32); + (*msg__).mod[31] = 0x01; + } else __WITHCHK; + } else if (__IS(msg__typ, Texts_FileMsg, 1)) { + if (__IS(msg__typ, Texts_FileMsg, 1)) { + Texts_FileMsg *msg__ = (void*)msg; + if ((*msg__).id == 1) { + Files_Set(&r, Files_Rider__typ, (*(Texts_Alien*)&E)->file, (*(Texts_Alien*)&E)->org); + i = (*(Texts_Alien*)&E)->span; + while (i > 0) { + Files_Read(&r, Files_Rider__typ, (void*)&ch); + Files_Write(&(*msg__).r, Files_Rider__typ, ch); + i -= 1; + } + } + } else __WITHCHK; + } + } else __WITHCHK; +} + +void Texts_OpenBuf (Texts_Buffer B) +{ + Texts_Run u = NIL; + __NEW(u, Texts_RunDesc); + u->next = u; + u->prev = u; + B->head = u; + B->len = 0; +} + +void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB) +{ + Texts_Run u = NIL, v = NIL, vn = NIL; + u = SB->head->next; + v = DB->head->prev; + while (u != SB->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + vn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + } else { + vn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + v->next = vn; + vn->prev = v; + v = vn; + u = u->next; + } + v->next = DB->head; + DB->head->prev = v; + DB->len += SB->len; +} + +void Texts_Recall (Texts_Buffer *B) +{ + *B = Texts_del; + Texts_del = NIL; +} + +void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B) +{ + Texts_Run u = NIL, v = NIL, w = NIL, wn = NIL; + INT32 uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Find(T, &end, &v, &vo, &vd); + w = B->head->prev; + while (u != v) { + if (__ISP(u, Texts_PieceDesc, 1)) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(u, Texts_PieceDesc, 1)); + wn->len -= ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + } else { + wn = (Texts_Run)Texts_CloneElem(__GUARDP(u, Texts_ElemDesc, 1)); + } + w->next = wn; + wn->prev = w; + w = wn; + u = u->next; + ud = 0; + } + if (vd > 0) { + wn = (Texts_Run)Texts_ClonePiece(__GUARDP(v, Texts_PieceDesc, 1)); + wn->len = vd - ud; + __GUARDP(wn, Texts_PieceDesc, 1)->org += ud; + w->next = wn; + wn->prev = w; + w = wn; + } + w->next = B->head; + B->head->prev = w; + B->len += end - beg; +} + +void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B) +{ + Texts_Run u = NIL, un = NIL, v = NIL; + Texts_Piece p = NIL, q = NIL; + INT32 uo, ud, len; + Texts_Find(T, &pos, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + len = B->len; + v = B->head->next; + Texts_Merge(T, u, &v); + Texts_Splice(un, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Append (Texts_Text T, Texts_Buffer B) +{ + Texts_Run v = NIL; + INT32 pos, len; + pos = T->len; + len = B->len; + v = B->head->next; + Texts_Merge(T, T->head->prev, &v); + Texts_Splice(T->head, v, B->head->prev, T); + T->len += len; + B->head->next = B->head; + B->head->prev = B->head; + B->len = 0; + if (T->notify != NIL) { + (*T->notify)(T, 1, pos, pos + len); + } +} + +void Texts_Delete (Texts_Text T, INT32 beg, INT32 end) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + __NEW(Texts_del, Texts_BufDesc); + Texts_OpenBuf(Texts_del); + Texts_del->len = end - beg; + Texts_Splice(Texts_del->head, un, v, NIL); + Texts_Merge(T, u, &vn); + u->next = vn; + vn->prev = u; + T->len -= end - beg; + if (T->notify != NIL) { + (*T->notify)(T, 2, beg, end); + } +} + +void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff) +{ + Texts_Run c = NIL, u = NIL, un = NIL, v = NIL, vn = NIL; + INT32 co, uo, ud, vo, vd; + Texts_Find(T, &beg, &u, &uo, &ud); + Texts_Split(ud, &u, &un); + c = T->cache; + co = T->corg; + Texts_Find(T, &end, &v, &vo, &vd); + Texts_Split(vd, &v, &vn); + T->cache = c; + T->corg = co; + while (un != vn) { + if ((__IN(0, sel, 32) && fnt != NIL)) { + un->fnt = fnt; + } + if (__IN(1, sel, 32)) { + un->col = col; + } + if (__IN(2, sel, 32)) { + un->voff = voff; + } + Texts_Merge(T, u, &un); + if (u->next == un) { + u = un; + un = un->next; + } else { + u->next = un; + un->prev = u; + } + } + Texts_Merge(T, u, &un); + u->next = un; + un->prev = u; + if (T->notify != NIL) { + (*T->notify)(T, 0, beg, end); + } +} + +void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos) +{ + Texts_Run u = NIL; + if (pos >= T->len) { + pos = T->len; + } + Texts_Find(T, &pos, &u, &(*R).org, &(*R).off); + (*R).run = u; + (*R).eot = 0; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, __GUARDP(u, Texts_PieceDesc, 1)->org + (*R).off); + } +} + +void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch) +{ + Texts_Run u = NIL; + INT32 pos; + CHAR nextch; + u = (*R).run; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).off += 1; + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&*ch); + (*R).elem = NIL; + if ((*ch == 0x0a && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + *ch = 0x0d; + } else if ((*ch == 0x0d && __GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + pos = Files_Pos(&(*R).rider, Files_Rider__typ); + Files_Read(&(*R).rider, Files_Rider__typ, (void*)&nextch); + if (nextch == 0x0a) { + (*R).off += 1; + } else { + Files_Set(&(*R).rider, Files_Rider__typ, __GUARDP(u, Texts_PieceDesc, 1)->file, pos); + } + } + } else if (__ISP(u, Texts_ElemDesc, 1)) { + *ch = 0x1c; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + *ch = 0x00; + (*R).elem = NIL; + (*R).eot = 1; + } + if ((*R).off == u->len) { + (*R).org += u->len; + u = u->next; + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + } else __WITHCHK; + } + (*R).run = u; + (*R).off = 0; + } +} + +void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL, un = NIL; + u = (*R).run; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org += u->len; + u = u->next; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + un = u->next; + (*R).run = un; + (*R).org += 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + if (__ISP(un, Texts_PieceDesc, 1)) { + if (__ISP(un, Texts_PieceDesc, 1)) { + Files_Set(&(*R).rider, Files_Rider__typ, (*(Texts_Piece*)&un)->file, (*(Texts_Piece*)&un)->org); + } else __WITHCHK; + } + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ) +{ + Texts_Run u = NIL; + u = (*R).run->prev; + while (__ISP(u, Texts_PieceDesc, 1)) { + (*R).org -= u->len; + u = u->prev; + } + if (__ISP(u, Texts_ElemDesc, 1)) { + (*R).run = u; + (*R).org -= 1; + (*R).off = 0; + (*R).fnt = u->fnt; + (*R).col = u->col; + (*R).voff = u->voff; + (*R).elem = __GUARDP(u, Texts_ElemDesc, 1); + } else { + (*R).eot = 1; + (*R).elem = NIL; + } +} + +INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ) +{ + return (*R).org + (*R).off; +} + +void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos) +{ + Texts_OpenReader((void*)&*S, S__typ, T, pos); + (*S).line = 0; + (*S).nextCh = ' '; +} + +static struct Scan__31 { + Texts_Scanner *S; + ADDRESS *S__typ; + CHAR *ch; + BOOLEAN *negE; + INT16 *e; + struct Scan__31 *lnk; +} *Scan__31_s; + +static void ReadScaleFactor__32 (void); + +static void ReadScaleFactor__32 (void) +{ + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + if (*Scan__31_s->ch == '-') { + *Scan__31_s->negE = 1; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } else { + *Scan__31_s->negE = 0; + if (*Scan__31_s->ch == '+') { + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } + } + while (('0' <= *Scan__31_s->ch && *Scan__31_s->ch <= '9')) { + *Scan__31_s->e = (*Scan__31_s->e * 10 + (INT16)*Scan__31_s->ch) - 48; + Texts_Read((void*)&*Scan__31_s->S, Scan__31_s->S__typ, &*Scan__31_s->ch); + } +} + +void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ) +{ + CHAR ch, term; + BOOLEAN neg, negE, hex; + INT8 i, j, h; + INT16 e; + INT32 k; + REAL x, f; + LONGREAL y, g; + CHAR d[32]; + struct Scan__31 _s; + _s.S = S; _s.S__typ = S__typ; + _s.ch = &ch; + _s.negE = &negE; + _s.e = &e; + _s.lnk = Scan__31_s; + Scan__31_s = &_s; + ch = (*S).nextCh; + i = 0; + for (;;) { + if (ch == 0x0d) { + (*S).line += 1; + } else if ((ch != ' ' && ch != 0x09)) { + break; + } + Texts_Read((void*)&*S, S__typ, &ch); + } + if ((('A' <= __CAP(ch) && __CAP(ch) <= 'Z') || ch == '/') || ch == '.') { + do { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } while (!((((__CAP(ch) > 'Z' && ch != '_') || ('A' > __CAP(ch) && ch > '9')) || ((('0' > ch && ch != '.')) && ch != '/')) || i == 63)); + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i; + (*S).class = 1; + } else if (ch == '"') { + Texts_Read((void*)&*S, S__typ, &ch); + while ((((ch != '"' && ch >= ' ')) && i != 63)) { + (*S).s[__X(i, 64)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + (*S).s[__X(i, 64)] = 0x00; + (*S).len = i + 1; + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 2; + } else { + if (ch == '-') { + neg = 1; + Texts_Read((void*)&*S, S__typ, &ch); + } else { + neg = 0; + } + if (('0' <= ch && ch <= '9')) { + hex = 0; + j = 0; + for (;;) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + if (ch < '0') { + break; + } + if ('9' < ch) { + if (('A' <= ch && ch <= 'F')) { + hex = 1; + ch = __CHR((INT16)ch - 7); + } else if (('a' <= ch && ch <= 'f')) { + hex = 1; + ch = __CHR((INT16)ch - 39); + } else { + break; + } + } + } + if (ch == 'H') { + Texts_Read((void*)&*S, S__typ, &ch); + (*S).class = 3; + if (i - j > 8) { + j = i - 8; + } + k = (INT16)d[__X(j, 32)] - 48; + j += 1; + if ((i - j == 7 && k >= 8)) { + k -= 16; + } + while (j < i) { + k = __ASHL(k, 4) + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + } else if (ch == '.') { + Texts_Read((void*)&*S, S__typ, &ch); + h = i; + while (('0' <= ch && ch <= '9')) { + d[__X(i, 32)] = ch; + i += 1; + Texts_Read((void*)&*S, S__typ, &ch); + } + if (ch == 'D') { + e = 0; + y = (LONGREAL)0; + g = (LONGREAL)1; + do { + y = y * (LONGREAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + g = g / (LONGREAL)(LONGREAL)10; + y = ((INT16)d[__X(j, 32)] - 48) * g + y; + j += 1; + } + ReadScaleFactor__32(); + if (negE) { + if (e <= 308) { + y = y / (LONGREAL)Reals_TenL(e); + } else { + y = (LONGREAL)0; + } + } else if (e > 0) { + if (e <= 308) { + y = Reals_TenL(e) * y; + } else { + __HALT(40); + } + } + if (neg) { + y = -y; + } + (*S).class = 5; + (*S).y = y; + } else { + e = 0; + x = (REAL)0; + f = (REAL)1; + do { + x = x * (REAL)10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == h)); + while (j < i) { + f = f / (REAL)(REAL)10; + x = ((INT16)d[__X(j, 32)] - 48) * f + x; + j += 1; + } + if (ch == 'E') { + ReadScaleFactor__32(); + } + if (negE) { + if (e <= 38) { + x = x / (REAL)Reals_Ten(e); + } else { + x = (REAL)0; + } + } else if (e > 0) { + if (e <= 38) { + x = Reals_Ten(e) * x; + } else { + __HALT(40); + } + } + if (neg) { + x = -x; + } + (*S).class = 4; + (*S).x = x; + } + if (hex) { + (*S).class = 0; + } + } else { + (*S).class = 3; + k = 0; + do { + k = k * 10 + ((INT16)d[__X(j, 32)] - 48); + j += 1; + } while (!(j == i)); + if (neg) { + (*S).i = -k; + } else { + (*S).i = k; + } + if (hex) { + (*S).class = 0; + } else { + (*S).class = 3; + } + } + } else { + (*S).class = 6; + if (neg) { + (*S).c = '-'; + } else { + (*S).c = ch; + Texts_Read((void*)&*S, S__typ, &ch); + } + } + } + (*S).nextCh = ch; + Scan__31_s = _s.lnk; +} + +void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ) +{ + __NEW((*W).buf, Texts_BufDesc); + Texts_OpenBuf((*W).buf); + (*W).fnt = Texts_FontsDefault; + (*W).col = 15; + (*W).voff = 0; + (*W).file = Files_New((CHAR*)"", 1); + Files_Set(&(*W).rider, Files_Rider__typ, (*W).file, 0); +} + +void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt) +{ + (*W).fnt = fnt; +} + +void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col) +{ + (*W).col = col; +} + +void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff) +{ + (*W).voff = voff; +} + +void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Files_Write(&(*W).rider, Files_Rider__typ, ch); + (*W).buf->len += 1; + un = (*W).buf->head; + u = un->prev; + if ((((((((((__ISP(u, Texts_PieceDesc, 1) && __GUARDP(u, Texts_PieceDesc, 1)->file == (*W).file)) && __STRCMP(u->fnt->name, (*W).fnt->name) == 0)) && u->col == (*W).col)) && u->voff == (*W).voff)) && !__GUARDP(u, Texts_PieceDesc, 1)->ascii)) { + u->len += 1; + } else { + __NEW(p, Texts_PieceDesc); + u->next = (Texts_Run)p; + p->prev = u; + p->next = un; + un->prev = (Texts_Run)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 = 0; + } +} + +void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e) +{ + Texts_Run u = NIL, un = NIL; + if (e->base != NIL) { + __HALT(99); + } + (*W).buf->len += 1; + e->len = 1; + e->fnt = (*W).fnt; + e->col = (*W).col; + e->voff = (*W).voff; + un = (*W).buf->head; + u = un->prev; + u->next = (Texts_Run)e; + e->prev = u; + e->next = un; + un->prev = (Texts_Run)e; +} + +void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ) +{ + Texts_Write(&*W, W__typ, 0x0d); +} + +void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len) +{ + INT16 i; + __DUP(s, s__len, CHAR); + i = 0; + while (s[__X(i, s__len)] >= ' ') { + Texts_Write(&*W, W__typ, s[__X(i, s__len)]); + i += 1; + } + __DEL(s); +} + +void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n) +{ + INT16 i; + INT64 x0; + CHAR a[24]; + i = 0; + if (x < 0) { + if (x == (-9223372036854775807LL-1)) { + Texts_WriteString(&*W, W__typ, (CHAR*)" -9223372036854775808", 22); + return; + } else { + n -= 1; + x0 = -x; + } + } else { + x0 = x; + } + do { + a[__X(i, 24)] = __CHR(__MOD(x0, 10) + 48); + x0 = __DIV(x0, 10); + i += 1; + } while (!(x0 == 0)); + while (n > (INT64)i) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + if (x < 0) { + Texts_Write(&*W, W__typ, '-'); + } + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 24)]); + } while (!(i == 0)); +} + +void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x) +{ + INT16 i; + INT32 y; + CHAR a[20]; + i = 0; + Texts_Write(&*W, W__typ, ' '); + do { + y = __MASK(x, -16); + if (y < 10) { + a[__X(i, 20)] = __CHR(y + 48); + } else { + a[__X(i, 20)] = __CHR(y + 55); + } + x = __ASHR(x, 4); + i += 1; + } while (!(i == 8)); + do { + i -= 1; + Texts_Write(&*W, W__typ, a[__X(i, 20)]); + } while (!(i == 0)); +} + +void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n) +{ + INT16 e; + REAL x0; + CHAR d[9]; + e = Reals_Expo(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 9) { + n = 3; + } else { + n -= 6; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 8)); + if (x < (REAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __ASHR((e - 127) * 77, 8); + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + x0 = Reals_Ten(n - 1); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + x = x * 1.0000000e-001; + e += 1; + } + Reals_Convert(x, n, (void*)d, 9); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 9)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'E'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +static struct WriteRealFix__53 { + Texts_Writer *W; + ADDRESS *W__typ; + INT16 *i; + CHAR (*d)[9]; + struct WriteRealFix__53 *lnk; +} *WriteRealFix__53_s; + +static void dig__54 (INT16 n); +static void seq__56 (CHAR ch, INT16 n); + +static void seq__56 (CHAR ch, INT16 n) +{ + while (n > 0) { + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, ch); + n -= 1; + } +} + +static void dig__54 (INT16 n) +{ + while (n > 0) { + *WriteRealFix__53_s->i -= 1; + Texts_Write(&*WriteRealFix__53_s->W, WriteRealFix__53_s->W__typ, (*WriteRealFix__53_s->d)[__X(*WriteRealFix__53_s->i, 9)]); + n -= 1; + } +} + +void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k) +{ + INT16 e, i; + CHAR sign; + REAL x0; + CHAR d[9]; + struct WriteRealFix__53 _s; + _s.W = W; _s.W__typ = W__typ; + _s.i = &i; + _s.d = (void*)d; + _s.lnk = WriteRealFix__53_s; + WriteRealFix__53_s = &_s; + e = Reals_Expo(x); + if (k < 0) { + k = 0; + } + if (e == 0) { + seq__56(' ', (n - k) - 2); + Texts_Write(&*W, W__typ, '0'); + seq__56(' ', k + 1); + } else if (e == 255) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + seq__56(' ', n - 4); + } else { + e = __ASHR((e - 127) * 77, 8); + if (x < (REAL)0) { + sign = '-'; + x = -x; + } else { + sign = ' '; + } + if (e >= 0) { + x = x / (REAL)Reals_Ten(e); + } else { + x = Reals_Ten(-e) * x; + } + if (x >= (REAL)10) { + x = 1.0000000e-001 * x; + e += 1; + } + if (k + e >= 8) { + k = 8 - e; + } else if (k + e < 0) { + k = -e; + x = (REAL)0; + } + x0 = Reals_Ten(k + e); + x = x0 * x + 5.0000000e-001; + if (x >= (REAL)10 * x0) { + e += 1; + } + e += 1; + i = k + e; + Reals_Convert(x, i, (void*)d, 9); + if (e > 0) { + seq__56(' ', ((n - e) - k) - 2); + Texts_Write(&*W, W__typ, sign); + dig__54(e); + Texts_Write(&*W, W__typ, '.'); + dig__54(k); + } else { + seq__56(' ', (n - k) - 3); + Texts_Write(&*W, W__typ, sign); + Texts_Write(&*W, W__typ, '0'); + Texts_Write(&*W, W__typ, '.'); + seq__56('0', -e); + dig__54(k + e); + } + } + WriteRealFix__53_s = _s.lnk; +} + +void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x) +{ + INT16 i; + CHAR d[8]; + Reals_ConvertH(x, (void*)d, 8); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 8)]); + i += 1; + } while (!(i == 8)); +} + +void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n) +{ + INT16 e; + LONGREAL x0; + CHAR d[16]; + e = Reals_ExpoL(x); + if (e == 0) { + Texts_WriteString(&*W, W__typ, (CHAR*)" 0", 4); + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 3)); + } else if (e == 2047) { + Texts_WriteString(&*W, W__typ, (CHAR*)" NaN", 5); + while (n > 4) { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } + } else { + if (n <= 10) { + n = 3; + } else { + n -= 7; + } + do { + Texts_Write(&*W, W__typ, ' '); + n -= 1; + } while (!(n <= 16)); + if (x < (LONGREAL)0) { + Texts_Write(&*W, W__typ, '-'); + x = -x; + } else { + Texts_Write(&*W, W__typ, ' '); + } + e = __SHORT(__ASHR((e - 1023) * 77, 8), 32768); + if (e >= 0) { + x = x / (LONGREAL)Reals_TenL(e); + } else { + x = Reals_TenL(-e) * x; + } + if (x >= (LONGREAL)10) { + x = 1.00000000000000e-001 * x; + e += 1; + } + x0 = Reals_TenL(n - 1); + x = x0 * x + 5.00000000000000e-001; + if (x >= (LONGREAL)10 * x0) { + x = 1.00000000000000e-001 * x; + e += 1; + } + Reals_ConvertL(x, n, (void*)d, 16); + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + Texts_Write(&*W, W__typ, '.'); + do { + n -= 1; + Texts_Write(&*W, W__typ, d[__X(n, 16)]); + } while (!(n == 0)); + Texts_Write(&*W, W__typ, 'D'); + if (e < 0) { + Texts_Write(&*W, W__typ, '-'); + e = -e; + } else { + Texts_Write(&*W, W__typ, '+'); + } + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 100) + 48)); + e = (int)__MOD(e, 100); + Texts_Write(&*W, W__typ, __CHR(__DIV(e, 10) + 48)); + Texts_Write(&*W, W__typ, __CHR((int)__MOD(e, 10) + 48)); + } +} + +void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x) +{ + INT16 i; + CHAR d[16]; + Reals_ConvertHL(x, (void*)d, 16); + i = 0; + do { + Texts_Write(&*W, W__typ, d[__X(i, 16)]); + i += 1; + } while (!(i == 16)); +} + +static struct WriteDate__43 { + Texts_Writer *W; + ADDRESS *W__typ; + struct WriteDate__43 *lnk; +} *WriteDate__43_s; + +static void WritePair__44 (CHAR ch, INT32 x); + +static void WritePair__44 (CHAR ch, INT32 x) +{ + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, ch); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR(__DIV(x, 10) + 48)); + Texts_Write(&*WriteDate__43_s->W, WriteDate__43_s->W__typ, __CHR((int)__MOD(x, 10) + 48)); +} + +void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d) +{ + struct WriteDate__43 _s; + _s.W = W; _s.W__typ = W__typ; + _s.lnk = WriteDate__43_s; + WriteDate__43_s = &_s; + WritePair__44(' ', __MASK(d, -32)); + WritePair__44('.', __MASK(__ASHR(d, 5), -16)); + WritePair__44('.', __MASK(__ASHR(d, 9), -128)); + WritePair__44(' ', __MASK(__ASHR(t, 12), -32)); + WritePair__44(':', __MASK(__ASHR(t, 6), -64)); + WritePair__44(':', __MASK(t, -64)); + WriteDate__43_s = _s.lnk; +} + +static struct Load0__16 { + Texts_Text *T; + INT8 *ecnt; + Files_File *f; + Texts_FileMsg *msg; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Load0__16 *lnk; +} *Load0__16_s; + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e); + +static void LoadElem__17 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, INT32 span, Texts_Elem *e) +{ + Heap_Module M = NIL; + Heap_Command Cmd; + Texts_Alien a = NIL; + INT32 org, ew, eh; + INT8 eno; + Texts_new = NIL; + Files_ReadLInt(&*r, r__typ, &ew); + Files_ReadLInt(&*r, r__typ, &eh); + Files_Read(&*r, r__typ, (void*)&eno); + if (eno > *Load0__16_s->ecnt) { + *Load0__16_s->ecnt = eno; + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->mods)[__X(eno, 64)], 32); + Files_ReadString(&*r, r__typ, (void*)(*Load0__16_s->procs)[__X(eno, 64)], 32); + } + org = Files_Pos(&*r, r__typ); + M = Modules_ThisMod((*Load0__16_s->mods)[__X(eno, 64)], 32); + if (M != NIL) { + Cmd = Modules_ThisCommand(M, (*Load0__16_s->procs)[__X(eno, 64)], 32); + if (Cmd != NIL) { + (*Cmd)(); + } + } + *e = Texts_new; + if (*e != NIL) { + (*e)->W = ew; + (*e)->H = eh; + (*e)->base = *Load0__16_s->T; + (*Load0__16_s->msg).pos = pos; + (*(*e)->handle)(*e, (void*)&*Load0__16_s->msg, Texts_FileMsg__typ); + if (Files_Pos(&*r, r__typ) != org + span) { + *e = NIL; + } + } + if (*e == NIL) { + Files_Set(&*r, r__typ, *Load0__16_s->f, org + span); + __NEW(a, Texts__1); + a->W = ew; + a->H = eh; + a->handle = Texts_HandleAlien; + a->base = *Load0__16_s->T; + a->file = *Load0__16_s->f; + a->org = org; + a->span = span; + __COPY((*Load0__16_s->mods)[__X(eno, 64)], a->mod, 32); + __COPY((*Load0__16_s->procs)[__X(eno, 64)], a->proc, 32); + *e = (Texts_Elem)a; + } +} + +static void Texts_Load0 (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Texts_Run u = NIL, un = NIL; + Texts_Piece p = NIL; + Texts_Elem e = NIL; + INT32 org, pos, hlen, plen; + INT8 ecnt, fcnt, fno, col, voff; + Files_File f = NIL; + Texts_FileMsg msg; + CHAR mods[64][32], procs[64][32]; + CHAR name[32]; + Texts_FontsFont fnts[32]; + struct Load0__16 _s; + _s.T = &T; + _s.ecnt = &ecnt; + _s.f = &f; + _s.msg = &msg; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Load0__16_s; + Load0__16_s = &_s; + pos = Files_Pos(&*r, r__typ); + f = Files_Base(&*r, r__typ); + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + T->head = u; + ecnt = 0; + fcnt = 0; + msg.id = 0; + msg.r = *r; + Files_ReadLInt(&msg.r, Files_Rider__typ, &hlen); + org = (pos - 2) + hlen; + pos = org; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + while (fno != 0) { + if (fno > fcnt) { + fcnt = fno; + Files_ReadString(&msg.r, Files_Rider__typ, (void*)name, 32); + fnts[__X(fno, 32)] = Texts_FontsThis((void*)name, 32); + } + Files_Read(&msg.r, Files_Rider__typ, (void*)&col); + Files_Read(&msg.r, Files_Rider__typ, (void*)&voff); + Files_ReadLInt(&msg.r, Files_Rider__typ, &plen); + if (plen > 0) { + __NEW(p, Texts_PieceDesc); + p->file = f; + p->org = pos; + p->ascii = 0; + un = (Texts_Run)p; + un->len = plen; + } else { + LoadElem__17(&msg.r, Files_Rider__typ, pos - org, -plen, &e); + un = (Texts_Run)e; + un->len = 1; + } + un->col = col; + un->voff = voff; + pos += un->len; + u->next = un; + un->prev = u; + u = un; + Files_Read(&msg.r, Files_Rider__typ, (void*)&fno); + } + u->next = T->head; + T->head->prev = u; + T->cache = T->head; + T->corg = 0; + Files_ReadLInt(&msg.r, Files_Rider__typ, &T->len); + Files_Set(&*r, r__typ, f, Files_Pos(&msg.r, Files_Rider__typ) + T->len); + Load0__16_s = _s.lnk; +} + +void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + INT16 tag; + Files_ReadInt(&*r, r__typ, &tag); + if (tag != -4095) { + Files_Set(&*r, r__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ) - 2); + } + Texts_Load0(&*r, r__typ, T); +} + +void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + Texts_Run u = NIL; + Texts_Piece p = NIL; + CHAR tag, version; + INT32 hlen; + __DUP(name, name__len, CHAR); + f = Files_Old(name, name__len); + if (f == NIL) { + f = Files_New((CHAR*)"", 1); + } + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Read(&r, Files_Rider__typ, (void*)&tag); + Files_Read(&r, Files_Rider__typ, (void*)&version); + if (tag == 0xf0 || (tag == 0x01 && version == 0xf0)) { + Texts_Load0(&r, Files_Rider__typ, T); + } else { + __NEW(u, Texts_RunDesc); + u->len = 2147483647; + u->fnt = NIL; + u->col = 15; + __NEW(p, Texts_PieceDesc); + if ((tag == 0xf7 && version == 0x07)) { + Files_Set(&r, Files_Rider__typ, f, 28); + Files_ReadLInt(&r, Files_Rider__typ, &hlen); + Files_Set(&r, Files_Rider__typ, f, 22 + hlen); + Files_ReadLInt(&r, Files_Rider__typ, &T->len); + p->org = 26 + hlen; + } else { + T->len = Files_Length(f); + p->org = 0; + } + if (T->len > 0) { + p->len = T->len; + p->fnt = Texts_FontsDefault; + p->col = 15; + p->voff = 0; + p->file = f; + p->ascii = 1; + u->next = (Texts_Run)p; + u->prev = (Texts_Run)p; + p->next = u; + p->prev = u; + } else { + u->next = u; + u->prev = u; + } + T->head = u; + T->cache = T->head; + T->corg = 0; + } + __DEL(name); +} + +static struct Store__39 { + INT8 *ecnt; + Texts_FileMsg *msg; + Texts_IdentifyMsg *iden; + CHAR (*mods)[64][32], (*procs)[64][32]; + struct Store__39 *lnk; +} *Store__39_s; + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e); + +static void StoreElem__40 (Files_Rider *r, ADDRESS *r__typ, INT32 pos, Texts_Elem e) +{ + Files_Rider r1; + INT32 org, span; + INT8 eno; + __COPY((*Store__39_s->iden).mod, (*Store__39_s->mods)[__X(*Store__39_s->ecnt, 64)], 32); + __COPY((*Store__39_s->iden).proc, (*Store__39_s->procs)[__X(*Store__39_s->ecnt, 64)], 32); + eno = 1; + while (__STRCMP((*Store__39_s->mods)[__X(eno, 64)], (*Store__39_s->iden).mod) != 0 || __STRCMP((*Store__39_s->procs)[__X(eno, 64)], (*Store__39_s->iden).proc) != 0) { + eno += 1; + } + Files_Set(&r1, Files_Rider__typ, Files_Base(&*r, r__typ), Files_Pos(&*r, r__typ)); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_WriteLInt(&*r, r__typ, 0); + Files_Write(&*r, r__typ, eno); + if (eno == *Store__39_s->ecnt) { + *Store__39_s->ecnt += 1; + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).mod, 32); + Files_WriteString(&*r, r__typ, (*Store__39_s->iden).proc, 32); + } + (*Store__39_s->msg).pos = pos; + org = Files_Pos(&*r, r__typ); + (*e->handle)(e, (void*)&*Store__39_s->msg, Texts_FileMsg__typ); + span = Files_Pos(&*r, r__typ) - org; + Files_WriteLInt(&r1, Files_Rider__typ, -span); + Files_WriteLInt(&r1, Files_Rider__typ, e->W); + Files_WriteLInt(&r1, Files_Rider__typ, e->H); +} + +void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T) +{ + Files_Rider r1; + Texts_Run u = NIL, un = NIL; + Texts_Elem e = NIL; + INT32 org, pos, delta, hlen, rlen; + INT8 ecnt, fcnt; + CHAR ch; + INT8 fno; + Texts_FileMsg msg; + Texts_IdentifyMsg iden; + CHAR mods[64][32], procs[64][32]; + Texts_FontsFont fnts[32]; + CHAR block[1024]; + struct Store__39 _s; + _s.ecnt = &ecnt; + _s.msg = &msg; + _s.iden = &iden; + _s.mods = (void*)mods; + _s.procs = (void*)procs; + _s.lnk = Store__39_s; + Store__39_s = &_s; + org = Files_Pos(&*r, r__typ); + msg.id = 1; + msg.r = *r; + Files_WriteLInt(&msg.r, Files_Rider__typ, 0); + u = T->head->next; + pos = 0; + delta = 0; + fcnt = 1; + ecnt = 1; + while (u != T->head) { + if (__ISP(u, Texts_ElemDesc, 1)) { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + } else { + iden.mod[0] = 0x01; + } + if (iden.mod[0] != 0x00) { + fnts[__X(fcnt, 32)] = u->fnt; + fno = 1; + while (__STRCMP(fnts[__X(fno, 32)]->name, u->fnt->name) != 0) { + fno += 1; + } + Files_Write(&msg.r, Files_Rider__typ, fno); + if (fno == fcnt) { + fcnt += 1; + Files_WriteString(&msg.r, Files_Rider__typ, u->fnt->name, 32); + } + Files_Write(&msg.r, Files_Rider__typ, u->col); + Files_Write(&msg.r, Files_Rider__typ, u->voff); + } + if (__ISP(u, Texts_PieceDesc, 1)) { + rlen = u->len; + un = u->next; + while ((((((__ISP(un, Texts_PieceDesc, 1) && un->fnt == u->fnt)) && un->col == u->col)) && un->voff == u->voff)) { + rlen += un->len; + un = un->next; + } + Files_WriteLInt(&msg.r, Files_Rider__typ, rlen); + pos += rlen; + u = un; + } else if (iden.mod[0] != 0x00) { + StoreElem__40(&msg.r, Files_Rider__typ, pos, __GUARDP(u, Texts_ElemDesc, 1)); + pos += 1; + u = u->next; + } else { + delta += 1; + u = u->next; + } + } + Files_Write(&msg.r, Files_Rider__typ, 0); + Files_WriteLInt(&msg.r, Files_Rider__typ, T->len - delta); + hlen = (Files_Pos(&msg.r, Files_Rider__typ) - org) + 2; + Files_Set(&r1, Files_Rider__typ, Files_Base(&msg.r, Files_Rider__typ), org); + Files_WriteLInt(&r1, Files_Rider__typ, hlen); + u = T->head->next; + while (u != T->head) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if (__ISP(u, Texts_PieceDesc, 1)) { + if ((*(Texts_Piece*)&u)->ascii) { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 0) { + Files_Read(&r1, Files_Rider__typ, (void*)&ch); + delta -= 1; + if (ch == 0x0a) { + Files_Write(&msg.r, Files_Rider__typ, 0x0d); + } else { + Files_Write(&msg.r, Files_Rider__typ, ch); + } + } + } else { + Files_Set(&r1, Files_Rider__typ, (*(Texts_Piece*)&u)->file, (*(Texts_Piece*)&u)->org); + delta = (*(Texts_Piece*)&u)->len; + while (delta > 1024) { + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, 1024); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, 1024); + delta -= 1024; + } + Files_ReadBytes(&r1, Files_Rider__typ, (void*)block, 1024, delta); + Files_WriteBytes(&msg.r, Files_Rider__typ, (void*)block, 1024, delta); + } + } else __WITHCHK; + } else { + iden.mod[0] = 0x00; + (*__GUARDP(u, Texts_ElemDesc, 1)->handle)(__GUARDP(u, Texts_ElemDesc, 1), (void*)&iden, Texts_IdentifyMsg__typ); + if (iden.mod[0] != 0x00) { + Files_Write(&msg.r, Files_Rider__typ, 0x1c); + } + } + u = u->next; + } + __GUARDEQR(r, r__typ, Files_Rider) = msg.r; + if (T->notify != NIL) { + (*T->notify)(T, 3, 0, 0); + } + Store__39_s = _s.lnk; +} + +void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len) +{ + Files_File f = NIL; + Files_Rider r; + INT16 i, res; + CHAR bak[64]; + __DUP(name, name__len, CHAR); + f = Files_New(name, name__len); + Files_Set(&r, Files_Rider__typ, f, 0); + Files_Write(&r, Files_Rider__typ, 0xf0); + Files_Write(&r, Files_Rider__typ, 0x01); + Texts_Store(&r, Files_Rider__typ, T); + i = 0; + while (name[__X(i, name__len)] != 0x00) { + i += 1; + } + __COPY(name, bak, 64); + bak[__X(i, 64)] = '.'; + bak[__X(i + 1, 64)] = 'B'; + bak[__X(i + 2, 64)] = 'a'; + bak[__X(i + 3, 64)] = 'k'; + bak[__X(i + 4, 64)] = 0x00; + Files_Rename(name, name__len, bak, 64, &res); + Files_Register(f); + __DEL(name); +} + +static void EnumPtrs(void (*P)(void*)) +{ + P(Texts_new); + P(Texts_del); + P(Texts_FontsDefault); +} + +__TDESC(Texts_FontDesc, 1, 0) = {__TDFLDS("FontDesc", 32), {-8}}; +__TDESC(Texts_RunDesc, 1, 3) = {__TDFLDS("RunDesc", 40), {0, 8, 24, -32}}; +__TDESC(Texts_PieceDesc, 1, 4) = {__TDFLDS("PieceDesc", 56), {0, 8, 24, 40, -40}}; +__TDESC(Texts_ElemMsg, 1, 0) = {__TDFLDS("ElemMsg", 1), {-8}}; +__TDESC(Texts_ElemDesc, 1, 4) = {__TDFLDS("ElemDesc", 64), {0, 8, 24, 56, -40}}; +__TDESC(Texts_FileMsg, 1, 1) = {__TDFLDS("FileMsg", 32), {16, -16}}; +__TDESC(Texts_CopyMsg, 1, 1) = {__TDFLDS("CopyMsg", 8), {0, -16}}; +__TDESC(Texts_IdentifyMsg, 1, 0) = {__TDFLDS("IdentifyMsg", 64), {-8}}; +__TDESC(Texts_BufDesc, 1, 1) = {__TDFLDS("BufDesc", 16), {8, -16}}; +__TDESC(Texts_TextDesc, 1, 2) = {__TDFLDS("TextDesc", 40), {16, 24, -24}}; +__TDESC(Texts_Reader, 1, 4) = {__TDFLDS("Reader", 72), {8, 24, 40, 56, -40}}; +__TDESC(Texts_Scanner, 1, 4) = {__TDFLDS("Scanner", 168), {8, 24, 40, 56, -40}}; +__TDESC(Texts_Writer, 1, 4) = {__TDFLDS("Writer", 56), {0, 8, 32, 48, -40}}; +__TDESC(Texts__1, 1, 5) = {__TDFLDS("", 144), {0, 8, 24, 56, 64, -48}}; + +export void *Texts__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Files); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(Reals); + __REGMOD("Texts", EnumPtrs); + __INITYP(Texts_FontDesc, Texts_FontDesc, 0); + __INITYP(Texts_RunDesc, Texts_RunDesc, 0); + __INITYP(Texts_PieceDesc, Texts_RunDesc, 1); + __INITYP(Texts_ElemMsg, Texts_ElemMsg, 0); + __INITYP(Texts_ElemDesc, Texts_RunDesc, 1); + __INITYP(Texts_FileMsg, Texts_ElemMsg, 1); + __INITYP(Texts_CopyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_IdentifyMsg, Texts_ElemMsg, 1); + __INITYP(Texts_BufDesc, Texts_BufDesc, 0); + __INITYP(Texts_TextDesc, Texts_TextDesc, 0); + __INITYP(Texts_Reader, Texts_Reader, 0); + __INITYP(Texts_Scanner, Texts_Reader, 1); + __INITYP(Texts_Writer, Texts_Writer, 0); + __INITYP(Texts__1, Texts_ElemDesc, 2); +/* BEGIN */ + Texts_del = NIL; + __NEW(Texts_FontsDefault, Texts_FontDesc); + __MOVE("Syntax10.Scn.Fnt", Texts_FontsDefault->name, 17); + __ENDMOD; +} diff --git a/bootstrap/windows-88/Texts.h b/bootstrap/windows-88/Texts.h new file mode 100644 index 00000000..081eec2c --- /dev/null +++ b/bootstrap/windows-88/Texts.h @@ -0,0 +1,173 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef Texts__h +#define Texts__h + +#include "SYSTEM.h" +#include "Files.h" + +typedef + struct Texts_BufDesc { + INT32 len; + INT64 _prvt0; + } Texts_BufDesc; + +typedef + Texts_BufDesc *Texts_Buffer; + +typedef + struct Texts_ElemMsg { + char _prvt0[1]; + } Texts_ElemMsg; + +typedef + struct Texts_ElemDesc *Texts_Elem; + +typedef + struct Texts_CopyMsg { /* Texts_ElemMsg */ + Texts_Elem e; + } Texts_CopyMsg; + +typedef + struct Texts_RunDesc { + INT64 _prvt0; + char _prvt1[27]; + } Texts_RunDesc; + +typedef + void (*Texts_Handler)(Texts_Elem, Texts_ElemMsg*, ADDRESS *); + +typedef + struct Texts_ElemDesc { + INT64 _prvt0; + char _prvt1[28]; + INT32 W, H; + Texts_Handler handle; + char _prvt2[8]; + } Texts_ElemDesc; + +typedef + struct Texts_FileMsg { /* Texts_ElemMsg */ + INT16 id; + INT32 pos; + Files_Rider r; + } Texts_FileMsg; + +typedef + struct Texts_FontDesc { + char _prvt0[32]; + } Texts_FontDesc; + +typedef + Texts_FontDesc *Texts_FontsFont; + +typedef + struct Texts_IdentifyMsg { /* Texts_ElemMsg */ + CHAR mod[32], proc[32]; + } Texts_IdentifyMsg; + +typedef + struct Texts_TextDesc *Texts_Text; + +typedef + void (*Texts_Notifier)(Texts_Text, INT16, INT32, INT32); + +typedef + struct Texts_Reader { + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[40]; + } Texts_Reader; + +typedef + struct Texts_Scanner { /* Texts_Reader */ + BOOLEAN eot; + Texts_FontsFont fnt; + INT8 col, voff; + Texts_Elem elem; + char _prvt0[40]; + CHAR nextCh; + INT16 line, class; + INT32 i; + REAL x; + LONGREAL y; + CHAR c; + INT8 len; + CHAR s[64]; + } Texts_Scanner; + +typedef + struct Texts_TextDesc { + INT32 len; + Texts_Notifier notify; + char _prvt0[20]; + } Texts_TextDesc; + +typedef + struct Texts_Writer { + Texts_Buffer buf; + Texts_FontsFont fnt; + INT8 col, voff; + char _prvt0[38]; + } Texts_Writer; + + +import Texts_Elem Texts_new; + +import ADDRESS *Texts_FontDesc__typ; +import ADDRESS *Texts_RunDesc__typ; +import ADDRESS *Texts_ElemMsg__typ; +import ADDRESS *Texts_ElemDesc__typ; +import ADDRESS *Texts_FileMsg__typ; +import ADDRESS *Texts_CopyMsg__typ; +import ADDRESS *Texts_IdentifyMsg__typ; +import ADDRESS *Texts_BufDesc__typ; +import ADDRESS *Texts_TextDesc__typ; +import ADDRESS *Texts_Reader__typ; +import ADDRESS *Texts_Scanner__typ; +import ADDRESS *Texts_Writer__typ; + +import void Texts_Append (Texts_Text T, Texts_Buffer B); +import void Texts_ChangeLooks (Texts_Text T, INT32 beg, INT32 end, UINT32 sel, Texts_FontsFont fnt, INT8 col, INT8 voff); +import void Texts_Close (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_Copy (Texts_Buffer SB, Texts_Buffer DB); +import void Texts_CopyElem (Texts_Elem SE, Texts_Elem DE); +import void Texts_Delete (Texts_Text T, INT32 beg, INT32 end); +import Texts_Text Texts_ElemBase (Texts_Elem E); +import INT32 Texts_ElemPos (Texts_Elem E); +import void Texts_Insert (Texts_Text T, INT32 pos, Texts_Buffer B); +import void Texts_Load (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Open (Texts_Text T, CHAR *name, ADDRESS name__len); +import void Texts_OpenBuf (Texts_Buffer B); +import void Texts_OpenReader (Texts_Reader *R, ADDRESS *R__typ, Texts_Text T, INT32 pos); +import void Texts_OpenScanner (Texts_Scanner *S, ADDRESS *S__typ, Texts_Text T, INT32 pos); +import void Texts_OpenWriter (Texts_Writer *W, ADDRESS *W__typ); +import INT32 Texts_Pos (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Read (Texts_Reader *R, ADDRESS *R__typ, CHAR *ch); +import void Texts_ReadElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_ReadPrevElem (Texts_Reader *R, ADDRESS *R__typ); +import void Texts_Recall (Texts_Buffer *B); +import void Texts_Save (Texts_Text T, INT32 beg, INT32 end, Texts_Buffer B); +import void Texts_Scan (Texts_Scanner *S, ADDRESS *S__typ); +import void Texts_SetColor (Texts_Writer *W, ADDRESS *W__typ, INT8 col); +import void Texts_SetFont (Texts_Writer *W, ADDRESS *W__typ, Texts_FontsFont fnt); +import void Texts_SetOffset (Texts_Writer *W, ADDRESS *W__typ, INT8 voff); +import void Texts_Store (Files_Rider *r, ADDRESS *r__typ, Texts_Text T); +import void Texts_Write (Texts_Writer *W, ADDRESS *W__typ, CHAR ch); +import void Texts_WriteDate (Texts_Writer *W, ADDRESS *W__typ, INT32 t, INT32 d); +import void Texts_WriteElem (Texts_Writer *W, ADDRESS *W__typ, Texts_Elem e); +import void Texts_WriteHex (Texts_Writer *W, ADDRESS *W__typ, INT32 x); +import void Texts_WriteInt (Texts_Writer *W, ADDRESS *W__typ, INT64 x, INT64 n); +import void Texts_WriteLn (Texts_Writer *W, ADDRESS *W__typ); +import void Texts_WriteLongReal (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x, INT16 n); +import void Texts_WriteLongRealHex (Texts_Writer *W, ADDRESS *W__typ, LONGREAL x); +import void Texts_WriteReal (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n); +import void Texts_WriteRealFix (Texts_Writer *W, ADDRESS *W__typ, REAL x, INT16 n, INT16 k); +import void Texts_WriteRealHex (Texts_Writer *W, ADDRESS *W__typ, REAL x); +import void Texts_WriteString (Texts_Writer *W, ADDRESS *W__typ, CHAR *s, ADDRESS s__len); +import void *Texts__init(void); + + +#endif // Texts diff --git a/bootstrap/windows-88/VT100.c b/bootstrap/windows-88/VT100.c new file mode 100644 index 00000000..346fb37b --- /dev/null +++ b/bootstrap/windows-88/VT100.c @@ -0,0 +1,275 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Out.h" +#include "Strings.h" + + +export CHAR VT100_CSI[5]; +static CHAR VT100_tmpstr[32]; + + +export void VT100_CHA (INT16 n); +export void VT100_CNL (INT16 n); +export void VT100_CPL (INT16 n); +export void VT100_CUB (INT16 n); +export void VT100_CUD (INT16 n); +export void VT100_CUF (INT16 n); +export void VT100_CUP (INT16 n, INT16 m); +export void VT100_CUU (INT16 n); +export void VT100_DECTCEMh (void); +export void VT100_DECTCEMl (void); +export void VT100_DSR (INT16 n); +export void VT100_ED (INT16 n); +export void VT100_EL (INT16 n); +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len); +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len); +export void VT100_HVP (INT16 n, INT16 m); +export void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +export void VT100_RCP (void); +export void VT100_Reset (void); +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end); +export void VT100_SCP (void); +export void VT100_SD (INT16 n); +export void VT100_SGR (INT16 n); +export void VT100_SGR2 (INT16 n, INT16 m); +export void VT100_SU (INT16 n); +export void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); + + +static void VT100_Reverse0 (CHAR *str, ADDRESS str__len, INT16 start, INT16 end) +{ + CHAR h; + while (start < end) { + h = str[__X(start, str__len)]; + str[__X(start, str__len)] = str[__X(end, str__len)]; + str[__X(end, str__len)] = h; + start += 1; + end -= 1; + } +} + +void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len) +{ + CHAR b[21]; + INT16 s, e; + INT8 maxLength; + maxLength = 11; + if (int_ == (-2147483647-1)) { + __MOVE("-2147483648", b, 12); + e = 11; + } else { + if (int_ < 0) { + b[0] = '-'; + int_ = -int_; + s = 1; + } else { + s = 0; + } + e = s; + do { + b[__X(e, 21)] = __CHR((int)__MOD(int_, 10) + 48); + int_ = __DIV(int_, 10); + e += 1; + } while (!(int_ == 0)); + b[__X(e, 21)] = 0x00; + VT100_Reverse0((void*)b, 21, s, e - 1); + } + __COPY(b, str, str__len); +} + +static void VT100_EscSeq0 (CHAR *letter, ADDRESS letter__len) +{ + CHAR cmd[9]; + __DUP(letter, letter__len, CHAR); + __COPY(VT100_CSI, cmd, 9); + Strings_Append(letter, letter__len, (void*)cmd, 9); + Out_String(cmd, 9); + __DEL(letter); +} + +static void VT100_EscSeq (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeqSwapped (INT16 n, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[2]; + CHAR cmd[7]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 2); + __COPY(VT100_CSI, cmd, 7); + Strings_Append(letter, letter__len, (void*)cmd, 7); + Strings_Append(nstr, 2, (void*)cmd, 7); + Out_String(cmd, 7); + __DEL(letter); +} + +static void VT100_EscSeq2 (INT16 n, INT16 m, CHAR *letter, ADDRESS letter__len) +{ + CHAR nstr[5], mstr[5]; + CHAR cmd[12]; + __DUP(letter, letter__len, CHAR); + VT100_IntToStr(n, (void*)nstr, 5); + VT100_IntToStr(m, (void*)mstr, 5); + __COPY(VT100_CSI, cmd, 12); + Strings_Append(nstr, 5, (void*)cmd, 12); + Strings_Append((CHAR*)";", 2, (void*)cmd, 12); + Strings_Append(mstr, 5, (void*)cmd, 12); + Strings_Append(letter, letter__len, (void*)cmd, 12); + Out_String(cmd, 12); + __DEL(letter); +} + +void VT100_Reset (void) +{ + CHAR cmd[6]; + __COPY("\033", cmd, 6); + Strings_Append((CHAR*)"c", 2, (void*)cmd, 6); + Out_String(cmd, 6); + Out_Ln(); +} + +void VT100_CUU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"A", 2); +} + +void VT100_CUD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"B", 2); +} + +void VT100_CUF (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"C", 2); +} + +void VT100_CUB (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"D", 2); +} + +void VT100_CNL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"E", 2); +} + +void VT100_CPL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"F", 2); +} + +void VT100_CHA (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"G", 2); +} + +void VT100_CUP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"H", 2); +} + +void VT100_ED (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"J", 2); +} + +void VT100_EL (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"K", 2); +} + +void VT100_SU (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"S", 2); +} + +void VT100_SD (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"T", 2); +} + +void VT100_HVP (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"f", 2); +} + +void VT100_SGR (INT16 n) +{ + VT100_EscSeq(n, (CHAR*)"m", 2); +} + +void VT100_SGR2 (INT16 n, INT16 m) +{ + VT100_EscSeq2(n, m, (CHAR*)"m", 2); +} + +void VT100_DSR (INT16 n) +{ + VT100_EscSeq(6, (CHAR*)"n", 2); +} + +void VT100_SCP (void) +{ + VT100_EscSeq0((CHAR*)"s", 2); +} + +void VT100_RCP (void) +{ + VT100_EscSeq0((CHAR*)"u", 2); +} + +void VT100_DECTCEMl (void) +{ + VT100_EscSeq0((CHAR*)"\?25l", 5); +} + +void VT100_DECTCEMh (void) +{ + VT100_EscSeq0((CHAR*)"\?25h", 5); +} + +void VT100_SetAttr (CHAR *attr, ADDRESS attr__len) +{ + CHAR tmpstr[16]; + __DUP(attr, attr__len, CHAR); + __COPY(VT100_CSI, tmpstr, 16); + Strings_Append(attr, attr__len, (void*)tmpstr, 16); + Out_String(tmpstr, 16); + __DEL(attr); +} + + +export void *VT100__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Strings); + __REGMOD("VT100", 0); + __REGCMD("DECTCEMh", VT100_DECTCEMh); + __REGCMD("DECTCEMl", VT100_DECTCEMl); + __REGCMD("RCP", VT100_RCP); + __REGCMD("Reset", VT100_Reset); + __REGCMD("SCP", VT100_SCP); +/* BEGIN */ + __COPY("\033", VT100_CSI, 5); + Strings_Append((CHAR*)"[", 2, (void*)VT100_CSI, 5); + __ENDMOD; +} diff --git a/bootstrap/windows-88/VT100.h b/bootstrap/windows-88/VT100.h new file mode 100644 index 00000000..4e708647 --- /dev/null +++ b/bootstrap/windows-88/VT100.h @@ -0,0 +1,38 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef VT100__h +#define VT100__h + +#include "SYSTEM.h" + + +import CHAR VT100_CSI[5]; + + +import void VT100_CHA (INT16 n); +import void VT100_CNL (INT16 n); +import void VT100_CPL (INT16 n); +import void VT100_CUB (INT16 n); +import void VT100_CUD (INT16 n); +import void VT100_CUF (INT16 n); +import void VT100_CUP (INT16 n, INT16 m); +import void VT100_CUU (INT16 n); +import void VT100_DECTCEMh (void); +import void VT100_DECTCEMl (void); +import void VT100_DSR (INT16 n); +import void VT100_ED (INT16 n); +import void VT100_EL (INT16 n); +import void VT100_HVP (INT16 n, INT16 m); +import void VT100_IntToStr (INT32 int_, CHAR *str, ADDRESS str__len); +import void VT100_RCP (void); +import void VT100_Reset (void); +import void VT100_SCP (void); +import void VT100_SD (INT16 n); +import void VT100_SGR (INT16 n); +import void VT100_SGR2 (INT16 n, INT16 m); +import void VT100_SU (INT16 n); +import void VT100_SetAttr (CHAR *attr, ADDRESS attr__len); +import void *VT100__init(void); + + +#endif // VT100 diff --git a/bootstrap/windows-88/extTools.c b/bootstrap/windows-88/extTools.c new file mode 100644 index 00000000..ce2fc413 --- /dev/null +++ b/bootstrap/windows-88/extTools.c @@ -0,0 +1,139 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#define SHORTINT INT8 +#define INTEGER INT16 +#define LONGINT INT32 +#define SET UINT32 + +#include "SYSTEM.h" +#include "Configuration.h" +#include "Heap.h" +#include "Modules.h" +#include "OPM.h" +#include "Out.h" +#include "Platform.h" +#include "Strings.h" + +typedef + CHAR extTools_CommandString[4096]; + + +static extTools_CommandString extTools_CFLAGS; + + +export void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len); +export void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len); + + +static void extTools_execute (CHAR *title, ADDRESS title__len, CHAR *cmd, ADDRESS cmd__len) +{ + INT16 r, status, exitcode; + extTools_CommandString fullcmd; + __DUP(title, title__len, CHAR); + __DUP(cmd, cmd__len, CHAR); + if (__IN(18, OPM_Options, 32)) { + Out_String((CHAR*)" ", 3); + Out_String(cmd, cmd__len); + Out_Ln(); + } + __COPY(cmd, fullcmd, 4096); + Heap_GC(0); + r = Platform_System(fullcmd, 4096); + status = __MASK(r, -128); + exitcode = __ASHR(r, 8); + if (exitcode > 127) { + exitcode = exitcode - 256; + } + if (r != 0) { + Out_String(title, title__len); + Out_String(cmd, cmd__len); + Out_Ln(); + Out_String((CHAR*)"-- failed: status ", 19); + Out_Int(status, 1); + Out_String((CHAR*)", exitcode ", 12); + Out_Int(exitcode, 1); + Out_String((CHAR*)".", 2); + Out_Ln(); + if ((status == 0 && exitcode == 127)) { + Out_String((CHAR*)"Is the C compiler in the current command path\?", 47); + Out_Ln(); + } + if (status != 0) { + Modules_Halt(status); + } else { + Modules_Halt(exitcode); + } + } + __DEL(title); + __DEL(cmd); +} + +static void extTools_InitialiseCompilerCommand (CHAR *s, ADDRESS s__len, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + __DUP(additionalopts, additionalopts__len, CHAR); + __COPY("gcc -fPIC -g -Wno-stringop-overflow", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Strings_Append(additionalopts, additionalopts__len, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 4096); + Strings_Append(extTools_CFLAGS, 4096, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); + __DEL(additionalopts); +} + +void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len) +{ + extTools_CommandString cmd; + __DUP(moduleName, moduleName__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, (CHAR*)"", 1); + Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c", 3, (void*)cmd, 4096); + extTools_execute((CHAR*)"C compile: ", 12, cmd, 4096); + __DEL(moduleName); +} + +void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len) +{ + extTools_CommandString cmd; + __DUP(additionalopts, additionalopts__len, CHAR); + extTools_InitialiseCompilerCommand((void*)cmd, 4096, additionalopts, additionalopts__len); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + Strings_Append((CHAR*)".c ", 4, (void*)cmd, 4096); + if (statically) { + Strings_Append((CHAR*)" -static", 9, (void*)cmd, 4096); + } + Strings_Append((CHAR*)" -o ", 5, (void*)cmd, 4096); + Strings_Append(moduleName, moduleName__len, (void*)cmd, 4096); + if (!statically || 1) { + Strings_Append((CHAR*)" -L\"", 5, (void*)cmd, 4096); + Strings_Append(OPM_InstallDir, 1024, (void*)cmd, 4096); + Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 4096); + Strings_Append((CHAR*)" -lvoc", 7, (void*)cmd, 4096); + Strings_Append((CHAR*)"-O", 3, (void*)cmd, 4096); + Strings_Append(OPM_Model, 10, (void*)cmd, 4096); + Strings_Append((CHAR*)"", 1, (void*)cmd, 4096); + } + extTools_execute((CHAR*)"C compile and link: ", 21, cmd, 4096); + __DEL(additionalopts); +} + + +export void *extTools__init(void) +{ + __DEFMOD; + __MODULE_IMPORT(Configuration); + __MODULE_IMPORT(Heap); + __MODULE_IMPORT(Modules); + __MODULE_IMPORT(OPM); + __MODULE_IMPORT(Out); + __MODULE_IMPORT(Platform); + __MODULE_IMPORT(Strings); + __REGMOD("extTools", 0); +/* BEGIN */ + __ENDMOD; +} diff --git a/bootstrap/windows-88/extTools.h b/bootstrap/windows-88/extTools.h new file mode 100644 index 00000000..686f0b4e --- /dev/null +++ b/bootstrap/windows-88/extTools.h @@ -0,0 +1,16 @@ +/* voc 2.1.0 [2025/06/24]. Bootstrapping compiler for address size 8, alignment 8. xrtspaSF */ + +#ifndef extTools__h +#define extTools__h + +#include "SYSTEM.h" + + + + +import void extTools_Assemble (CHAR *moduleName, ADDRESS moduleName__len); +import void extTools_LinkMain (CHAR *moduleName, ADDRESS moduleName__len, BOOLEAN statically, CHAR *additionalopts, ADDRESS additionalopts__len); +import void *extTools__init(void); + + +#endif // extTools diff --git a/doc/Compiling.md b/doc/Compiling.md new file mode 100644 index 00000000..ebb84ce9 --- /dev/null +++ b/doc/Compiling.md @@ -0,0 +1,84 @@ +## Compiling + +An Oberon command line program is built from one or more modules. One module must be designated a main module. + +### Files generated + +From each non-main module the following files are generated in the current directory: + +| Filename | Purpose | +| ---------- | --------------------------------------------------------------------- | +| ```module.sym``` | Oberon symbols required to ```IMPORT``` this module in another compilation.| +| ```module.c``` | C source code for compilation by gcc, clang or msc. | +| ```module.h``` | C header files required by C compiler when importing this module. | + +Note that the filename of the .sym, .c and .h files is the name of the module from the ```MODULE``` statement at the start of the source file. It is not the name of the .mod file. + +If the compilation is successful, the Oberon compiler will automatically invoke the C compiler. The compiler option ```-V``` will cause the compiler to display the C compiler command used. + +### Successful compilation report + +For a successful compilation, the compiler displays a single line comprising + + * The name of the file being compiled + * The name of the module from the ```MODULE``` statment + * Compiler configuration (only if the ```-V``` verbose option is selected) + * A possible symbol update status message + * The number of characters compiled + +If a symbols file already exists, the compiler will check whether the new compilation changes the symbols, and if so whether the change is just an extension, or a more serious compatability threatening modification. If there is a change the compiler displays either ```Extended symbol file``` or ```New symbol file```. + +For example: + +``` +$ voc test.mod +test.mod Compiling test. New symbol file. 364 chars. +``` + +### Symbol file changes + +By default the compiler will refuse to compile a module if its symbols are different from those in the .sym file present from a previous compilation. To allow the compiler to change the symbols, one of the following options must be used. + +| Compiler option | Use | +| :-------------: | --------------------------- | +| ```-e``` | Allow extension of symbols. Do not allow changes to existing symbols. | +| ```-s``` | Allow changes to and extensions of symbols. | +| ```-F``` | Force generation of new symbol file.* | + +\* A new symbol file may be forced to guarantee that a symbol file is generated for a module that has the same name as an installed library module. + +### Main module + +The main module should be the last module compiled as it imports all other modules. + +The program logic should be started from the main module's initialisation code. + +The following options designate the main module: + +| Compiler option | Use | +| :-------------: | --------------------------- | +| ```-m``` | Generate loadable binary using dynamic library loading (*see note*) | +| ```-M``` | Generate loadable binary with all library references statically linked (*see note*) | + +For a main module, no .sym or .h files are generated, and the C compiler is called with additional parameters to generate the execututable binary, linking the object files needed for imported modules. + +*Note:* not all systems support both static and dynamic linking: some support only static; some support only dynamic. When a system only supports one, ```-m``` and ```-M``` behave the same. + +### Separate compilation + +Each module may be compiled by a separate command line, although the imports of a module must be compiled before the module is compiled. All three generated files (.sym, .c and .h) must be retained at least until all modules dependent on this module have been compiled. + +Multiple modules may be compiled on a single compiler command line. + +Options on the command line that preceed all module file names will be used as global settings: each module will be compiled with these settings except as overriden on a per file basis. + +Options on the command line that follow a module file name are specific to that module. + +For example: + +``` + voc -s alpha.mod beta.mod main.mod -m +``` + +Will apply the ```-s``` option to all modules (allow changes to and extension of symbols), and will apply the ```-m``` option (main program) only to ```main.mod```. + diff --git a/doc/Features.md b/doc/Features.md new file mode 100644 index 00000000..ffcb4a93 --- /dev/null +++ b/doc/Features.md @@ -0,0 +1,177 @@ +## Features + +#### 32 bit and 64 bit systems vs integer, set and address size. + +The Oberon language specification sets explicit lower bounds on the maximum and minimum +values supported by SHORTINT, INTEGER and LONGINT, and the maximum number of items supported +by SET. + +Most Oberon systems implemented these lower bounds, however a few more recent systems allow +wider ranges of values. + +While it may seem safe to compile code developed on earlier systems with the newer, larger +integer and set types, it is not. Some examples: + + - Code that uses MIN(INTEGER), MAX(INTEGER) etc. as a flag values will run into problems if + it tries to store the flag value to a file using standard library functions. The Oakwood + guidelines specify that INTEGER be stored in 16 bits on file regardless of it's size in + memory*. + + - Code that assumes that INTEGER values wrap around at known values will fail. For example + i: SHORTINT; ... i := 127; INC(i); will produce -128 on original systems, but +128 on + systems with a larger SHORTINT representation. + + - Bit manipulation code that uses SYSTEM.VAL to access parts of values will access the + wrong number of bits. For example, the implementation of REAL and LONGREAL library functions + use SYSTEM.VAL(SET, realvalue) to access and change the sign, mantissa and exponent of REALs. + +Therefore we provide compilation options to select the representation of SHORTINT, INTEGER, LONGINT and SET. + +\* It makes sense for Oakwood to insist on fixed sizes for the standard types as this is a pre-requisite +for stable file exchange between different builds of applications, and between different applications following a standard file format. + + +#### Compiler options for integer and set sizes. + +The -O2 and -OC compiler options select between the two most commonly used integer and set +type implementations. + +| Type | -O2 option (default) | -OC option | +| --- | --- | --- | +| SHORTINT | 8 bit | 16 bit | +| INTEGER | 16 bit | 32 bit | +| LONGINT | 32 bit | 64 bit | +| SET | 32 bit | 64 bit | + + +The following Oberon types are independent of compiler size: + +| Types | Size | +| ----- | ------- | +| REAL | 32 bit floating point | +| LONGREAL | 64 bit floating point | +| HUGEINT* | 64 bit signed integer | +| BYTE** | 8 bit signed integer (-OC model only) | +| CHAR*** | 8 bit character | + +\* The additional type HUGEINT is predefined as a 64 bit integer, providing 64 bit support even +in -O2 compilations. + +\** The additional type BYTE is defined for -OC (Component Pascal) model only and is a *signed* +8 bit integer. + +\*** No built-in support is provided for the UTF-16 or UCS-2 Unicode encodings. UTF-8 is the recommended Unicode encoding for text. + - 16 bits has been insufficient for the Unicode character repetoire for at least 15 years. + - Writing systems often require more than one unicode codepoint to represent a single character (and what constitutes a character can vary according to context). + - UTF-8 is now widely used. + +See [UTF-8 Everywhere](http://utf8everywhere.org/) for much more background on this recommendation. + + +#### SYSTEM.Mod support for fixed size integers and sets. + +SYSTEM.Mod includes the following additional types: + +| Type | Size | Range | +| --- | --- | --- | +| SYSTEM.INT8 | 8 bit | -128 .. 127 | +| SYSTEM.INT16 | 16 bit | -32,768 .. 32,767 | +| SYSTEM.INT32 | 32 bit | -2,147,483,6478 .. ‭2,147,483,647‬ | +| SYSTEM.INT64 | 64 bit | -‭9,223,372,036,854,775,808 .. ‭9,223,372,036,854,775,807‬ | +| SYSTEM.SET32 | 32 bit | 0 .. 31 | +| SYSTEM.SET64 | 64 bit | 0 .. 63 | + +Integer literals are recognised within the full signed 64 bit integer range MIN(SYSTEM.INT64) to MAX(SYSTEM.INT64). Additionally the parsing of hex notation allows negative values to be entered as a full 16 hex digits with top bit set. For example, -1 may be represented in Oberon source as 0FFFFFFFFFFFFFFFFH. + + +#### The SHORT and LONG functions + +SHORT() of LONGINT and INTEGER values, and LONG() of SHORTINT and INTEGER values behave as +originally specified by Oberon-2. + +In -O2, where LONGINT is 32 bits, LONG() now accepts a LONGINT value returning a HUGEINT value. + +In -OC, where SHORTINT is 16 bits, SHORT() now accepts a SHORTINT value returning a SYSTEM.INT8 value. + +#### ASH() + +The Arithmetic shift function is defined by Oberon-2 as follows: + +| Name | Argument types | Result Type | Function | +| ---- | --- | --- | --- | +| ASH(*x*, *n*) | *x*, *n*: integer type | LONGINT | arithmetic shift (*x* * 2^*n*) | + +For compatability this definition is retained for all integer types up to LONGINT in size. +Additionally, when *x* is the new HUGEINT type, the result is HUGEINT. + + +#### Pointers and Addresses + +Most Oberon systems have implicitly or explicitly assumed that LONGINT is large enough to hold +machine addresses. With the requirement to support 32 bit LONGINT on 64 bit systems, this is no +longer possible. + +The type SYSTEM.ADDRESS is added, a signed integer type equivalent to either SYSTEM.INT32 or SYSTEM.INT64 +according to the system address size. As a general purpose integer type it can be used not just to +store machine addresses, but also for any arithmetic purpose related to machine addresses, such as +lengths of memory objects or offsets into memory objects. + +The following SYSTEM module predefined functions and procedures now use SYSTEM.ADDRESS instead of LONGINT. + +*Function procedures* + +| Name | Argument types | Result Type | Function | +| ---- | --- | --- | --- | +| SYSTEM.ADR(*v*) | any | SYSTEM.ADDRESS | Address of argument | +| SYSTEM.BIT(*a*, *n*) | *a*: SYSTEM.ADDESS; *n*: integer | BOOLEAN | bit *n* of Mem[*a*] | + +*Proper procedures* + +| Name | Argument types | Function | +| ---- | --- | --- | +| SYSTEM.GET(*a*, *v*) | *a*: SYSTEM.ADDRESS; *v*: any basic type, pointer, procedure type | *v* := Mem[*a*] | +| SYSTEM.PUT(*a*, *x*) | *a*: SYSTEM.ADDRESS; *x*: any basic type, pointer, procedure type | Mem[*a*] := *v* | +| SYSTEM.MOVE(*a0*, *a1*, *n*) | *a0*, *a1*: SYSTEM.ADDRESS; *n*: integer | Mem[*a1*..*a1*+*n*-1] := Mem[*a0*..*a0*+*n*-1] | + +Note that the standard function LEN() still returns LONGINT. + + +#### Files.Mod - Oberon System file semantics on Linux and Windows + +The oberon system has a simpler approach to files than most contemporary operating systems: the data part is manipulated entirely independently of the directory of file names. While Linux has inodes and directories, it does not expose them as independently as Oberon does. + +In particular a file is created in Oberon without touching the directory. Only when a program is ready to expose it in the directory does it call the OS to 'Register' the file. + +In order to mimic this behaviour on Windows and Linux, a new file goes through a number of stages: + + 1. Files.New returns a Files.File, which is an opaque pointer to a file descriptor record. No OS file is created at this stage. + 2. As the first data is written to the file, it is buffered. Still no OS file is created at this stage. + 3. As more data is written to the file more buffers are allocated. Still no OS file is created. + 4. After a limit is reached (currently 4 buffers of 4KB each), a temporary OS file is created, and a buffer reclaimed by flushing it to the temporary file. + 5. Data continues to be written to buffers, with buffers being flushed to the temporary file as necessary to maintain the limit of 4 buffers per file. + 6. Finally, when the client program calls Register, any active buffers are flushed to disk, and the temporary file is renamed to the client specified registration name. + +##### OS file handle lifetime + +Once an OS file has been opened, either by Files.Old, or by sufficient data written to a new file, or by Files.Register, it wil remain open. The client program can Files.Set a new rider on the file at any time. + +Only if the Files.File becomes inaccessible will the garbage collector (eventually) recover the space used by the file descriptor, and only at this time will the OS file handle be closed. + +As in Oberon, Files.Close is only a mechanism to flush buffers, the file remains accessible and may be passed successfully to Files.Set. + +##### Rename and Delete + +Note that on a real Oberon system, it is possible to call rename and delete on files that are currently accessible through a Files.File pointer. For example a program could register a Files.File, and then call Files.Delete passing the same filename - the Files.File remains valid, containing the same data, only the directory entry is removed. + +Such behaviour is not supported on Unix/Windows - an attempt to delete a file that is registered and in use by the program will fail. + + + +#### Runtime error and exit handling + +When passed FALSE, ASSERT displays the message 'Assertion failure.'. If a second, nonzero value is passed to ASSERT it will also be displayed. ASSERT then exits to the OS passing the assert value or zero. + +HALT displays the message 'Terminated by Halt(n)'. For negative values that correspond to a standard runtime error a descriptive string is also printed. Finally Halt exits to the oprerating system passing the error code. + +Bear in mind that both Unix and Windows generally treat the return code as a signed 8 bit value, ignoring higher order bits. Therefore it is best to restrict HALT and ASSERT codes to the range -128 .. 127. + diff --git a/doc/Files.md b/doc/Files.md new file mode 100644 index 00000000..54355260 --- /dev/null +++ b/doc/Files.md @@ -0,0 +1,70 @@ +## Oberon's Files.Mod - differences from POSIX style file APIs + +Most operating systems provide file access in a similar and familiar manner: + - A new file is initially created as an entry in a filesystem directory referencing an empty file. + - File writes add to this file though buffers that will be flushed when full and at file close. + - Following file close the file is inacccessible until reopened. + +#### Why is a file *always* indexed in the filesystem directory? + +Before computers, files would be stored in filing cabinets for long term storage and retrieval, but they would also live independent of filing cabinets, for example in in-trays or out-trays, or loose on desks while being assembled. + +A file outside the filing cabinet might be being in the process of updating and so in an incomplete or inconsistant state. A file in the filing cabinet might be considered complete and consistent. + +#### Oberon Files.Mod behaviour + +Oberons filesystem behaviour is arguably closer to pre-computer usage. Files can easily exist independent of the filesystem directory: + + - Files.New creates a Files.File object that is fully writeable (and readable) but which is not (yet) indexed in the the filesystem. + - Files.Register puts the files name into the filesystem directory. + - Files.Delete takes the files name out of the filesystem directory. + - Neither Register nor Delete affect the file content or access to it. + - The files disk space will be recovered when there is neither a Files.File object referencing the file, nor is its file name present in the directory. + +For example it would be possible for a program to create a new file (Files.New), and then repeatedly put it into the directory (Files.Register) and take it out of the directory (Files.Delete) while at all times the Files.File returned by Files.New remains valid and the content and connected riders are unaffected by the directory changes. + +#### Comparing the Posix and Oberon approaches to file creation. + +On a real Oberon system, file access is independent of the file directory and the Oberon APIs directly reflect the system implementation. + +On a POSIX like system some Oberon APIs require implementation workarounds. This table illustrates Oberon behaviour by describing how it is implemented on top of a POSIX like filesystem. + +|Oberon API|Oberon behaviour|C API|C behaviour| +|---|---|---|---| +|Files.New(name)|Creates a file handle (Files.File) but does not touch the disk.|fopen(name, "w")|Creates an empty file and returns a handle. The empty file is immediately visible to other processes.| +|Files.Set(rider,file,pos)|Creates a rider at a given file position. Multiple riders may be created on the same file at the same or different positions.|----|----| +|Files.WriteBytes(rider,bytes,len)|Buffers are allocated to store written data (current implementation is up to 4 buffers, each 4kb).
Until the buffers are full nothing is written to disk and no file is created in the OS|fwrite()|Data is written to a buffer up to a system dependant size, nothing is written to disk.| +|Files.WriteBytes beyond buffer size|Once more than 16kb has been written, Vishap Oberon creates a temporary file to back up least recently accessed buffers.|fwrite()...|Once the internal buffer is full it is written to the named disk file| +|Files.Register|If all data is still in buffers (no temp file has been created), an OS file is created using the name originally passed to Files.New.
If a temporary file had been created it is renamed to the name originally passed to Files.New.
All buffered data is flushed to the file.|(no equivalent)|| +|Files.Delete|If there is no Files.File in the same program referencing the file then unlink/DeleteFile is called.
If there is a Files.File the OS file is renamed as a temporary file.
Any riders active on the file remain valid.
The file can be reregistered later.|unlink() or DeleteFile()|The file is marked for deletion and will be removed from the filesystem directory when no processes have it open.
Neither Windows nor Linux allow the file to be put back into the directory.| +|Files.Close|Any buffered data is flushed to disk. *The file object and all riders remain valid, data can still be read and written*.|close|Any buffered data is flushed to disk. The file handle is no longer valid for use.| + +Note that the Oberon approach results naturally in files not being visible to other processes until the writer has written a complete set of data. + +On other systems one common workaround is to write to a temporary file, and then rename it to it's public name, taking care of course to create the temporary file on the same device/partition where it will be published. + +Another workaround is to use file locking to keep the file inaccessible until the full set of data is written, of course taking care to avoid deadlocks. + + +### More on the Vishap Oberon emulation of Oberon system file access. + +Emulation of Oberon system behaviour is part of the Vishap Oberon run time system linked into each program. When multiple Oberon programs are running there are necessarily multiple run time systems running. + +#### Two programs writing to the same file + +Each run time system provides Oberon like buffer management. For example, each run time system ensures that multiple riders based on the same file share the same file buffers, such that writes to one of the riders are immediately availble to all (suitably positioned) other riders. + +It is a limitation that this parallel read and write behaviour does not work accross multiple porgams. + +#### Deleting and re-registering files + +Each run time system tracks deletes and registers to provide Oberon system behaviour, allowing a file to be registered, deleted, and re-registered as often as desired. (When the file is deleted, the run time system converts it back to a temporary file.) + +It is a limitation that the run time system does not provide full Oberon behaviour when a file is opened that is also in use by another program, or for which there are other hard links. + +#### Details + +|Activity|Behaviour| +|---|---| +|Rider buffering|File decriptors and buffers are not shared between multiple instances of the runtime system, therefore if two separate programs call Files.Old on the same file, writes to a rider in one program will usually not be reflected by reads in another program.
Further if both programs are writing to parts of the file that fall in the same buffer area, data will likely be lost: the second program to flush its buffer will overwrite new data written by the program that flushed first. While this is expected behaviour for most operating systems, it is not Oberon behaviour.| +|Register and Delete|When an Oberon program program calls Files.Delete passing a filename for which there is a Files.File instance, its runtime system renames the file as a temporary file and records that it is unregistered. The file continues to be accessible by all programs that have it open. When the program that deleted it completes it will call unlink, causing the OS to actually remove it once no programs have it open. This much is valid Oberon system behaviour.
However only the runtime system of the program that deleted the file knows that it is now unregistered and can successfully register it again. Run time systems of other running Vishap Oberon programs still think the file is registered and will be unable to Register it themselves.| \ No newline at end of file diff --git a/doc/History.md b/doc/History.md new file mode 100644 index 00000000..26d20bdf --- /dev/null +++ b/doc/History.md @@ -0,0 +1,134 @@ +### History + +#### Changes from 2.0 to 2.1.0 + + - Features + - Modules of a multi-module program may now be compiled independently - it is + no longer necessary to compile all modules on a single compiler command line. + - The file system location of standard libraries is now determined relative to + where the compiler binary loads from, rather than a fixed location built + into the compiler at install time. + - ```make full``` no longer installs the compiler, and can be run without + root/administrator priviledges. Optionally use ```make install``` to install. + - New warning message to advise of redefinition of standard predefined types. + - Supports revised Oberon array assignment. As well as supporting assignments + between arrays of identical type and size, also supports assignment of arrays + of identical type where the target is larger than the source. + - Fixes: + - Files.Mod provide Oberon system compatible behaviour when deleting an open file. + - The open file will be renamed to a temporary file, remaining accessible and + can be (re)registered. If not registered the temporary file will be deleted + at exit. + - Support allocated memory straddling and above 7FFFFFFFH. + - Flush output on assertion failure. + - Fix 2 or more dimension open array parameter addressing. + - Remove invalid large integer literal warnings on OpenBSD. + - Fix incorrect type generation when a record variable of type LONGINT immediately + follows a record variable of type SYSTEM.ADDRESS. + +#### Changes from 1.2 to 2.0 + +The biggest changes relative to Vishap Oberon 1.2 are in the build system and in the implementation of platform specific support. Where possible platform specific code has removed or replaced by platform agnostic code. + + - The same make commands are used for all platforms, Linux, BSD, Darwin and Windows. In particular 'make full' +builds the compiler, library and tools, installs the compiler and tools, and runs a couple of confidence tests. + + - The C program 'configure.c', a much expanded version of vocparam.c, generates all the platform specific make variables, and the configuration constants compiled into the compiler. Configure.c is compiled and executed at the start of every make command. + + - Both makefiles are platform independent, compatible with both BSD make and GNU make. (For Visual C builds on Windows a separate make.cmd contains the equivalent functionality expressed as a Windows .cmd file.) + + - All duplicate files required to build Linux/BSD/Darwin variants have been removed by refactoring them to be platform independent: + - Rather than accessing Linux structures through Oberon RECORDs intended to match their memory layout, code procedures are used to reference C constants and struct fields directly. (This resolves a number of complexities with structure field order and layout variations across operating systems.) + - Size dependent code is abstracted into simple definitions in SYSTEM.h and referenced from code procedures. + - Files.Mod is extended with a file search path feature removing the need for Files0.Mod, Text0.Mod and Kernel0.Mod. Instead OPM.cmdln.Mod calls the new Files.SetSearchPath. + - Kernel.Mod, Unix.Mod and SYSTEM.Mod are refactored into Heap.Mod and PlatformUnix.Mod. An alternate Platform module implementation PlatformWindows.Mod is used for Microsoft C based builds, using the Win32 API directly. + - All use of the LONGINT type in C source, including in code procedures, now explicitly specify 'LONGINT'. Previously the code often used 'long' instead, assuming it was interchangeable with 'LONGINT', but for some platforms LONGINT is 'long long', not 'long'. + + - The enlistment no longer includes compiled binaries. Instead it includes pre-translated sets of C source covering both platforms and the three C data model variants. (See directory 'bootstrap'.) + + - The bootstrap sources are used on any fresh enlistment or clean build ('make full' is always a clean build). These sources, combined with the platform independence improvements outlined above, have built correctly from a fresh enlistment on all Linux, BSD and cygwin platforms that I have tried, including the raspberry pi under raspbian, and in the termux terminal emulator on android. + +The result is that there is now a single version of earch Oberon source file, with the exceptions only of PlatformUnix.Mod/PlatformWindows.Mod in the compiler, and oocCILP32.Mod/oocCLP64.Mod/oocCLLP64.Mod in the ooc library. + +The full build is now free of warnings: + + - Missing ELSE warnings solved by adding ELSE. + + - C code conversion between integer and pointer of different size solved by casting with with uintptr_t as an intermediate type. + + - C code conversion between signed and unsigned char types solved by explicitly casting 'CHAR's passed to system APIs in code procedures to 'char'. + +The full build now includes a few confidence tests to make sure that the basics work OK. + +HALT/exit code has been simplified. Exit now just calls the system exit API rather than calling the kill API and passing our own process ID. For runtime errors it now displayes the appropriate error message (e.g. Index out of range). + +The jump buffer was not used by any code and has been removed. (It seems from a comment to have been intended for use during some termination code, but the termination code does not use it.) + +Compilation errors now include the line number at the start of the displayed source line. The pos (character offset) is still displayed on the error message line. The error handling code was already doing some walking of the source file to find start and end of line - I changed this to walk through the source file from the start identifying line end positions, counting lines and caching the position at the start of the last error line. The resultant code is simpler, and displays the line number without losing the pos. The performance cost of walking the source file is not an issue. + +##### A few bug fix details: + + - There was a problem with the dynamic array size parameter passed to NEW when expressed as a literal on 64 bit builds. This happens a number of times in the compiler and library. Now in theory it is not necessary to specify the size of numeric literals on parameters to ANSI C functions as the compiler should know the size from the declaration of the called function. (i.e. it shouldn't matter whether one passes '1', '1l', or '1ll'.) +Therefore while OPM.PromoteIntConstToLInt was coded to generate 'l' at the end of long literal parameters on K&R C, it intentionally omitted the 'l' when the compiler was known to be ANSI - and all currently supported compilers are ANSI. +**But** it is not safe to omit the 'l' in literal parameters to C vararg functions: the C compiler cannot get the vararg parameter size from the declaration, and so uses the literal size. Thus only 32 bits are pushed to the stack where 64 bits are required. On a 64 bit Oberon, the implementation of SYSTEM\_NEWARR then reads a full 64 bits. Often the uninitialised 32 bits are zero, and everything works correctly. Rarely they are a very small integer and the system thrashes a while allocating page tables and then continues normally. Other times a segmentation fault or out of memery error is generated. +Removing the test for ANSI and thus always generating the trailing 'l' for LONGINTs is a sufficient fix for the data models supported by the previous versions of Vishap Oberon. +However there is a further complication - this is not sufficient for the LLP64 C data model used by 64 bit Windows. In LLP64, 'long' is only 32 bit. The 64 bit integer type is 'long long' and literal numerics of this type would require an 'll' suffix. +The simple solution was to generate a (LONGINT)(n) typecast, which forces n to the correct size in all cases. + + - SYSTEM.H __VAL(t, x) was defined as (\*(t\*)&(x)) which maps the new type onto the memory of the old. This produces the wrong result if the new type is larger than the old type, because it includes memory that does not belong to the variable into the result. This has been corrected to the simpler ((t)(x)) which will do the appropriate signed or unsigned extension. + + - There was a serious issue with accessing free'd memory in RETURN expressions. Oberon generates code to create local copies of dynamic strings passed by value (so that code is free to change the value parameter without affecting the original string). +The copy is not allocated from the Oberon Heap, but direct from the OS (e.g. via malloc on Linux/Unix). At function return the compiler inserts a call to C's free before the return statement. +The problem comes when the expression on the Oberon RETURN statement references the local string copy. This gets compiled to a C 'return' statement that references the free'd memory. Sometimes the C free will not have modified the string copy, and no error is seen. However all bets are off - the OS or C runtime could have done anything to this memory as part of heap management (e.g. used it for free chain linkage), and with pre-emptive multitasking it may have been reallocated and used for another purpose before the return expression refers to it. This bug hit me occasionally and took a while to find. +The solution I have implemented is to generate declaration of a return value variable at the entry of every function, and to generate code to evaluate the return expression into the variable *before* generating the code to free the local string copy. +In theory the Oberon compiler could inspect the return value for reference to a local copy and only generate the result variable when necessary, however this considerably complicate the Oberon compiler source code for procedure entry and would be of questionalble value, as the C compiler should be able to optimize code with a result variable much the same as code without it. + + - Texts.WriteInt corrected to work with both 4 and 8 byte LONGINTs. Previously values with more than 11 digits caused an index out of range error. + + - Between voc.Translate and extTools.Mod, the main program was being compiled twice by the C compiler. It is now compiled once. + +#### Other changes: + + - In his latest specs (around 2013) Wirth removed the 'COPY(a, b)' character array copy procedure, replacing it with 'b := a'. I have accordingly enabled 'b := a' in voc as an alternative to 'COPY(a, b)' (COPY is still supported.). + + - Oberon code often writes to Oberon.Log expecting the text to appear on the screen. While voc has an Oberon.DumpLog procedure, I looked into making the behaviour automatic. Interestingly the voc source declares the Text notifier constants replace, insert and delete, but omits implementation of the notifier calls. The implementation turned out to be very little code, and I have used it to echo all text written to Oberon.Log to the console. This has the advantage over DumpLog that text is written immediately rather than only when DumpLog is called, and allows existing program source to work unchanged. + + - While working on Vishap Oberon I have been using the name 'olang' rather than 'voc', partly to avoid mixing up binary files, and partly because I had not (re)reached compatability with voc. Since I reckon I'm close to complete, I have now parameterised the code to allow any file name for the compiler and install dir, and switched it back to 'voc' by default. src/tools/make/configure.c line 12 specifies the name that will be built. + + - I experimented with making INTEGER always 32 bit and LONGINT always 64 bit (i.e. even on 32 bit platfroms), but soon found that the libraries assume 16 bit INTEGER and 32 bit LONGINT all over the place. This experimental behaviour is still available by uncommenting the '#define LARGE' in src/tools/make/configure.c line 14. + +#### Norayr/voc issues addressed + +The following issues are taken from https://github.com/norayr/voc/issues. + +##### Issue 7 - 'silence ccomp warnings'. +This has been done. + +##### Issue 9 - 'oberon.par arguments'. +Done for all supported platforms including Ubuntu, FreeBSD, OpenBSD, Raspbian, Darwin, Cygwin and MS C, on a mixture of 32 and 64 bit architectures. + +The vast majority of info in the .par file is redundant. For example the size and alignment of char, unsigned char, int and float is independent of platform. + +A single value is sufficient to specify alignment: above this size this value is the alignment, below this size, the alignment is the same as the type size. (Actually the latter is the type size rounded up to the enclosing power of two, but as all the Oberon type sizes are powers of two this step is unecessary.) + +The only platform differences come around the meaning of 'long' vs 'long long', pointer size and alignment of 64 bit values. These are just 3 possible combinations: + +| Pointer size | Alignment | Used on | Bootstrap directories | +| ------------ | --------- | ---------------- | --------------------- | +| 32 bit | 32 bit | Unix | unix-44 | +| 32 bit | 64 bit | Unix and Windows | unix-48, windows-48 | +| 64 bit | 64 bit | Unix and Windows | unix-88, windows-88 | + +The various C data models are named using common C compiler terminology as follows: + +| Name | 'int' size | 'long' size | 'long long' size | pointer size | +| ----- | ---------- | ----------- | ---------------- | ------------ | +| ILP32 | 32 | 32 | 64 | 32 | +| LLP64 | 32 | 32 | 64 | 64 | +| LP64 | 32 | 64 | 64 | 64 | + +##### Issue 13 - 'prepare Linux/x86asm target'. +Linux is currently compiled using PlatfromUnix.Mod, but the integration of Windows support has made the Platform interface reasonably OS independent, so implementing a PlatformLinux.Mod using Linux kernel calls directly should be straightforward. + +##### Issue 14 - 'separate rtl from SYSTEM?'. +OS specific code is now all in Platformxxx.Mod. Memory management (including the loaded module list) is now in Heap.Mod. SYSTEM.h is platform independent, with minimal ifdefs to allow compiling on all platforms. For example, when SYSTEM.h/SYSTEM.c need to allocate memory, or to halt, they call into Platform.Mod. diff --git a/doc/Installation.md b/doc/Installation.md new file mode 100644 index 00000000..d9ad75cd --- /dev/null +++ b/doc/Installation.md @@ -0,0 +1,162 @@ +## Building and installation summary + +The Oberon compiler and libraries may be built and installed on Linux based, BSD based or Windows based systems. + +### Windows systems + +Bulding on Windows is not so simple largely because there is more than one way to do it: + + - Install the cygwin project and use Windows from the cygwin bash shell rather like Linux. + With the pre-requisites installed using the cygwin setup.exe gui tool, clone and run make + as on Linux. + This builds a compiler that is dependent on the cygwin environment, and which compiles + Oberon programs to binaries that are themselves dependent on the cygwin environment. + + - Install the cygwin project and the mingw compiler. The Oberon compiler this builds is + still dependent on the cygwin environment, but programs built with this compiler are + Windows binaries dependent only on standard Microsoft APIs and libraries. + + - Use the Windows 10 Bash on Ubuntu on Windows (aka WSL - Windows Subsystem for Linux). + The Oberon compiler can be built in the WSL using exactly the same procedure + as on a normal Ubuntu environment, and the resulting compiler and user programs will run + within the Windows subsystem for Linux. + + - Build with the Microsoft C compiler generating native windows binaries. A make.cmd script + is provided which has been developed for and tested with the free 'Visual C++ build tools' + available at http://landinghub.visualstudio.com/visual-cpp-build-tools. + +For full details about building with Cygwin or native Microsoft C environments see [**Cygwin and MSC Installation**](/doc/Winstallation.md) + + +### Building the Oberon compiler and libraries on a Linux or BSD based system + +This approach is for + - All Linux based systems + - includes Android (specifically termux on Android) + - includes Windows subsystem for Linux (aka Bash on Ubuntu on Windows) + - All BSD based systems + - includes macOS (Darwin) + + +#### 1. Install pre-requisites + +The build process has the following pre-requisites: + + - gcc (or clang) compiler + - static libraries for the chosen compiler + - git + - make + - diff + +Example pre-requisite installation commands: + +| Platform | Pre-requisite installation | +| --------- | ------------ | +| Debian/Ubuntu/Mint ... | `apt-get install git` | +| Fedora/RHEL/CentOS ... | `yum install git gcc glibc-static` (`dnf` instead of `yum` on recent Fedoras) | +| FreeBSD/NetBSD | `pkg install git` | +| OpenBSD | `pkg_add git gcc` | +| OpenSUSE | `zypper install gcc git-core make glibc-devel-static` | + +On Mac OS (Darwin) just type the git command. OS/X will tell you that it is not installed and ask if you want to install it (say yes). Note that Darwin builds always use clang, the OS will redirect attempts to use gcc to clang. + + +#### 2. Clone the Oberon compiler repository + +Create and change to a directory in which to make the compiler and clone with this command: + +`git clone https://github.com/vishaps/voc` + +This will create a subdirectory 'voc' which includes the following files and directories: + +| Name | Content | +| --- | --- | +| src/ | Compiler and library source, build tools and tests. | +| bootstrap/ | Pre-generated C source for the compiler targetting the 5 distinct build models needed. | +| doc/ | Documents (including this one). | +| makefile | Makefile for all BSD- and Linux- like environments. Includes tests. | +| make.cmd | Makefile specifically for native Microsoft C builds. No tests. | + + +#### 3. Build the Oberon compiler and library + +``` +cd voc +make full +``` + +The makefile will: + + - Compile and run a C program that determines your C compiler and OS's configuration and creates + the files Configuration.Make and Configuration.Mod. + - C Compile the bootstrap C sources to generate an interim Oberon compiler for your configuration. + - Use the interim compiler to compile the src/compiler and src/runtime directories and statically + link the final Oberon compiler. This compiler is then used for the remaining steps. + - Build the .sym file browser command `showdef`. + - Build all the libraries in -O2 mode, and a subset in -OC mode. + - Create an installation directory structure local to your copy of the repository. + - Run a set of confidence tests. + +The makefile will use either gcc or clang, whichever is installed. If you have both installed you can specify which to use by running either `export CC=gcc` or `export CC=clang` before the `make full` command. + + +#### Installation directories: + +If the makefile succeeds it will end with instructions on how to set your path variable so that the +compiler (voc) is found. + + +#### Installing to system directories + +You may optionally install to system directories such as /opt or /usr/local/share. + +First be sure to have completed `make full` successfully. + +Then from a root prompt, or using sudo, run `make install` + +The installation will be made to: + +| System | Install dir | +| ----------------------- | -------------------------------------- | +| All types of Linux | /opt/voc | +| BSD (including Darwin) | /usr/local/share/voc | +| Termux (android) | /data/data/com.termux/files/opt/voc | + +As with `make full`, `make install` will exit with instructions on how to set +your PATH. + + +#### Installation directory contentains: + +| Directory | Content | +| --- | --- | +| bin/ | Compiler and symbol file browser command binaries. | +| lib/ | Static and dynamic link libraries for all (-O2 and -OC) type models. | +| 2/include/ | C compiler header files for -O2 modules | +| 2/sym/ | .sym files for -O2 modules | +| C/include/ | C compiler header files for -OC modules | +| C/sym/ | .sym files for -OC modules | + + + +### 32 and 64 bit + +The compiler may be built on both 32 bit and 64 bit systems. + +Oberon programs may be compiled using the -O2 (default) or -OC elementary type models. The elementary +types are as follows: + +| Model | 8 bit | 16 bit | 32 bit | 64 bit | +| --- | ---- | --- | --- | --- | +| -O2 (default) | `SHORTINT` | `INTEGER` | `LONGINT` and `SET` | `HUGEINT` | +| -OC | `BYTE` | `SHORTINT` | `INTEGER` | `LONGINT` and `SET` | + +A convention of many Oberon compilers has been that LONGINT is a suitable integer type for +manipulating addresses. However since the size of pointer types is fixed by the OS and we +support both 32 and 64 bit operating systems, LONGINT is not always sufficient for us. + +Accordingly, the SYSTEM module has been updated to ease the development of platform independent +code, with new types such as `SYSTEM.INT8`, `SYSTEM.INT16`, `SYSTEM.INT32`, `SYSTEM.INT64` +and `SYSTEM.ADDRESS`. + +For details, see [**Features**](/doc/Features.md). diff --git a/doc/Porting.md b/doc/Porting.md new file mode 100644 index 00000000..8bb2e74e --- /dev/null +++ b/doc/Porting.md @@ -0,0 +1,58 @@ +### Porting to a new platform + +Porting to a new 32 or 64 bit platform is usually automatically handled +by `make full`: + + - The makefile compiles `src/tools/make/configure.c` with the + platform's default C compiler. + - `configure.c` determines which types to use for 32 and 64 bit + variables, and their alignment. + - `configure.c` uses a number of strategies to determine the + operating system it is running on and what the appropriate + installation directory will be. + - `configure.c` sets makefile variables that are used to select + which of 5 sets of pre-prepared C source files to build to create + the bootstrap compiler. + +On most systems this will be sufficient for `make full` to build +and install the compiler and libraries. + +`make full` will terminate with a message such as: + +`--- Branch v2docs freebsd gcc LP64 confidence tests passed ---` + + +#### Updating configure.c + +Most likely you will only need to change `configure.c` if it cannot determine +the correct install directory. + +In this case add code to `src/tools/make/configure.c`'s +function `determineOS()` to set the `os` variable to the name +of the new OS platform. + +The following variables are also set by `determineOS()` to the +followind defaults: + +variable | set to | example +-------- | ------ | ------- +`platform` | Base platform | `"unix"` +`binext` | Binary file extension | `""` +`staticlink` | Static linking option | `"-static"` + +If your new platform does not support static linking, set the +`staticlink` variable to `""`. + +Then modify `determineInstallDirectory()` to select the correct +instalation root based on the changes you have made to `determineOS()`. + +The `platform` variable selects which variety of the Platform +module is compiled. Vishap provides two varieties, one specific +to the Windows API (`Platformwindows.Mod`), and one suitable for +Unix-like systems including Linux, BSD, Android and cygwin +(`Platformunix.Mod`). + +If you are porting to a system that does not provide a Unix style API, it will +be necessary to implement a new variant of Platform.Mod providing the same +interface as Platformunix.Mod and Platform Windows.Mod. + diff --git a/doc/Winstallation.md b/doc/Winstallation.md new file mode 100644 index 00000000..74eb3c97 --- /dev/null +++ b/doc/Winstallation.md @@ -0,0 +1,256 @@ +### Building the Oberon compiler and libraries on a Windows system + +This approach is for Windows systems using + - Cygwin (with or without mingw) + - Microsoft Visual C + +Building on Bash on Ubuntu on Windows (aka Windows Subsystem for Linux) is the same as building on Ubuntu, +for which see [**Installation**](/doc/Installation.md). + +### Building and installing with Cygwin + +Cygwin comes in 32 bit and 64 bit flavours, and both may be installed on a 64 bit system. On such a dual system, Oberon may be built and installed in both Cygwins. + + +#### 1. Install pre-requisites + +The build process has the following pre-requisites: + + - gcc (or clang) compiler + - static libraries for the chosen compiler + - git + - make + - diff + +To install these, run the Cygwin setup program (setup-x86.exe or setup-x86_64.exe as appropriate), work +your way through the initaial questions until you reach the 'Select packages' page, and make sure the +following packages are selected: + +| Section | Package | +| --- | --- | +| devel | binutils | +| devel | git | +| devel | gcc-core | +| devel | make | +| utils | diffutils | + +Click next and continue to the end of setup. + +#### 2. Clone the Oberon compiler repository + +Create and change to a directory in which to make the compiler and clone with this command: + +`git clone https://github.com/vishaps/voc` + +This will create a subdirectory 'voc' including the following files and directories: + +| Name | Content | +| --- | --- | +| src/ | Compiler and library source, build tools and tests. | +| bootstrap/ | Pre-generated C source for the compiler targetting the 5 distinct build models needed. | +| doc/ | Documents (including this one). | +| makefile | Makefile for all BSD- and Linux- like environments. Includes tests. | +| make.cmd | Makefile specifically for native Microsoft C builds. No tests. | + +#### 3. Build and install the Oberon compiler and library + + +``` +cd voc +[sudo] make full +``` + +The makefile will: + + - Compile and run a C program that determines your C compiler and OS's configuration and creates + the files Configuration.Make and Configuration.Mod. + - C Compile the bootstrap C sources to generate an interim Oberon compiler for your configuration. + - Use the interim compiler to compile the src/compiler and src/runtime directories and statically + link the final Oberon compiler. This compiler is then used for the remaining steps. + - Build the .sym file browser command `showdef`. + - Build all the libraries in -O2 mode, and a subset in -OC mode. + - Install the compiler and libraries by copying them to an appropriate location for your OS. + - Run a set of confidence tests. + + +### Build using mingw under cygwin + +### Build using Microsft C + + + +#### Installation directories: + +If it succeeds the makefile will end with instructions on how to set your path variable so that the +compiler (voc) is found. + +The installation will be found at: + +| Built with | Install dir | +| --------------- | -------------------------------------- | +| cygwin | /opt/voc | +| cygwin + mingw | %PROGRAMFILES%/voc | +| MSC | %PROGRAMFILES%/voc | + +The installation directory contains: + +| Directory | Content | +| --- | --- | +| bin/ | Compiler and symbol file browser command binaries. | +| lib/ | Static and dynamic link libraries for all (-O2 and -OC) type models. | +| 2/include/ | C compiler header files for -O2 modules | +| 2/sym/ | .sym files for -O2 modules | +| C/include/ | C compiler header files for -OC modules | +| C/sym/ | .sym files for -OC modules | + + + +### 32 and 64 bit + +The compiler may be built on both 32 bit and 64 bit systems. + +User Oberon programs may be compiled using the -O2 (default) or -OC elementary type models. The elementary +types are as follows: + +| Model | 8 bit types | 16 bit types | 32 bit types | 64 bit types | +| --- | ---- | --- | --- | --- | +| -O2 (default) | `SHORTINT` | `INTEGER` | `LONGINT` and `SET` | `HUGEINT` | +| -OC | `BYTE` | `SHORTINT` | `INTEGER` | `LONGINT` and `SET` | + +Of course the size of pointer types is fixed by the OS. + +The SYSTEM module has been updated to ease the development of platform independent code, with new +types such as `SYSTEM.INT8`, `SYSTEM.INT16`, `SYSTEM.INT32`, `SYSTEM.INT64` and `SYSTEM.ADDRESS`. + +For more details, see [**Features**](doc/Features.md). + +---- + +---- + +The size of compiler built is determined by the C compiler that runs, which is in turn determined by +the shell or command prompt configuration you are running under. + +The following type sizes follow the built compiler size: + +| Types | 32 bit builds | 64 bit builds | +| ----- | ------------- | ------------- | +| INTEGER | 16 bit | 32 bit | +| LONGINT, SET | 32 bit | 64 bit | + +Note that many library modules have been written with the assumption that INTEGER +is 16 bit and LONGINT 32 bit, therefore they will only work in 32 bit builds. + +#### Which compiler? (gcc vs clang) + +By default make uses the compiler defined in variable CC. This can be overriden by running 'export CC=gcc' or 'export CC=clang' from the command line before running make. + +*Note*: be sure to run 'make clean' any time you change the value of CC. Otherwise directories will be mixed up. + +*Note*: Darwin (MAC OS/X) redirects gcc to clang, so specifying CC=gcc still builds clang binaries under Darwin. + + +#### Building on Windows + +There are three ways to build on Windows: + +| Type | How to build | Compiled binary uses: | +| ----------- | ------- | --------------------- | +| cygwin | Use 'make' from cygwin bash shell. | cygwin.dll | +| mingw under cygwin | Set CC for mingw then use 'make' from cygwin bash shell. | Win32 API | +| Visual C | Use 'make.cmd' from Visual C command prompt. | Win32 API | + +##### mingw on cygwin + +To use mingw, install the correct sized package and export CC= the compiler name: + + - For 32 bit cygwin + + - use setup-x86.exe to add the package mingw64-i686-gcc-core. + - run 'export CC=i686-w64-mingw32-gcc' then 'make full' + + - For 64 bit cygwin + + - use setup-x86\_64.exe to add the package mingw64-x86\_64-gcc-core. + - run 'export CC=x86_64-w64-mingw32-gcc' then 'make full' + +(*Note*: Don't be put off by the name 'mingw64' in the 32 bit package.) + +##### Microsoft Visual C compiler + +Use the free command line Visual C++ compiler. At the time of writing it can be +downloaded here: + + http://landinghub.visualstudio.com/visual-cpp-build-tools + +For example (Windows 10): + +Start an adminstrator command prompt from the start button as follows: + + Start / All apps / Visual C++ Build Tools + +Right click on + + Visual C++ 2015 x86 Native Build Tools Command Prompt + +or + + Visual C++ 2015 x64 Native Build Tools Command Prompt + +And select + + More / Administrative Command Prompt + +#### How make adapts to each platform + +On all platforms other than Visual C on Windows, make runs from a bash shell, +using makefile in the enlistment root, and vishap.make in the src/tools/make +directory. + +For Visual C only, there is a slightly cut down implementation of the same +functionality in the file 'make.cmd' in the enlistment root. + +In all cases src/tools/make/configure.c is executed to determine all +platform dependent parameters: it generates two files: + + - Configuration.Make: a set of environment variables included by the makefile + - Configuration.Mod: An Oberon MODULE containing just configuraton constants. + +The following examples correspond to a 32 bit Ubuntu build using GCC: + +Configuration.Make: + + OLANGDIR=/home/dave/projects/oberon/olang + COMPILER=gcc + OS=ubuntu + VERSION=1.2 + ONAME=voc + DATAMODEL=ILP32 + INTSIZE=2 + ADRSIZE=4 + ALIGNMENT=4 + INSTALLDIR=/opt/voc + PLATFORM=unix + BINEXT= + COMPILE=gcc -fPIC -g + STATICLINK=-static + LDCONFIG=if echo "/opt/voc/lib" >/etc/ld.so.conf.d/libvoc.conf; then ldconfig; fi + +Configuration.Mod: + + MODULE Configuration; + CONST + name* = 'voc'; + versionLong* = '1.2 [2016/06/11] for gcc ILP32 on ubuntu'; + intsize* = 2; + addressSize* = 4; + alignment* = 4; + objext* = '.o'; + objflag* = ' -o '; + linkflags* = ' -L"'; + libspec* = ' -l voc'; + compile* = 'gcc -fPIC -g'; + dataModel* = 'ILP32'; + installdir* = '/opt/voc'; + staticLink* = '-static'; + END Configuration. diff --git a/doc/ctags.md b/doc/ctags.md new file mode 100644 index 00000000..d6e8a40d --- /dev/null +++ b/doc/ctags.md @@ -0,0 +1,82 @@ +## Code navigation with ctags + +[`ctags`](https://github.com/universal-ctags/ctags) is a tool that creates an index file for names in various programming langauges, which helps code comprehension by giving information to text editors to search, locate, and interactively suggest names, identifiers, symbols etc. Particularly for Oberon, the `oberon.ctags` file, located in the project root, contains definitions for Oberon modules and procedures (but not receiver procedures). + +Below you can find installation instructions and usage examples for `ctags` to navigate Oberon source code, in particular, using the universal tags implementation (not tested with other implementations), with `vim` (you can find or add guides for your text editor). + +## Install universal tags + +#### Use your package manager + +`pacman -S ctags` (arch linux) +`apt install universal-ctags` (debian, ubuntu) +`brew install universal-ctags` (macOS) +... + +#### Compile from source + +`git clone https://github.com/universal-ctags/ctags.git` +follow [build instructions](https://github.com/universal-ctags/ctags/blob/master/README.md#how-to-build-and-install) + +## Using ctags with vim and Oberon + +the following instructions are for POSIX systems, but can be easily adapted to other systems + +#### Configuration + +First, generate tags in project root +`make tags` + +When you add or change names in source files, you have to regenerate the `tags` file. That can be done by running `make tags` again. Optionally, use a `vim` plugin such as [vim-gutentags](https://github.com/ludovicchabant/vim-gutentags) to automate this process. Install it (or skip this step): + +`git clone https://github.com/ludovicchabant/vim-gutentags ~/.vim/plugin/` + +or wherever your vim global plugin directory is specified in `:h plugin`. + +Add this to your `~/.vimrc` +``` +" search upwards for tags file until home directory +set tags=./tags;~ +" qualified name metadata for plugin +let g:gutentags_ctags_extra_args = ['--extras=+q'] +``` + +To use `oberon.ctags` with a plugin or for Oberon language detection outside its directory: +`cp oberon.ctags ~/.config/ctags/` +or +`cp oberon.ctags $XDG_CONFIG_HOME/ctags/` + +#### Usage examples + +tags documentation is in vim +`:h tags` + +some examples: +``` +vim -t "Compiler" +vim -t "OPS.Get" +vim -c ":ts Platform.Read" +vim -c ":ta BrowserCmd.ShowDef" +``` + +Inside vim when you have cursor on the first letter `M` of `Module.Procedure`, do this to jump to procedure definition: +`v 3e ` *(visually select the fully qualified name)* +module definition: +`` +To come back: +`` + +Putting cursor on `P` of `Module.Procedure` is not guaranteed to resolve correctly to the correct module, so choose the fully qualified name. This is a [known limitation](https://docs.ctags.io/en/latest/man/ctags-faq.7.html#how-do-i-jump-to-the-tag-i-want-instead-of-the-wrong-one-by-the-same-name) of `ctags` (any suggestions for handling this better are welcome). + +To address this, you can visually select as in the above examples, or resolve ambiguities interactively: +`g ` +`:ts Write` +`:ts Platform.Write` +or make vim see the qualified name as a complete keyword: +`iskeyword+=.` +in `.vimrc` +`autocmd FileType oberon,modula2 setlocal iskeyword+=.` + +**TODO** +There is some auto-completion, but it doesn't work well. One idea is to define a custom `omnifunc` that suggests only exported symbols (`*`) from a file (module scope is file), so that when you type `OPS.` and press `` you can have useful suggestions (similar to `showdef`). + diff --git a/make.cmd b/make.cmd new file mode 100644 index 00000000..a47b97f0 --- /dev/null +++ b/make.cmd @@ -0,0 +1,516 @@ +@echo off + +:: make.cmd - Build Oberon with Microsoft C compiler. + +:: Expects the path to include cl.exe. + +:: As of December 2016 the Microsoft C compiler and build tools +:: can be downloaded independently of the full Visual Studio IDE +:: as the 'Visual C++ Build Tools 2015'. + +:: See: http://landinghub.visualstudio.com/visual-cpp-build-tools + +:: With this installed, from the start button select: +:: All Apps / Visual C++ Build Tools / Visual C++ 2015 x86 Native Build Tools Command Prompt +:: or All Apps / Visual C++ Build Tools / Visual C++ 2015 x64 Native Build Tools Command Prompt + + + + +:: Create configuration and parameter files. + +cl -nologo -Isrc\runtime src\tools\make\configure.c >msc-listing || type msc-listing +setlocal +configure.exe +del configure.obj configure.exe 2>nul + + +:: Extract make variables into local environment + +for /F "delims='=' tokens=1,2" %%a in (Configuration.make) do set %%a=%%b + +set FLAVOUR=%OS%.%DATAMODEL%.%COMPILER% +set BUILDDIR=build\%FLAVOUR% +set OBECOMP=%ONAME%%BINEXT% +set MODEL=2 + +for /F %%d in ('cd');do set ROOTDIR=%%d + + +:: Process target parameter + +if "%1" equ "" ( + call :usage +) else ( + call :%1 +) +endlocal +goto :eof + + + + +:usage +@echo. +@echo Usage: +@echo. +@echo. make full - Make compiler to 'install' subdirectory +@echo. make install - Install 'install' subdir to OS. Requires administrator privileges +@echo. +@echo. make clean - Remove made files +@echo. make compiler - Build the compiler but not the library +@echo. make library - Build all library files and make library +@echo. make install - Install built compiler and library (from administrator prompt) +goto :eof + + + + +:full +call :clean || exit /b +echo. +echo.--- Compiler build started --- +echo. +call :compiler || exit /b +echo. +echo.--- Compiler build successfull --- +echo. +call :browsercmd || exit /b +echo. +echo.--- Library build started --- +echo. +call :library || exit /b +echo. +echo.--- Library build successfull --- +echo. +call :makeinstalldir || exit /b +goto :eof + + + + +:makeinstalldir +rmdir /s /q "%ROOTDIR%\install" >nul 2>&1 +mkdir "%ROOTDIR%\install" >nul 2>&1 + +mkdir "%ROOTDIR%\install\bin" >nul 2>&1 +copy %OBECOMP% "%ROOTDIR%\install\bin" >nul +copy %BUILDDIR%\showdef.exe "%ROOTDIR%\install\bin" >nul + +mkdir "%ROOTDIR%\install\2" >nul 2>&1 +mkdir "%ROOTDIR%\install\2\include" >nul 2>&1 +mkdir "%ROOTDIR%\install\2\sym" >nul 2>&1 +copy %BUILDDIR%\2\*.h "%ROOTDIR%\install\2\include" >nul +copy %BUILDDIR%\2\*.sym "%ROOTDIR%\install\2\sym" >nul + +mkdir "%ROOTDIR%\install\C" >nul 2>&1 +mkdir "%ROOTDIR%\install\C\include" >nul 2>&1 +mkdir "%ROOTDIR%\install\C\sym" >nul 2>&1 +copy %BUILDDIR%\C\*.h "%ROOTDIR%\install\C\include" >nul +copy %BUILDDIR%\C\*.sym "%ROOTDIR%\install\C\sym" >nul + +mkdir "%ROOTDIR%\install\lib" >nul 2>&1 +copy %BUILDDIR%\2\lib%ONAME%* "%ROOTDIR%\install\lib" >nul +copy %BUILDDIR%\C\lib%ONAME%* "%ROOTDIR%\install\lib" >nul + +echo. +echo Now add %ROOTDIR%\install\bin to your path, for example with the command: +echo PATH %ROOTDIR%\install\bin;%%PATH%% +echo. +goto :eof + + + +:install +whoami /groups | find "12288" >nul +if errorlevel 1 ( +echo make install - administrator rights required. Please run under an administrator command prompt. +goto :eof +) +echo Installing to %INSTALLDIR% +rmdir /s /q "%INSTALLDIR%" >nul 2>&1 +xcopy /E /I /Y "%ROOTDIR%\install" "%INSTALLDIR%" >nul +echo. +echo Now add %INSTALLDIR%\bin to your path, for example with the command: +echo PATH %INSTALLDIR%\bin;%%PATH%% +echo. +goto :eof + + + +:uninstall +whoami /groups | find "12288" >nul +if errorlevel 1 ( +echo make uninstall - administrator rights required. Please run under an administrator command prompt. +goto :eof +) +echo Uninstalling %INSTALLDIR% +rmdir /s /q "%INSTALLDIR%" >nul 2>&1 +goto :eof + + + + +:compiler +call :translate || exit /b +call :assemble || exit /b +goto :eof + + + + +:clean +echo.--- Cleaning branch ... %OS% %COMPILER% %DATAMODEL% --- +rd /s /q %BUILDDIR% 2>nul +del /q %OBECOMP% 2>nul +goto :eof + + + + +:assemble +echo. +echo.make assemble - compiling Oberon compiler c source:: +echo. VERSION: %VERSION% +echo. Target characeristics: +echo. PLATFORM: %PLATFORM% +echo. OS: %OS% +echo. BUILDDIR: %BUILDDIR% +echo. INSTALLDIR: %INSTALLDIR% +echo. Oberon characteristics: +echo. MODEL: %MODEL% +echo. ADRSIZE: %ADRSIZE% +echo. ALIGNMENT: %ALIGNMENT% +echo. C compiler: +echo. COMPILER: %COMPILER% +echo. COMPILE: %COMPILE% +echo. DATAMODEL: %DATAMODEL% + +cd %BUILDDIR% + +cl -nologo /Zi -c SYSTEM.c Configuration.c Platform.c Heap.c || exit /b +cl -nologo /Zi -c Out.c Reals.c Strings.c Modules.c || exit /b +cl -nologo /Zi -c Files.c Texts.c VT100.c || exit /b +cl -nologo /Zi -c OPM.c extTools.c OPS.c OPT.c || exit /b +cl -nologo /Zi -c OPC.c OPV.c OPB.c OPP.c || exit /b + +cl -nologo /Zi Compiler.c /Fe%ROOTDIR%\%OBECOMP% /link /INCREMENTAL:NO ^ +SYSTEM.obj Configuration.obj Platform.obj Heap.obj Out.obj Reals.obj ^ +Modules.obj Files.obj Strings.obj Texts.obj VT100.obj extTools.obj ^ +OPM.obj OPS.obj OPT.obj OPC.obj OPV.obj OPB.obj OPP.obj || exit /b + +cd %ROOTDIR% +copy src\runtime\*.c %BUILDDIR% >nul +copy src\runtime\*.h %BUILDDIR% >nul +copy src\runtime\*.Txt %BUILDDIR% >nul +copy src\runtime\*.Txt %ROOTDIR% >nul +echo.%OBECOMP% created. +goto :eof + + + + +:compilefromsavedsource +echo.Populating clean build directory from bootstrap C sources. +mkdir %BUILDDIR% >nul 2>nul +copy bootstrap\%PLATFORM%-%ADRSIZE%%ALIGNMENT%\*.* %BUILDDIR% >nul +copy bootstrap\*.c %BUILDDIR% >nul +copy bootstrap\*.h %BUILDDIR% >nul +call :assemble || exit /b +copy bootstrap\*.c %BUILDDIR% >nul +copy bootstrap\*.h %BUILDDIR% >nul +goto :eof + + + + +:translate +:: Make sure we have an oberon compiler binary: if we built one earlier we'll use it, +:: otherwise use one of the saved sets of C sources in the bootstrap directory. +if not exist %OBECOMP% call :compilefromsavedsource + +echo. +echo.make translate - translating compiler source: +echo. PLATFORM: %PLATFORM% +echo. MODEL: %MODEL% +echo. ADRSIZE: %ADRSIZE% +echo. ALIGNMENT: %ALIGNMENT% + +md %BUILDDIR% 2>nul +cd %BUILDDIR% +del *.sym >nul 2>nul +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../Configuration.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Platform%PLATFORM%.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfFapx -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Heap.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Reals.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Strings.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Out.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Modules.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfFx -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Files.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/Texts.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/runtime/VT100.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPM.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/extTools.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfFx -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPS.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPT.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPC.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPV.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPB.Mod || exit /b +%ROOTDIR%\%OBECOMP% -SsfF -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/OPP.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ssfm -A%ADRSIZE%%ALIGNMENT% -O%MODEL% ../../src/compiler/Compiler.Mod || exit /b + +cd %ROOTDIR% +copy src\runtime\*.c %BUILDDIR% >nul +copy src\runtime\*.h %BUILDDIR% >nul +copy src\runtime\*.Txt %BUILDDIR% >nul + +echo.%BUILDDIR% filled with compiler C source. +goto :eof + + + + +:browsercmd +echo. +echo.Making symbol browser +cd %BUILDDIR% +%ROOTDIR%/%OBECOMP% -fSs ../../src/runtime/Oberon.Mod +%ROOTDIR%/%OBECOMP% -fSm ../../src/tools/browser/BrowserCmd.Mod +cl -nologo BrowserCmd.c Oberon.c /Feshowdef.exe ^ + Platform.obj Texts.obj OPT.obj Heap.obj Out.obj SYSTEM.obj OPM.obj OPS.obj OPV.obj ^ + Files.obj Reals.obj Modules.obj VT100.obj Configuration.obj Strings.obj ^ + OPC.obj +cd %ROOTDIR% +goto :eof + + + + +:runtime +echo. +echo.Making runtime library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Platform%PLATFORM%.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Heap.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Modules.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Reals.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Strings.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Out.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/In.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/VT100.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Files.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Math.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/MathL.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Texts.Mod +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/runtime/Oberon.Mod +cd %ROOTDIR% +goto :eof + + +:v4 +echo. +echo.Making V4 library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/v4/Args.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/v4/Console.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/v4/Printer.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/v4/Sets.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:ooc2 +echo.Making ooc2 library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2Strings.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2Ascii.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2CharClass.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2ConvTypes.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2IntConv.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2IntStr.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc2/ooc2Real0.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:ooc +echo.Making ooc library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLowReal.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLowLReal.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocRealMath.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocOakMath.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLRealMath.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLongInts.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocComplexMath.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLComplexMath.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocAscii.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocCharClass.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocStrings.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocConvTypes.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLRealConv.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocLRealStr.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocRealConv.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocRealStr.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocIntConv.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocIntStr.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocMsg.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocSysClock.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocTime.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocChannel.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocStrings2.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocRts.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocFilenames.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocTextRider.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocBinaryRider.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocJulianDay.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocFilenames.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocwrapperlibc.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ooc/oocC%DATAMODEL%.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:oocX11 +echo No X11 support on plain Windows - use cygwin and build with cygwin make. +goto :eof + +:ulm +echo.Making ulm library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTypes.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmObjects.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmPriorities.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmDisciplines.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmServices.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSys.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSYSTEM.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmEvents.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmProcess.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmResources.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmForwarders.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmRelatedEvents.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmStreams.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmStrings.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSysTypes.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTexts.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSysConversions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmErrors.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSysErrors.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSysStat.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmASCII.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSets.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmIO.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmAssertions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmIndirectDisciplines.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmStreamDisciplines.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmIEEE.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmMC68881.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmReals.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmPrint.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmWrite.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmConstStrings.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmPlotters.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmSysIO.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmLoader.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmNetIO.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmPersistentObjects.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmPersistentDisciplines.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmOperations.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmScales.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTimes.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmClocks.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTimers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmConditions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmStreamConditions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTimeConditions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmCiphers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmCipherOps.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmBlockCiphers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmAsymmetricCiphers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmConclusions.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmRandomGenerators.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmTCrypt.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/ulm/ulmIntOperations.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:pow32 +echo.Making pow32 library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/pow/powStrings.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:misc +echo.Making misc library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/misc/crt.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/misc/Listen.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/misc/MersenneTwister.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/misc/MultiArrays.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/misc/MultiArrayRiders.Mod || exit /b +cd %ROOTDIR% +goto :eof + +:s3 +echo.Making s3 library for -O%MODEL% +cd %BUILDDIR%\%MODEL% +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethBTrees.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethMD5.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethSets.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlib.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlibBuffers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlibInflate.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlibDeflate.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlibReaders.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZlibWriters.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethZip.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethRandomNumbers.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethGZReaders.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethGZWriters.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethUnicode.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethDates.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethReals.Mod || exit /b +%ROOTDIR%\%OBECOMP% -Ffs -O%MODEL% ../../../src/library/s3/ethStrings.Mod || exit /b +cd %ROOTDIR% +goto :eof + + + + +:initlibrary +rd /s /q %BUILDDIR%\%MODEL% >nul 2>nul +mkdir %BUILDDIR% >nul 2>nul +mkdir %BUILDDIR%\%MODEL% >nul 2>nul +copy src\runtime\*.c %BUILDDIR%\%MODEL% >nul +copy src\runtime\*.h %BUILDDIR%\%MODEL% >nul +cd %BUILDDIR%\%MODEL% +cl -nologo -c SYSTEM.c +cd %ROOTDIR% +goto :eof + + +:library +SET MODEL=2 +call :initlibrary || exit /b +call :runtime || exit /b +call :v4 || exit /b +call :ooc2 || exit /b +call :ooc || exit /b +call :ulm || exit /b +call :pow32 || exit /b +call :misc || exit /b +call :s3 || exit /b +lib -nologo %BUILDDIR%\%MODEL%\*.obj -out:%BUILDDIR%\%MODEL%\lib%ONAME%-O%MODEL%.lib || exit /b + +SET MODEL=C +call :initlibrary || exit /b +call :runtime || exit /b +lib -nologo %BUILDDIR%\%MODEL%\*.obj -out:%BUILDDIR%\%MODEL%\lib%ONAME%-O%MODEL%.lib || exit /b +goto :eof + + + + + + + + diff --git a/makefile b/makefile index 60f338e3..08b69845 100644 --- a/makefile +++ b/makefile @@ -1,309 +1,332 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = x86_64 -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = gcc -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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 +# Vishap Oberon master makefile. +# +# Makes sure configuration parameters are up to date and then hands off +# to src/tools/make/oberon.mk. -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) +# To build and install the Oberon compiler and library on a Unix based +# OS (Linux/Mac/BSD etc.) or on cygwin, run: +# +# make full +# +# To override your OSs default C compiler, first run +# +# export CC=compiler +# +# Where compiler is one of: +# +# clang +# gcc +# tcc +# i686-w64-mingw32-gcc (32 bit cygwin only) +# x86_64-w64-mingw32-gcc (64 bit cygwin only) +# +# (To build on native Windows use make.cmd, not this makefile. Make.cmd automatically +# assumes use of the Microsoft compiler cl.) -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) +# C compiler data models and sizes and alignments of Oberon types. +# +# There are just three distinct data models that we build for: +# +# 44 - 32 bit pointers, 32 bit alignment +# 48 - 32 bit pointers, 64 bit alignment +# 88 - 64 bit pointers, 64 bit alignment +# +# Meaning of n bit alignment: +# +# Individual variables of up to n bits are aligned in memory to +# whole multiples of their own size, rounded up to a power of two. +# Variables larger than n bits are aligned to n bits. +# +# (n will always be a power of 2). +# +# Thus: +# +# Size 32 bit alignment 64 bit alignment +# -------- ---------------- ---------------- +# CHAR 1 byte 1 byte 1 byte +# INTEGER 4 bytes 4 bytes 4 bytes +# LONGINT 8 bytes 4 bytes 8 bytes +# +# Note that in practice for 32 and 64 bit systems, this only affects +# LONGINT. +# +# C data model names: +# +# name 32 bit types 64 bit types alignment +# --------- ------------------ ------------------------ --------- +# ILP32 int, long, pointer long long 32 or 64 +# LP64 int long, long long, pointer 64 +# LLP64 int, long long long 64 -# cp *.o $(PREFIX)/lib/voc/$(RELEASE)/obj/ -uninstall: - rm -rf $(PREFIX) - rm -rf $(PREFIXLN) + + + +# Default make target - explain usage +usage: + @echo "" + @echo Usage: + @echo "" + @echo " make full" + @echo "" + @echo " Does a full, clean build, and runs confidence tests." + @echo " An installation directory image is left in the local repository install directory." + @echo "" + @echo "Targets for building and installation:" + @echo " make clean - Clean out the build directory" + @echo " make compiler - Build the compiler but not the library" + @echo " make browsercmd - Build the symbol browser (showdef)" + @echo " make library - Build all library files and make library" + @echo " make O2library - Build all library files with Oberon-2 type sizes" + @echo " make OClibrary - Build all library files with Component Pascal type sizes" + @echo " make install - Install built compiler and library in /opt or C:\\PROGRAM FILES*" + @echo " (Needs root access)" + @echo "" + @echo "Targets for (re)creating and reverting bootstrap C sources:" + @echo " make bootstrap - Update bootstrap C source directories." + @echo " make revertbootstrap - Use git checkout to restore bootstrap C source directories" + +# Code navigation helper +# doc/ctags.md +.PHONY: tags +tags: + ctags -R --options=oberon.ctags --extras=+q + +# Generate config files Configuration.Make and Configuration.Mod +FORCE: + +configuration: FORCE + @$(CC) -I src/runtime -o a.o src/tools/make/configure.c + @./a.o + @rm a.o + @echo BRANCH=$$(git rev-parse --abbrev-ref HEAD)>>Configuration.Make + @echo Branch: $$(git rev-parse --abbrev-ref HEAD). + + +bootstrapconfiguration: FORCE + @$(CC) -I src/runtime -o a.o src/tools/make/configure.c + @./a.o bootstrap + @rm a.o + @echo BRANCH=$$(git rev-parse --abbrev-ref HEAD)>>Configuration.Make + @echo Branch: $$(git rev-parse --abbrev-ref HEAD). + + + + +reportsizes: FORCE + @$(CC) -I src/runtime -o a.o src/tools/make/configure.c + @./a.o report + @rm a.o + + + + +# --- Building and installation --- + + + + +# clean - clean out the bulid directory +clean: configuration + @make -f src/tools/make/oberon.mk -s clean + + + + +# full: Full build of compiler and libarary. +full: configuration + @make -f src/tools/make/oberon.mk -s clean +# Make bootstrap compiler from source suitable for current data model + @printf "\n\n--- Compiler build started ---\n\n" + @make -f src/tools/make/oberon.mk -s compilerfromsavedsource MODEL=2 +# Use bootstrap compiler to make compiler binary from latest compiler sources + @make -f src/tools/make/oberon.mk -s translate MODEL=2 + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 +# Use latest compiler to make compiler binary from latest compiler sources + @make -f src/tools/make/oberon.mk -s translate MODEL=2 + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 + @printf "\n\n--- Compiler build successfull ---\n\n" + @make -f src/tools/make/oberon.mk -s browsercmd MODEL=2 + @printf "\n\n--- Library build started ---\n\n" + @make -f src/tools/make/oberon.mk -s library MODEL=2 + @make -f src/tools/make/oberon.mk -s library MODEL=C + @printf "\n\n--- Library build successfull ---\n\n" + @make -f src/tools/make/oberon.mk -s sourcechanges + @make -f src/tools/make/oberon.mk -s makeinstalldir + @printf "\n\n--- Confidence tests started ---\n\n" + @make -f src/tools/make/oberon.mk -s confidence MODEL=2 + @make -f src/tools/make/oberon.mk -s instructions + + +assemble: + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 + + +compilerfromsavedsource: + @make -f src/tools/make/oberon.mk -s compilerfromsavedsource + + + +# compile: compiler only, without cleaning +compiler: configuration + @make -f src/tools/make/oberon.mk -s translate MODEL=2 + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 + + + +# Report changes to compiler source relative to bootstrap compiler +sourcechanges: + @make -f src/tools/make/oberon.mk -s sourcechanges + + +# browsercmd: build the 'showdef' command +browsercmd: configuration + @make -f src/tools/make/oberon.mk -s browsercmd MODEL=2 + + + + +# library: build all directories under src/library +O2library: configuration + @make -f src/tools/make/oberon.mk -s library MODEL=2 + +OClibrary: configuration + @make -f src/tools/make/oberon.mk -s library MODEL=C + + + + +# Individual library components +v4: configuration + @make -f src/tools/make/oberon.mk -s v4 MODEL=2 + +ooc2: configuration + @make -f src/tools/make/oberon.mk -s ooc2 MODEL=2 + +ooc: configuration + @make -f src/tools/make/oberon.mk -s ooc MODEL=2 + +ulm: configuration + @make -f src/tools/make/oberon.mk -s ulm MODEL=2 + +pow32: configuration + @make -f src/tools/make/oberon.mk -s pow32 MODEL=2 + +misc: configuration + @make -f src/tools/make/oberon.mk -s misc MODEL=2 + +s3: configuration + @make -f src/tools/make/oberon.mk -s s3 MODEL=2 + + + +# makeinstalldir: Copy built files to local install directory +makeinstalldir: + @make -f src/tools/make/oberon.mk -s makeinstalldir + + +# install: Copy built files to install directory +install: configuration + @make -f src/tools/make/oberon.mk -s install + +uninstall: configuration + @make -f src/tools/make/oberon.mk -s uninstall + + + + +# confidence: Run a set of confidence tests +confidence: configuration + @make -f src/tools/make/oberon.mk -s confidence MODEL=2 + +planned-binary-change: + @date >src/test/confidence/planned-binary-change + + + + +# --- Bootstrap C source generation and reversion --- + + +# bootstrap: Rebuild the bootstrap directories +# If the bootstrap directories are broken or only partially +# built then run 'make revertbootstrap' first. +bootstrap: bootstrapconfiguration + @make -f src/tools/make/oberon.mk -s clean + @make -f src/tools/make/oberon.mk -s translate MODEL=2 + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 + rm -rf bootstrap/* + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=4 PLATFORM=unix BUILDDIR=bootstrap/unix-44 && rm bootstrap/unix-44/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=8 PLATFORM=unix BUILDDIR=bootstrap/unix-48 && rm bootstrap/unix-48/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=4 ADRSIZE=8 ALIGNMENT=8 PLATFORM=unix BUILDDIR=bootstrap/unix-88 && rm bootstrap/unix-88/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=8 PLATFORM=windows BUILDDIR=bootstrap/windows-48 && rm bootstrap/windows-48/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=4 ADRSIZE=8 ALIGNMENT=8 PLATFORM=windows BUILDDIR=bootstrap/windows-88 && rm bootstrap/windows-88/*.sym + cp src/runtime/*.[ch] bootstrap + + +bootstrapunclean: bootstrapconfiguration + rm -rf bootstrap/* + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=4 PLATFORM=unix BUILDDIR=bootstrap/unix-44 && rm bootstrap/unix-44/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=8 PLATFORM=unix BUILDDIR=bootstrap/unix-48 && rm bootstrap/unix-48/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=4 ADRSIZE=8 ALIGNMENT=8 PLATFORM=unix BUILDDIR=bootstrap/unix-88 && rm bootstrap/unix-88/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=8 PLATFORM=windows BUILDDIR=bootstrap/windows-48 && rm bootstrap/windows-48/*.sym + make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=4 ADRSIZE=8 ALIGNMENT=8 PLATFORM=windows BUILDDIR=bootstrap/windows-88 && rm bootstrap/windows-88/*.sym + cp src/runtime/*.[ch] bootstrap + + + +revertbootstrap: + @rm -rf bootstrap/* + git checkout bootstrap + + + + +# --- multi-machine multi-platform build management --- + +# NOTE: No longer used. Obsoleted by postpush.pl and buildall.pl. + + + +# coordinator: Start the test machine coordinator +coordinator: configuration + @make -f src/tools/make/oberon.mk -s clean + @make -f src/tools/make/oberon.mk -s translate + @make -f src/tools/make/oberon.mk -s assemble + @make -f src/tools/make/oberon.mk -s testtools + @rm -f "build/*.log" + cd build && ../testcoordinator.exe + + + + +# auto: machine specific build server +auto: configuration + @make -f src/tools/make/oberon.mk -s auto + + + + +# autoonce: What auto does each time a build is triggered. +autoonce: configuration + git pull + @if make -s full; then echo \*\* Succeeded \*\*; else echo \*\* Failed \*\*;fi + + + + +# autobuild: Start test clients. +autobuild: configuration + ./testclient -c "make -s autoonce" + + + + +# autostop: Tell test clients to exit their wait loop. +autostop: configuration + ./testclient -c "exit" diff --git a/makefile.darwin.clang.x86_64 b/makefile.darwin.clang.x86_64 deleted file mode 100644 index 8fee0d18..00000000 --- a/makefile.darwin.clang.x86_64 +++ /dev/null @@ -1,310 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = darwin -TARCH = x86_64 -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = clang -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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" -PRF = "/Users/noch/local" -endif -PREFIX = $(PRF)/voc-$(RELEASE) -PREFIXLN = $(PRF)/voc - -CCOPT = -fPIC $(INCLUDEPATH) -g -SHRLIBEXT = dylib -CC = $(CCOMP) $(CCOPT) -c -CL = $(CCOMP) $(CCOPT) -LD = libtool -dynamic -lSystem -compatibility_version $(RELEASE) -current_version $(RELEASE) -install_name $(PREFIX)/lib/$(LIBRARY).$(SHRLIBEXT) -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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/makefile.freebsd.clang.x86_64 b/makefile.freebsd.clang.x86_64 deleted file mode 100644 index dd829077..00000000 --- a/makefile.freebsd.clang.x86_64 +++ /dev/null @@ -1,309 +0,0 @@ -#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.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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 -m $(PREFIX)/lib - ln -s $(PREFIX) $(PREFIXLN) - -# cp *.o $(PREFIX)/lib/voc/$(RELEASE)/obj/ -uninstall: - rm -rf $(PREFIX) - rm -rf $(PREFIXLN) diff --git a/makefile.linux.clang.powerpc b/makefile.linux.clang.powerpc deleted file mode 100644 index 235fd695..00000000 --- a/makefile.linux.clang.powerpc +++ /dev/null @@ -1,309 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = powerpc -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = clang -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/makefile.linux.clang.x86_64 b/makefile.linux.clang.x86_64 deleted file mode 100644 index c7b7d4ec..00000000 --- a/makefile.linux.clang.x86_64 +++ /dev/null @@ -1,309 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = x86_64 -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = clang -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/makefile.linux.gcc.armv6j_hardfp b/makefile.linux.gcc.armv6j_hardfp deleted file mode 100644 index c1484669..00000000 --- a/makefile.linux.gcc.armv6j_hardfp +++ /dev/null @@ -1,309 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = armv6j_hardfp -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = gcc -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/makefile.linux.gcc.powerpc b/makefile.linux.gcc.powerpc deleted file mode 100644 index 58f07a4c..00000000 --- a/makefile.linux.gcc.powerpc +++ /dev/null @@ -1,309 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = powerpc -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = gcc -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/makefile.linux.gcc.x86 b/makefile.linux.gcc.x86 deleted file mode 100644 index af0bc83b..00000000 --- a/makefile.linux.gcc.x86 +++ /dev/null @@ -1,309 +0,0 @@ -#SHELL := /bin/bash -BUILDID=$(shell date +%Y/%m/%d) -TOS = linux -TARCH = x86 -#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc -CCOMP = gcc -RELEASE = 1.1 - - -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/lib/s3/$(TARCH):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) -sPFS Args.Mod Console.Mod Unix.Mod - sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod - $(VOCSTATIC0) -sPFS prf.Mod - $(VOCSTATIC0) -sPFS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod - $(VOCSTATIC0) -sxPFS Files0.Mod - $(VOCSTATIC0) -sPFS Reals.Mod Texts0.Mod - $(VOCSTATIC0) -sPFS vt100.Mod - -# build the compiler -stage4: - $(VOCSTATIC0) -sPFS errors.Mod - $(VOCSTATIC0) -sPFS extTools.Mod - $(VOCSTATIC0) -sPFS OPM.cmdln.Mod - $(VOCSTATIC0) -sxPFS OPS.Mod - $(VOCSTATIC0) -sPFS 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) -sPF Kernel.Mod - $(VOCSTATIC) -sPF Files.Mod - $(VOCSTATIC) -sPF Texts.Mod - $(VOCSTATIC) -sPF Printer.Mod - $(VOCSTATIC) -sPF Strings.Mod - $(VOCSTATIC) -sPF Sets.Mod - $(VOCSTATIC) -sPF Sets0.Mod - $(VOCSTATIC) -sPF Oberon.Mod - - #ooc libs - $(VOCSTATIC) -sPF oocAscii.Mod - $(VOCSTATIC) -sPF oocStrings.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod - $(VOCSTATIC) -sPF oocOakStrings.Mod - $(VOCSTATIC) -sPF oocCharClass.Mod - $(VOCSTATIC) -sPF oocConvTypes.Mod - $(VOCSTATIC) -sPF oocIntConv.Mod - $(VOCSTATIC) -sPF oocIntStr.Mod - $(VOCSTATIC) -sPF oocSysClock.Mod - $(VOCSTATIC) -sPF oocTime.Mod - $(VOCSTATIC) -sPF oocRandomNumbers.Mod -# $(VOCSTATIC) -s oocLongStrings.Mod -# $(CC) oocLongStrings.c -# $(VOCSTATIC) -s oocMsg.Mod -# $(CC) oocMsg.c - - - #ooc2 libs - $(VOCSTATIC) -sPF ooc2Strings.Mod - $(VOCSTATIC) -sPF ooc2Ascii.Mod - $(VOCSTATIC) -sPF ooc2CharClass.Mod - $(VOCSTATIC) -sPF ooc2ConvTypes.Mod - $(VOCSTATIC) -sPF ooc2IntConv.Mod - $(VOCSTATIC) -sPF ooc2IntStr.Mod - $(VOCSTATIC) -sPF ooc2Real0.Mod - #ooc libs - $(VOCSTATIC) -sPF oocLowReal.Mod oocLowLReal.Mod - $(VOCSTATIC) -sPF oocRealMath.Mod oocOakMath.Mod - $(VOCSTATIC) -sPF oocLRealMath.Mod - $(VOCSTATIC) -sPF oocLongInts.Mod - $(VOCSTATIC) -sPF oocComplexMath.Mod oocLComplexMath.Mod - $(VOCSTATIC) -sPF oocLRealConv.Mod oocLRealStr.Mod - $(VOCSTATIC) -sPF oocRealConv.Mod oocRealStr.Mod - $(VOCSTATIC) -sPF oocMsg.Mod oocChannel.Mod - $(VOCSTATIC) -sPF oocStrings2.Mod oocRts.Mod oocFilenames.Mod - $(VOCSTATIC) -sPF oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod - $(VOCSTATIC) -sPF oocFilenames.Mod - $(VOCSTATIC) -sPF oocwrapperlibc.Mod - $(VOCSTATIC) -sPF oocC.Mod - - #Ulm's Oberon system libs - $(VOCSTATIC) -sPF ulmSys.Mod - $(VOCSTATIC) -sPF ulmSYSTEM.Mod - $(VOCSTATIC) -sPF ulmASCII.Mod - $(VOCSTATIC) -sPF ulmSets.Mod - $(VOCSTATIC) -sPF ulmObjects.Mod - $(VOCSTATIC) -sPF ulmDisciplines.Mod - $(VOCSTATIC) -sPF ulmPriorities.Mod - $(VOCSTATIC) -sPF ulmServices.Mod - $(VOCSTATIC) -sPF ulmEvents.Mod - $(VOCSTATIC) -sPF ulmResources.Mod - $(VOCSTATIC) -sPF ulmForwarders.Mod - $(VOCSTATIC) -sPF ulmRelatedEvents.Mod - $(VOCSTATIC) -sPF ulmIO.Mod - $(VOCSTATIC) -sPF ulmProcess.Mod - $(VOCSTATIC) -sPF ulmTypes.Mod - $(VOCSTATIC) -sPF ulmStreams.Mod - $(VOCSTATIC) -sPF ulmAssertions.Mod - $(VOCSTATIC) -sPF ulmIndirectDisciplines.Mod - $(VOCSTATIC) -sPF ulmStreamDisciplines.Mod - $(VOCSTATIC) -sPF ulmIEEE.Mod - $(VOCSTATIC) -sPF ulmMC68881.Mod - $(VOCSTATIC) -sPF ulmReals.Mod - $(VOCSTATIC) -sPF ulmPrint.Mod - $(VOCSTATIC) -sPF ulmWrite.Mod - $(VOCSTATIC) -sPF ulmTexts.Mod - $(VOCSTATIC) -sPF ulmStrings.Mod - $(VOCSTATIC) -sPF ulmConstStrings.Mod - $(VOCSTATIC) -sPF ulmPlotters.Mod - $(VOCSTATIC) -sPF ulmSysTypes.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmErrors.Mod - $(VOCSTATIC) -sPF ulmSysErrors.Mod - $(VOCSTATIC) -sPF ulmSysIO.Mod - $(VOCSTATIC) -sPF ulmLoader.Mod - $(VOCSTATIC) -sPF ulmNetIO.Mod - $(VOCSTATIC) -sPF ulmPersistentObjects.Mod - $(VOCSTATIC) -sPF ulmPersistentDisciplines.Mod - $(VOCSTATIC) -sPF ulmOperations.Mod - $(VOCSTATIC) -sPF ulmScales.Mod - $(VOCSTATIC) -sPF ulmTimes.Mod - $(VOCSTATIC) -sPF ulmClocks.Mod - $(VOCSTATIC) -sPF ulmTimers.Mod - $(VOCSTATIC) -sPF ulmConditions.Mod - $(VOCSTATIC) -sPF ulmStreamConditions.Mod - $(VOCSTATIC) -sPF ulmTimeConditions.Mod - $(VOCSTATIC) -sPF ulmSysConversions.Mod - $(VOCSTATIC) -sPF ulmSysStat.Mod - $(VOCSTATIC) -sPF ulmCiphers.Mod - $(VOCSTATIC) -sPF ulmCipherOps.Mod - $(VOCSTATIC) -sPF ulmBlockCiphers.Mod - $(VOCSTATIC) -sPF ulmAsymmetricCiphers.Mod - $(VOCSTATIC) -sPF ulmConclusions.Mod - $(VOCSTATIC) -sPF ulmRandomGenerators.Mod - $(VOCSTATIC) -sPF ulmTCrypt.Mod - $(VOCSTATIC) -sPF ulmIntOperations.Mod - - #pow32 libs - $(VOCSTATIC) -sPF powStrings.Mod - - #misc libs - $(VOCSTATIC) -sPF MultiArrays.Mod - $(VOCSTATIC) -sPF MultiArrayRiders.Mod - $(VOCSTATIC) -sPF MersenneTwister.Mod - $(VOCSTATIC) -sPF Listen.Mod - - #s3 libs - $(VOCSTATIC) -sPF ethBTrees.Mod - $(VOCSTATIC) -sPF ethMD5.Mod - $(VOCSTATIC) -sPF ethSets.Mod - $(VOCSTATIC) -sPF ethZlib.Mod - $(VOCSTATIC) -sPF ethZlibBuffers.Mod - $(VOCSTATIC) -sPF ethZlibInflate.Mod - $(VOCSTATIC) -sPF ethZlibDeflate.Mod - $(VOCSTATIC) -sPF ethZlibReaders.Mod - $(VOCSTATIC) -sPF ethZlibWriters.Mod - $(VOCSTATIC) -sPF ethZip.Mod - $(VOCSTATIC) -sPF ethRandomNumbers.Mod - $(VOCSTATIC) -sPF ethGZReaders.Mod - $(VOCSTATIC) -sPF ethGZWriters.Mod - $(VOCSTATIC) -sPF ethUnicode.Mod - $(VOCSTATIC) -sPF ethDates.Mod - $(VOCSTATIC) -sPF ethReals.Mod - $(VOCSTATIC) -sPF ethStrings.Mod - -# build remaining tools -# $(VOCSTATIC0) -sPFS 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) diff --git a/oberon.ctags b/oberon.ctags new file mode 100644 index 00000000..f0ef512f --- /dev/null +++ b/oberon.ctags @@ -0,0 +1,14 @@ +# universal tags +# ctags -R --options=oberon.ctags --extras=+q + +--langdef=Oberon{_autoFQTag} + +--map-Oberon=+.mod +--map-Oberon=+.Mod + +--kinddef-Oberon=m,module,modules +--kinddef-Oberon=p,procedure,procedures + +--regex-Oberon=/^\s*MODULE\s+([a-zA-Z][a-zA-Z0-9]*)\s*;/\1/m/{scope=push} +--regex-Oberon=/^\s*PROCEDURE\s*(\^|-)?\s*([a-zA-Z][a-zA-Z0-9]*)/\2/p/{scope=ref} + diff --git a/src/compiler/Compiler.Mod b/src/compiler/Compiler.Mod new file mode 100755 index 00000000..5855a008 --- /dev/null +++ b/src/compiler/Compiler.Mod @@ -0,0 +1,177 @@ +MODULE Compiler; (* J. Templ 3.2.95 *) + + IMPORT + SYSTEM, Heap, Platform, Configuration, + OPP, OPB, OPT, + OPV, OPC, OPM, + extTools, Strings, VT100; + + PROCEDURE Module*(VAR done: BOOLEAN); + VAR ext, new: BOOLEAN; p: OPT.Node; + BEGIN + OPP.Module(p, OPM.Options); + IF OPM.noerr THEN + OPV.Init; + OPT.InitRecno; + OPV.AdrAndSize(OPT.topScope); + OPT.Export(ext, new); + IF OPM.noerr THEN + OPM.OpenFiles(OPT.SelfName); + OPM.DeleteObj(OPT.SelfName); (* Make sure old object file isn't left hanging around. *) + OPC.Init; + OPV.Module(p); + IF OPM.noerr THEN + IF (OPM.mainprog IN OPM.Options) & (OPM.modName # "SYSTEM") THEN + OPM.DeleteSym(OPT.SelfName); + OPM.LogVT100(VT100.Green); OPM.LogWStr(" Main program."); OPM.LogVT100(VT100.ResetAll); + ELSE + IF new THEN + OPM.LogVT100(VT100.Green); OPM.LogWStr(" New symbol file."); OPM.LogVT100(VT100.ResetAll); + OPM.RegisterNewSym + ELSIF ext THEN + OPM.LogWStr(" Extended symbol file."); + OPM.RegisterNewSym + END + END; + ELSE + OPM.DeleteSym(OPT.SelfName) + END + END + END; + OPM.CloseFiles; OPT.Close; + OPM.LogWLn; + done := OPM.noerr; + END Module; + + + PROCEDURE PropagateElementaryTypeSizes; + VAR adrinttyp: OPT.Struct; + BEGIN + OPT.sysptrtyp.size := OPM.AddressSize; + OPT.sysptrtyp.idfp := OPT.sysptrtyp.form; + OPM.FPrint(OPT.sysptrtyp.idfp, OPT.sysptrtyp.size); + + OPT.adrtyp.size := OPM.AddressSize; + OPT.adrtyp.idfp := OPT.adrtyp.form; + OPM.FPrint(OPT.adrtyp.idfp, OPT.adrtyp.size); + + adrinttyp := OPT.IntType(OPM.AddressSize); + OPT.adrtyp.strobj := adrinttyp.strobj; + + OPT.sinttyp := OPT.IntType(OPM.ShortintSize); + OPT.inttyp := OPT.IntType(OPM.IntegerSize); + OPT.linttyp := OPT.IntType(OPM.LongintSize); + + OPT.sintobj.typ := OPT.sinttyp; + OPT.intobj.typ := OPT.inttyp; + OPT.lintobj.typ := OPT.linttyp; + + CASE OPM.SetSize OF + |4: OPT.settyp := OPT.set32typ + ELSE OPT.settyp := OPT.set64typ + END; + OPT.setobj.typ := OPT.settyp; + + (* Enable or disable (non-system) BYTE type *) + IF OPM.Model = "C" THEN + OPT.cpbytetyp.strobj.name[4] := 0X (* Enable Component Pascal non-system BYTE type *) + ELSE + OPT.cpbytetyp.strobj.name[4] := '@' (* Disable Component Pascal non-system BYTE type *) + END + END PropagateElementaryTypeSizes; + + + PROCEDURE FindLocalObjectFiles(VAR objectnames: ARRAY OF CHAR); + VAR + l: OPT.Link; + fn: ARRAY 64 OF CHAR; + id: Platform.FileIdentity; + BEGIN + objectnames[0] := 0X; + l := OPT.Links; WHILE l # NIL DO + (* Tell linker to link this module as an object file if both a symbol + and an object file exist in the current directory. *) + COPY(l.name, fn); Strings.Append('.sym', fn); + IF Platform.IdentifyByName(fn, id) = 0 THEN + COPY(l.name, fn); Strings.Append(Configuration.objext, fn); + IF Platform.IdentifyByName(fn, id) = 0 THEN + Strings.Append(' ', objectnames); + Strings.Append(fn, objectnames) + ELSE + (* Found symbol file but no object file. *) + OPM.LogVT100(VT100.LightRed); + OPM.LogWStr("Link warning: a local symbol file is present for module "); OPM.LogWStr(l.name); + OPM.LogWStr(", but local object file '"); OPM.LogWStr(fn); OPM.LogWStr("' is missing."); + OPM.LogVT100(VT100.ResetAll); OPM.LogWLn + END + ELSE + (* No symbol file present in current directory. + Assume this referenced module is in a library. *) + END; + l := l.next + END + END FindLocalObjectFiles; + + + PROCEDURE Translate*; + VAR + done: BOOLEAN; + linkfiles: ARRAY 2048 OF CHAR; (* Object files to be linked into main program. *) + BEGIN + IF OPM.OpenPar() THEN + (* gclock(); slightly faster translation but may lead to opening "too many files" *) + + LOOP + OPM.Init(done); (* Get next module name from command line *) + IF ~done THEN RETURN END ; + + OPM.InitOptions; (* Get options for this module *) + PropagateElementaryTypeSizes; + + (* Compile source to .c and .h files *) + Heap.GC(FALSE); + Module(done); + IF ~done THEN + OPM.LogWLn; OPM.LogWStr("Module compilation failed."); OPM.LogWLn; + Platform.Exit(1) + END; + + (* 'assemble' (i.e. c compile) .c to object or executable. *) + IF ~(OPM.dontasm IN OPM.Options) THEN + IF OPM.dontlink IN OPM.Options THEN + (* If not linking, just assemble each module. *) + extTools.Assemble(OPM.modName) + ELSE + IF ~(OPM.mainprog IN OPM.Options) THEN + (* Assemble non main program and add object name to link list *) + extTools.Assemble(OPM.modName); + ELSE + (* Assemble and link main program *) + FindLocalObjectFiles(linkfiles); + extTools.LinkMain(OPM.modName, OPM.mainlinkstat IN OPM.Options, linkfiles) + END + END + END + END (* loop *) + END + END Translate; + + PROCEDURE Trap(sig: SYSTEM.INT32); + BEGIN + Heap.FINALL(); + IF sig = 3 THEN + Platform.Exit(0) + ELSE + IF sig = 4 THEN + OPM.LogWStr(" --- Oberon compiler internal error"); OPM.LogWLn + END ; + Platform.Exit(2) + END + END Trap; + +BEGIN + Platform.SetInterruptHandler(Trap); + Platform.SetQuitHandler(Trap); + Platform.SetBadInstructionHandler(Trap); + Translate +END Compiler. diff --git a/src/compiler/OPB.Mod b/src/compiler/OPB.Mod new file mode 100644 index 00000000..3ff7fffc --- /dev/null +++ b/src/compiler/OPB.Mod @@ -0,0 +1,1514 @@ +(* Oberon Portable build parse tree (front end) *) +MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) + + IMPORT OPT, OPS, OPM, SYSTEM; + + + CONST + AssertTrap = 0; (* default trap number *) + + + VAR + exp: INTEGER; (* side effect of log*) + maxExp: SYSTEM.INT64; (* max n in ASH(1, n) on this machine *) + + + PROCEDURE err(n: INTEGER); + BEGIN OPM.err(n) + END err; + + + PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node; + VAR node: OPT.Node; + BEGIN + CASE obj^.mode OF + | OPT.Var: node := OPT.NewNode(OPT.Nvar); + node^.readonly := (obj^.vis = OPT.externalR) & (obj^.mnolev < 0) + | OPT.VarPar: node := OPT.NewNode(OPT.Nvarpar) + | OPT.Con: node := OPT.NewNode(OPT.Nconst); + node^.conval := OPT.NewConst(); + node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) + | OPT.Typ: node := OPT.NewNode(OPT.Ntype) + | OPT.LProc + ..OPT.IProc: node := OPT.NewNode(OPT.Nproc) + ELSE node := OPT.NewNode(OPT.Nvar); err(127) + END ; + node^.obj := obj; node^.typ := obj^.typ; + RETURN node + END NewLeaf; + + PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node; y: OPT.Node); + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(class); node^.typ := OPT.notyp; + node^.left := x; node^.right := y; x := node + END Construct; + + PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node); + BEGIN + IF x = NIL THEN x := y ELSE last^.link := y END ; + WHILE y^.link # NIL DO y := y^.link END ; + last := y + END Link; + + PROCEDURE BoolToInt(b: BOOLEAN): INTEGER; + BEGIN + IF b THEN RETURN 1 ELSE RETURN 0 END + END BoolToInt; + + PROCEDURE IntToBool(i: SYSTEM.INT64): BOOLEAN; + BEGIN RETURN i # 0 + END IntToBool; + + PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.booltyp; + x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x + END NewBoolConst; + + PROCEDURE OptIf*(VAR x: OPT.Node); (* x^.link = NIL *) + VAR if, pred: OPT.Node; + BEGIN + if := x^.left; + WHILE if^.left^.class = OPT.Nconst DO + IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN + ELSIF if^.link = NIL THEN x := x^.right; RETURN + ELSE if := if^.link; x^.left := if + END + END ; + pred := if; if := if^.link; + WHILE if # NIL DO + IF if^.left^.class = OPT.Nconst THEN + IF IntToBool(if^.left^.conval^.intval) THEN + pred^.link := NIL; x^.right := if^.right; RETURN + ELSE if := if^.link; pred^.link := if + END + ELSE pred := if; if := if^.link + END + END + END OptIf; + + PROCEDURE Nil*(): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.niltyp; + x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x + END Nil; + + PROCEDURE EmptySet*(): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.settyp; + x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x + END EmptySet; + + PROCEDURE SetIntType(node: OPT.Node); + BEGIN node.typ := OPT.IntType(OPT.IntSize(node.conval.intval)) + END SetIntType; + + PROCEDURE SetSetType(node: OPT.Node); + VAR i32: SYSTEM.INT32; + BEGIN SYSTEM.GET(SYSTEM.ADR(node.conval.setval)+4, i32); (* See if upper 32 bits are zero *) + IF i32 = 0 THEN node.typ := OPT.set32typ ELSE node.typ := OPT.set64typ END + END SetSetType; + + PROCEDURE NewIntConst*(intval: SYSTEM.INT64): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); + x^.conval^.intval := intval; SetIntType(x); RETURN x + END NewIntConst; + + PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); + x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc; + RETURN x + END NewRealConst; + + PROCEDURE NewString*(VAR str: OPS.String; len: SYSTEM.INT64): OPT.Node; + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; + x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := OPM.Longint(len); + x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str; + RETURN x + END NewString; + + PROCEDURE CharToString(n: OPT.Node); + VAR ch: CHAR; + BEGIN + n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt(); + IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ; + n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL + END CharToString; + + PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(class); node^.typ := typ; + node^.left := x; node^.right := y; x := node + END BindNodes; + + PROCEDURE NotVar(x: OPT.Node): BOOLEAN; + BEGIN RETURN (x^.class >= OPT.Nconst) & ((x^.class # OPT.Nmop) OR (x^.subcl # OPT.val) OR (x^.left^.class >= OPT.Nconst)) + END NotVar; + + PROCEDURE DeRef*(VAR x: OPT.Node); + VAR strobj, bstrobj: OPT.Object; typ, btyp: OPT.Struct; + BEGIN + typ := x^.typ; + IF x^.class >= OPT.Nconst THEN err(78) + ELSIF typ^.form = OPT.Pointer THEN + IF typ = OPT.sysptrtyp THEN err(57) END ; + btyp := typ^.BaseTyp; strobj := typ^.strobj; bstrobj := btyp^.strobj; + IF (strobj # NIL) & (strobj^.name # "") & (bstrobj # NIL) & (bstrobj^.name # "") THEN + btyp^.pbused := TRUE + END ; + BindNodes(OPT.Nderef, btyp, x, NIL) + ELSE err(84) + END + END DeRef; + + PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node); + VAR f: INTEGER; typ: OPT.Struct; + BEGIN + f := y^.typ^.form; + IF x^.class >= OPT.Nconst THEN err(79) + ELSIF (f # OPT.Int) OR (y^.class IN {OPT.Nproc, OPT.Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; + IF x^.typ^.comp = OPT.Array THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPT.Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END + ELSIF x^.typ^.comp = OPT.DynArr THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPT.Nconst) & (y^.conval^.intval < 0) THEN err(81) END + ELSE err(82); typ := OPT.undftyp + END ; + BindNodes(OPT.Nindex, typ, x, y); x^.readonly := x^.left^.readonly + END Index; + + PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object); + BEGIN (*x^.typ^.comp = OPT.Record*) + IF x^.class >= OPT.Nconst THEN err(77) END ; + IF (y # NIL) & (y^.mode IN {OPT.Fld, OPT.TProc}) THEN + BindNodes(OPT.Nfield, y^.typ, x, NIL); x^.obj := y; + x^.readonly := x^.left^.readonly OR ((y^.vis = OPT.externalR) & (y^.mnolev < 0)) + ELSE err(83); x^.typ := OPT.undftyp + END + END Field; + + PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN); + + PROCEDURE GTT(t0, t1: OPT.Struct); + VAR node: OPT.Node; t: OPT.Struct; + BEGIN t := t0; + WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ; + IF t # t1 THEN + WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ; + IF (t1 = t0) OR (t0.form = OPT.Undef (*SYSTEM.PTR*)) THEN + IF guard THEN BindNodes(OPT.Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly + ELSE node := OPT.NewNode(OPT.Nmop); node^.subcl := OPS.is; node^.left := x; + node^.obj := obj; x := node + END + ELSE err(85) + END + ELSIF t0 # t1 THEN err(85) (* prevent down guard *) + ELSIF ~guard THEN + IF x^.class = OPT.Nguard THEN (* cannot skip guard *) + node := OPT.NewNode(OPT.Nmop); node^.subcl := OPS.is; node^.left := x; + node^.obj := obj; x := node + ELSE x := NewBoolConst(TRUE) + END + END + END GTT; + + BEGIN + IF NotVar(x) THEN err(112) + ELSIF x^.typ^.form = OPT.Pointer THEN + IF (x^.typ^.BaseTyp^.comp # OPT.Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) + ELSIF obj^.typ^.form = OPT.Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) + ELSE err(86) + END + ELSIF (x^.typ^.comp = OPT.Record) & (x^.class = OPT.Nvarpar) & (obj^.typ^.comp = OPT.Record) THEN + GTT(x^.typ, obj^.typ) + ELSE err(87) + END ; + IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END + END TypTest; + + PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node); + VAR f: INTEGER; k: SYSTEM.INT64; + BEGIN f := x^.typ^.form; + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (f = OPT.Int) & (y^.typ^.form = OPT.Set) THEN + IF x^.class = OPT.Nconst THEN + k := x^.conval^.intval; + IF (k < 0) OR (k >= y.typ.size*8) THEN err(202) + ELSIF y^.class = OPT.Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL + ELSE BindNodes(OPT.Ndop, OPT.booltyp, x, y); x^.subcl := OPS.in + END + ELSE BindNodes(OPT.Ndop, OPT.booltyp, x, y); x^.subcl := OPS.in + END + ELSE err(92) + END ; + x^.typ := OPT.booltyp + END In; + + PROCEDURE log(x: SYSTEM.INT64): SYSTEM.INT64; + BEGIN exp := 0; + IF x > 0 THEN + WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END + END ; + RETURN x + END log; + + PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const); + VAR min, max, r: LONGREAL; + BEGIN + IF f = OPT.Real THEN min := OPM.MinReal; max := OPM.MaxReal + ELSE min := OPM.MinLReal; max := OPM.MaxLReal + END ; + r := ABS(x^.realval); + IF (r > max) OR (r < min) THEN + err(nr); x^.realval := 1.0 + ELSIF f = OPT.Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) + END ; + x^.intval := OPM.ConstNotAlloc + END CheckRealType; + + PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node); + VAR f: INTEGER; typ: OPT.Struct; z: OPT.Node; + + PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node; + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(OPT.Nmop); node^.subcl := op; node^.typ := typ; + node^.left := z; RETURN node + END NewOp; + + BEGIN z := x; + IF (z^.class = OPT.Ntype) OR (z^.class = OPT.Nproc) THEN err(126) + ELSE typ := z^.typ; f := typ^.form; + CASE op OF + |OPS.not: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + |OPS.plus: IF ~(f IN {OPT.Int} + OPT.realSet) THEN err(96) END + |OPS.minus: IF f IN {OPT.Int, OPT.Set} + OPT.realSet THEN + IF z^.class = OPT.Nconst THEN + IF f = OPT.Int THEN + IF z^.conval^.intval = MIN(SYSTEM.INT64) THEN err(203) + ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z) + END + ELSIF f IN OPT.realSet THEN z^.conval^.realval := -z^.conval^.realval + ELSE + IF z.typ.size = 8 THEN + z^.conval^.setval := -z^.conval^.setval + ELSE + z.conval.setval := z.conval.setval / {0..31} + END + END; + z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(97) + END + |OPT.abs: IF f IN {OPT.Int} + OPT.realSet THEN + IF z^.class = OPT.Nconst THEN + IF f = OPT.Int THEN + IF z^.conval^.intval = MIN(SYSTEM.INT64) THEN err(203) + ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z) + END + ELSE z^.conval^.realval := ABS(z^.conval^.realval) + END ; + z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END + |OPT.cap: IF f = OPT.Char THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z^.typ := OPT.chartyp + END + |OPT.odd: IF f = OPT.Int THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z^.typ := OPT.booltyp + |OPT.adr: IF (z^.class = OPT.Nconst) & (f = OPT.Char) & (z^.conval^.intval >= 20H) THEN (*SYSTEM.ADR*) + CharToString(z); f := OPT.String + END; + IF (z^.class < OPT.Nconst) OR (f = OPT.String) THEN z := NewOp(op, typ, z) + ELSE err(127) + END ; + z^.typ := OPT.adrtyp + |OPT.cc: IF (f = OPT.Int) & (z^.class = OPT.Nconst) THEN (*SYSTEM.CC*) + IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END + ELSE err(69) + END ; + z^.typ := OPT.booltyp + ELSE OPM.LogWStr("unhandled case in OPB.MOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; + END + END ; + x := z + END MOp; + + PROCEDURE CheckPtr(x, y: OPT.Node); + VAR g: INTEGER; p, q, t: OPT.Struct; + BEGIN g := y^.typ^.form; + IF g = OPT.Pointer THEN + p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp; + IF (p^.comp = OPT.Record) & (q^.comp = OPT.Record) THEN + IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ; + WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ; + IF p = NIL THEN err(100) END + ELSE err(100) + END + ELSIF g # OPT.NilTyp THEN err(100) + END + END CheckPtr; + + PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN); + VAR ft, at: OPT.Struct; + BEGIN + WHILE fp # NIL DO + IF ap # NIL THEN + ft := fp^.typ; at := ap^.typ; + WHILE (ft^.comp = OPT.DynArr) & (at^.comp = OPT.DynArr) DO + ft := ft^.BaseTyp; at := at^.BaseTyp + END ; + IF ft # at THEN + IF (ft^.form = OPT.ProcTyp) & (at^.form = OPT.ProcTyp) THEN + IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE) + ELSE err(117) + END + ELSE err(115) + END + END ; + IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ; + ap := ap^.link + ELSE err(116) + END ; + fp := fp^.link + END ; + IF ap # NIL THEN err(116) END + END CheckParameters; + + PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *) + BEGIN + IF y^.mode IN {OPT.XProc, OPT.IProc, OPT.LProc} THEN + IF y^.mode = OPT.LProc THEN + IF y^.mnolev = 0 THEN y^.mode := OPT.XProc + ELSE err(73) + END + END ; + IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE) + ELSE err(117) + END + ELSE err(113) + END + END CheckProc; + + PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node); + VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: SYSTEM.INT64; + temp: BOOLEAN; (* temp avoids err 215 *) + + PROCEDURE ConstCmp(): INTEGER; + VAR res: INTEGER; + BEGIN + CASE f OF + |OPT.Undef: res := OPS.eql + |OPT.Byte, + OPT.Char + ..OPT.Int: IF xval^.intval < yval^.intval THEN res := OPS.lss + ELSIF xval^.intval > yval^.intval THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.Real, + OPT.LReal: IF xval^.realval < yval^.realval THEN res := OPS.lss + ELSIF xval^.realval > yval^.realval THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.Bool: IF xval^.intval # yval^.intval THEN res := OPS.neq + ELSE res := OPS.eql + END + |OPT.Set: IF xval^.setval # yval^.setval THEN res := OPS.neq + ELSE res := OPS.eql + END + |OPT.String: IF xval^.ext^ < yval^.ext^ THEN res := OPS.lss + ELSIF xval^.ext^ > yval^.ext^ THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.NilTyp, + OPT.Pointer, + OPT.ProcTyp: IF xval^.intval # yval^.intval THEN res := OPS.neq + ELSE res := OPS.eql + END + ELSE OPM.LogWStr("unhandled case in OPB.ConstCmp, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + END ; + x^.typ := OPT.booltyp; RETURN res + END ConstCmp; + + BEGIN + (* f, x, xval are for left side; g, y, yval for right side. *) + f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval; + IF f # g THEN + CASE f OF + |OPT.Char: IF g = OPT.String THEN CharToString(x) + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END ; + |OPT.Int: IF g = OPT.Int THEN + IF x.typ.size <= y.typ.size THEN x.typ := y.typ ELSE x.typ := OPT.IntType(x.typ.size) END + ELSIF g = OPT.Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval + ELSIF g = OPT.LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.Real: IF g = OPT.Int THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPT.LReal THEN x^.typ := OPT.lrltyp + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.LReal: IF g = OPT.Int THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPT.Real THEN y^.typ := OPT.lrltyp + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.String: IF g = OPT.Char THEN CharToString(y); g := OPT.String + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END ; + |OPT.NilTyp: IF ~(g IN {OPT.Pointer, OPT.ProcTyp}) THEN err(100) END + |OPT.Pointer: CheckPtr(x, y) + |OPT.ProcTyp: IF g # OPT.NilTyp THEN err(100) END + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END ; + f := x^.typ^.form + END ; (* {x^.typ = y^.typ} *) + CASE op OF + |OPS.times: IF f = OPT.Int THEN xv := xval^.intval; yv := yval^.intval; + IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *) + (xv > 0) & (yv > 0) & (yv <= MAX(SYSTEM.INT64) DIV xv) OR + (xv > 0) & (yv < 0) & (yv >= MIN(SYSTEM.INT64) DIV xv) OR + (xv < 0) & (yv > 0) & (xv >= MIN(SYSTEM.INT64) DIV yv) OR + (xv < 0) & (yv < 0) & (xv # MIN(SYSTEM.INT64)) & (yv # MIN(SYSTEM.INT64)) & (-xv <= MAX(SYSTEM.INT64) DIV (-yv)) THEN + xval^.intval := xv * yv; SetIntType(x) + ELSE err(204) + END + ELSIF f IN OPT.realSet THEN + temp := ABS(yval^.realval) <= 1.0; + IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN + xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval) + ELSE err(204) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval * yval^.setval; SetSetType(x) + ELSIF f # OPT.Undef THEN err(101) + END + |OPS.slash: IF f = OPT.Int THEN + IF yval^.intval # 0 THEN + xval^.realval := xval^.intval / yval^.intval; CheckRealType(OPT.Real, 205, xval) + ELSE err(205); xval^.realval := 1.0 + END ; + x^.typ := OPT.realtyp + ELSIF f IN OPT.realSet THEN + temp := ABS(yval^.realval) >= 1.0; + IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN + xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval) + ELSE err(205) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval / yval^.setval; SetSetType(x) + ELSIF f # OPT.Undef THEN err(102) + END + |OPS.div: IF f = OPT.Int THEN + IF yval^.intval # 0 THEN + xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x) + ELSE err(205) + END + ELSIF f # OPT.Undef THEN err(103) + END + |OPS.mod: IF f = OPT.Int THEN + IF yval^.intval # 0 THEN + xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x) + ELSE err(205) + END + ELSIF f # OPT.Undef THEN err(104) + END + |OPS.and: IF f = OPT.Bool THEN + xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval)) + ELSE err(94) + END + |OPS.plus: IF f = OPT.Int THEN + temp := (yval^.intval >= 0) & (xval^.intval <= MAX(SYSTEM.INT64) - yval^.intval); + IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(SYSTEM.INT64) - yval^.intval) THEN + INC(xval^.intval, yval^.intval); SetIntType(x) + ELSE err(206) + END + ELSIF f IN OPT.realSet THEN + temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval); + IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN + xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) + ELSE err(206) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval + yval^.setval; SetSetType(x) + ELSIF f # OPT.Undef THEN err(105) + END + |OPS.minus: IF f = OPT.Int THEN + IF (yval^.intval >= 0) & (xval^.intval >= MIN(SYSTEM.INT64) + yval^.intval) OR + (yval^.intval < 0) & (xval^.intval <= MAX(SYSTEM.INT64) + yval^.intval) THEN + DEC(xval^.intval, yval^.intval); SetIntType(x) + ELSE err(207) + END + ELSIF f IN OPT.realSet THEN + temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval); + IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN + xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) + ELSE err(207) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval - yval^.setval; SetSetType(x) + ELSIF f # OPT.Undef THEN err(106) + END + |OPS.or: IF f = OPT.Bool THEN + xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval)) + ELSE err(95) + END + |OPS.eql: xval^.intval := BoolToInt(ConstCmp() = OPS.eql) + |OPS.neq: xval^.intval := BoolToInt(ConstCmp() # OPS.eql) + |OPS.lss: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPS.lss) + END + |OPS.leq: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPS.gtr) + END + |OPS.gtr: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPS.gtr) + END + |OPS.geq: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPS.lss) + END + ELSE + OPM.LogWStr("unhandled case in OPB.ConstOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; + END + END ConstOp; + + PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct); (* Convert node x to new type typ *) + VAR node: OPT.Node; f, g: INTEGER; k: SYSTEM.INT64; r: LONGREAL; + BEGIN f := x^.typ^.form; g := typ^.form; (* f: old form, g: new form *) + IF x^.class = OPT.Nconst THEN + IF (f = OPT.Set) & (g = OPT.Set) & (x.typ.size > typ.size) THEN + SetSetType(x); + IF x.typ.size > typ.size THEN err(203); x^.conval^.setval := {} END + ELSIF f = OPT.Int THEN + IF g = OPT.Int THEN + IF x.typ.size > typ.size THEN SetIntType(x); + IF x.typ.size > typ.size THEN err(203); x^.conval^.intval := 1 END + END + ELSIF g IN OPT.realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc + ELSE (*g = OPT.Char*) k := x^.conval^.intval; + IF (0 > k) OR (k > 0FFH) THEN err(220) END + END + ELSIF f IN OPT.realSet THEN + IF g IN OPT.realSet THEN CheckRealType(g, 203, x^.conval) + ELSE (* g = OPT.Int *) + r := x^.conval^.realval; + IF (r < MIN(SYSTEM.INT64)) OR (r > MAX(SYSTEM.INT64)) THEN err(203); r := 1 END ; + x^.conval^.intval := ENTIER(r); SetIntType(x) + END + ELSE (* (f IN {OPT.Char, OPT.Byte}) & (g IN {OPT.Byte} + OPT.intSet) OR (f = OPT.Undef) *) + END ; + x^.obj := NIL + ELSIF (x^.class = OPT.Nmop) & (x^.subcl = OPT.conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN + (* don't create new node *) + IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END + ELSE node := OPT.NewNode(OPT.Nmop); node^.subcl := OPT.conv; node^.left := x; x := node + END ; + x^.typ := typ + END Convert; + + PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node); + VAR f, g: INTEGER; t, z: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: SYSTEM.INT64; + + PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(OPT.Ndop); node^.subcl := op; node^.typ := typ; + node^.left := x; node^.right := y; x := node + END NewOp; + + PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN; + VAR ok, xCharArr, yCharArr: BOOLEAN; + BEGIN + xCharArr := ((x^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (x^.typ^.BaseTyp^.form=OPT.Char)) OR (f=OPT.String); + yCharArr := (((y^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (y^.typ^.BaseTyp^.form=OPT.Char)) OR (g=OPT.String)); + IF xCharArr & (g = OPT.Char) & (y^.class = OPT.Nconst) THEN CharToString(y); g := OPT.String; yCharArr := TRUE END ; + IF yCharArr & (f = OPT.Char) & (x^.class = OPT.Nconst) THEN CharToString(x); f := OPT.String; xCharArr := TRUE END ; + ok := xCharArr & yCharArr; + IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *) + IF (f=OPT.String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) + x^.typ := OPT.chartyp; x^.conval^.intval := 0; + Index(y, NewIntConst(0)) + ELSIF (g=OPT.String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) + y^.typ := OPT.chartyp; y^.conval^.intval := 0; + Index(x, NewIntConst(0)) + END + END ; + RETURN ok + END strings; + + + BEGIN z := x; + IF (z^.class = OPT.Ntype) OR (z^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (z^.class = OPT.Nconst) & (y^.class = OPT.Nconst) THEN ConstOp(op, z, y); z^.obj := NIL + ELSE + IF z^.typ # y^.typ THEN + g := y^.typ^.form; + CASE z^.typ^.form OF + |OPT.Char: IF z^.class = OPT.Nconst THEN CharToString(z) ELSE err(100) END + |OPT.Int: IF (g = OPT.Int) & (y.typ.size < z.typ.size) THEN Convert(y, z.typ) + ELSIF g IN {OPT.Int} + OPT.realSet THEN Convert(z, y.typ) + ELSE err(100) + END + |OPT.Set: IF (g = OPT.Set) & (y.typ.size < z.typ.size) THEN Convert(y, z.typ) + ELSIF (g = OPT.Set) THEN Convert(z, y.typ) + ELSE err(100) + END + |OPT.Real: IF g = OPT.Int THEN Convert(y, z^.typ) + ELSIF g IN OPT.realSet THEN Convert(z, y^.typ) + ELSE err(100) + END + |OPT.LReal: IF g IN {OPT.Int} + OPT.realSet THEN Convert(y, z^.typ) + ELSIF g IN OPT.realSet THEN Convert(y, z^.typ) (* DCWB: Surely this line does nothing. *) + ELSE err(100) + END + |OPT.NilTyp: IF ~(g IN {OPT.Pointer, OPT.ProcTyp}) THEN err(100) END + |OPT.Pointer: CheckPtr(z, y) + |OPT.ProcTyp: IF g # OPT.NilTyp THEN err(100) END + |OPT.String: + |OPT.Comp: IF z^.typ^.comp = OPT.Record THEN err(100) END + ELSE err(100) + END + END ; (* {z^.typ = y^.typ} *) + typ := z^.typ; f := typ^.form; g := y^.typ^.form; + CASE op OF + |OPS.times: do := TRUE; + IF f = OPT.Int THEN + IF z^.class = OPT.Nconst THEN val := z^.conval^.intval; + IF val = 1 THEN do := FALSE; z := y + ELSIF val = 0 THEN do := FALSE + ELSIF log(val) = 1 THEN + t := y; y := z; z := t; + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + END + ELSIF y^.class = OPT.Nconst THEN val := y^.conval^.intval; + IF val = 1 THEN do := FALSE + ELSIF val = 0 THEN do := FALSE; z := y + ELSIF log(val) = 1 THEN + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + END + END + ELSIF ~(f IN {OPT.Undef, OPT.Real..OPT.Set}) THEN err(105); typ := OPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.slash: IF f = OPT.Int THEN + IF (y^.class = OPT.Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; + Convert(z, OPT.realtyp); Convert(y, OPT.realtyp); + typ := OPT.realtyp + ELSIF f IN OPT.realSet THEN + IF (y^.class = OPT.Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END + ELSIF (f # OPT.Set) & (f # OPT.Undef) THEN err(102); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.div: do := TRUE; + IF f = OPT.Int THEN + IF y^.class = OPT.Nconst THEN val := y^.conval^.intval; + IF val = 0 THEN err(205) + ELSIF val = 1 THEN do := FALSE + ELSIF log(val) = 1 THEN + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL + END + END + ELSIF f # OPT.Undef THEN err(103); typ := OPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.mod: IF f = OPT.Int THEN + IF y^.class = OPT.Nconst THEN + IF y^.conval^.intval = 0 THEN err(205) + ELSIF log(y^.conval^.intval) = 1 THEN + op := OPT.msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL + END + END + ELSIF f # OPT.Undef THEN err(104); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.and: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + IF IntToBool(z^.conval^.intval) THEN z := y END + ELSIF (y^.class = OPT.Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) + (*ELSIF (y^.class = OPT.Nconst) & ~IntToBool(y^.conval^.intval) THEN + don't optimize z & FALSE -> FALSE: side effects possible *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # OPT.Undef THEN err(94); z^.typ := OPT.undftyp + END + |OPS.plus: IF ~(f IN {OPT.Undef, OPT.Int..OPT.Set}) THEN err(105); typ := OPT.undftyp END ; + do := TRUE; + IF f = OPT.Int THEN + IF (z^.class = OPT.Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; + IF (y^.class = OPT.Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.minus: IF ~(f IN {OPT.Undef, OPT.Int..OPT.Set}) THEN err(106); typ := OPT.undftyp END ; + IF (f # OPT.Int) OR (y^.class # OPT.Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END + |OPS.or: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + IF ~IntToBool(z^.conval^.intval) THEN z := y END + ELSIF (y^.class = OPT.Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) + (*ELSIF (y^.class = OPT.Nconst) & IntToBool(y^.conval^.intval) THEN + don't optimize z OR TRUE -> TRUE: side effects possible *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # OPT.Undef THEN err(95); z^.typ := OPT.undftyp + END + |OPS.eql, + OPS.neq: IF (f IN {OPT.Undef..OPT.Set, OPT.NilTyp, OPT.Pointer, OPT.ProcTyp}) OR strings(z, y) THEN typ := OPT.booltyp + ELSE err(107); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.lss, + OPS.leq, + OPS.gtr, + OPS.geq: IF (f IN {OPT.Undef, OPT.Char..OPT.LReal}) OR strings(z, y) THEN typ := OPT.booltyp + ELSE + OPM.LogWLn; OPM.LogWStr("ELSE in Op()"); OPM.LogWLn; + err(108); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + ELSE OPM.LogWStr("unhandled case in OPB.Op, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; + END + END ; + x := z + END Op; + + PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node); + VAR k, l: SYSTEM.INT64; + BEGIN + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.typ^.form = OPT.Int) & (y^.typ^.form = OPT.Int) THEN + IF x^.class = OPT.Nconst THEN + k := x^.conval^.intval; + IF (0 > k) OR (k > MAX(SYSTEM.SET64)) THEN err(202) END + END ; + IF y^.class = OPT.Nconst THEN + l := y^.conval^.intval; + IF (0 > l) OR (l > MAX(SYSTEM.SET64)) THEN err(202) END + END ; + IF (x^.class = OPT.Nconst) & (y^.class = OPT.Nconst) THEN + IF k <= l THEN + x^.conval^.setval := {k..l}; SetSetType(x) + ELSE err(201); x^.conval^.setval := {l..k} + END ; + x^.obj := NIL + ELSE BindNodes(OPT.Nupto, OPT.settyp, x, y) + END + ELSE err(93) + END ; + x^.typ := OPT.settyp (* todo: syntax for specifying set type e.g. SYSTEM.SET64{n1..n2} *) + END SetRange; + + PROCEDURE SetElem*(VAR x: OPT.Node); + VAR k: SYSTEM.INT64; + BEGIN + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF x^.typ^.form # OPT.Int THEN err(93) + ELSIF x^.class = OPT.Nconst THEN + k := x^.conval^.intval; + IF (0 <= k) & (k <= MAX(SYSTEM.SET64)) THEN + x^.conval^.setval := {}; INCL(x.conval.setval, k); + ELSE err(202) + END; + SetSetType(x); x^.obj := NIL + ELSE + Convert(x, OPT.settyp); x^.typ := OPT.settyp + END; + END SetElem; + + PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *) + VAR (* x is designator (target) type *) + y: OPT.Struct; (* expression (source) type *) + f: INTEGER; (* designator (target) form *) + g: INTEGER; (* expression (source) form *) + p, q: OPT.Struct; + BEGIN + y := ynode^.typ; f := x^.form; g := y^.form; + (* + IF OPM.verbose IN OPM.Options THEN + OPM.LogWLn; OPM.LogWStr("PROCEDURE CheckAssign"); OPM.LogWLn; + END; + IF OPM.verbose IN OPM.Options THEN + OPM.LogWStr("y.form = "); OPM.LogWNum(y.form, 0); OPM.LogWLn; + OPM.LogWStr("f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + OPM.LogWStr("g = "); OPM.LogWNum(g, 0); OPM.LogWLn; + OPM.LogWStr("ynode.typ.syze = "); OPM.LogWNum(ynode.typ.size, 0); OPM.LogWLn; + END; + *) + IF (ynode^.class = OPT.Ntype) OR (ynode^.class = OPT.Nproc) & (f # OPT.ProcTyp) THEN err(126) END ; + CASE f OF + OPT.Undef, + OPT.String: + | OPT.Byte: IF ~((g IN {OPT.Byte, OPT.Char, OPT.Int}) & (y.size = 1)) THEN err(113) END + | OPT.Bool, + OPT.Char: IF g # f THEN err(113) END + | OPT.Int, + OPT.Set: IF (g # f) OR (x.size < y.size) THEN err(113) END + | OPT.Real: IF ~(g IN {OPT.Int..OPT.Real}) THEN err(113) END + | OPT.LReal: IF ~(g IN {OPT.Int..OPT.LReal}) THEN err(113) END + | OPT.Pointer: IF (x = y) OR (g = OPT.NilTyp) OR (x = OPT.sysptrtyp) & (g = OPT.Pointer) THEN (* ok *) + ELSIF g = OPT.Pointer THEN + p := x^.BaseTyp; q := y^.BaseTyp; + IF (p^.comp = OPT.Record) & (q^.comp = OPT.Record) THEN + WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE err(113) + END + | OPT.ProcTyp: IF ynode^.class = OPT.Nproc THEN CheckProc(x, ynode^.obj) + ELSIF (x = y) OR (g = OPT.NilTyp) THEN (* ok *) + ELSE err(113) + END + | OPT.NoTyp, + OPT.NilTyp: err(113) + | OPT.Comp: x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x^.comp = OPT.Array THEN + IF (ynode^.class = OPT.Nconst) & (g = OPT.Char) THEN CharToString(ynode); y := ynode^.typ; g := OPT.String END ; + IF x = y THEN (* ok *) + ELSIF (y.comp = OPT.Array) & (y.BaseTyp = x.BaseTyp) & (y.n <= x.n) THEN (* OK by Oberon-07/2013 *) + ELSIF (y.comp = OPT.DynArr) & (y.BaseTyp = x.BaseTyp) THEN (* OK by Oberon-07/2013, length tested at runtime *) + err(113) + (* if no error issued the compiler will crash later + in OPC.CompleteIdent because NIL will be passed to it + from OPC.Len + which is called from OPV.stat + OPV.stat gets n: OPT.node + where both n^.left.obj and n^.right.obj are NIL. + n^.right.obj is then passed to OPC.Len + + at this point, in this ELSIF body + x^.comp = OPT.Array + x^.strobj.name= + y^.strobj is NIL already! + + it's interesting that OPT.InStruct functions + Sarr case is entered, but not Sdarr + + issuing error for now to eliminate compiler crash. + *) + ELSIF x^.BaseTyp = OPT.chartyp THEN (* Assign to (static) ARRAY OF CHAR *) + IF g = OPT.String THEN (*check length of string*) + IF ynode^.conval^.intval2 > x^.n THEN err(114) END + ELSE err(113) + END + ELSE err(113) + END + ELSIF x^.comp = OPT.Record THEN + IF x = y THEN (* ok *) + ELSIF y^.comp = OPT.Record THEN + q := y^.BaseTyp; + WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE (* Assign to dynamic array *) err(113) + END + ELSE OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + END ; + IF (ynode^.class = OPT.Nconst) & (g < f) & (g IN {OPT.Int..OPT.Real}) & (f IN {OPT.Int..OPT.LReal}) THEN + Convert(ynode, x) + END + END CheckAssign; + + PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN); + BEGIN +(* avoid unnecessary intermediate variables in voc + IF (x^.class = OPT.Nmop) & (x^.subcl = val) THEN x := x^.left END ; + IF x^.class = OPT.Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) + IF (x^.class = OPT.Nvar) & (dynArrToo OR (x^.typ^.comp # OPT.DynArr)) THEN x^.obj^.leaf := FALSE END +*) + END CheckLeaf; + + PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER); (* par0: first param of standard proc *) + VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node; + BEGIN x := par0; f := x^.typ^.form; + CASE fctno OF + |OPT.haltfn: (*HALT*) + IF (f = OPT.Int) & (x^.class = OPT.Nconst) THEN + IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN + BindNodes(OPT.Ntrap, OPT.notyp, x, x) + ELSE err(218) + END + ELSE err(69) + END ; + x^.typ := OPT.notyp + |OPT.newfn: (*NEW*) + typ := OPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = OPT.Pointer THEN + IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x^.readonly THEN err(76) END ; + f := x^.typ^.BaseTyp^.comp; + IF f IN {OPT.Record, OPT.DynArr, OPT.Array} THEN + IF f = OPT.DynArr THEN typ := x^.typ^.BaseTyp END ; + BindNodes(OPT.Nassign, OPT.notyp, x, NIL); x^.subcl := OPT.newfn + ELSE err(111) + END + ELSE err(111) + END ; + x^.typ := typ + |OPT.absfn: (*ABS*) + MOp(OPT.abs, x) + |OPT.capfn: (*CAP*) + MOp(OPT.cap, x) + |OPT.ordfn: (*ORD*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Char THEN Convert(x, OPT.inttyp) + ELSE err(111) + END ; + x^.typ := OPT.inttyp + |OPT.entierfn: (*ENTIER*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.realSet THEN Convert(x, OPT.linttyp) + ELSE err(111) + END ; + x^.typ := OPT.linttyp + |OPT.oddfn: (*ODD*) + MOp(OPT.odd, x) + |OPT.minfn: (*MIN*) + IF x^.class = OPT.Ntype THEN + CASE f OF + OPT.Bool: x := NewBoolConst(FALSE) + | OPT.Char: x := NewIntConst(0); x^.typ := OPT.chartyp + | OPT.Int: x := NewIntConst(OPM.SignedMinimum(x.typ.size)) + | OPT.Set: x := NewIntConst(0); x^.typ := OPT.inttyp + | OPT.Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) + | OPT.LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) + ELSE err(111) + END + ELSE err(110) + END + |OPT.maxfn: (*MAX*) + IF x^.class = OPT.Ntype THEN + CASE f OF + OPT.Bool: x := NewBoolConst(TRUE) + | OPT.Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp + | OPT.Int: x := NewIntConst(OPM.SignedMaximum(x.typ.size)) + | OPT.Set: x := NewIntConst(x.typ.size*8-1); x^.typ := OPT.inttyp + | OPT.Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) + | OPT.LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) + ELSE err(111) + END + ELSE err(110) + END + |OPT.chrfn: (*CHR*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN {OPT.Undef, OPT.Int} THEN Convert(x, OPT.chartyp) + ELSE err(111); x^.typ := OPT.chartyp + END + |OPT.shortfn: (*SHORT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + typ := OPT.ShorterOrLongerType(x.typ, -1); + IF typ = NIL THEN err(111) ELSE Convert(x, typ) END + ELSIF f = OPT.LReal THEN Convert(x, OPT.realtyp) + ELSE err(111) + END + |OPT.longfn: (*LONG*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + typ := OPT.ShorterOrLongerType(x.typ, 1); + IF typ = NIL THEN err(111) ELSE Convert(x, typ) END + ELSIF f = OPT.Real THEN Convert(x, OPT.lrltyp) + ELSIF f = OPT.Char THEN Convert(x, OPT.linttyp) + ELSE err(111) + END + |OPT.incfn, + OPT.decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF f # OPT.Int THEN err(111) + ELSIF x^.readonly THEN err(76) + END + |OPT.inclfn, + OPT.exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF x.typ.form # OPT.Set THEN err(111); x^.typ := OPT.settyp + ELSIF x^.readonly THEN err(76) + END + |OPT.lenfn: (*LEN*) + IF ~(x^.typ^.comp IN {OPT.DynArr, OPT.Array}) THEN err(131) END + |OPT.copyfn: (*COPY*) + IF (x^.class = OPT.Nconst) & (f = OPT.Char) THEN CharToString(x); f := OPT.String END ; + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (~(x^.typ^.comp IN {OPT.DynArr, OPT.Array}) OR (x^.typ^.BaseTyp^.form # OPT.Char)) + & (f # OPT.String) THEN err(111) + END + |OPT.ashfn: (*ASH*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + IF x.typ.size < OPT.linttyp.size THEN Convert(x, OPT.linttyp) END + ELSE err(111); x^.typ := OPT.linttyp + END + |OPT.adrfn: (*SYSTEM.ADR*) + CheckLeaf(x, FALSE); MOp(OPT.adr, x) + |OPT.sizefn: (*SIZE*) + IF x^.class # OPT.Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {OPT.Byte..OPT.Set, OPT.Pointer, OPT.ProcTyp}) + OR (x^.typ^.comp IN {OPT.Array, OPT.Record}) THEN + OPT.TypSize(x^.typ); x^.typ^.pvused := TRUE; x := NewIntConst(x^.typ^.size) + ELSE err(111); x := NewIntConst(1) + END + |OPT.ccfn: (*SYSTEM.CC*) + MOp(OPT.cc, x) + |OPT.lshfn, + OPT.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(f IN {OPT.Int, OPT.Byte, OPT.Char, OPT.Set}) THEN err(111) + END + |OPT.getfn, + OPT.putfn, + OPT.bitfn, + OPT.movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.class = OPT.Nconst) & (f = OPT.Int) & (x.typ.size < OPT.adrtyp.size) THEN Convert(x, OPT.adrtyp) + ELSIF ~((x.typ.form IN {OPT.Pointer, OPT.Int}) & (x.typ.size = OPM.AddressSize)) THEN err(111); x^.typ := OPT.adrtyp + END + |OPT.getrfn, + OPT.putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f = OPT.Int) & (x^.class = OPT.Nconst) THEN + IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END + ELSE err(69) + END + |OPT.valfn: (*SYSTEM.VAL*) + IF x^.class # OPT.Ntype THEN err(110) + ELSIF (f IN {OPT.Undef, OPT.String, OPT.NoTyp}) OR (x^.typ^.comp = OPT.DynArr) THEN err(111) + END + |OPT.sysnewfn: (*SYSTEM.NEW*) + IF NotVar(x) THEN err(112) + ELSIF f = OPT.Pointer THEN + IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END + ELSE err(111) + END + |OPT.assertfn: (*ASSERT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # OPT.Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(OPS.not, x) + END + ELSE OPM.LogWStr("unhandled case in OPB.StPar0, fctno = "); OPM.LogWNum(fctno, 0); OPM.LogWLn; + END ; + par0 := x + END StPar0; + + PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT); (* x: second parameter of standard proc *) + VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node; + + PROCEDURE NewOp(class, subcl: SHORTINT; left, right: OPT.Node): OPT.Node; + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(class); node^.subcl := subcl; + node^.left := left; node^.right := right; RETURN node + END NewOp; + + BEGIN p := par0; f := x^.typ^.form; + CASE fctno OF + |OPT.incfn, + OPT.decfn: (*INC DEC*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); p^.typ := OPT.notyp + ELSE + IF x^.typ # p^.typ THEN + IF (f = OPT.Int) + & ( (x^.class = OPT.Nconst) + OR (p.typ.form = OPT.Int) & (x.typ.size <= p.typ.size)) THEN Convert(x, p^.typ) + ELSE err(111) + END + END ; + p := NewOp(OPT.Nassign, fctno, p, x); + p^.typ := OPT.notyp + END + |OPT.inclfn, + OPT.exclfn: (*INCL, EXCL*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + IF (x^.class = OPT.Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval >= p.typ.size*8)) THEN err(202) + END; + p := NewOp(OPT.Nassign, fctno, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.lenfn: (*LEN*) + IF ~(f = OPT.Int) OR (x^.class # OPT.Nconst) THEN err(69) + ELSIF x.typ.size = 1 THEN (* Hard limit of 127 dimensions *) + L := OPM.Integer(x^.conval^.intval); typ := p^.typ; + WHILE (L > 0) & (typ^.comp IN {OPT.DynArr, OPT.Array}) DO typ := typ^.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ^.comp IN {OPT.DynArr, OPT.Array}) THEN err(132) + ELSE x^.obj := NIL; + IF typ^.comp = OPT.DynArr THEN + WHILE p^.class = OPT.Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) + p := NewOp(OPT.Ndop, OPT.len, p, x); p^.typ := OPT.linttyp + ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p) + END + END + ELSE err(132) + END + |OPT.copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF (x^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (x^.typ^.BaseTyp^.form = OPT.Char) THEN + IF x^.readonly THEN err(76) END ; + t := x; x := p; p := t; p := NewOp(OPT.Nassign, OPT.copyfn, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.ashfn: (*ASH*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + IF (p^.class = OPT.Nconst) & (x^.class = OPT.Nconst) THEN + IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1 + ELSIF x^.conval^.intval >= 0 THEN + IF ABS(p^.conval^.intval) <= MAX(SYSTEM.INT64) DIV ASH(1, x^.conval^.intval) THEN + p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval) + ELSE err(208); p^.conval^.intval := 1 + END + ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval) + END ; + p^.obj := NIL + ELSE p := NewOp(OPT.Ndop, OPT.ash, p, x); p^.typ := p.left.typ (* LONGINT, or INT64 if larger *) + END + ELSE err(111) + END + |OPT.newfn: (*NEW(p, x...)*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF p^.typ^.comp = OPT.DynArr THEN + IF f = OPT.Int THEN + IF (x^.class = OPT.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END + ELSE err(111) + END ; + p^.right := x; p^.typ := p^.typ^.BaseTyp + ELSE err(64) + END + |OPT.lshfn, + OPT.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f # OPT.Int THEN err(111) + ELSE + IF fctno = OPT.lshfn THEN p := NewOp(OPT.Ndop, OPT.lsh, p, x) ELSE p := NewOp(OPT.Ndop, OPT.rot, p, x) END ; + p^.typ := p^.left^.typ + END + |OPT.getfn, + OPT.putfn, + OPT.getrfn, + OPT.putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN {OPT.Undef..OPT.Set, OPT.Pointer, OPT.ProcTyp} THEN + IF (fctno = OPT.getfn) OR (fctno = OPT.getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(OPT.Nassign, fctno, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.bitfn: (*SYSTEM.BIT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + p := NewOp(OPT.Ndop, OPT.bit, p, x) + ELSE err(111) + END ; + p^.typ := OPT.booltyp + |OPT.valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + (* p (1st param): desired type *) + (* x (2nd param): constant or value to be converted to p *) + IF (x^.class = OPT.Ntype) + OR (x^.class = OPT.Nproc) + OR (f IN {OPT.Undef, OPT.String, OPT.NoTyp}) + OR (x^.typ^.comp = OPT.DynArr) THEN + err(126) + END; + (* Warn if the result type includes memory past the end of the source variable *) + OPT.TypSize(x.typ); OPT.TypSize(p.typ); + IF (x.class # OPT.Nconst) & (x.typ.size < p.typ.size) THEN err(-308) END; + + IF (x.class = OPT.Nconst) & (x.typ.form = OPT.Int) & (p.typ.form = OPT.Int) THEN + (* Convert integer constants in place allowing usage in CONST section. *) + Convert(x, p.typ) + ELSE + t := OPT.NewNode(OPT.Nmop); t^.subcl := OPT.val; t^.left := x; x := t; + (* + IF (x^.class >= OPT.Nconst) OR ((f IN OPT.realSet) # (p^.typ^.form IN OPT.realSet)) THEN + t := OPT.NewNode(OPT.Nmop); t^.subcl := val; t^.left := x; x := t + ELSE x^.readonly := FALSE + END ; + *) + x^.typ := p^.typ; + END; + p := x + |OPT.sysnewfn: (*SYSTEM.NEW*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + p := NewOp(OPT.Nassign, OPT.sysnewfn, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.movefn: (*SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.class = OPT.Nconst) & (f = OPT.Int) & (x.typ.size < OPT.adrtyp.size) THEN Convert(x, OPT.adrtyp) + ELSIF ~((x.typ.form IN {OPT.Pointer, OPT.Int}) & (x.typ.size = OPM.AddressSize)) THEN err(111); x^.typ := OPT.adrtyp + END; + p^.link := x + |OPT.assertfn: (*ASSERT*) + IF (f = OPT.Int) & (x^.class = OPT.Nconst) THEN + IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN + BindNodes(OPT.Ntrap, OPT.notyp, x, x); + x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; + Construct(OPT.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPT.Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p^.class = OPT.Ntrap THEN err(99) + ELSE p^.subcl := OPT.assertfn + END + ELSE err(218) + END + ELSE err(69) + END + ELSE err(64) + END ; + par0 := p + END StPar1; + + PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *) + VAR node: OPT.Node; f: INTEGER; p: OPT.Node; + BEGIN p := par0; f := x^.typ^.form; + IF fctno = OPT.newfn THEN (*NEW(p, ..., x...*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF p^.typ^.comp # OPT.DynArr THEN err(64) + ELSIF f = OPT.Int THEN + IF (x^.class = OPT.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; + node := p^.right; WHILE node^.link # NIL DO node := node^.link END; + node^.link := x; p^.typ := p^.typ^.BaseTyp + ELSE err(111) + END + ELSIF (fctno = OPT.movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Int THEN + node := OPT.NewNode(OPT.Nassign); node^.subcl := OPT.movefn; node^.right := p; + node^.left := p^.link; p^.link := x; p := node + ELSE err(111) + END ; + p^.typ := OPT.notyp + ELSE err(64) + END ; + par0 := p + END StParN; + + PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER); + VAR dim: INTEGER; x, p: OPT.Node; + BEGIN p := par0; + IF fctno <= OPT.ashfn THEN + IF (fctno = OPT.newfn) & (p^.typ # OPT.notyp) THEN + IF p^.typ^.comp = OPT.DynArr THEN err(65) END ; + p^.typ := OPT.notyp + ELSIF fctno <= OPT.sizefn THEN (* 1 param *) + IF parno < 1 THEN err(65) END + ELSE (* more than 1 param *) + IF ((fctno = OPT.incfn) OR (fctno = OPT.decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(OPT.Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ + ELSIF (fctno = OPT.lenfn) & (parno = 1) THEN (*LEN*) + IF p^.typ^.comp = OPT.DynArr THEN dim := 0; + WHILE p^.class = OPT.Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(OPT.Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := OPT.len + ELSE + p := NewIntConst(p^.typ^.n) + END + ELSIF parno < 2 THEN err(65) + END + END + ELSIF fctno = OPT.assertfn THEN + IF parno = 1 THEN x := NIL; + BindNodes(OPT.Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); + x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; + Construct(OPT.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPT.Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p^.class = OPT.Ntrap THEN err(99) + ELSE p^.subcl := OPT.assertfn + END + ELSIF parno < 1 THEN err(65) + END + ELSE (*SYSTEM*) + IF (parno < 1) OR + (fctno > OPT.ccfn) & (parno < 2) OR + (fctno = OPT.movefn) & (parno < 3) THEN err(65) + END + END ; + par0 := p + END StFct; + + PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN); + VAR f: INTEGER; + BEGIN (* ftyp^.comp = OPT.DynArr *) + f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; + IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *) + IF ~(f IN {OPT.Array, OPT.DynArr}) OR ~((atyp.form IN {OPT.Byte..OPT.Char, OPT.Int}) & (atyp.size = 1)) THEN + IF OPM.verbose IN OPM.Options THEN err(-301) END + END + ELSIF f IN {OPT.Array, OPT.DynArr} THEN + IF ftyp^.comp = OPT.DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) + ELSIF ftyp # atyp THEN + IF ~fvarpar & (ftyp.form = OPT.Pointer) & (atyp.form = OPT.Pointer) THEN + ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; + IF (ftyp^.comp = OPT.Record) & (atyp^.comp = OPT.Record) THEN + WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ; + IF atyp = NIL THEN err(113) END + ELSE err(66) + END + ELSE err(66) + END + END ; + ELSE err(67) + END + END DynArrParCheck; + + PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object); + BEGIN + IF fp^.typ^.form = OPT.Pointer THEN + IF x^.class = OPT.Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = OPT.Record*) err(71) END + END + END CheckReceiver; + + PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object); + BEGIN + IF (x^.obj # NIL) & (x^.obj^.mode IN {OPT.LProc, OPT.XProc, OPT.TProc, OPT.CProc}) THEN + fpar := x^.obj^.link; + IF x^.obj^.mode = OPT.TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END + ELSIF (x^.class # OPT.Ntype) & (x^.typ # NIL) & (x^.typ^.form = OPT.ProcTyp) THEN + fpar := x^.typ^.link + ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp + END + END PrepCall; + + PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object); + VAR q: OPT.Struct; + BEGIN + IF fp.typ.form # OPT.Undef THEN + IF fp^.mode = OPT.VarPar THEN + IF NotVar(ap) THEN err(122) + ELSE CheckLeaf(ap, FALSE) + END ; + IF ap^.readonly THEN err(76) END ; + IF fp^.typ^.comp = OPT.DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) + ELSIF (fp^.typ^.comp = OPT.Record) & (ap^.typ^.comp = OPT.Record) THEN + q := ap^.typ; + WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(111) END + ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = OPT.Pointer) THEN (* ok *) + ELSIF (ap^.typ # fp^.typ) + & ~( (fp^.typ^.form = OPT.Byte) + & (ap.typ.form IN {OPT.Byte..OPT.Char, OPT.Int}) + & (ap.typ.size = 1)) THEN err(123) + ELSIF (fp^.typ^.form = OPT.Pointer) & (ap^.class = OPT.Nguard) THEN err(123) + END + ELSIF fp^.typ^.comp = OPT.DynArr THEN + IF (ap^.class = OPT.Nconst) & (ap^.typ^.form = OPT.Char) THEN CharToString(ap) END ; + IF (ap^.typ^.form = OPT.String) & (fp^.typ^.BaseTyp^.form = OPT.Char) THEN (* ok *) + ELSIF ap^.class >= OPT.Nconst THEN err(59) + ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE) + END + ELSE CheckAssign(fp^.typ, ap) + END + END + END Param; + + PROCEDURE StaticLink*(dlev: SHORTINT); + VAR scope: OPT.Object; + BEGIN + scope := OPT.topScope; + WHILE dlev > 0 DO DEC(dlev); + INCL(scope^.link^.conval^.setval, OPT.slNeeded); + scope := scope^.left + END + END StaticLink; + + PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object); + VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT; + BEGIN + IF x^.class = OPT.Nproc THEN typ := x^.typ; + lev := x^.obj^.mnolev; + IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ; + IF x^.obj^.mode = OPT.IProc THEN err(121) END + ELSIF (x^.class = OPT.Nfield) & (x^.obj^.mode = OPT.TProc) THEN typ := x^.typ; + x^.class := OPT.Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link + ELSE typ := x^.typ^.BaseTyp + END ; + BindNodes(OPT.Ncall, typ, x, apar); x^.obj := fp + END Call; + + PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object); + VAR x: OPT.Node; + BEGIN + x := OPT.NewNode(OPT.Nenter); x^.typ := OPT.notyp; x^.obj := proc; + x^.left := procdec; x^.right := stat; procdec := x + END Enter; + + PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object); + VAR node: OPT.Node; + BEGIN + IF proc = NIL THEN (* return from module *) + IF x # NIL THEN err(124) END + ELSE + IF x # NIL THEN CheckAssign(proc^.typ, x) + ELSIF proc^.typ # OPT.notyp THEN err(124) + END + END ; + node := OPT.NewNode(OPT.Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node + END Return; + + PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node); + VAR z: OPT.Node; + BEGIN + IF x^.class >= OPT.Nconst THEN err(56) END ; + CheckAssign(x^.typ, y); + IF x^.readonly THEN err(76) END ; + IF x^.typ^.comp = OPT.Record THEN + IF x^.class = OPT.Nguard THEN z := x^.left ELSE z := x END ; + IF (z^.class = OPT.Nderef) & (z^.left^.class = OPT.Nguard) THEN + z^.left := z^.left^.left (* skip guard before dereferencing *) + END ; + IF (x^.typ^.strobj # NIL) & ((z^.class = OPT.Nderef) OR (z^.class = OPT.Nvarpar)) THEN + BindNodes(OPT.Neguard, x^.typ, z, NIL); x := z + END + ELSIF (x^.typ^.comp = OPT.Array) & (x^.typ^.BaseTyp = OPT.chartyp) & + (y^.typ^.form = OPT.String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) + y^.typ := OPT.chartyp; y^.conval^.intval := 0; + Index(x, NewIntConst(0)) + END; + BindNodes(OPT.Nassign, OPT.notyp, x, y); + x^.subcl := OPT.assign; + END Assign; + + PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct); + VAR node: OPT.Node; + BEGIN + node := OPT.NewNode(OPT.Ninittd); node^.typ := typ; + node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos; + IF inittd = NIL THEN inittd := node ELSE last^.link := node END ; + last := node + END Inittd; + +BEGIN + maxExp := log(MAX(SYSTEM.INT64) DIV 2 + 1); maxExp := exp +END OPB. diff --git a/src/compiler/OPC.Mod b/src/compiler/OPC.Mod new file mode 100644 index 00000000..80e6bd66 --- /dev/null +++ b/src/compiler/OPC.Mod @@ -0,0 +1,1343 @@ +MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) +(* C source code generator version + + 30.4.2000 jt, synchronized with BlackBox version, in particular + various promotion rules changed (long) => (LONGINT), xxxL avoided +*) + + IMPORT OPT, OPM, Configuration, SYSTEM; + + CONST demoVersion = FALSE; + + + CONST + UndefinedType = 0; (* named type not yet defined *) + ProcessingType = 1; (* pointer type is being processed *) + PredefinedType = 2; (* for all predefined types *) + + DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) + DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) + + BasicIncludeFile = "SYSTEM"; + + Export = "export "; (* particularily introduced for VC++ declspec() *) + Extern = "import "; (* particularily introduced for VC++ declspec() *) + LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) + GlobalScope = "_s"; (* pointer to current scope extension *) + LinkName = "lnk"; (* pointer to previous scope field *) + FlagExt = "__h"; + LenExt = "__len"; + DynTypExt = "__typ"; + TagExt = "__typ"; + Tab = 9X; + + (* The following are defined as hex to avoid confusing editor syntax highlighting *) + Backslash = 5CX; + DoubleQuote = 22X; + + + VAR + indentLevel: INTEGER; + hashtab: ARRAY 105 OF SHORTINT; + keytab: ARRAY 50, 9 OF CHAR; + GlbPtrs: BOOLEAN; + BodyNameExt: ARRAY 13 OF CHAR; + + + PROCEDURE Init*; + BEGIN + indentLevel := 0; + BodyNameExt := "__init(void)" + END Init; + + PROCEDURE Indent* (count: INTEGER); + BEGIN INC(indentLevel, count) + END Indent; + + PROCEDURE BegStat*; + VAR i: INTEGER; + BEGIN i := indentLevel; + WHILE i > 0 DO OPM.Write(Tab); DEC (i) END + END BegStat; + + PROCEDURE EndStat*; + BEGIN OPM.Write(';'); OPM.WriteLn + END EndStat; + + PROCEDURE BegBlk*; + BEGIN OPM.Write('{'); OPM.WriteLn; INC(indentLevel) + END BegBlk; + + PROCEDURE EndBlk*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}'); OPM.WriteLn + END EndBlk; + + PROCEDURE EndBlk0*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}') + END EndBlk0; + + PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); + VAR ch: CHAR; i: INTEGER; + BEGIN ch := s[0]; i := 0; + WHILE ch # 0X DO + IF ch = "#" THEN OPM.WriteInt(x) + ELSE OPM.Write(ch); + END ; + INC(i); ch := s[i] + END + END Str1; + + PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO INC(i) END ; + RETURN i + END Length; + + PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; + VAR i, h: INTEGER; + BEGIN i := 0; h := 0; + WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; + RETURN h MOD 105 + END PerfectHash; + + PROCEDURE Ident* (obj: OPT.Object); + VAR mode, level, h: INTEGER; + BEGIN + mode := obj^.mode; level := obj^.mnolev; + IF (mode IN {OPT.Var, OPT.Typ, OPT.LProc}) & (level > 0) OR (mode IN {OPT.Fld, OPT.VarPar}) THEN + OPM.WriteStringVar(obj^.name); + h := PerfectHash(obj^.name); + IF hashtab[h] >= 0 THEN + IF keytab[hashtab[h]] = obj^.name THEN OPM.Write('_') END + END + ELSIF (mode = OPT.Typ) & (obj.typ.form IN {OPT.Int, OPT.Set}) THEN + IF obj.typ = OPT.adrtyp THEN OPM.WriteString("ADDRESS") + ELSE + IF obj.typ.form = OPT.Int THEN OPM.WriteString("INT") ELSE OPM.WriteString("UINT") END; + OPM.WriteInt(obj.typ.size*8) + END + ELSE + IF (mode # OPT.Typ) OR (obj^.linkadr # PredefinedType) THEN + IF mode = OPT.TProc THEN Ident(obj^.link^.typ^.strobj) + ELSIF level < 0 THEN (* use unaliased module name *) + OPM.WriteStringVar(OPT.GlbMod[-level].name); + IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; + ELSE OPM.WriteStringVar(OPM.modName) + END ; + OPM.Write('_') + ELSIF (obj = OPT.sysptrtyp^.strobj) + OR (obj = OPT.bytetyp^.strobj) THEN + OPM.WriteString("SYSTEM_") + END; + OPM.WriteStringVar(obj^.name); + END + END Ident; + + PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); + VAR pointers: INTEGER; + BEGIN + openClause := FALSE; + IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # OPT.Record) THEN + IF typ^.comp IN {OPT.Array, OPT.DynArr} THEN + Stars (typ^.BaseTyp, openClause); + openClause := (typ^.comp = OPT.Array) + ELSIF typ^.form = OPT.ProcTyp THEN + OPM.Write('('); OPM.Write('*') + ELSE + pointers := 0; + (*WHILE (typ^.strobj = NIL) & (typ^.form = OPT.Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; + IF (typ^.comp # OPT.DynArr) & (pointers # 0) THEN Stars (typ, openClause) END ;*) + WHILE ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.form = OPT.Pointer) DO + INC (pointers); typ := typ^.BaseTyp + END ; + IF pointers > 0 THEN + IF typ^.comp # OPT.DynArr THEN Stars (typ, openClause) END ; + IF openClause THEN OPM.Write('('); openClause := FALSE END ; + WHILE pointers > 0 DO OPM.Write('*'); DEC (pointers) END + END + END + END + END Stars; + + PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + + PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); + VAR + typ: OPT.Struct; + varPar, openClause: BOOLEAN; form, comp: INTEGER; + BEGIN + typ := dcl^.typ; + varPar := ((dcl^.mode = OPT.VarPar) & (typ^.comp # OPT.Array)) OR (typ^.comp = OPT.DynArr) OR scopeDef; + Stars(typ, openClause); + IF varPar THEN + IF openClause THEN OPM.Write('(') END ; + OPM.Write('*') + END ; + IF dcl.name # "" THEN Ident(dcl) END ; + IF varPar & openClause THEN OPM.Write(')') END ; + openClause := FALSE; + LOOP + form := typ^.form; + comp := typ^.comp; + IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = OPT.NoTyp) OR (comp = OPT.Record) THEN EXIT + ELSIF (form = OPT.Pointer) & (typ^.BaseTyp^.comp # OPT.DynArr) THEN + openClause := TRUE + ELSIF (form = OPT.ProcTyp) OR (comp IN {OPT.Array, OPT.DynArr}) THEN + IF openClause THEN OPM.Write(')'); openClause := FALSE END ; + IF form = OPT.ProcTyp THEN + OPM.Write(")"); AnsiParamList(typ^.link, FALSE); + EXIT + ELSIF comp = OPT.Array THEN + OPM.Write('['); OPM.WriteInt(typ^.n); OPM.Write(']') + END + ELSE + EXIT + END ; + typ := typ^.BaseTyp + END + END DeclareObj; + + PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) + BEGIN + IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN + OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) + ELSE Ident(typ^.strobj) + END + END Andent; + + PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; + BEGIN + (* imported anonymous types have obj^.name = ""; + used e.g. for repeating inherited fields *) + RETURN (obj^.name = "") + OR (obj^.mnolev >= 0) + & (obj^.linkadr # 3+OPM.currFile ) + & (obj^.linkadr # PredefinedType) + END Undefined; + + PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + + PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) + VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; + BEGIN + typ := dcl^.typ; prev := typ; + WHILE ((typ^.strobj = NIL) OR (typ^.comp = OPT.DynArr) OR Undefined(typ^.strobj)) + & (typ^.comp # OPT.Record) + & (typ^.form # OPT.NoTyp) + & ~((typ^.form = OPT.Pointer) & (typ^.BaseTyp^.comp = OPT.DynArr)) DO + prev := typ; typ := typ^.BaseTyp; + END ; + obj := typ^.strobj; + IF typ^.form = OPT.NoTyp THEN (* proper procedure *) + OPM.WriteString('void') + ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) + Ident(obj) + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString('struct '); Andent(typ); + IF (prev.form # OPT.Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN + (* named record type not yet declared OR anonymous record with empty name *) + IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # OPT.internal) THEN + OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) + ELSE OPM.Write(' '); BegBlk + END ; + FieldList(typ, TRUE, off, n, dummy); + EndBlk0 + END + ELSIF (typ^.form = OPT.Pointer) & (typ^.BaseTyp^.comp = OPT.DynArr) THEN + typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; + WHILE typ^.comp = OPT.DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; + OPM.WriteString('struct '); BegBlk; + BegStat; Str1("ADDRESS len[#]", nofdims); EndStat; + BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) + obj.typ.form := OPT.Comp; obj.typ.comp := OPT.Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := OPT.Fld; obj.name := "data"; + obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(' '); DeclareObj(obj, FALSE); + EndStat; EndBlk0 + END + END DeclareBase; + + PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; + VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; + BEGIN + IF (typ^.form = OPT.Pointer) & (typ^.sysflag = 0) THEN RETURN 1 + ELSIF (typ^.comp = OPT.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO + IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) + ELSE INC(n) + END ; + fld := fld^.link + END ; + RETURN n + ELSIF typ^.comp = OPT.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPT.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + RETURN NofPtrs(btyp) * n + ELSE RETURN 0 + END + END NofPtrs; + + PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); + VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; + BEGIN + IF (typ^.form = OPT.Pointer) & (typ^.sysflag = 0) THEN + OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + ELSIF (typ^.comp = OPT.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO + IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) + ELSE + OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + END ; + fld := fld^.link + END + ELSIF typ^.comp = OPT.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPT.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + IF NofPtrs(btyp) > 0 THEN i := 0; + WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END + END + END + END PutPtrOffsets; + + PROCEDURE InitTProcs(typ, obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitTProcs(typ, obj^.left); + IF obj^.mode = OPT.TProc THEN + BegStat; + OPM.WriteString("__INITBP("); + Ident(typ); OPM.WriteString(', '); Ident(obj); + Str1(", #)", obj^.adr DIV 10000H); + EndStat + END ; + InitTProcs(typ, obj^.right) + END + END InitTProcs; + + PROCEDURE PutBase(typ: OPT.Struct); + BEGIN + IF typ # NIL THEN + PutBase(typ^.BaseTyp); + Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") + END + END PutBase; + + PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); + VAR typ: OPT.Struct; dim: INTEGER; + BEGIN + IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; + dim := 1; typ := par^.typ^.BaseTyp; + WHILE typ^.comp = OPT.DynArr DO + IF ansiDefine THEN OPM.WriteString(", ADDRESS ") ELSE OPM.WriteString(', ') END ; + IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp; INC(dim) + END + END LenList; + + PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); + BEGIN + OPM.Write('('); + WHILE par # NIL DO + IF macro THEN OPM.WriteStringVar(par.name) + ELSE + IF (par^.mode = OPT.Var) & (par^.typ^.form = OPT.Real) THEN OPM.Write("_") END ; + Ident(par) + END ; + IF par^.typ^.comp = OPT.DynArr THEN + OPM.WriteString(', '); LenList(par, FALSE, TRUE); + ELSIF (par^.mode = OPT.VarPar) & (par^.typ^.comp = OPT.Record) THEN + OPM.WriteString(', '); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) + END ; + par := par^.link; + IF par # NIL THEN OPM.WriteString(', ') END + END ; + OPM.Write(')') + END DeclareParams; + + PROCEDURE ^DefineType(str: OPT.Struct); + PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); + + PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a OPT.TProc definition *) + VAR par: OPT.Object; + BEGIN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + par := obj^.link; WHILE par # NIL DO DefineType(par^.typ); par := par^.link END + END DefineTProcTypes; + + PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DeclareTProcs(obj^.left, empty); + IF obj^.mode = OPT.TProc THEN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + IF OPM.currFile = OPM.HeaderFile THEN + IF obj^.vis = OPT.external THEN + DefineTProcTypes(obj); + OPM.WriteString(Extern); empty := FALSE; + ProcHeader(obj, FALSE) + END + ELSE empty := FALSE; + DefineTProcTypes(obj); + IF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE) + END + END ; + DeclareTProcs(obj^.right, empty) + END + END DeclareTProcs; + + PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; + VAR typ, base: OPT.Struct; mno: LONGINT; + BEGIN typ := obj^.link^.typ; (* receiver type *) + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; + WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; + OPT.FindField(obj^.name, typ, obj); + RETURN obj + END BaseTProc; + + PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DefineTProcMacros(obj^.left, empty); + IF (obj^.mode = OPT.TProc) & (obj = BaseTProc(obj)) THEN + IF (OPM.currFile = OPM.BodyFile) OR ((OPM.currFile = OPM.HeaderFile) & (obj^.vis = OPT.external)) THEN + OPM.WriteString("#define __"); + Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.WriteString(" __SEND("); + IF obj^.link^.typ^.form = OPT.Pointer THEN + OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") + ELSE Ident(obj^.link); OPM.WriteString(TagExt) + END ; + Str1(", #, ", obj^.adr DIV 10000H); + IF obj^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(obj^.typ^.strobj) END ; + OPM.WriteString("(*)"); + AnsiParamList(obj^.link, FALSE); + OPM.WriteString(", "); + DeclareParams(obj^.link, TRUE); + OPM.Write(")"); OPM.WriteLn + END + END ; + DefineTProcMacros(obj^.right, empty) + END + END DefineTProcMacros; + + PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) + VAR obj, field, par: OPT.Object; empty: BOOLEAN; + BEGIN + IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) OR ((OPM.currFile = OPM.HeaderFile) & (str^.strobj # NIL) & (str^.strobj^.vis = OPT.external)) THEN + obj := str^.strobj; + IF (obj = NIL) OR Undefined(obj) THEN + IF obj # NIL THEN (* check for cycles *) + IF obj^.linkadr = ProcessingType THEN + IF str^.form # OPT.Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END + ELSE obj^.linkadr := ProcessingType + END + END ; + IF str^.comp = OPT.Record THEN + (* the following exports the base type of an exported type even if the former is non-exported *) + IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE (field # NIL) & (field^.mode = OPT.Fld) DO + IF (field^.vis # OPT.internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; + field := field^.link + END + ELSIF str^.form = OPT.Pointer THEN + IF str^.BaseTyp^.comp # OPT.Record THEN DefineType(str^.BaseTyp) END + ELSIF str^.comp IN {OPT.Array, OPT.DynArr} THEN + IF (str^.BaseTyp^.strobj # NIL) & (str^.BaseTyp^.strobj^.linkadr = ProcessingType) THEN (*cyclic base type*) + OPM.Mark(244, str^ .txtpos); str^.BaseTyp^.strobj^.linkadr := PredefinedType + END ; + DefineType(str^.BaseTyp) + ELSIF str^.form = OPT.ProcTyp THEN + IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE field # NIL DO DefineType(field^.typ); field := field^.link END + END + END ; + IF (obj # NIL) & Undefined(obj) THEN + OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); + obj^.linkadr := ProcessingType; + DeclareBase(obj); OPM.Write(' '); + obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) + DeclareObj(obj, FALSE); + obj^.typ^.strobj := obj; (* SG: revert trick *) + obj^.linkadr := 3+OPM.currFile; + EndStat; Indent(-1); OPM.WriteLn; + IF obj^.typ^.comp = OPT.Record THEN empty := TRUE; + DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); + IF ~empty THEN OPM.WriteLn END + ELSIF (obj^.typ^.form = OPT.Pointer) & (obj^.typ^.BaseTyp^.comp = OPT.Record) THEN + empty := TRUE; + DeclareTProcs(obj^.typ^.BaseTyp^.link, empty); + DefineTProcMacros(obj^.typ^.BaseTyp^.link, empty); + IF ~empty THEN OPM.WriteLn END + END + END + END + END DefineType; + + PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + BEGIN i := 0; + WHILE x[i+1] = y[i] DO INC(i) END; + RETURN y[i] = 0X; + END Prefixed; + + PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); + VAR i: INTEGER; ext: OPT.ConstExt; + BEGIN + IF obj # NIL THEN + CProcDefs(obj^.left, vis); + (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) + IF (obj^.mode = OPT.CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN + ext := obj.conval.ext; i := 1; + IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN + OPM.WriteString("#define "); Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.Write(Tab); + END ; + FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; + OPM.WriteLn + END ; + CProcDefs(obj^.right, vis) + END + END CProcDefs; + + PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); + BEGIN + IF obj # NIL THEN + TypeDefs(obj^.left, vis); + (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) + IF (obj^.mode = OPT.Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; + TypeDefs(obj^.right, vis) + END + END TypeDefs; + + PROCEDURE DefAnonRecs(n: OPT.Node); + VAR o: OPT.Object; typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO + typ := n^.typ; + IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN + DefineType(typ); (* declare base and field types, if any *) + NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn + (* simply defines a named struct, but not a type; + o.name = "" signals field list expansion for DeclareBase in this very special case *) + END ; + n := n^.link + END + END DefAnonRecs; + + PROCEDURE TDescDecl* (typ: OPT.Struct); + VAR nofptrs: LONGINT; + o: OPT.Object; + BEGIN + BegStat; OPM.WriteString("__TDESC("); + Andent(typ); + Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); + OPM.Write(DoubleQuote); + IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; + OPM.Write(DoubleQuote); + Str1(', #), {', typ^.size); + nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.AddressSize); + EndStat + END TDescDecl; + + PROCEDURE InitTDesc*(typ: OPT.Struct); + BEGIN + BegStat; OPM.WriteString("__INITYP("); + Andent(typ); OPM.WriteString(", "); + IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; + Str1(", #)", typ^.extlev); + EndStat; + IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END + END InitTDesc; + + PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); + (* gap: Required gap - already calculated based on alignment requirements + off: Current offset - where gap begins + align: Containing record type alignment + n: Next ordinal to use for private field names + curAlign: Largest alignment of any field so far + *) + VAR adr: LONGINT; + BEGIN + adr := off; OPT.Align(adr, align); + IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) + DEC(gap, (adr - off) + align); + BegStat; + CASE align OF + |2: OPM.WriteString("INT16") + |4: OPM.WriteString("INT32") + |8: OPM.WriteString("INT64") + ELSE OPM.LogWLn; OPM.LogWStr("Unexpected enclosing alignment in FillGap.") + END; + Str1(" _prvt#", n); INC(n); EndStat; + curAlign := align + END ; + IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END + END FillGap; + + PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; + BEGIN + fld := typ.link; + align := typ^.align MOD 10000H; + IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) + ELSE off := 0; n := 0; curAlign := 1 + END; + (* off: Current offset into record + align: Overall (RECORD) alignment + curAlign: Current alignment - largest alignment of any field so far + n: Next ordinal to use for private field names + *) + WHILE (fld # NIL) & (fld.mode = OPT.Fld) DO + IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = OPT.internal) + OR (OPM.currFile = OPM.BodyFile) & (fld.vis = OPT.internal) & (typ^.mno # 0) THEN + (* Skip private fields *) + fld := fld.link; + WHILE (fld # NIL) & (fld.mode = OPT.Fld) & (fld.vis = OPT.internal) DO fld := fld.link END; + ELSE + (* mimic OPV.TypSize to detect gaps caused by private fields *) + adr := off; + fldAlign := OPT.BaseAlignment(fld^.typ); + OPT.Align(adr, fldAlign); + gap := fld.adr - adr; + IF fldAlign > curAlign THEN curAlign := fldAlign END; + IF gap > 0 THEN + FillGap(gap, off, align, n, curAlign) + END; + BegStat; DeclareBase(fld); OPM.Write(' '); DeclareObj(fld, FALSE); + off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; + WHILE (fld # NIL) + & (fld.mode = OPT.Fld) + & (fld.typ = base) + & (fld.adr = off) +(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # OPT.internal) OR (fld.typ.strobj = NIL)) DO + OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link + END; + EndStat + END + END; + IF last THEN + adr := typ.size - typ^.sysflag DIV 100H; + IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; + IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END + END + END FieldList; + + PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); + (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) + VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; + BEGIN + base := NIL; first := TRUE; + WHILE (obj # NIL) & (obj^.mode # OPT.TProc) DO + IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN + IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) + IF ~first THEN EndStat END ; + first := FALSE; + base := obj^.typ; lastvis := obj^.vis; + BegStat; + IF (vis = 1) & (obj^.vis # OPT.internal) THEN OPM.WriteString(Extern) + ELSIF (obj^.mnolev = 0) & (vis = 0) THEN + IF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END + END ; + IF (vis = 2) & (obj^.mode = OPT.Var) & (base^.form = OPT.Real) THEN OPM.WriteString("double") + ELSE DeclareBase(obj) + END + ELSE OPM.Write(","); + END ; + OPM.Write(' '); + IF (vis = 2) & (obj^.mode = OPT.Var) & (base^.form = OPT.Real) THEN OPM.Write("_") END ; + DeclareObj(obj, vis = 3); + IF obj^.typ^.comp = OPT.DynArr THEN (* declare len parameter(s) *) + EndStat; BegStat; + base := OPT.adrtyp; + OPM.WriteString("ADDRESS "); LenList(obj, FALSE, TRUE) + ELSIF (obj^.mode = OPT.VarPar) & (obj^.typ^.comp = OPT.Record) THEN + EndStat; BegStat; + OPM.WriteString("ADDRESS *"); Ident(obj); OPM.WriteString(TagExt); + base := NIL + ELSIF (OPM.ptrinit IN OPM.Options) & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = OPT.Pointer) THEN + OPM.WriteString(" = NIL") + END + END ; + obj := obj^.link + END ; + IF ~first THEN EndStat END + END IdentList; + + PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + VAR name: ARRAY 32 OF CHAR; + BEGIN + OPM.Write("("); + IF (obj = NIL) OR (obj^.mode = OPT.TProc) THEN OPM.WriteString("void") + ELSE + LOOP + DeclareBase(obj); + IF showParamNames THEN + OPM.Write(' '); DeclareObj(obj, FALSE) + ELSE + COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) + END ; + IF obj^.typ^.comp = OPT.DynArr THEN + OPM.WriteString(", ADDRESS "); + LenList(obj, TRUE, showParamNames) + ELSIF (obj^.mode = OPT.VarPar) & (obj^.typ^.comp = OPT.Record) THEN + OPM.WriteString(", ADDRESS *"); + IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END + END ; + IF (obj^.link = NIL) OR (obj^.link.mode = OPT.TProc) THEN EXIT END ; + OPM.WriteString(", "); + obj := obj^.link + END + END ; + OPM.Write(")") + END AnsiParamList; + + PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); + BEGIN + IF proc^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(proc^.typ^.strobj) END ; + OPM.Write(' '); Ident(proc); OPM.Write(' '); + AnsiParamList(proc^.link, TRUE); + IF ~define THEN OPM.Write(";") END ; + OPM.WriteLn + END ProcHeader; + + PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) + BEGIN + IF obj # NIL THEN + ProcPredefs(obj^.left, vis); + IF (obj^.mode IN {OPT.LProc, OPT.XProc}) & (obj^.vis >= vis) & ((obj^.history # OPT.removed) OR (obj^.mode = OPT.LProc)) THEN + (* previous OPT.XProc may be deleted or become OPT.LProc after interface change*) + IF vis = OPT.external THEN OPM.WriteString(Extern) + ELSIF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE); + END ; + ProcPredefs(obj^.right, vis); + END; + END ProcPredefs; + + PROCEDURE Include(name: ARRAY OF CHAR); + BEGIN + OPM.WriteString("#include "); OPM.Write(DoubleQuote); OPM.WriteStringVar(name); + OPM.WriteString(".h"); OPM.Write(DoubleQuote); OPM.WriteLn + END Include; + + PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); + BEGIN + IF obj # NIL THEN + IncludeImports(obj^.left, vis); + IF (obj^.mode = OPT.Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) + Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) + END; + IncludeImports(obj^.right, vis); + END; + END IncludeImports; + + PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); + VAR typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO + typ := n^.typ; + IF (vis = OPT.internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN + BegStat; + IF vis = OPT.external THEN OPM.WriteString(Extern) + ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + OPM.WriteString("ADDRESS *"); Andent(typ); OPM.WriteString(DynTypExt); + EndStat + END ; + n := n^.link + END + END GenDynTypes; + + PROCEDURE GenHdr*(n: OPT.Node); + BEGIN + (* includes are delayed until it is known which ones are needed in the header *) + OPM.currFile := OPM.HeaderFile; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; + GenDynTypes(n, OPT.external); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 1); + OPM.WriteString(Extern); OPM.WriteString("void *"); + OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); + EndStat; OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; + OPM.WriteString("#endif // "); OPM.WriteStringVar(OPM.modName); OPM.WriteLn + END GenHdr; + + PROCEDURE GenHeaderMsg; + VAR i: INTEGER; + BEGIN + OPM.WriteString("/* "); OPM.WriteString(Configuration.name); + OPM.Write(" "); OPM.WriteString(Configuration.versionLong); OPM.Write (" "); (* noch *) + FOR i := 0 TO MAX(SET) DO + IF i IN OPM.Options THEN + CASE i OF (* c.f. ScanOptions in OPM *) + | OPM.inxchk: OPM.Write("x") + | OPM.ranchk: OPM.Write("r") + | OPM.typchk: OPM.Write("t") + | OPM.newsf: OPM.Write("s") + | OPM.ptrinit: OPM.Write("p") + | OPM.assert: OPM.Write("a") + | OPM.extsf: OPM.Write("e") + | OPM.mainprog: OPM.Write("m") + | OPM.dontasm: OPM.Write("S") + | OPM.dontlink: OPM.Write("c") + | OPM.mainlinkstat: OPM.Write("M") + | OPM.notcoloroutput: OPM.Write("f") + | OPM.forcenewsym: OPM.Write("F") + | OPM.verbose: OPM.Write("v") + ELSE OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; + END + END + END; + OPM.WriteString(" */"); OPM.WriteLn + END GenHeaderMsg; + + PROCEDURE GenHdrIncludes*; + BEGIN + OPM.currFile := OPM.HeaderInclude; + GenHeaderMsg; + OPM.WriteLn; + OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteLn; + + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn + END GenHdrIncludes; + + PROCEDURE GenBdy*(n: OPT.Node); + BEGIN + OPM.currFile := OPM.BodyFile; + GenHeaderMsg; + OPM.WriteLn; + + (* Define model dependent type sizes *) + OPM.WriteString("#define SHORTINT INT"); OPM.WriteInt(OPT.sinttyp.size*8); OPM.WriteLn; + OPM.WriteString("#define INTEGER INT"); OPM.WriteInt(OPT.inttyp.size*8); OPM.WriteLn; + OPM.WriteString("#define LONGINT INT"); OPM.WriteInt(OPT.linttyp.size*8); OPM.WriteLn; + OPM.WriteString("#define SET UINT"); OPM.WriteInt(OPT.settyp.size*8); OPM.WriteLn; + OPM.WriteLn; + + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; + GenDynTypes(n, OPT.internal); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn + END GenBdy; + + PROCEDURE RegCmds(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + RegCmds(obj^.left); + IF (obj^.mode = OPT.XProc) & (obj^.history # OPT.removed) THEN + IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) + BegStat; OPM.WriteString('__REGCMD("'); + OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat + END + END ; + RegCmds(obj^.right) + END + END RegCmds; + + PROCEDURE InitImports(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitImports(obj^.left); + IF (obj^.mode = OPT.Mod) & (obj^.mnolev # 0) THEN + BegStat; OPM.WriteString("__MODULE_IMPORT("); + OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); + OPM.Write(')'); EndStat + END ; + InitImports(obj^.right) + END + END InitImports; + + PROCEDURE GenEnumPtrs* (var: OPT.Object); + VAR typ: OPT.Struct; n: LONGINT; + BEGIN GlbPtrs := FALSE; + WHILE var # NIL DO + typ := var^.typ; + IF NofPtrs(typ) > 0 THEN + IF ~GlbPtrs THEN GlbPtrs := TRUE; + OPM.WriteString("static void EnumPtrs(void (*P)(void*))"); OPM.WriteLn; + BegBlk + END ; + BegStat; + IF typ^.form = OPT.Pointer THEN + OPM.WriteString("P("); Ident(var); OPM.Write(")"); + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") + ELSIF typ^.comp = OPT.Array THEN + n := typ^.n; typ := typ^.BaseTyp; + WHILE typ^.comp = OPT.Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN + OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) + END + END ; + EndStat + END ; + var := var^.link + END ; + IF GlbPtrs THEN + EndBlk; OPM.WriteLn + END + END GenEnumPtrs; + + PROCEDURE EnterBody*; + BEGIN + OPM.WriteLn; OPM.WriteString(Export); + IF OPM.mainprog IN OPM.Options THEN + OPM.WriteString("int main(int argc, char **argv)"); OPM.WriteLn; + ELSE + OPM.WriteString("void *"); + OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; + END ; + BegBlk; BegStat; + IF OPM.mainprog IN OPM.Options THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; + EndStat; + IF (OPM.mainprog IN OPM.Options) & demoVersion THEN BegStat; + OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); + EndStat + END ; + InitImports(OPT.topScope^.right); + BegStat; + IF OPM.mainprog IN OPM.Options THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; + OPM.WriteString(OPM.modName); + IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; + EndStat; + IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END + END EnterBody; + + PROCEDURE ExitBody*; + BEGIN + BegStat; + IF OPM.mainprog IN OPM.Options THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; + OPM.WriteLn; EndBlk + END ExitBody; + + PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) + VAR scope: OPT.Object; + BEGIN + scope := proc^.scope; + OPM.WriteString('static '); OPM.WriteString('struct '); OPM.WriteStringVar(scope^.name); OPM.Write(' '); + BegBlk; + IdentList(proc^.link, 3); (* parameters *) + IdentList(scope^.scope, 3); (* local variables *) + BegStat; (* scope link field declaration *) + OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.Write('*'); OPM.WriteString(LinkName); EndStat; + EndBlk0; OPM.Write(' '); + OPM.Write('*'); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; + ProcPredefs (scope^.right, 0); + OPM.WriteLn; + END DefineInter; + + PROCEDURE NeedsRetval*(proc: OPT.Object): BOOLEAN; (* aux. variable __retval needed for return *) + BEGIN (* simple rule; ignores DUPlicated value arrays because they use alloca. *) + RETURN (proc^.typ # OPT.notyp) & ~proc^.scope^.leaf + END NeedsRetval; + + PROCEDURE EnterProc* (proc: OPT.Object); + VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; + BEGIN + IF proc^.vis # OPT.external THEN OPM.WriteString('static ') END ; + ProcHeader(proc, TRUE); + BegBlk; + scope := proc^.scope; + IdentList(scope^.scope, 0); + IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) + BegStat; OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.WriteString(LocalScope); EndStat + END ; + IF NeedsRetval(proc) THEN BegStat; Ident(proc^.typ^.strobj); OPM.WriteString(" __retval"); EndStat END; + var := proc^.link; + WHILE var # NIL DO (* declare copy of fixed size value array parameters *) + IF (var^.typ^.comp = OPT.Array) & (var^.mode = OPT.Var) THEN + BegStat; + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; + OPM.Write(' '); Ident(var); OPM.WriteString("__copy"); + EndStat + END ; + var := var^.link + END ; + var := proc^.link; + WHILE var # NIL DO (* copy value array parameters *) + IF (var^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (var^.mode = OPT.Var) & (var^.typ^.sysflag = 0) THEN + BegStat; + IF var^.typ^.comp = OPT.Array THEN + OPM.WriteString("__DUPARR("); + Ident(var); OPM.WriteString(', '); + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END + ELSE + OPM.WriteString('__DUP('); + Ident(var); OPM.WriteString(', '); Ident(var); OPM.WriteString(LenExt); + typ := var^.typ^.BaseTyp; dim := 1; + WHILE typ^.comp = OPT.DynArr DO + OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); + typ := typ^.BaseTyp; INC(dim) + END ; + OPM.WriteString(', '); + IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) + ELSE Ident(typ^.strobj) + END + END ; + OPM.Write(')'); EndStat + END ; + var := var^.link + END ; + IF ~scope^.leaf THEN + var := proc^.link; (* copy addresses of parameters into local scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); + OPM.WriteString(' = '); + IF var^.typ^.comp IN {OPT.Array, OPT.DynArr} THEN OPM.WriteString("(void*)") + (* K&R and ANSI differ in the type: array or element type*) + ELSIF var^.mode # OPT.VarPar THEN OPM.Write("&") + END ; + Ident(var); + IF var^.typ^.comp = OPT.DynArr THEN + typ := var^.typ; dim := 0; + REPEAT (* copy len(s) *) + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + OPM.WriteString(' = '); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp + UNTIL typ^.comp # OPT.DynArr; + ELSIF (var^.mode = OPT.VarPar) & (var^.typ^.comp = OPT.Record) THEN + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(TagExt); + OPM.WriteString(' = '); Ident(var); OPM.WriteString(TagExt) + END ; + EndStat + END; + var := var^.link; + END; + var := scope^.scope; (* copy addresses of local variables into scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(' = '); + IF var^.typ^.comp # OPT.Array THEN OPM.Write("&") + ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) + END ; + Ident(var); EndStat + END ; + var := var^.link + END; + (* now link new scope *) + BegStat; OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + OPM.WriteString(' = '); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; + BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(' = '); + OPM.Write("&"); OPM.WriteString(LocalScope); EndStat + END + END EnterProc; + + PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); + VAR var: OPT.Object; indent: BOOLEAN; + BEGIN + indent := eoBlock; + IF implicitRet & (proc^.typ # OPT.notyp) THEN + OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn + ELSIF ~eoBlock OR implicitRet THEN + IF ~proc^.scope^.leaf THEN + (* link scope pointer of nested proc back to previous scope *) + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString(' = '); OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + EndStat + END; + (* delete array value parameters *) + var := proc^.link; + WHILE var # NIL DO + IF (var^.typ^.comp = OPT.DynArr) & (var^.mode = OPT.Var) & (var^.typ^.sysflag = 0) THEN + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteString('__DEL('); Ident(var); OPM.Write(')'); EndStat + END ; + var := var^.link + END + END ; + IF eoBlock THEN EndBlk; OPM.WriteLn + ELSIF indent THEN BegStat + END + END ExitProc; + + PROCEDURE CompleteIdent*(obj: OPT.Object); + VAR comp, level: INTEGER; + BEGIN + (* obj^.mode IN {OPT.Var, OPT.VarPar} *) + level := obj^.mnolev; + IF obj^.adr = 1 THEN (* WITH-variable *) + IF obj^.typ^.comp = OPT.Record THEN Ident(obj); OPM.WriteString("__") + ELSE (* cast with guard pointer type *) + OPM.WriteString("(*("); Ident(obj^.typ^.strobj); OPM.WriteString("*)&"); Ident(obj); OPM.Write(")") + END + ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) + comp := obj^.typ^.comp; + IF (obj^.mode # OPT.VarPar) & (comp # OPT.DynArr) THEN OPM.Write('*'); END; + OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString("->"); Ident(obj) + ELSE + Ident(obj) + END + END CompleteIdent; + + PROCEDURE TypeOf*(ap: OPT.Object); + VAR i: INTEGER; + BEGIN + ASSERT(ap.typ.comp = OPT.Record); + IF ap.mode = OPT.VarPar THEN + IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) + OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) + ELSE (*local var-par record*) + Ident(ap) + END ; + OPM.WriteString(TagExt) + ELSIF ap^.typ^.strobj # NIL THEN + Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) + ELSE Andent(ap.typ) (*anonymous ap type, p^ *) + END + END TypeOf; + + PROCEDURE Cmp*(rel: INTEGER); + BEGIN + CASE rel OF + | OPT.eql: OPM.WriteString(" == ") + | OPT.neq: OPM.WriteString(" != ") + | OPT.lss: OPM.WriteString(" < ") + | OPT.leq: OPM.WriteString(" <= ") + | OPT.gtr: OPM.WriteString(" > ") + | OPT.geq: OPM.WriteString(" >= ") + ELSE OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; + END; + END Cmp; + + PROCEDURE CharacterLiteral(c: SYSTEM.INT64); + BEGIN + IF (c < 32) OR (c > 126) THEN + OPM.WriteString("0x"); OPM.WriteHex(c) + ELSE + OPM.Write("'"); + IF (c = ORD(Backslash)) OR (c = ORD("'")) OR (c = ORD("?")) THEN + OPM.Write(Backslash) + END; + OPM.Write(CHR(c)); + OPM.Write("'") + END + END CharacterLiteral; + + PROCEDURE StringLiteral(s: ARRAY OF CHAR; l: LONGINT); + VAR i: LONGINT; c: INTEGER; + BEGIN + OPM.Write(DoubleQuote); + i := 0; WHILE i < l DO + c := ORD(s[i]); + IF (c < 32) OR (c > 126) THEN + (* Encode binary character value using exactly 3 octal digits. + Use octal in preference to hex as only the octal escape + syntax ensures a subsequent character will not be absorbed + into this literal. *) + OPM.Write(Backslash); + OPM.Write(CHR(ORD("0") + c DIV 64)); c := c MOD 64; + OPM.Write(CHR(ORD("0") + c DIV 8)); c := c MOD 8; + OPM.Write(CHR(ORD("0") + c)) + ELSE + IF (c = ORD(Backslash)) OR (c = ORD(DoubleQuote)) OR (c = ORD("?")) THEN + OPM.Write(Backslash) + END; + OPM.Write(CHR(c)); + END; + INC(i); + END; + OPM.Write(DoubleQuote) + END StringLiteral; + + PROCEDURE Case*(caseVal: SYSTEM.INT64; form: INTEGER); + VAR + ch: CHAR; + BEGIN + OPM.WriteString('case '); + CASE form OF + | OPT.Char: CharacterLiteral(caseVal) + | OPT.Int: OPM.WriteInt(caseVal); + ELSE OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + OPM.WriteString(': '); + END Case; + + PROCEDURE SetInclude* (exclude: BOOLEAN); + BEGIN + IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; + END SetInclude; + + PROCEDURE Increment* (decrement: BOOLEAN); + BEGIN + IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; + END Increment; + + PROCEDURE Halt* (n: LONGINT); + BEGIN + Str1("__HALT(#)", n) + END Halt; + + PROCEDURE IntLiteral*(n: SYSTEM.INT64; size: LONGINT); + BEGIN + IF (size > OPM.CIntSize) & (n <= OPM.CIntMax) & (n > OPM.CIntMin) THEN + OPM.WriteString("((INT"); OPM.WriteInt(size*8); OPM.WriteString(")("); + OPM.WriteInt(n); OPM.WriteString("))") + ELSE + OPM.WriteInt(n) + END + END IntLiteral; + + PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: SYSTEM.INT64); + VAR + d: SYSTEM.INT64; + BEGIN + d := dim; + WHILE d > 0 DO array := array^.BaseTyp; DEC(d) END; + IF array^.comp = OPT.DynArr THEN + CompleteIdent(obj); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END + ELSE (* array *) + OPM.WriteInt(array.n) + END + END Len; + + PROCEDURE Constant* (con: OPT.Const; form: INTEGER); + VAR i: INTEGER; s: SYSTEM.SET64; + hex: SYSTEM.INT64; skipLeading: BOOLEAN; + BEGIN + CASE form OF + | OPT.Byte: OPM.WriteInt(con^.intval) + | OPT.Bool: OPM.WriteInt(con^.intval) + | OPT.Char: CharacterLiteral(con.intval) + | OPT.Int: OPM.WriteInt(con^.intval) + | OPT.Real: OPM.WriteReal(con^.realval, "f") + | OPT.LReal: OPM.WriteReal(con^.realval, 0X) + | OPT.Set: OPM.WriteString("0x"); + skipLeading := TRUE; + s := con^.setval; i := MAX(SYSTEM.SET64) + 1; + REPEAT + hex := 0; + REPEAT + DEC(i); hex := 2 * hex; + IF i IN s THEN INC(hex) END + UNTIL i MOD 8 = 0; + IF (hex # 0) OR ~skipLeading THEN + OPM.WriteHex(hex); + skipLeading := FALSE + END + UNTIL i = 0; + IF skipLeading THEN OPM.Write("0") END + | OPT.String: StringLiteral(con.ext^, con.intval2-1) + | OPT.NilTyp: OPM.WriteString('NIL'); + ELSE OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + END Constant; + + + PROCEDURE InitKeywords; + VAR n, i: SHORTINT; + + PROCEDURE Enter(s: ARRAY OF CHAR); + VAR h: INTEGER; + BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) + END Enter; + + BEGIN n := 0; + FOR i := 0 TO LEN(hashtab)-1 DO hashtab[i] := -1 END ; + Enter("ADDRESS"); (* pseudo keyword used by voc *) + Enter("INT16"); (* pseudo keyword used by voc *) + Enter("INT32"); (* pseudo keyword used by voc *) + Enter("INT64"); (* pseudo keyword used by voc *) + Enter("INT8"); (* pseudo keyword used by voc *) + Enter("UINT16"); (* pseudo keyword used by voc *) + Enter("UINT32"); (* pseudo keyword used by voc *) + Enter("UINT64"); (* pseudo keyword used by voc *) + Enter("UINT8"); (* pseudo keyword used by voc *) + + Enter("asm"); + Enter("auto"); + Enter("break"); + Enter("case"); + Enter("char"); + Enter("const"); + Enter("continue"); + Enter("default"); + Enter("do"); + Enter("double"); + Enter("else"); + Enter("enum"); + Enter("extern"); + Enter("export"); (* pseudo keyword used by voc *) + Enter("float"); + Enter("for"); + Enter("fortran"); + Enter("goto"); + Enter("if"); + Enter("import"); (* pseudo keyword used by voc *) + Enter("int"); + Enter("long"); + Enter("register"); + Enter("return"); + Enter("short"); + Enter("signed"); + Enter("sizeof"); + Enter("size_t"); + Enter("static"); + Enter("struct"); + Enter("switch"); + Enter("typedef"); + Enter("union"); + Enter("unsigned"); + Enter("void"); + Enter("volatile"); + Enter("while"); + +(* what about common predefined names from cpp as e.g. + Operating System: ibm, gcos, os, tss and unix + Hardware: interdata, pdp11, u370, u3b, + u3b2, u3b5, u3b15, u3b20d, + vax, ns32000, iAPX286, i386, + sparc , and sun + UNIX system variant: + RES, and RT + The lint(1V) command: + lint + *) + END InitKeywords; + +BEGIN InitKeywords +END OPC. diff --git a/src/compiler/OPM.Mod b/src/compiler/OPM.Mod new file mode 100755 index 00000000..ab3d7dae --- /dev/null +++ b/src/compiler/OPM.Mod @@ -0,0 +1,865 @@ +MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) +(* constants needed for C code generation + + 31.1.2007 jt synchronized with BlackBox version, in particular PromoteIntConstToLInt added +*) + + IMPORT SYSTEM, Texts, Files, Platform, Modules, Out, Configuration, VT100, Strings; + + CONST + OptionChar* = "-"; + MaxCommentLen* = 1024; + + (* compiler option flag bits; don't change the encoding *) + inxchk* = 0; (* index check on *) + ranchk* = 2; (* range check on *) + typchk* = 3; (* type check on *) + newsf* = 4; (* generation of new symbol file allowed *) + ptrinit* = 5; (* pointer initialization *) + assert* = 7; (* assert evaluation *) + extsf* = 9; (* extension of old symbol file allowed *) + mainprog* = 10; (* translate module body into C main function *) + dontasm* = 13; (* don't call external assembler/C compiler *) + dontlink* = 14; (* don't link *) + mainlinkstat* = 15; (* generate code for main module and then link object file statically *) + notcoloroutput* = 16; (* turn off color output *) + forcenewsym* = 17; (* force new symbol file *) + verbose* = 18; (* verbose *) + + nilval* = 0; + + MaxRExp* = 38; + MaxLExp* = 308; + + MinHaltNr* = 0; + MaxHaltNr* = 255; + MaxSysFlag* = 1; + + MaxCC* = -1; (* SYSTEM.CC, GETREG, PUTREG; not implementable in C backend *) + MinRegNr* = 0; + MaxRegNr* = -1; + + LANotAlloc* = -1; (* XProc link adr initialization *) + ConstNotAlloc* = -1; (* for allocation of string and real constants *) + TDAdrUndef* = -1; (* no type desc allocated *) + + MaxCases* = 128; + MaxCaseRange* = 512; + + MaxStruct* = 255; + + (* maximal number of hidden fields in an exported record: *) + MaxHdFld* = 2048; + + HdPtrName* = "@ptr"; + HdProcName* = "@proc"; + HdTProcName* = "@tproc"; + + ExpHdPtrFld* = TRUE; + ExpHdProcFld* = FALSE; + ExpHdTProc* = FALSE; + + NEWusingAdr* = FALSE; + + Eot* = 0X; + + HeaderFile* = 0; + BodyFile* = 1; + HeaderInclude* = 2; + + (* C default expression integral size details. Const for now, should be var for avr_gcc/sdcc support *) + CIntSize* = 4; + CIntMax* = 7FFFFFFFH; + CIntMin* = -CIntMax - 1; + + + SFext = ".sym"; (* symbol file extension *) + BFext = ".c"; (* body file extension *) + HFext = ".h"; (* header file extension *) + SFtag = 0F7X; (* symbol file tag *) + SFver = 084X; (* symbol file version. Increment if symbol file format is changed. *) + + + TYPE + FileName = ARRAY 32 OF CHAR; + + VAR + currentComment: ARRAY MaxCommentLen OF CHAR; + hasComment: BOOLEAN; + + SourceFileName : ARRAY 256 OF CHAR; + + GlobalModel, Model*: ARRAY 10 OF CHAR; (* 2: S8/I16/L32, C: S16/I32/L64, V:S8/I32/L64 *) + GlobalAddressSize, AddressSize*: INTEGER; + GlobalAlignment, Alignment*: INTEGER; + GlobalOptions*, Options*: SET; + + ShortintSize*, IntegerSize*, LongintSize*, SetSize*: INTEGER; + + MaxIndex*: SYSTEM.INT64; + + MinReal*, MaxReal*, MinLReal*, MaxLReal*: LONGREAL; + + noerr*: BOOLEAN; + curpos*, errpos*: LONGINT; (* character and error position in source file *) + breakpc*: LONGINT; (* set by OPV.Init *) + currFile*: INTEGER; (* current output file *) + level*: INTEGER; (* procedure nesting level *) + pc*, entno*: INTEGER; (* entry number *) + modName*: ARRAY 32 OF CHAR; + objname*: ARRAY 64 OF CHAR; + + ErrorLineStartPos, ErrorLineLimitPos, ErrorLineNumber: LONGINT; (* Limit = start of next line *) + + lasterrpos: LONGINT; + inR: Texts.Reader; + Log, Errors: Texts.Text; + oldSF, newSF: Files.Rider; + R: ARRAY 3 OF Files.Rider; + + oldSFile, newSFile, HFile, BFile, HIFile: Files.File; + + S: INTEGER; + + InstallDir*: ARRAY 1024 OF CHAR; + ResourceDir*: ARRAY 1024 OF CHAR; + + + (* ------------------------- Log Output ------------------------- *) + + PROCEDURE LogW*(ch: CHAR); BEGIN Out.Char(ch) END LogW; + PROCEDURE LogWStr*(s: ARRAY OF CHAR); BEGIN Out.String(s) END LogWStr; + PROCEDURE LogWNum*(i, len: SYSTEM.INT64); BEGIN Out.Int(i, len) END LogWNum; + PROCEDURE LogWLn*; BEGIN Out.Ln END LogWLn; + + PROCEDURE LogVT100*(vt100code: ARRAY OF CHAR); + BEGIN + IF Out.IsConsole & ~(notcoloroutput IN Options) THEN + VT100.SetAttr(vt100code) + END + END LogVT100; + + PROCEDURE LogCompiling*(modname: ARRAY OF CHAR); + BEGIN + LogWStr("Compiling "); LogWStr(modname); + IF verbose IN Options THEN + LogWStr(", s:"); LogWNum(ShortintSize*8,1); + LogWStr( " i:"); LogWNum(IntegerSize*8,1); + LogWStr( " l:"); LogWNum(LongintSize*8,1); + LogWStr( " adr:"); LogWNum(AddressSize*8,1); + LogWStr( " algn:"); LogWNum(Alignment*8,1) + END; + LogW("."); + END LogCompiling; + + (* for exported comments *) + PROCEDURE StoreComment*(text: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (i < MaxCommentLen - 1) & (text[i] # 0X) DO + currentComment[i] := text[i]; INC(i) + END; + currentComment[i] := 0X; + hasComment := TRUE; + END StoreComment; + + PROCEDURE GetComment*(VAR text: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + IF hasComment THEN + i := 0; + WHILE (i < LEN(text)) & (i < MaxCommentLen) & (currentComment[i] # 0X) DO + text[i] := currentComment[i]; INC(i) + END; + text[i] := 0X; + hasComment := FALSE + ELSE + text[0] := 0X + END; + END GetComment; + + + (* Integer size support *) + + PROCEDURE SignedMaximum*(bytecount: LONGINT): SYSTEM.INT64; + VAR result: SYSTEM.INT64; + BEGIN + result := 1; + result := SYSTEM.LSH(result, bytecount*8-1); + RETURN result - 1; + END SignedMaximum; + + PROCEDURE SignedMinimum*(bytecount: LONGINT): SYSTEM.INT64; + BEGIN RETURN -SignedMaximum(bytecount) - 1 + END SignedMinimum; + + + (* Unchecked conversion of any size integer to INTEGER or LONGINT *) + + PROCEDURE Longint* (n: SYSTEM.INT64): LONGINT; BEGIN RETURN SYSTEM.VAL(LONGINT, n) END Longint; + PROCEDURE Integer* (n: SYSTEM.INT64): INTEGER; BEGIN RETURN SYSTEM.VAL(INTEGER, n) END Integer; + + + + + (* --------------- Initialisation and parameter handling ---------------*) + + PROCEDURE ScanOptions(s: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + i := 1; (* skip - *) + WHILE s[i] # 0X DO + CASE s[i] OF + + (* Run time safety *) + | "p": Options := Options / {ptrinit} (* Initialise pointers to NIL. *) + | "a": Options := Options / {assert} (* Halt on assertion failures. *) + | "r": Options := Options / {ranchk} (* Halt on range check failures. *) + | "t": Options := Options / {typchk} (* Halt on type guad failure. *) + | "x": Options := Options / {inxchk} (* Halt on index out of range. *) + + (* Symbol file management *) + | "e": Options := Options / {extsf} (* Allow extension of old symbol file. *) + | "s": Options := Options / {newsf} (* Allow generation of new symbol file. *) + | "F": Options := Options / {forcenewsym} (* Force generation of new symbol file. *) + + (* C compiler and linker control *) + | "m": Options := Options / {mainprog} (* This module is main. Link dynamically. *) + | "M": Options := Options / {mainlinkstat} (* This module is main. Link statically. *) + | "S": Options := Options / {dontasm} (* Don't call C compiler *) + | "c": Options := Options / {dontlink} (* Don't link. *) + + (* Miscellaneous *) + | "f": Options := Options / {notcoloroutput} (* Disable VT100 control characters in status output. *) + | "V": Options := Options / {verbose} + + (* Elementary type size model *) + | "O": IF i+1 >= Strings.Length(s) THEN LogWStr("-O option requires following size model character."); LogWLn ELSE + Model[0] := s[i+1]; Model[1] := 0X; + IF (Model[0] # '2') & (Model[0] # 'C') & (Model[0] # 'V') THEN + LogWStr("Unrecognised size model character following -O."); LogWLn + END; + INC(i) + END + + (* Target machine address size and alignment *) + | "A": IF i+2 >= Strings.Length(s) THEN LogWStr("-M option requires two following digits."); LogWLn ELSE + AddressSize := ORD(s[i+1]) - ORD('0'); Alignment := ORD(s[i+2]) - ORD('0'); + INC(i, 2) + END + ELSE + LogWStr(" warning: option "); + LogW(OptionChar); + LogW(s[i]); + LogWStr(" ignored"); + LogWLn + END; + INC(i) + END; + END ScanOptions; + + + PROCEDURE -GetAlignment(VAR a: INTEGER) "struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s"; + + PROCEDURE OpenPar*(): BOOLEAN; (* prepare for a sequence of translations *) + VAR s: ARRAY 256 OF CHAR; + BEGIN + IF Modules.ArgCount = 1 THEN + LogWLn; + LogWStr("Oberon-2 compiler v"); LogWStr(Configuration.versionLong); LogW("."); LogWLn; + LogWStr("Based on Ofront by J. Templ and Software Templ OEG."); LogWLn; + LogWStr("Further development by Norayr Chilingarian, David Brown and others."); LogWLn; + LogWStr("Loaded from "); LogWStr(Modules.BinaryDir); LogWLn; + LogWLn; + LogWStr("Usage:"); LogWLn; + LogWLn; + LogWStr(" "); LogWStr(Configuration.name); LogWStr(" options {files {options}}."); LogWLn; + LogWLn; + LogWStr('Options:'); LogWLn; + LogWLn; + LogWStr(" Run time safety"); LogWLn; + LogWStr(" -p Initialise pointers to NIL. On by default."); LogWLn; + LogWStr(" -a Halt on assertion failures. On by default."); LogWLn; + LogWStr(" -r Halt on range check failures."); LogWLn; + LogWStr(" -t Halt on type guard failure. On by default."); LogWLn; + LogWStr(" -x Halt on index out of range. On by default."); LogWLn; + LogWLn; + LogWStr(" Symbol file management"); LogWLn; + LogWStr(" -e Allow extension of old symbol file."); LogWLn; + LogWStr(" -s Allow generation of new symbol file."); LogWLn; + LogWStr(" -F Force generation of new symbol file."); LogWLn; + LogWLn; + LogWStr(" C compiler and linker control"); LogWLn; + LogWStr(" -m This module is main. Link dynamically."); LogWLn; + LogWStr(" -M This module is main. Link statically."); LogWLn; + LogWStr(" -S Don't call C compiler"); LogWLn; + LogWStr(" -c Don't link."); LogWLn; + LogWLn; + LogWStr(" Miscellaneous"); LogWLn; + LogWStr(" -f Disable VT100 control characters in status output."); LogWLn; + LogWStr(" -V Display compiler debugging messages."); LogWLn; + LogWLn; + LogWStr(" Size model for elementary types (default O2)"); LogWLn; + LogWStr(" -O2 Original Oberon / Oberon-2: 8 bit SHORTINT, 16 bit INTEGER, 32 bit LONGINT and SET."); LogWLn; + LogWStr(" -OC Component Pascal: 16 bit SHORTINT, 32 bit INTEGER and SET, 64 bit LONGINT."); LogWLn; + LogWStr(" -OV Alternate large model: 8 bit SHORTINT, 32 bit INTEGER, 64 bit LONGINT and SET."); LogWLn; + LogWLn; + LogWStr(" Target machine address size and alignment (default is that of the running compiler binary)"); LogWLn; + LogWStr(" -A44 32 bit addresses, 32 bit alignment (e.g. Unix/linux 32 bit on x86)."); LogWLn; + LogWStr(" -A48 32 bit addresses, 64 bit alignment (e.g. Windows 32 bit on x86, linux 32 bit on arm)."); LogWLn; + LogWStr(" -A88 64 bit addresses, 64 bit alignment (e.g. 64 bit platforms)."); LogWLn; + LogWLn; + LogWStr("All options are off by default, except where noted above."); LogWLn; + LogWStr("Initial options specify defaults for all files."); LogWLn; + LogWStr("Options following a filename are specific to that file."); LogWLn; + LogWStr("Repeating an option toggles its value."); LogWLn; + RETURN FALSE + ELSE + (* Set options to initial defaults *) + AddressSize := SIZE(SYSTEM.ADDRESS); (* This compilers address size *) + GetAlignment(Alignment); (* This compilers alignment *) + Model := "2"; (* Size model of common Oberon-2 implementations: S8/I16/L32 *) + Options := {inxchk, typchk, ptrinit, assert}; (* Default options *) + + (* Pick up global option changes from start of command line *) + S:=1; s:=""; Modules.GetArg(S, s); + WHILE s[0] = OptionChar DO + ScanOptions(s); + INC(S); s:=""; Modules.GetArg(S, s) + END; + + (* Record global option settings for this command line *) + GlobalAddressSize := AddressSize; + GlobalAlignment := Alignment; + GlobalModel := Model; + GlobalOptions := Options; + + RETURN TRUE + END; + END OpenPar; + + + PROCEDURE InitOptions*; (* get the options for one translation *) + VAR s: ARRAY 256 OF CHAR; searchpath, modules: ARRAY 1024 OF CHAR; + MODULES: ARRAY 1024 OF CHAR; + + BEGIN + Options := GlobalOptions; Model:=GlobalModel; Alignment := GlobalAlignment; AddressSize := GlobalAddressSize; + + s:=""; Modules.GetArg(S, s); + WHILE s[0] = OptionChar DO + ScanOptions(s); + INC(S); s:=""; Modules.GetArg(S, s) + END; + + IF mainlinkstat IN Options THEN INCL(Options, mainprog) END; + + MaxIndex := SignedMaximum(AddressSize); + CASE Model[0] OF + |'2': ShortintSize := 1; IntegerSize := 2; LongintSize := 4; SetSize := 4; + |'C': ShortintSize := 2; IntegerSize := 4; LongintSize := 8; SetSize := 4; + |'V': ShortintSize := 1; IntegerSize := 4; LongintSize := 8; SetSize := 8; + ELSE ShortintSize := 1; IntegerSize := 2; LongintSize := 4; SetSize := 4; + END; + + (*IF verbose IN Options THEN VerboseListSizes END;*) + + ResourceDir := InstallDir; + IF ResourceDir[0] # 0X THEN + Strings.Append("/", ResourceDir); + Strings.Append(Model, ResourceDir); + END; + + modules := ""; Platform.GetEnv("MODULES", modules); + searchpath := "."; Platform.GetEnv("OBERON", searchpath); + Strings.Append(";.;", searchpath); + Strings.Append(modules, searchpath); + Strings.Append(";", searchpath); + Strings.Append(ResourceDir, searchpath); + Strings.Append("/sym;", searchpath); + Files.SetSearchPath(searchpath); + END InitOptions; + + + PROCEDURE Init*(VAR done: BOOLEAN); (* get the source for one translation *) + VAR + T: Texts.Text; + beg, end, time: LONGINT; + s: ARRAY 256 OF CHAR; + BEGIN + done := FALSE; + curpos := 0; + IF S >= Modules.ArgCount THEN RETURN END ; + + s:=""; Modules.GetArg(S, s); + + NEW(T); Texts.Open(T, s); + LogWStr(s); LogWStr(" "); + COPY(s, SourceFileName); (* to keep it also in this module -- noch *) + + IF T.len = 0 THEN + LogWStr(s); LogWStr(" not found."); LogWLn + ELSE + Texts.OpenReader(inR, T, 0); + done := TRUE + END; + + INC(S); + level := 0; noerr := TRUE; errpos := curpos; lasterrpos := curpos -10; + ErrorLineStartPos := 0; ErrorLineLimitPos := 0; ErrorLineNumber := 0; + END Init; + + + + (* ------------------------- read source text -------------------------*) + + PROCEDURE Get*(VAR ch: CHAR); (* read next character from source text, 0X if eof *) + BEGIN + curpos := Texts.Pos(inR); + Texts.Read(inR, ch); + + (* TODO, remove curpos var, and provide fn returning Texts.Pos(inR) - 1. *) + (* Or, better still, record symbol position in OPS. *) + + IF (ch < 09X) & ~inR.eot THEN ch := " " END + END Get; + + + PROCEDURE MakeFileName(VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR); + VAR i, j: INTEGER; ch: CHAR; + BEGIN i := 0; + LOOP ch := name[i]; + IF ch = 0X THEN EXIT END ; + FName[i] := ch; INC(i) + END ; + j := 0; + REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j) + UNTIL ch = 0X + END MakeFileName; + + + PROCEDURE LogErrMsg(n: INTEGER); + VAR l: INTEGER; S: Texts.Scanner; c: CHAR; + BEGIN + IF n >= 0 THEN + LogVT100(VT100.Red); LogWStr(" err "); LogVT100(VT100.ResetAll) + ELSE + LogVT100(VT100.Magenta); LogWStr(" warning "); n := -n; LogVT100(VT100.ResetAll) + END; + LogWNum(n, 1); + LogWStr(" "); + + IF Errors = NIL THEN NEW(Errors); Texts.Open(Errors, "Errors.Txt") END; + + Texts.OpenScanner(S, Errors, 0); + REPEAT l := S.line; Texts.Scan(S) + UNTIL (l # S.line) & (S.class = Texts.Int) & (S.i = n) OR S.eot; + IF ~S.eot THEN + Texts.Read(S, c); + WHILE ~S.eot & (c >= ' ') DO Out.Char(c); Texts.Read(S, c) END + END + END LogErrMsg; + + + PROCEDURE FindLine(f: Files.File; VAR r: Files.Rider; pos: SYSTEM.INT64); + (* Updates ErrorLineStartPos, ErrorLineLimitPos, ErrorLineNumber to + describe the line containing pos. + Exits with the rider set to the start of the line conaining pos. *) + VAR + ch, cheol: CHAR; + BEGIN + IF pos < ErrorLineStartPos THEN (* Desired position is before saved position, start again at the begnning of file *) + ErrorLineStartPos := 0; ErrorLineLimitPos := 0; ErrorLineNumber := 0 + END; + IF pos < ErrorLineLimitPos THEN (* Current saved line positions contain pos *) + Files.Set(r, f, ErrorLineStartPos); + RETURN + END; + + Files.Set(r, f, ErrorLineLimitPos); + Files.Read(r, ch); + WHILE (ErrorLineLimitPos < pos) & ~r.eof DO + ErrorLineStartPos := ErrorLineLimitPos; + INC(ErrorLineNumber); + WHILE (ch # 0X) & (ch # 0DX) & (ch # 0AX) DO + Files.Read(r, ch); INC(ErrorLineLimitPos) + END; + cheol := ch; Files.Read(r, ch); INC(ErrorLineLimitPos); + IF (cheol = 0DX) & (ch = 0AX) THEN + INC(ErrorLineLimitPos); Files.Read(r, ch) + END + END; + Files.Set(r, f, ErrorLineStartPos); + END FindLine; + + + PROCEDURE ShowLine(pos: SYSTEM.INT64); + VAR + f: Files.File; + r: Files.Rider; + line: ARRAY 1023 OF CHAR; + i: INTEGER; + ch: CHAR; + BEGIN + f := Files.Old(SourceFileName); + FindLine(f, r, pos); + + i := 0; Files.Read(r, ch); + WHILE (ch # 0X) & (ch # 0DX) & (ch # 0AX) & (i < LEN(line)-1) DO + line[i] := ch; INC(i); Files.Read(r, ch) + END; + line[i] := 0X; + + LogWLn; LogWLn; + LogWNum(ErrorLineNumber, 4); LogWStr(": "); LogWStr(line); LogWLn; + LogWStr(" "); + + IF pos >= ErrorLineLimitPos THEN pos := ErrorLineLimitPos-1 END; + i := SHORT(Longint(pos - ErrorLineStartPos)); + WHILE i > 0 DO LogW(" "); DEC(i) END; + + LogVT100(VT100.Green); LogW("^"); LogVT100(VT100.ResetAll); + END ShowLine; + + + PROCEDURE Mark*(n: INTEGER; pos: LONGINT); + BEGIN + IF pos = -1 THEN pos := 0 END; + IF n >= 0 THEN + noerr := FALSE; + IF (pos < lasterrpos) OR (lasterrpos + 9 < pos) THEN lasterrpos := pos; ShowLine(pos); LogWLn; LogWStr(" "); + IF n < 249 THEN LogWStr(" pos"); LogWNum(pos, 6); LogErrMsg(n) + ELSIF n = 255 THEN LogWStr("pos"); LogWNum(pos, 6); LogWStr(" pc "); LogWNum(breakpc, 1) + ELSIF n = 254 THEN LogWStr("pc not found") + ELSE LogWStr(objname); + IF n = 253 THEN LogWStr(" is new, compile with option e") + ELSIF n = 252 THEN LogWStr(" is redefined, compile with option s") + ELSIF n = 251 THEN LogWStr(" is redefined (private part only), compile with option s") + ELSIF n = 250 THEN LogWStr(" is no longer visible, compile with option s") + ELSIF n = 249 THEN LogWStr(" is not consistently imported, recompile imports") + END + END + END + ELSE + IF pos >= 0 THEN ShowLine(pos); LogWLn; LogWStr(" pos"); LogWNum(pos, 6) END ; + LogErrMsg(n); + IF pos < 0 THEN LogWLn END + END + END Mark; + + + PROCEDURE err*(n: INTEGER); + BEGIN Mark(n, errpos) + END err; + + + (* ------------------------ Fingerprint hashing ----------------------- *) + + PROCEDURE FingerprintBytes(VAR fp: LONGINT; VAR bytes: ARRAY OF SYSTEM.BYTE); + VAR i: INTEGER; l: LONGINT; + BEGIN + ASSERT(LEN(bytes) MOD SIZE(LONGINT) = 0); + i := 0; WHILE i < LEN(bytes) DO + SYSTEM.GET(SYSTEM.ADR(bytes[i]), l); + fp := SYSTEM.ROT(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, fp) / SYSTEM.VAL(SET, l)), 1); + INC(i, SIZE(LONGINT)) + END + END FingerprintBytes; + + PROCEDURE FPrint* (VAR fp: LONGINT; val: HUGEINT); BEGIN FingerprintBytes(fp, val) END FPrint; + PROCEDURE FPrintSet* (VAR fp: LONGINT; val: SYSTEM.SET64); BEGIN FingerprintBytes(fp, val) END FPrintSet; + PROCEDURE FPrintReal* (VAR fp: LONGINT; val: REAL); BEGIN FingerprintBytes(fp, val) END FPrintReal; + PROCEDURE FPrintLReal*(VAR fp: LONGINT; val: LONGREAL); BEGIN FingerprintBytes(fp, val) END FPrintLReal; + + + + + (* ------------------------- Read Symbol File ------------------------- *) + + PROCEDURE SymRCh*(VAR ch: CHAR); + BEGIN Files.Read(oldSF, ch) + END SymRCh; + + (* todo - combine RInt64 and RInt *) + PROCEDURE SymRInt*(): LONGINT; + VAR k: LONGINT; + BEGIN Files.ReadNum(oldSF, k); RETURN k + END SymRInt; + + PROCEDURE SymRInt64*(): SYSTEM.INT64; + VAR k: SYSTEM.INT64; + BEGIN Files.ReadNum(oldSF, k); RETURN k + END SymRInt64; + + PROCEDURE SymRSet*(VAR s: SYSTEM.SET64); + BEGIN Files.ReadNum(oldSF, s) + END SymRSet; + + PROCEDURE SymRReal*(VAR r: REAL); + BEGIN Files.ReadReal(oldSF, r) + END SymRReal; + + PROCEDURE SymRLReal*(VAR lr: LONGREAL); + BEGIN Files.ReadLReal(oldSF, lr) + END SymRLReal; + + PROCEDURE CloseOldSym*; + BEGIN Files.Close(Files.Base(oldSF)) + END CloseOldSym; + + PROCEDURE OldSym*(VAR modName: ARRAY OF CHAR; VAR done: BOOLEAN); + VAR tag, ver: CHAR; fileName: FileName; res: INTEGER; + BEGIN + oldSFile := NIL; done := FALSE; + MakeFileName(modName, fileName, SFext); + oldSFile := Files.Old(fileName); done := oldSFile # NIL; + IF done THEN + Files.Set(oldSF, oldSFile, 0); Files.Read(oldSF, tag); Files.Read(oldSF, ver); + IF (tag # SFtag) OR (ver # SFver) THEN + (* Possibly a symbol file from another Oberon implementation, e.g. HP-Oberon, + or from a symbol incompatible version of this Oberon. *) + IF ~(newsf IN Options) THEN err(-306) END; + CloseOldSym; done := FALSE + END + END + END OldSym; + + PROCEDURE eofSF*(): BOOLEAN; + BEGIN RETURN oldSF.eof + END eofSF; + + + + + (* ------------------------- Write Symbol File ------------------------- *) + + PROCEDURE SymWCh*(ch: CHAR); + BEGIN Files.Write(newSF, ch) + END SymWCh; + + PROCEDURE SymWInt*(i: SYSTEM.INT64); + BEGIN Files.WriteNum(newSF, i) + END SymWInt; + + PROCEDURE SymWSet*(s: SYSTEM.SET64); + BEGIN Files.WriteNum(newSF, SYSTEM.VAL(SYSTEM.INT64, s)) + END SymWSet; + + PROCEDURE SymWReal*(r: REAL); + BEGIN Files.WriteReal(newSF, r) + END SymWReal; + + PROCEDURE SymWLReal*(lr: LONGREAL); + BEGIN Files.WriteLReal(newSF, lr) + END SymWLReal; + + PROCEDURE RegisterNewSym*; + BEGIN + IF (modName # "SYSTEM") OR (mainprog IN Options) THEN Files.Register(newSFile) END + END RegisterNewSym; + + PROCEDURE DeleteSym*(VAR modulename: ARRAY OF CHAR); + VAR fn: FileName; res: INTEGER; + BEGIN MakeFileName(modulename, fn, SFext); Files.Delete(fn, res) + END DeleteSym; + + PROCEDURE DeleteObj*(VAR modulename: ARRAY OF CHAR); + VAR fn: FileName; res: INTEGER; + BEGIN MakeFileName(modulename, fn, Configuration.objext); Files.Delete(fn, res) + END DeleteObj; + + PROCEDURE NewSym*(VAR modName: ARRAY OF CHAR); + VAR fileName: FileName; + BEGIN MakeFileName(modName, fileName, SFext); + newSFile := Files.New(fileName); + IF newSFile # NIL THEN Files.Set(newSF, newSFile, 0); + Files.Write(newSF, SFtag); Files.Write(newSF, SFver) + ELSE err(153) + END + END NewSym; + + + + + (* ------------------------- Write Header & Body Files ------------------------- *) + + PROCEDURE Write*(ch: CHAR); + BEGIN Files.Write(R[currFile], ch) + END Write; + + PROCEDURE WriteString*(s: ARRAY [1] OF CHAR); + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO INC(i) END ; + Files.WriteBytes(R[currFile], s, i) + END WriteString; + + PROCEDURE WriteStringVar*(VAR s: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO INC(i) END ; + Files.WriteBytes(R[currFile], s, i) + END WriteStringVar; + + PROCEDURE WriteHex* (i: SYSTEM.INT64); + VAR s: ARRAY 3 OF CHAR; + digit : SYSTEM.INT32; + BEGIN + digit := SHORT(i) DIV 16; + IF digit < 10 THEN s[0] := CHR (ORD ("0") + digit); ELSE s[0] := CHR (ORD ("a") - 10 + digit ); END; + digit := SHORT(i) MOD 16; + IF digit < 10 THEN s[1] := CHR (ORD ("0") + digit); ELSE s[1] := CHR (ORD ("a") - 10 + digit ); END; + s[2] := 0X; + WriteString(s) + END WriteHex; + + PROCEDURE WriteInt* (i: SYSTEM.INT64); + VAR s: ARRAY 26 OF CHAR; i1, k: SYSTEM.INT64; + BEGIN + IF (i = SignedMinimum(2)) OR (i = SignedMinimum(4)) OR (i = SignedMinimum(8)) THEN + (* abs(minint) is one more than maxint, causing problems representing the value as a minus sign + followed by absoute value. Therefore represent as -maxint - 1. For INTEGER this avoids a + compiler warning 'this decimal constant is unsigned only in ISO C90', for LONGINT it is the + only way to represent MinLInt. *) + Write("("); WriteInt(i+1); WriteString("-1)") + ELSE i1 := ABS(i); + IF i1 <= MAX(SYSTEM.INT32) THEN k := 0 ELSE s := "LL"; k := 2 END; + s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k); + WHILE i1 > 0 DO s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k) END ; + IF i < 0 THEN s[k] := "-"; INC(k) END ; + WHILE k > 0 DO DEC(k); Write(s[k]) END; + END; + END WriteInt; + + PROCEDURE WriteReal* (r: LONGREAL; suffx: CHAR); + VAR W: Texts.Writer; T: Texts.Text; R: Texts.Reader; s: ARRAY 32 OF CHAR; ch: CHAR; i: INTEGER; + BEGIN +(*should be improved *) + IF (r < SignedMaximum(LongintSize)) & (r > SignedMinimum(LongintSize)) & (r = ENTIER(r)) THEN + IF suffx = "f" THEN WriteString("(REAL)") ELSE WriteString("(LONGREAL)") END ; + WriteInt(ENTIER(r)) + ELSE + Texts.OpenWriter(W); + IF suffx = "f" THEN Texts.WriteLongReal(W, r, 16) ELSE Texts.WriteLongReal(W, r, 23) END ; + NEW(T); Texts.Open(T, ""); Texts.Append(T, W.buf); + Texts.OpenReader(R, T, 0); i := 0; Texts.Read(R, ch); + WHILE ch # 0X DO s[i] := ch; INC(i); Texts.Read(R, ch) END ; + (* s[i] := suffx; s[i+1] := 0X; + suffix does not work in K&R *) + s[i] := 0X; + i := 0; ch := s[0]; + WHILE (ch # "D") & (ch # 0X) DO INC(i); ch := s[i] END ; + IF ch = "D" THEN s[i] := "e" END ; + WriteString(s) + END + END WriteReal; + + PROCEDURE WriteLn* (); + BEGIN Files.Write(R[currFile], 0AX) + END WriteLn; + + PROCEDURE Append(VAR R: Files.Rider; F: Files.File); + VAR R1: Files.Rider; buffer: ARRAY 4096 OF CHAR; + BEGIN + IF F # NIL THEN + Files.Set(R1, F, 0); Files.ReadBytes(R1, buffer, LEN(buffer)); + WHILE LEN(buffer) - R1.res > 0 DO + Files.WriteBytes(R, buffer, LEN(buffer) - R1.res); + Files.ReadBytes(R1, buffer, LEN(buffer)) + END + END + END Append; + + PROCEDURE OpenFiles*(VAR moduleName: ARRAY OF CHAR); + VAR FName: FileName; + BEGIN + COPY(moduleName, modName); + HFile := Files.New(""); + IF HFile # NIL THEN Files.Set(R[HeaderFile], HFile, 0) ELSE err(153) END ; + MakeFileName(moduleName, FName, BFext); + BFile := Files.New(FName); + IF BFile # NIL THEN Files.Set(R[BodyFile], BFile, 0) ELSE err(153) END ; + MakeFileName(moduleName, FName, HFext); + HIFile := Files.New(FName); + IF HIFile # NIL THEN Files.Set(R[HeaderInclude], HIFile, 0) ELSE err(153) END ; + END OpenFiles; + + PROCEDURE CloseFiles*; + VAR FName: FileName; res: INTEGER; + BEGIN + IF noerr THEN LogWStr(" "); LogWNum(Files.Pos(R[BodyFile]), 0); LogWStr(" chars.") END; + IF noerr THEN + IF modName = "SYSTEM" THEN + IF ~(mainprog IN Options) THEN Files.Register(BFile) END + ELSIF ~(mainprog IN Options) THEN + Append(R[HeaderInclude], HFile); + Files.Register(HIFile); Files.Register(BFile) + ELSE + MakeFileName(modName, FName, HFext); Files.Delete(FName, res); + MakeFileName(modName, FName, SFext); Files.Delete(FName, res); + Files.Register(BFile) + END + END ; + HFile := NIL; BFile := NIL; HIFile := NIL; newSFile := NIL; oldSFile := NIL; + Files.Set(R[0], NIL, 0); Files.Set(R[1], NIL, 0); Files.Set(R[2], NIL, 0); Files.Set(newSF, NIL, 0); Files.Set(oldSF, NIL, 0) + END CloseFiles; + + +(* === Installation directory discovery === *) + + PROCEDURE IsProbablyInstallDir(s: ARRAY OF CHAR): BOOLEAN; + VAR testpath: ARRAY 4096 OF CHAR; identity: Platform.FileIdentity; + BEGIN + COPY(InstallDir, testpath); + Strings.Append("/lib/lib", testpath); + Strings.Append(Configuration.name, testpath); + Strings.Append("-O2.a", testpath); + IF Platform.IdentifyByName(testpath, identity) # 0 THEN RETURN FALSE END; + + COPY(InstallDir, testpath); + Strings.Append("/2/include/Oberon.h", testpath); + IF Platform.IdentifyByName(testpath, identity) # 0 THEN RETURN FALSE END; + + COPY(InstallDir, testpath); + Strings.Append("/2/sym/Files.sym", testpath); + IF Platform.IdentifyByName(testpath, identity) # 0 THEN RETURN FALSE END; + + RETURN TRUE; + END IsProbablyInstallDir; + + PROCEDURE FindInstallDir; + VAR i: INTEGER; + BEGIN + (* First try location of binary (with .d appended) *) + COPY(Modules.BinaryDir, InstallDir); + Strings.Append("/", InstallDir); + Strings.Append(Configuration.name, InstallDir); + Strings.Append(".d", InstallDir); + IF IsProbablyInstallDir(InstallDir) THEN RETURN END; + + (* Now test whether binary is in bin directory under install dir. *) + COPY(Modules.BinaryDir, InstallDir); + i := Strings.Length(InstallDir); + WHILE (i > 0) & (InstallDir[i-1] # '/') DO DEC(i) END; + IF (i > 0) & (InstallDir[i-1] = '/') THEN + InstallDir[i-1] := 0X; + IF IsProbablyInstallDir(InstallDir) THEN RETURN END + END; + + (* Give up! Use install directory from configuration. *) + COPY(Configuration.installdir, InstallDir) + END FindInstallDir; + + + +BEGIN + MaxReal := 3.40282346D38; (* REAL is 4 bytes *) + MaxLReal := 1.7976931348623157D307 * 9.999999; (* LONGREAL is 8 bytes, should be 1.7976931348623157D308 *) + MinReal := -MaxReal; + MinLReal := -MaxLReal; + FindInstallDir; + + hasComment := FALSE; + currentComment[0] := 0X; +END OPM. diff --git a/src/voc/OPP.Mod b/src/compiler/OPP.Mod similarity index 52% rename from src/voc/OPP.Mod rename to src/compiler/OPP.Mod index 160cfec6..96117cad 100644 --- a/src/voc/OPP.Mod +++ b/src/compiler/OPP.Mod @@ -1,76 +1,15 @@ +(* OPP - Oberon Portable Parser (front end) *) MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IMPORT - OPB, OPT, OPS, OPM; - - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (* symbol values *) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (*function number*) - haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (* node subclasses *) - super = 1; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; + OPB, OPT, OPS, OPM, SYSTEM; TYPE CaseTable = ARRAY OPM.MaxCases OF RECORD low, high: LONGINT END ; - + VAR sym, level: SHORTINT; LoopLevel: INTEGER; @@ -93,19 +32,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE qualident(VAR id: OPT.Object); VAR obj: OPT.Object; lev: SHORTINT; - BEGIN (*sym = ident*) + BEGIN (*sym = OPS.ident*) OPT.Find(obj); OPS.Get(sym); - IF (sym = period) & (obj # NIL) & (obj^.mode = Mod) THEN + IF (sym = OPS.period) & (obj # NIL) & (obj^.mode = OPT.Mod) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.FindImport(obj, obj); OPS.Get(sym) - ELSE err(ident); obj := NIL + ELSE err(OPS.ident); obj := NIL END END ; IF obj = NIL THEN err(0); - obj := OPT.NewObj(); obj^.mode := Var; obj^.typ := OPT.undftyp; obj^.adr := 0 + obj := OPT.NewObj(); obj^.mode := OPT.Var; obj^.typ := OPT.undftyp; obj^.adr := 0 ELSE lev := obj^.mnolev; - IF (obj^.mode IN {Var, VarPar}) & (lev # level) THEN + IF (obj^.mode IN {OPT.Var, OPT.VarPar}) & (lev # level) THEN obj^.leaf := FALSE; IF lev > 0 THEN OPB.StaticLink(level-lev) END END @@ -115,30 +54,32 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ConstExpression(VAR x: OPT.Node); BEGIN Expression(x); - IF x^.class # Nconst THEN - err(50); x := OPB.NewIntConst(1) + IF x^.class # OPT.Nconst THEN + err(50); x := OPB.NewIntConst(1) END END ConstExpression; PROCEDURE CheckMark(VAR vis: SHORTINT); BEGIN OPS.Get(sym); - IF (sym = times) OR (sym = minus) THEN + IF (sym = OPS.times) OR (sym = OPS.minus) THEN IF level > 0 THEN err(47) END ; - IF sym = times THEN vis := external ELSE vis := externalR END ; + IF sym = OPS.times THEN vis := OPT.external ELSE vis := OPT.externalR END ; OPS.Get(sym) - ELSE vis := internal + ELSE vis := OPT.internal END END CheckMark; - + PROCEDURE CheckSysFlag(VAR sysflag: INTEGER; default: INTEGER); - VAR x: OPT.Node; sf: LONGINT; + VAR x: OPT.Node; sf: SYSTEM.INT64; BEGIN - IF sym = lbrak THEN OPS.Get(sym); ConstExpression(x); - IF x^.typ^.form IN intSet THEN sf := x^.conval^.intval; + IF sym = OPS.lbrak THEN OPS.Get(sym); + IF ~OPT.SYSimported THEN err(135) END; + ConstExpression(x); + IF x^.typ^.form = OPT.Int THEN sf := x^.conval^.intval; IF (sf < 0) OR (sf > OPM.MaxSysFlag) THEN err(220); sf := 0 END ELSE err(51); sf := 0 END ; - sysflag := SHORT(sf); CheckSym(rbrak) + sysflag := OPM.Integer(sf); CheckSym(OPS.rbrak) ELSE sysflag := default END END CheckSysFlag; @@ -146,54 +87,54 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE RecordType(VAR typ, banned: OPT.Struct); VAR fld, first, last, base: OPT.Object; ftyp: OPT.Struct; sysflag: INTEGER; - BEGIN typ := OPT.NewStr(Comp, Record); typ^.BaseTyp := NIL; + BEGIN typ := OPT.NewStr(OPT.Comp, OPT.Record); typ^.BaseTyp := NIL; CheckSysFlag(sysflag, -1); - IF sym = lparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); (*record extension*) - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(base); - IF (base^.mode = Typ) & (base^.typ^.comp = Record) THEN + IF (base^.mode = OPT.Typ) & (base^.typ^.comp = OPT.Record) THEN IF base^.typ = banned THEN err(58) ELSE base^.typ^.pvused := TRUE; typ^.BaseTyp := base^.typ; typ^.extlev := base^.typ^.extlev + 1; typ^.sysflag := base^.typ^.sysflag END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen) + CheckSym(OPS.rparen) END ; IF sysflag >= 0 THEN typ^.sysflag := sysflag END ; OPT.OpenScope(0, NIL); first := NIL; last := NIL; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN IF typ^.BaseTyp # NIL THEN OPT.FindField(OPS.name, typ^.BaseTyp, fld); IF fld # NIL THEN err(1) END END ; OPT.Insert(OPS.name, fld); CheckMark(fld^.vis); - fld^.mode := Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; + fld^.mode := OPT.Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; IF first = NIL THEN first := fld END ; IF last = NIL THEN typ^.link := fld ELSE last^.link := fld END ; last := fld - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(colon); Type(ftyp, banned); + CheckSym(OPS.colon); Type(ftyp, banned); ftyp^.pvused := TRUE; - IF ftyp^.comp = DynArr THEN ftyp := OPT.undftyp; err(88) END ; + IF ftyp^.comp = OPT.DynArr THEN ftyp := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := ftyp; first := first^.link END END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.semicolon) ELSE EXIT END END ; @@ -201,38 +142,38 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END RecordType; PROCEDURE ArrayType(VAR typ, banned: OPT.Struct); - VAR x: OPT.Node; n: LONGINT; sysflag: INTEGER; + VAR x: OPT.Node; n: SYSTEM.INT64; sysflag: INTEGER; BEGIN CheckSysFlag(sysflag, 0); - IF sym = of THEN (*dynamic array*) - typ := OPT.NewStr(Comp, DynArr); typ^.mno := 0; typ^.sysflag := sysflag; + IF sym = OPS.of THEN (*dynamic array*) + typ := OPT.NewStr(OPT.Comp, OPT.DynArr); typ^.mno := 0; typ^.sysflag := sysflag; OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 + IF typ^.BaseTyp^.comp = OPT.DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 ELSE typ^.n := 0 END ELSE - typ := OPT.NewStr(Comp, Array); typ^.sysflag := sysflag; ConstExpression(x); - IF x^.typ^.form IN intSet THEN n := x^.conval^.intval; + typ := OPT.NewStr(OPT.Comp, OPT.Array); typ^.sysflag := sysflag; ConstExpression(x); + IF x^.typ^.form = OPT.Int THEN n := x^.conval^.intval; IF (n <= 0) OR (n > OPM.MaxIndex) THEN err(63); n := 1 END ELSE err(51); n := 1 END ; - typ^.n := n; - IF sym = of THEN + typ^.n := OPM.Longint(n); + IF sym = OPS.of THEN OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE - ELSIF sym = comma THEN - OPS.Get(sym); IF sym # of THEN ArrayType(typ^.BaseTyp, banned) END + ELSIF sym = OPS.comma THEN + OPS.Get(sym); IF sym # OPS.of THEN ArrayType(typ^.BaseTyp, banned) END ELSE err(35) END ; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END + IF typ^.BaseTyp^.comp = OPT.DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END END END ArrayType; PROCEDURE PointerType(VAR typ: OPT.Struct); VAR id: OPT.Object; - BEGIN typ := OPT.NewStr(Pointer, Basic); CheckSysFlag(typ^.sysflag, 0); - CheckSym(to); - IF sym = ident THEN OPT.Find(id); + BEGIN typ := OPT.NewStr(OPT.Pointer, OPT.Basic); CheckSysFlag(typ^.sysflag, 0); + CheckSym(OPS.to); + IF sym = OPS.ident THEN OPT.Find(id); IF id = NIL THEN IF nofFwdPtr < LEN(FwdPtr) THEN FwdPtr[nofFwdPtr] := typ; INC(nofFwdPtr) ELSE err(224) @@ -240,8 +181,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) typ^.link := OPT.NewObj(); COPY(OPS.name, typ^.link^.name); typ^.BaseTyp := OPT.undftyp; OPS.Get(sym) (*forward ref*) ELSE qualident(id); - IF id^.mode = Typ THEN - IF id^.typ^.comp IN {Array, DynArr, Record} THEN + IF id^.mode = OPT.Typ THEN + IF id^.typ^.comp IN {OPT.Array, OPT.DynArr, OPT.Record} THEN typ^.BaseTyp := id^.typ ELSE typ^.BaseTyp := OPT.undftyp; err(57) END @@ -249,55 +190,59 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END END ELSE Type(typ^.BaseTyp, OPT.notyp); - IF ~(typ^.BaseTyp^.comp IN {Array, DynArr, Record}) THEN + IF ~(typ^.BaseTyp^.comp IN {OPT.Array, OPT.DynArr, OPT.Record}) THEN typ^.BaseTyp := OPT.undftyp; err(57) END END END PointerType; - + PROCEDURE FormalParameters(VAR firstPar: OPT.Object; VAR resTyp: OPT.Struct); VAR mode: SHORTINT; par, first, last, res: OPT.Object; typ: OPT.Struct; BEGIN first := NIL; last := firstPar; - IF (sym = ident) OR (sym = var) THEN + IF (sym = OPS.ident) OR (sym = OPS.var) THEN LOOP - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; + IF sym = OPS.var THEN OPS.Get(sym); mode := OPT.VarPar ELSE mode := OPT.Var END ; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.Insert(OPS.name, par); OPS.Get(sym); par^.mode := mode; par^.link := NIL; IF first = NIL THEN first := par END ; IF firstPar = NIL THEN firstPar := par ELSE last^.link := par END ; last := par - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) - ELSIF sym = var THEN err(comma); OPS.Get(sym) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) + ELSIF sym = OPS.var THEN err(OPS.comma); OPS.Get(sym) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); - IF mode = Var THEN typ^.pvused := TRUE END ; + CheckSym(OPS.colon); Type(typ, OPT.notyp); + IF ((typ.comp = OPT.Array) OR (typ.comp = OPT.Record)) + & (typ.strobj = NIL) THEN + err(-309) + END; + IF mode = OPT.Var THEN typ^.pvused := TRUE END ; (* typ^.pbused is set when parameter type name is parsed *) WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.semicolon) ELSE EXIT END END END ; - CheckSym(rparen); - IF sym = colon THEN + CheckSym(OPS.rparen); + IF sym = OPS.colon THEN OPS.Get(sym); resTyp := OPT.undftyp; - IF sym = ident THEN qualident(res); - IF res^.mode = Typ THEN - IF (res^.typ^.form < Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; + IF sym = OPS.ident THEN qualident(res); + IF res^.mode = OPT.Typ THEN + IF (res^.typ^.form < OPT.Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; ELSE err(54) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ELSE resTyp := OPT.notyp END @@ -306,24 +251,26 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE TypeDecl(VAR typ, banned: OPT.Struct); VAR id: OPT.Object; BEGIN typ := OPT.undftyp; - IF sym < lparen THEN err(12); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPS.lparen THEN err(12); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.lparen END ; - IF sym = ident THEN qualident(id); - IF id^.mode = Typ THEN - IF id^.typ # banned THEN typ := id^.typ ELSE err(58) END + IF sym = OPS.ident THEN qualident(id); + IF id^.mode = OPT.Typ THEN + IF id^.typ = banned THEN err(58) ELSE + typ := id.typ + END ELSE err(52) END - ELSIF sym = array THEN + ELSIF sym = OPS.array THEN OPS.Get(sym); ArrayType(typ, banned) - ELSIF sym = record THEN + ELSIF sym = OPS.record THEN OPS.Get(sym); RecordType(typ, banned); - OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) - ELSIF sym = pointer THEN + OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(OPS.end) + ELSIF sym = OPS.pointer THEN OPS.Get(sym); PointerType(typ) - ELSIF sym = procedure THEN - OPS.Get(sym); typ := OPT.NewStr(ProcTyp, Basic); CheckSysFlag(typ^.sysflag, 0); - IF sym = lparen THEN + ELSIF sym = OPS.procedure THEN + OPS.Get(sym); typ := OPT.NewStr(OPT.ProcTyp, OPT.Basic); CheckSysFlag(typ^.sysflag, 0); + IF sym = OPS.lparen THEN OPS.Get(sym); OPT.OpenScope(level, NIL); FormalParameters(typ^.link, typ^.BaseTyp); OPT.CloseScope ELSE typ^.BaseTyp := OPT.notyp; typ^.link := NIL @@ -331,69 +278,69 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(12) END ; LOOP - IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) THEN EXIT END; - err(15); IF sym = ident THEN EXIT END; + IF (sym >= OPS.semicolon) & (sym <= OPS.else) OR (sym = OPS.rparen) OR (sym = OPS.eof) THEN EXIT END; + err(15); IF sym = OPS.ident THEN EXIT END; OPS.Get(sym) END END TypeDecl; - + PROCEDURE Type(VAR typ, banned: OPT.Struct); BEGIN TypeDecl(typ, banned); - IF (typ^.form = Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END + IF (typ^.form = OPT.Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END END Type; PROCEDURE selector(VAR x: OPT.Node); VAR obj, proc: OPT.Object; y: OPT.Node; typ: OPT.Struct; name: OPS.Name; BEGIN LOOP - IF sym = lbrak THEN OPS.Get(sym); + IF sym = OPS.lbrak THEN OPS.Get(sym); LOOP - IF (x^.typ # NIL) & (x^.typ^.form = Pointer) THEN OPB.DeRef(x) END ; + IF (x^.typ # NIL) & (x^.typ^.form = OPT.Pointer) THEN OPB.DeRef(x) END ; Expression(y); OPB.Index(x, y); - IF sym = comma THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.comma THEN OPS.Get(sym) ELSE EXIT END END ; - CheckSym(rbrak) - ELSIF sym = period THEN OPS.Get(sym); - IF sym = ident THEN name := OPS.name; OPS.Get(sym); + CheckSym(OPS.rbrak) + ELSIF sym = OPS.period THEN OPS.Get(sym); + IF sym = OPS.ident THEN name := OPS.name; OPS.Get(sym); IF x^.typ # NIL THEN - IF x^.typ^.form = Pointer THEN OPB.DeRef(x) END ; - IF x^.typ^.comp = Record THEN + IF x^.typ^.form = OPT.Pointer THEN OPB.DeRef(x) END ; + IF x^.typ^.comp = OPT.Record THEN OPT.FindField(name, x^.typ, obj); OPB.Field(x, obj); - IF (obj # NIL) & (obj^.mode = TProc) THEN - IF sym = arrow THEN (* super call *) OPS.Get(sym); + IF (obj # NIL) & (obj^.mode = OPT.TProc) THEN + IF sym = OPS.arrow THEN (* super call *) OPS.Get(sym); y := x^.left; - IF y^.class = Nderef THEN y := y^.left END ; (* y = record variable *) + IF y^.class = OPT.Nderef THEN y := y^.left END ; (* y = record variable *) IF y^.obj # NIL THEN - proc := OPT.topScope; (* find innermost scope which owner is a TProc *) - WHILE (proc^.link # NIL) & (proc^.link^.mode # TProc) DO proc := proc^.left END ; + proc := OPT.topScope; (* find innermost scope which owner is a OPT.TProc *) + WHILE (proc^.link # NIL) & (proc^.link^.mode # OPT.TProc) DO proc := proc^.left END ; IF (proc^.link = NIL) OR (proc^.link^.link # y^.obj) THEN err(75) END ; typ := y^.obj^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(x^.obj^.name, typ^.BaseTyp, proc); - IF proc # NIL THEN x^.subcl := super ELSE err(74) END + IF proc # NIL THEN x^.subcl := OPT.super ELSE err(74) END ELSE err(75) END END ; - IF (obj^.typ # OPT.notyp) & (sym # lparen) THEN err(lparen) END + IF (obj^.typ # OPT.notyp) & (sym # OPS.lparen) THEN err(OPS.lparen) END END ELSE err(53) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END - ELSIF sym = arrow THEN OPS.Get(sym); OPB.DeRef(x) - ELSIF (sym = lparen) & (x^.class < Nconst) & (x^.typ^.form # ProcTyp) & - ((x^.obj = NIL) OR (x^.obj^.mode # TProc)) THEN + ELSIF sym = OPS.arrow THEN OPS.Get(sym); OPB.DeRef(x) + ELSIF (sym = OPS.lparen) & (x^.class < OPT.Nconst) & (x^.typ^.form # OPT.ProcTyp) & + ((x^.obj = NIL) OR (x^.obj^.mode # OPT.TProc)) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, TRUE) + IF obj^.mode = OPT.Typ THEN OPB.TypTest(x, obj, TRUE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen) + CheckSym(OPS.rparen) ELSE EXIT END END @@ -402,15 +349,15 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ActualParameters(VAR aparlist: OPT.Node; fpar: OPT.Object); VAR apar, last: OPT.Node; BEGIN aparlist := NIL; last := NIL; - IF sym # rparen THEN + IF sym # OPS.rparen THEN LOOP Expression(apar); IF fpar # NIL THEN OPB.Param(apar, fpar); OPB.Link(aparlist, last, apar); fpar := fpar^.link; ELSE err(64) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END END @@ -421,31 +368,31 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE StandProcCall(VAR x: OPT.Node); VAR y: OPT.Node; m: SHORTINT; n: INTEGER; BEGIN m := SHORT(SHORT(x^.obj^.adr)); n := 0; - IF sym = lparen THEN OPS.Get(sym); - IF sym # rparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); + IF sym # OPS.rparen THEN LOOP IF n = 0 THEN Expression(x); OPB.StPar0(x, m); n := 1 ELSIF n = 1 THEN Expression(y); OPB.StPar1(x, y, m); n := 2 ELSE Expression(y); OPB.StParN(x, y, m, n); INC(n) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(rparen) + CheckSym(OPS.rparen) ELSE OPS.Get(sym) END ; OPB.StFct(x, m, n) - ELSE err(lparen) + ELSE err(OPS.lparen) END ; - IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END + IF (level > 0) & ((m = OPT.newfn) OR (m = OPT.sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END END StandProcCall; - + PROCEDURE Element(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN Expression(x); - IF sym = upto THEN + IF sym = OPS.upto THEN OPS.Get(sym); Expression(y); OPB.SetRange(x, y) ELSE OPB.SetElem(x) END @@ -454,57 +401,57 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Sets(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN - IF sym # rbrace THEN + IF sym # OPS.rbrace THEN Element(x); LOOP - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END ; - Element(y); OPB.Op(plus, x, y) + Element(y); OPB.Op(OPS.plus, x, y) END ELSE x := OPB.EmptySet() END ; - CheckSym(rbrace) + CheckSym(OPS.rbrace) END Sets; - + PROCEDURE Factor(VAR x: OPT.Node); VAR fpar, id: OPT.Object; apar: OPT.Node; BEGIN - IF sym < lparen THEN err(13); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPS.lparen THEN err(13); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.lparen END ; - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) - ELSIF sym = lparen THEN + IF (x^.class = OPT.Nproc) & (x^.obj^.mode = OPT.SProc) THEN StandProcCall(x) (* x may be NIL *) + ELSIF sym = OPS.lparen THEN OPS.Get(sym); OPB.PrepCall(x, fpar); ActualParameters(apar, fpar); OPB.Call(x, apar, fpar); - CheckSym(rparen); + CheckSym(OPS.rparen); IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END - ELSIF sym = number THEN + ELSIF sym = OPS.number THEN CASE OPS.numtyp OF - char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp - | integer: x := OPB.NewIntConst(OPS.intval) - | real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) - | longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) + | OPS.char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp + | OPS.integer: x := OPB.NewIntConst(OPS.intval) + | OPS.real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) + | OPS.longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) ELSE OPM.LogWStr("unhandled case in OPP.Factor, OPS.numtyp = "); OPM.LogWNum(OPS.numtyp, 0); OPM.LogWLn; END ; OPS.Get(sym) - ELSIF sym = string THEN + ELSIF sym = OPS.string THEN x := OPB.NewString(OPS.str, OPS.intval); OPS.Get(sym) - ELSIF sym = nil THEN + ELSIF sym = OPS.nil THEN x := OPB.Nil(); OPS.Get(sym) - ELSIF sym = lparen THEN - OPS.Get(sym); Expression(x); CheckSym(rparen) - ELSIF sym = lbrak THEN - OPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) - ELSIF sym = lbrace THEN OPS.Get(sym); Sets(x) - ELSIF sym = not THEN - OPS.Get(sym); Factor(x); OPB.MOp(not, x) + ELSIF sym = OPS.lparen THEN + OPS.Get(sym); Expression(x); CheckSym(OPS.rparen) + ELSIF sym = OPS.lbrak THEN + OPS.Get(sym); err(OPS.lparen); Expression(x); CheckSym(OPS.rparen) + ELSIF sym = OPS.lbrace THEN OPS.Get(sym); Sets(x) + ELSIF sym = OPS.not THEN + OPS.Get(sym); Factor(x); OPB.MOp(OPS.not, x) ELSE err(13); OPS.Get(sym); x := NIL END ; IF x = NIL THEN x := OPB.NewIntConst(1); x^.typ := OPT.undftyp END @@ -513,7 +460,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Term(VAR x: OPT.Node); VAR y: OPT.Node; mulop: SHORTINT; BEGIN Factor(x); - WHILE (times <= sym) & (sym <= and) DO + WHILE (OPS.times <= sym) & (sym <= OPS.and) DO mulop := sym; OPS.Get(sym); Factor(y); OPB.Op(mulop, x, y) END @@ -522,11 +469,11 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE SimpleExpression(VAR x: OPT.Node); VAR y: OPT.Node; addop: SHORTINT; BEGIN - IF sym = minus THEN OPS.Get(sym); Term(x); OPB.MOp(minus, x) - ELSIF sym = plus THEN OPS.Get(sym); Term(x); OPB.MOp(plus, x) + IF sym = OPS.minus THEN OPS.Get(sym); Term(x); OPB.MOp(OPS.minus, x) + ELSIF sym = OPS.plus THEN OPS.Get(sym); Term(x); OPB.MOp(OPS.plus, x) ELSE Term(x) END ; - WHILE (plus <= sym) & (sym <= or) DO + WHILE (OPS.plus <= sym) & (sym <= OPS.or) DO addop := sym; OPS.Get(sym); Term(y); OPB.Op(addop, x, y) END @@ -535,19 +482,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Expression(VAR x: OPT.Node); VAR y: OPT.Node; obj: OPT.Object; relation: SHORTINT; BEGIN SimpleExpression(x); - IF (eql <= sym) & (sym <= geq) THEN + IF (OPS.eql <= sym) & (sym <= OPS.geq) THEN relation := sym; OPS.Get(sym); SimpleExpression(y); OPB.Op(relation, x, y) - ELSIF sym = in THEN + ELSIF sym = OPS.in THEN OPS.Get(sym); SimpleExpression(y); OPB.In(x, y) - ELSIF sym = is THEN + ELSIF sym = OPS.is THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, FALSE) + IF obj^.mode = OPT.Typ THEN OPB.TypTest(x, obj, FALSE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END END END Expression; @@ -555,27 +502,27 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Receiver(VAR mode: SHORTINT; VAR name: OPS.Name; VAR typ, rec: OPT.Struct); VAR obj: OPT.Object; BEGIN typ := OPT.undftyp; rec := NIL; - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; - name := OPS.name; CheckSym(ident); CheckSym(colon); - IF sym = ident THEN OPT.Find(obj); OPS.Get(sym); + IF sym = OPS.var THEN OPS.Get(sym); mode := OPT.VarPar ELSE mode := OPT.Var END ; + name := OPS.name; CheckSym(OPS.ident); CheckSym(OPS.colon); + IF sym = OPS.ident THEN OPT.Find(obj); OPS.Get(sym); IF obj = NIL THEN err(0) - ELSIF obj^.mode # Typ THEN err(72) + ELSIF obj^.mode # OPT.Typ THEN err(72) ELSE typ := obj^.typ; rec := typ; - IF rec^.form = Pointer THEN rec := rec^.BaseTyp END ; - IF ~((mode = Var) & (typ^.form = Pointer) & (rec^.comp = Record) OR - (mode = VarPar) & (typ^.comp = Record)) THEN err(70); rec := NIL END ; + IF rec^.form = OPT.Pointer THEN rec := rec^.BaseTyp END ; + IF ~((mode = OPT.Var) & (typ^.form = OPT.Pointer) & (rec^.comp = OPT.Record) OR + (mode = OPT.VarPar) & (typ^.comp = OPT.Record)) THEN err(70); rec := NIL END ; IF (rec # NIL) & (rec^.mno # level) THEN err(72); rec := NIL END END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen); - IF rec = NIL THEN rec := OPT.NewStr(Comp, Record); rec^.BaseTyp := NIL END + CheckSym(OPS.rparen); + IF rec = NIL THEN rec := OPT.NewStr(OPT.Comp, OPT.Record); rec^.BaseTyp := NIL END END Receiver; - + PROCEDURE Extends(x, b: OPT.Struct): BOOLEAN; BEGIN - IF (b^.form = Pointer) & (x^.form = Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; - IF (b^.comp = Record) & (x^.comp = Record) THEN + IF (b^.form = OPT.Pointer) & (x^.form = OPT.Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; + IF (b^.comp = OPT.Record) & (x^.comp = OPT.Record) THEN REPEAT x := x^.BaseTyp UNTIL (x = NIL) OR (x = b) END ; RETURN x = b @@ -588,41 +535,45 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) forward: BOOLEAN; PROCEDURE GetCode; - VAR ext: OPT.ConstExt; n: INTEGER; c: LONGINT; + VAR ext: OPT.ConstExt; n: INTEGER; c: SYSTEM.INT64; BEGIN ext := OPT.NewExt(); proc^.conval^.ext := ext; n := 0; - IF sym = string THEN + IF sym = OPS.string THEN WHILE OPS.str[n] # 0X DO ext[n+1] := OPS.str[n]; INC(n) END ; - ext^[0] := CHR(n); OPS.Get(sym) + ext^[0] := CHR(n); OPS.Get(sym); + (* + Console.String("Code procedure, length "); Console.Int(n,1); Console.Ln; + Console.String(' "'); Console.String(ext^); Console.String('"'); Console.Ln; + *) ELSE LOOP - IF sym = number THEN c := OPS.intval; INC(n); + IF sym = OPS.number THEN c := OPS.intval; INC(n); IF (c < 0) OR (c > 255) OR (n = OPT.MaxConstLen) THEN err(64); c := 1; n := 1 END ; OPS.Get(sym); ext^[n] := CHR(c) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = number THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.number THEN err(OPS.comma) ELSE ext^[0] := CHR(n); EXIT END END END ; - INCL(proc^.conval^.setval, hasBody) + INCL(proc^.conval^.setval, OPT.hasBody) END GetCode; PROCEDURE GetParams; BEGIN proc^.vis := vis; proc^.mode := mode; proc^.typ := OPT.notyp; proc^.conval := OPT.NewConst(); proc^.conval^.setval := {}; - IF sym = lparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); FormalParameters(proc^.link, proc^.typ) END ; IF fwd # NIL THEN OPB.CheckParameters(proc^.link, fwd^.link, TRUE); IF proc^.typ # fwd^.typ THEN err(117) END ; proc := fwd; OPT.topScope := proc^.scope; - IF mode = IProc THEN proc^.mode := IProc END + IF mode = OPT.IProc THEN proc^.mode := OPT.IProc END END END GetParams; @@ -630,14 +581,14 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR procdec, statseq: OPT.Node; c: LONGINT; BEGIN c := OPM.errpos; - INCL(proc^.conval^.setval, hasBody); - CheckSym(semicolon); Block(procdec, statseq); + INCL(proc^.conval^.setval, OPT.hasBody); + CheckSym(OPS.semicolon); Block(procdec, statseq); OPB.Enter(procdec, statseq, proc); x := procdec; x^.conval := OPT.NewConst(); x^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPS.ident THEN IF OPS.name # proc^.name THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPS.ident) END END Body; @@ -647,24 +598,24 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) objMode: SHORTINT; objName: OPS.Name; BEGIN - OPS.Get(sym); mode := TProc; + OPS.Get(sym); mode := OPT.TProc; IF level > 0 THEN err(73) END ; Receiver(objMode, objName, objTyp, recTyp); - IF sym = ident THEN + IF sym = OPS.ident THEN name := OPS.name; CheckMark(vis); OPT.FindField(name, recTyp, fwd); OPT.FindField(name, recTyp^.BaseTyp, baseProc); - IF (baseProc # NIL) & (baseProc^.mode # TProc) THEN baseProc := NIL END ; + IF (baseProc # NIL) & (baseProc^.mode # OPT.TProc) THEN baseProc := NIL END ; IF fwd = baseProc THEN fwd := NIL END ; IF (fwd # NIL) & (fwd^.mnolev # level) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode = TProc) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (fwd # NIL) & (fwd^.mode = OPT.TProc) & ~(OPT.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END ELSE IF fwd # NIL THEN err(1); fwd := NIL END ; OPT.OpenScope(0, NIL); OPT.topScope^.right := recTyp^.link; OPT.Insert(name, proc); - recTyp^.link := OPT.topScope^.right; OPT.CloseScope; + recTyp^.link := OPT.topScope^.right; OPT.CloseScope; END ; INC(level); OPT.OpenScope(level, proc); OPT.Insert(objName, proc^.link); proc^.link^.mode := objMode; proc^.link^.typ := objTyp; @@ -673,34 +624,34 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF (objMode # baseProc^.link^.mode) OR ~Extends(objTyp, baseProc^.link^.typ) THEN err(115) END ; OPB.CheckParameters(proc^.link^.link, baseProc^.link^.link, FALSE); IF proc^.typ # baseProc^.typ THEN err(117) END ; - IF (baseProc^.vis = external) & (proc^.vis = internal) & - (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = external) THEN err(109) + IF (baseProc^.vis = OPT.external) & (proc^.vis = OPT.internal) & + (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = OPT.external) THEN err(109) END ; - INCL(proc^.conval^.setval, isRedef) + INCL(proc^.conval^.setval, OPT.isRedef) END ; IF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPS.ident) END END TProcDecl; - - BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; - IF (sym # ident) & (sym # lparen) THEN - IF sym = times THEN (* mode set later in OPB.CheckAssign *) - ELSIF sym = arrow THEN forward := TRUE - ELSIF sym = plus THEN mode := IProc - ELSIF sym = minus THEN mode := CProc - ELSE err(ident) + + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := OPT.LProc; + IF (sym # OPS.ident) & (sym # OPS.lparen) THEN + IF sym = OPS.times THEN (* mode set later in OPB.CheckAssign *) + ELSIF sym = OPS.arrow THEN forward := TRUE + ELSIF sym = OPS.plus THEN mode := OPT.IProc + ELSIF sym = OPS.minus THEN mode := OPT.CProc + ELSE err(OPS.ident) END ; - IF (mode IN {IProc, CProc}) & ~OPT.SYSimported THEN err(135) END ; + IF (mode IN {OPT.IProc, OPT.CProc}) & ~OPT.SYSimported THEN err(135) END ; OPS.Get(sym) END ; - IF sym = lparen THEN TProcDecl - ELSIF sym = ident THEN OPT.Find(fwd); + IF sym = OPS.lparen THEN TProcDecl + ELSIF sym = OPS.ident THEN OPT.Find(fwd); name := OPS.name; CheckMark(vis); - IF (vis # internal) & (mode = LProc) THEN mode := XProc END ; - IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = SProc)) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode IN {LProc, XProc}) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (vis # OPT.internal) & (mode = OPT.LProc) THEN mode := OPT.XProc END ; + IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = OPT.SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd^.mode IN {OPT.LProc, OPT.XProc}) & ~(OPT.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END @@ -708,31 +659,31 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF fwd # NIL THEN err(1); fwd := NIL END ; OPT.Insert(name, proc) END ; - IF (mode # LProc) & (level > 0) THEN err(73) END ; + IF (mode # OPT.LProc) & (level > 0) THEN err(73) END ; INC(level); OPT.OpenScope(level, proc); proc^.link := NIL; GetParams; - IF mode = CProc THEN GetCode + IF mode = OPT.CProc THEN GetCode ELSIF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPS.ident) END END ProcedureDeclaration; - PROCEDURE CaseLabelList(VAR lab: OPT.Node; LabelForm: INTEGER; VAR n: INTEGER; VAR tab: CaseTable); + PROCEDURE CaseLabelList(VAR lab: OPT.Node; LabelTyp: OPT.Struct; VAR n: INTEGER; VAR tab: CaseTable); VAR x, y, lastlab: OPT.Node; i, f: INTEGER; xval, yval: LONGINT; BEGIN lab := NIL; lastlab := NIL; LOOP ConstExpression(x); f := x^.typ^.form; - IF f IN intSet + {Char} THEN xval := x^.conval^.intval + IF f IN {OPT.Int, OPT.Char} THEN xval := OPM.Longint(x^.conval^.intval) ELSE err(61); xval := 1 + END; + IF f = OPT.Int THEN + IF ~(LabelTyp.form = OPT.Int) OR (LabelTyp.size < x.typ.size) THEN err(60) END + ELSIF LabelTyp.form # f THEN err(60) END ; - IF f IN intSet THEN - IF LabelForm < f THEN err(60) END - ELSIF LabelForm # f THEN err(60) - END ; - IF sym = upto THEN - OPS.Get(sym); ConstExpression(y); yval := y^.conval^.intval; - IF (y^.typ^.form # f) & ~((f IN intSet) & (y^.typ^.form IN intSet)) THEN err(60) END ; + IF sym = OPS.upto THEN + OPS.Get(sym); ConstExpression(y); yval := OPM.Longint(y^.conval^.intval); + IF (y^.typ^.form # f) & ~((f = OPT.Int) & (y^.typ^.form = OPT.Int)) THEN err(60) END ; IF yval < xval THEN err(63); yval := xval END ELSE yval := xval END ; @@ -751,8 +702,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(213) END ; OPB.Link(lab, lastlab, x); - IF sym = comma THEN OPS.Get(sym) - ELSIF (sym = number) OR (sym = ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (sym = OPS.number) OR (sym = OPS.ident) THEN err(OPS.comma) ELSE EXIT END END @@ -764,37 +715,37 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE CasePart(VAR x: OPT.Node); VAR n: INTEGER; low, high: LONGINT; e: BOOLEAN; - tab: CaseTable; cases, lab, y, lastcase: OPT.Node; + tab: CaseTable; cases, lab, y, lastcase: OPT.Node; BEGIN Expression(x); pos := OPM.errpos; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN {Char..LInt}) THEN err(125) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(x^.typ^.form IN {OPT.Char..OPT.Int}) THEN err(125) END ; - CheckSym(of); cases := NIL; lastcase := NIL; n := 0; + CheckSym(OPS.of); cases := NIL; lastcase := NIL; n := 0; LOOP - IF sym < bar THEN - CaseLabelList(lab, x^.typ^.form, n, tab); - CheckSym(colon); StatSeq(y); - OPB.Construct(Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) + IF sym < OPS.bar THEN + CaseLabelList(lab, x^.typ, n, tab); + CheckSym(OPS.colon); StatSeq(y); + OPB.Construct(OPT.Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.bar THEN OPS.Get(sym) ELSE EXIT END END ; IF n > 0 THEN low := tab[0].low; high := tab[n-1].high; IF high - low > OPM.MaxCaseRange THEN err(209) END ELSE low := 1; high := 0 END ; - e := sym = else; - IF e THEN OPS.Get(sym); StatSeq(y) - ELSE + e := sym = OPS.else; + IF e THEN OPS.Get(sym); StatSeq(y) + ELSE y := NIL; - OPM.Mark(-307, OPM.curpos); (* notice about no else symbol; -- noch *) + OPM.Mark(-307, OPM.curpos); (* notice about no OPS.else symbol; -- noch *) END ; - OPB.Construct(Ncaselse, cases, y); OPB.Construct(Ncase, x, cases); + OPB.Construct(OPT.Ncaselse, cases, y); OPB.Construct(OPT.Ncase, x, cases); cases^.conval := OPT.NewConst(); cases^.conval^.intval := low; cases^.conval^.intval2 := high; IF e THEN cases^.conval^.setval := {1} ELSE cases^.conval^.setval := {} END END CasePart; - + PROCEDURE SetPos(x: OPT.Node); BEGIN x^.conval := OPT.NewConst(); x^.conval^.intval := pos @@ -802,29 +753,29 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE CheckBool(VAR x: OPT.Node); BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) - ELSIF x^.typ^.form # Bool THEN err(120); x := OPB.NewBoolConst(FALSE) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) + ELSIF x^.typ^.form # OPT.Bool THEN err(120); x := OPB.NewBoolConst(FALSE) END ; pos := OPM.errpos END CheckBool; BEGIN stat := NIL; last := NIL; LOOP x := NIL; - IF sym < ident THEN err(14); - REPEAT OPS.Get(sym) UNTIL sym >= ident + IF sym < OPS.ident THEN err(14); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.ident END ; - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF sym = becomes THEN + IF sym = OPS.becomes THEN OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF sym = eql THEN - err(becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN + ELSIF sym = OPS.eql THEN + err(OPS.becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) + ELSIF (x^.class = OPT.Nproc) & (x^.obj^.mode = OPT.SProc) THEN StandProcCall(x); IF (x # NIL) & (x^.typ # OPT.notyp) THEN err(55) END ELSE OPB.PrepCall(x, fpar); - IF sym = lparen THEN - OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(rparen) + IF sym = OPS.lparen THEN + OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(OPS.rparen) ELSE apar := NIL; IF fpar # NIL THEN err(65) END END ; @@ -833,36 +784,36 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END ; pos := OPM.errpos - ELSIF sym = if THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); - OPB.Construct(Nif, x, y); SetPos(x); lastif := x; - WHILE sym = elsif DO - OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); - OPB.Construct(Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) + ELSIF sym = OPS.if THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPS.then); StatSeq(y); + OPB.Construct(OPT.Nif, x, y); SetPos(x); lastif := x; + WHILE sym = OPS.elsif DO + OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(OPS.then); StatSeq(z); + OPB.Construct(OPT.Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) END ; - IF sym = else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; - OPB.Construct(Nifelse, x, y); CheckSym(end); OPB.OptIf(x); pos := OPM.errpos - ELSIF sym = case THEN - OPS.Get(sym); CasePart(x); CheckSym(end) - ELSIF sym = while THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); - OPB.Construct(Nwhile, x, y); CheckSym(end) - ELSIF sym = repeat THEN + IF sym = OPS.else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + OPB.Construct(OPT.Nifelse, x, y); CheckSym(OPS.end); OPB.OptIf(x); pos := OPM.errpos + ELSIF sym = OPS.case THEN + OPS.Get(sym); CasePart(x); CheckSym(OPS.end) + ELSIF sym = OPS.while THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPS.do); StatSeq(y); + OPB.Construct(OPT.Nwhile, x, y); CheckSym(OPS.end) + ELSIF sym = OPS.repeat THEN OPS.Get(sym); StatSeq(x); - IF sym = until THEN OPS.Get(sym); Expression(y); CheckBool(y) - ELSE err(until) + IF sym = OPS.until THEN OPS.Get(sym); Expression(y); CheckBool(y) + ELSE err(OPS.until) END ; - OPB.Construct(Nrepeat, x, y) - ELSIF sym = for THEN + OPB.Construct(OPT.Nrepeat, x, y) + ELSIF sym = OPS.for THEN OPS.Get(sym); - IF sym = ident THEN qualident(id); - IF ~(id^.typ^.form IN intSet) THEN err(68) END ; - CheckSym(becomes); Expression(y); pos := OPM.errpos; + IF sym = OPS.ident THEN qualident(id); + IF ~(id^.typ^.form = OPT.Int) THEN err(68) END ; + CheckSym(OPS.becomes); Expression(y); pos := OPM.errpos; x := OPB.NewLeaf(id); OPB.Assign(x, y); SetPos(x); - CheckSym(to); Expression(y); pos := OPM.errpos; - IF y^.class # Nconst THEN + CheckSym(OPS.to); Expression(y); pos := OPM.errpos; + IF y^.class # OPT.Nconst THEN name := "@@"; OPT.Insert(name, t); t^.name := "@for"; (* avoid err 1 *) - t^.mode := Var; t^.typ := x^.left^.typ; + t^.mode := OPT.Var; t^.typ := x^.left^.typ; obj := OPT.topScope^.scope; IF obj = NIL THEN OPT.topScope^.scope := t ELSE @@ -871,73 +822,73 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; z := OPB.NewLeaf(t); OPB.Assign(z, y); SetPos(z); OPB.Link(stat, last, z); y := OPB.NewLeaf(t) - ELSIF (y^.typ^.form < SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113) + ELSIF ~(y^.typ^.form = OPT.Int) OR (y.typ.size > x.left.typ.size) THEN err(113) END ; OPB.Link(stat, last, x); - IF sym = by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; + IF sym = OPS.by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; pos := OPM.errpos; x := OPB.NewLeaf(id); - IF z^.conval^.intval > 0 THEN OPB.Op(leq, x, y) - ELSIF z^.conval^.intval < 0 THEN OPB.Op(geq, x, y) - ELSE err(63); OPB.Op(geq, x, y) + IF z^.conval^.intval > 0 THEN OPB.Op(OPS.leq, x, y) + ELSIF z^.conval^.intval < 0 THEN OPB.Op(OPS.geq, x, y) + ELSE err(63); OPB.Op(OPS.geq, x, y) END ; - CheckSym(do); StatSeq(s); - y := OPB.NewLeaf(id); OPB.StPar1(y, z, incfn); SetPos(y); + CheckSym(OPS.do); StatSeq(s); + y := OPB.NewLeaf(id); OPB.StPar1(y, z, OPT.incfn); SetPos(y); IF s = NIL THEN s := y ELSE z := s; WHILE z^.link # NIL DO z := z^.link END ; z^.link := y END ; - CheckSym(end); OPB.Construct(Nwhile, x, s) - ELSE err(ident) + CheckSym(OPS.end); OPB.Construct(OPT.Nwhile, x, s) + ELSE err(OPS.ident) END - ELSIF sym = loop THEN + ELSIF sym = OPS.loop THEN OPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); - OPB.Construct(Nloop, x, NIL); CheckSym(end); pos := OPM.errpos - ELSIF sym = with THEN + OPB.Construct(OPT.Nloop, x, NIL); CheckSym(OPS.end); pos := OPM.errpos + ELSIF sym = OPS.with THEN OPS.Get(sym); idtyp := NIL; x := NIL; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); y := OPB.NewLeaf(id); - IF (id # NIL) & (id^.typ^.form = Pointer) & ((id^.mode = VarPar) OR ~id^.leaf) THEN + IF (id # NIL) & (id^.typ^.form = OPT.Pointer) & ((id^.mode = OPT.VarPar) OR ~id^.leaf) THEN err(245) (* jt: do not allow WITH on non-local pointers *) END ; - CheckSym(colon); - IF sym = ident THEN qualident(t); - IF t^.mode = Typ THEN + CheckSym(OPS.colon); + IF sym = OPS.ident THEN qualident(t); + IF t^.mode = OPT.Typ THEN IF id # NIL THEN idtyp := id^.typ; OPB.TypTest(y, t, FALSE); id^.typ := t^.typ ELSE err(130) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - pos := OPM.errpos; CheckSym(do); StatSeq(s); OPB.Construct(Nif, y, s); SetPos(y); + pos := OPM.errpos; CheckSym(OPS.do); StatSeq(s); OPB.Construct(OPT.Nif, y, s); SetPos(y); IF idtyp # NIL THEN id^.typ := idtyp; idtyp := NIL END ; IF x = NIL THEN x := y; lastif := x ELSE OPB.Link(x, lastif, y) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.bar THEN OPS.Get(sym) ELSE EXIT END END; - e := sym = else; + e := sym = OPS.else; IF e THEN OPS.Get(sym); StatSeq(s) ELSE s := NIL END ; - OPB.Construct(Nwith, x, s); CheckSym(end); + OPB.Construct(OPT.Nwith, x, s); CheckSym(OPS.end); IF e THEN x^.subcl := 1 END - ELSIF sym = exit THEN + ELSIF sym = OPS.exit THEN OPS.Get(sym); IF LoopLevel = 0 THEN err(46) END ; - OPB.Construct(Nexit, x, NIL); + OPB.Construct(OPT.Nexit, x, NIL); pos := OPM.errpos - ELSIF sym = return THEN OPS.Get(sym); - IF sym < semicolon THEN Expression(x) END ; + ELSIF sym = OPS.return THEN OPS.Get(sym); + IF sym < OPS.semicolon THEN Expression(x) END ; IF level > 0 THEN OPB.Return(x, OPT.topScope^.link) ELSE (* not standard Oberon *) OPB.Return(x, NIL) END ; pos := OPM.errpos END ; IF x # NIL THEN SetPos(x); OPB.Link(stat, last, x) END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF (sym <= OPS.ident) OR (OPS.if <= sym) & (sym <= OPS.return) THEN err(OPS.semicolon) ELSE EXIT END END @@ -951,67 +902,78 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) BEGIN first := NIL; last := NIL; nofFwdPtr := 0; LOOP - IF sym = const THEN + IF sym = OPS.const THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPS.ident DO OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.typ := OPT.sinttyp; obj^.mode := Var; (* Var to avoid recursive definition *) - IF sym = eql THEN + obj^.typ := OPT.sinttyp; obj^.mode := OPT.Var; (* OPT.Var to avoid recursive definition *) + IF sym = OPS.eql THEN OPS.Get(sym); ConstExpression(x) - ELSIF sym = becomes THEN - err(eql); OPS.Get(sym); ConstExpression(x) - ELSE err(eql); x := OPB.NewIntConst(1) + ELSIF sym = OPS.becomes THEN + err(OPS.eql); OPS.Get(sym); ConstExpression(x) + ELSE err(OPS.eql); x := OPB.NewIntConst(1) END ; - obj^.mode := Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) - CheckSym(semicolon) + obj^.mode := OPT.Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) + CheckSym(OPS.semicolon) END END ; - IF sym = type THEN + IF sym = OPS.type THEN OPS.Get(sym); - WHILE sym = ident DO - OPT.Insert(OPS.name, obj); obj^.mode := Typ; obj^.typ := OPT.undftyp; + WHILE sym = OPS.ident DO + OPT.Insert(OPS.name, obj); obj^.mode := OPT.Typ; obj^.typ := OPT.undftyp; CheckMark(obj^.vis); - IF sym = eql THEN - OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSIF (sym = becomes) OR (sym = colon) THEN - err(eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSE err(eql) + IF sym = OPS.eql THEN + IF (obj^.name = "SHORTINT") OR + (obj^.name = "INTEGER") OR + (obj^.name = "LONGINT") OR + (obj^.name = "HUGEINT") OR + (obj^.name = "REAL") OR + (obj^.name = "LONGREAL") OR + (obj^.name = "SET") OR + (obj^.name = "CHAR") OR + (obj^.name = "TRUE") OR (obj^.name = "FALSE") THEN + OPM.Mark(-310, OPM.curpos); (* notice about aliasing of predefined type *) + END; + OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) + ELSIF (sym = OPS.becomes) OR (sym = OPS.colon) THEN + err(OPS.eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) + ELSE err(OPS.eql) END ; IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END ; - IF obj^.typ^.comp IN {Record, Array, DynArr} THEN + IF obj^.typ^.comp IN {OPT.Record, OPT.Array, OPT.DynArr} THEN i := 0; WHILE i < nofFwdPtr DO typ := FwdPtr[i]; INC(i); IF typ^.link^.name = obj^.name THEN typ^.BaseTyp := obj^.typ; typ^.link^.name := "" END END END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END END ; - IF sym = var THEN + IF sym = OPS.var THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPS.ident DO LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.mode := Var; obj^.link := NIL; obj^.leaf := obj^.vis = internal; obj^.typ := OPT.undftyp; + obj^.mode := OPT.Var; obj^.link := NIL; obj^.leaf := obj^.vis = OPT.internal; obj^.typ := OPT.undftyp; IF first = NIL THEN first := obj END ; IF last = NIL THEN OPT.topScope^.scope := obj ELSE last^.link := obj END ; last := obj - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); + CheckSym(OPS.colon); Type(typ, OPT.notyp); typ^.pvused := TRUE; - IF typ^.comp = DynArr THEN typ := OPT.undftyp; err(88) END ; + IF typ^.comp = OPT.DynArr THEN typ := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END END ; - IF (sym < const) OR (sym > var) THEN EXIT END ; + IF (sym < OPS.const) OR (sym > OPS.var) THEN EXIT END ; END ; i := 0; WHILE i < nofFwdPtr DO @@ -1021,21 +983,21 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; OPT.topScope^.adr := OPM.errpos; procdec := NIL; lastdec := NIL; - WHILE sym = procedure DO + WHILE sym = OPS.procedure DO OPS.Get(sym); ProcedureDeclaration(x); IF x # NIL THEN IF lastdec = NIL THEN procdec := x ELSE lastdec^.link := x END ; lastdec := x END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END ; - IF sym = begin THEN OPS.Get(sym); StatSeq(statseq) + IF sym = OPS.begin THEN OPS.Get(sym); StatSeq(statseq) ELSE statseq := NIL END ; IF (level = 0) & (TDinit # NIL) THEN lastTDinit^.link := statseq; statseq := TDinit END ; - CheckSym(end) + CheckSym(OPS.end) END Block; PROCEDURE Module*(VAR prog: OPT.Node; opt: SET); @@ -1044,38 +1006,38 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) c: LONGINT; done: BOOLEAN; BEGIN OPS.Init; LoopLevel := 0; level := 0; OPS.Get(sym); - IF sym = module THEN OPS.Get(sym) ELSE err(16) END ; - IF sym = ident THEN - OPM.LogW(" "); OPM.LogWStr(OPS.name); - OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(semicolon); - IF sym = import THEN OPS.Get(sym); + IF sym = OPS.module THEN OPS.Get(sym) ELSE err(16) END; + IF sym = OPS.ident THEN + OPM.LogCompiling(OPS.name); + OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(OPS.semicolon); + IF sym = OPS.import THEN OPS.Get(sym); LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN COPY(OPS.name, aliasName); COPY(aliasName, impName); OPS.Get(sym); - IF sym = becomes THEN OPS.Get(sym); - IF sym = ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(ident) END + IF sym = OPS.becomes THEN OPS.Get(sym); + IF sym = OPS.ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(OPS.ident) END END ; OPT.Import(aliasName, impName, done) - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END ; IF OPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := OPM.errpos; Block(procdec, statseq); OPB.Enter(procdec, statseq, NIL); prog := procdec; prog^.conval := OPT.NewConst(); prog^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPS.ident THEN IF OPS.name # OPT.SelfName THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym # period THEN err(period) END + IF sym # OPS.period THEN err(OPS.period) END END - ELSE err(ident) + ELSE err(OPS.ident) END ; TDinit := NIL; lastTDinit := NIL END Module; diff --git a/src/compiler/OPS.Mod b/src/compiler/OPS.Mod new file mode 100644 index 00000000..f81bcae6 --- /dev/null +++ b/src/compiler/OPS.Mod @@ -0,0 +1,395 @@ +(* Oberon Portable Scanner (front end) *) +MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) + + IMPORT OPM, SYSTEM; + + CONST + MaxStrLen* = 1024; + MaxIdLen = 256; + + + (* Symbols values (also used as op values): + | 0 1 2 3 4 + ---|-------------------------------------------------------- + 0 | null * / DIV MOD + 5 | & + - OR = + 10 | # < <= > >= + 15 | IN IS ^ . , + 20 | : .. ) ] } + 25 | OF THEN DO TO BY + 30 | ( [ { ~ := + 35 | number NIL string ident ; + 40 | | END ELSE ELSIF UNTIL + 45 | IF CASE WHILE REPEAT FOR + 50 | LOOP WITH EXIT RETURN ARRAY + 55 | RECORD POINTER BEGIN CONST TYPE + 60 | VAR PROCEDURE IMPORT MODULE eof + *) + + null* = 0; times* = 1; slash* = 2; div* = 3; mod* = 4; + and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; + neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; + in* = 15; is* = 16; arrow* = 17; period* = 18; comma* = 19; + colon* = 20; upto* = 21; rparen* = 22; rbrak* = 23; rbrace* = 24; + of* = 25; then* = 26; do* = 27; to* = 28; by* = 29; + lparen* = 30; lbrak* = 31; lbrace* = 32; not* = 33; becomes* = 34; + number* = 35; nil* = 36; string* = 37; ident* = 38; semicolon* = 39; + bar* = 40; end* = 41; else* = 42; elsif* = 43; until* = 44; + if* = 45; case* = 46; while* = 47; repeat* = 48; for* = 49; + loop* = 50; with* = 51; exit* = 52; return* = 53; array* = 54; + record* = 55; pointer* = 56; begin* = 57; const* = 58; type* = 59; + var* = 60; procedure* = 61; import* = 62; module* = 63; eof* = 64; + + (* Symbol numtyp values *) + char* = 1; integer* = 2; real* = 3; longreal* = 4; + + + TYPE + Name* = ARRAY MaxIdLen OF CHAR; + String* = ARRAY MaxStrLen OF CHAR; + + VAR + (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) + name*: Name; + str*: String; + numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *) + intval*: SYSTEM.INT64; (* integer value or string length *) + realval*: REAL; + lrlval*: LONGREAL; + + ch: CHAR; (*current character*) + + PROCEDURE err(n: INTEGER); + BEGIN OPM.err(n) + END err; + + PROCEDURE Str(VAR sym: SHORTINT); + VAR i: INTEGER; och: CHAR; + BEGIN i := 0; och := ch; + LOOP OPM.Get(ch); + IF ch = och THEN EXIT END ; + IF ch < " " THEN err(3); EXIT END ; + IF i = MaxStrLen-1 THEN err(241); EXIT END ; + str[i] := ch; INC(i) + END ; + OPM.Get(ch); str[i] := 0X; intval := i + 1; + IF intval = 2 THEN + sym := number; numtyp := 1; intval := ORD(str[0]) + ELSE sym := string + END + END Str; + + PROCEDURE Identifier(VAR sym: SHORTINT); + VAR i: INTEGER; + BEGIN i := 0; + REPEAT + name[i] := ch; INC(i); OPM.Get(ch) + UNTIL (ch < "0") OR ("9" < ch) & (CAP(ch) < "A") OR ("Z" < CAP(ch)) OR (i = MaxIdLen); + IF i = MaxIdLen THEN err(240); DEC(i) END ; + name[i] := 0X; sym := ident + END Identifier; + + PROCEDURE Number; + CONST maxhexdigits = 16; + VAR i, m, n, d, e: INTEGER; dig: ARRAY 24 OF CHAR; f: LONGREAL; expCh: CHAR; neg: BOOLEAN; + + PROCEDURE Ten(e: INTEGER): LONGREAL; + VAR x, p: LONGREAL; + BEGIN x := 1; p := 10; + WHILE e > 0 DO + IF ODD(e) THEN x := x*p END; + e := e DIV 2; + IF e > 0 THEN p := p*p END (* prevent overflow *) + END; + RETURN x + END Ten; + + PROCEDURE Ord(ch: CHAR; hex: BOOLEAN): INTEGER; + BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *) + IF ch <= "9" THEN RETURN ORD(ch) - ORD("0") + ELSIF hex THEN RETURN ORD(ch) - ORD("A") + 10 + ELSE err(2); RETURN 0 + END + END Ord; + + BEGIN (* ("0" <= ch) & (ch <= "9") *) + i := 0; m := 0; n := 0; d := 0; + LOOP (* read mantissa *) + IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN + IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *) + IF n < LEN(dig) THEN dig[n] := ch; INC(n) END; + INC(m) + END; + OPM.Get(ch); INC(i) + ELSIF ch = "." THEN OPM.Get(ch); + IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT + ELSIF d = 0 THEN (* i > 0 *) d := i + ELSE err(2) + END + ELSE EXIT + END + END; (* 0 <= n <= m <= i, 0 <= d <= i *) + IF d = 0 THEN (* integer *) + IF n = m THEN intval := 0; i := 0; + IF ch = "X" THEN (* character *) OPM.Get(ch); numtyp := char; + IF n <= 2 THEN + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END + ELSE err(203) + END + ELSIF ch = "H" THEN (* hexadecimal *) OPM.Get(ch); numtyp := integer; + IF n <= maxhexdigits THEN + IF (n = maxhexdigits) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END + ELSE err(203) + END + ELSE (* decimal *) numtyp := integer; + WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); + IF intval <= (MAX(SYSTEM.INT64) - d) DIV 10 THEN intval := intval*10 + d + ELSE err(203) + END + END + END + ELSE err(203) + END + ELSE (* fraction *) + f := 0; e := 0; expCh := "E"; + WHILE n > 0 DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END; + IF (ch = "E") OR (ch = "D") THEN expCh := ch; OPM.Get(ch); neg := FALSE; + IF ch = "-" THEN neg := TRUE; OPM.Get(ch) + ELSIF ch = "+" THEN OPM.Get(ch) + END; + IF ("0" <= ch) & (ch <= "9") THEN + REPEAT n := Ord(ch, FALSE); OPM.Get(ch); + IF e <= (MAX(INTEGER) - n) DIV 10 THEN e := e*10 + n + ELSE err(203) + END + UNTIL (ch < "0") OR ("9" < ch); + IF neg THEN e := -e END + ELSE err(2) + END + END; + DEC(e, i-d-m); (* decimal point shift *) + IF expCh = "E" THEN numtyp := real; + IF (1-OPM.MaxRExp < e) & (e <= OPM.MaxRExp) THEN + IF e < 0 THEN realval := SHORT(f / Ten(-e)) + ELSE realval := SHORT(f * Ten(e)) + END + ELSE err(203) + END + ELSE numtyp := longreal; + IF (1-OPM.MaxLExp < e) & (e <= OPM.MaxLExp) THEN + IF e < 0 THEN lrlval := f / Ten(-e) + ELSE lrlval := f * Ten(e) + END + ELSE err(203) + END + END + END + END Number; + + PROCEDURE Get*(VAR sym: SHORTINT); + VAR s: SHORTINT; + + PROCEDURE Comment; + VAR + isExported: BOOLEAN; + commentText: ARRAY OPM.MaxCommentLen OF CHAR; + i: INTEGER; + nestLevel: INTEGER; + prevCh: CHAR; + BEGIN + FOR i := 0 TO LEN(commentText) - 1 DO + commentText[i] := 0X + END; + + isExported := FALSE; + i := 0; + nestLevel := 1; + prevCh := 0X; + + OPM.Get(ch); + + IF ch = "*" THEN + isExported := TRUE; + OPM.Get(ch); + IF ch = ")" THEN + (* Empty exported comment (**), handle and return *) + commentText[0] := 0X; + OPM.StoreComment(commentText); + OPM.Get(ch); (* consume character after closing comment *) + RETURN + END + END; + + WHILE (nestLevel > 0) & (ch # OPM.Eot) DO + IF (prevCh = "(") & (ch = "*") THEN + INC(nestLevel); + prevCh := ch; (* Don't set to 0X - keep the '*' *) + OPM.Get(ch) + ELSIF (prevCh = "*") & (ch = ")") THEN + DEC(nestLevel); + IF nestLevel = 0 THEN + OPM.Get(ch); (* move past ')' *) + ELSE + prevCh := ch; (* Keep the ')' *) + OPM.Get(ch) + END + ELSE + IF isExported & (nestLevel = 1) THEN + IF i < OPM.MaxCommentLen - 1 THEN + (* Handle all characters including newlines *) + IF (ch = 0DX) OR (ch = 0AX) THEN + (* Add newline if buffer is empty or last char isn't already a newline *) + IF (i = 0) OR (commentText[i-1] # 0AX) THEN + commentText[i] := 0AX; INC(i) + END; + (* Handle CRLF by skipping the LF if we just saw CR *) + IF (ch = 0DX) THEN + prevCh := ch; OPM.Get(ch); + IF ch = 0AX THEN + prevCh := ch; OPM.Get(ch) + END + ELSE + prevCh := ch; OPM.Get(ch) + END + ELSIF ch >= " " THEN + commentText[i] := ch; INC(i); + prevCh := ch; OPM.Get(ch) + ELSE + (* Skip control characters *) + prevCh := ch; OPM.Get(ch) + END + ELSE + prevCh := ch; OPM.Get(ch) + END + ELSE + prevCh := ch; OPM.Get(ch) + END + END + END; + + IF ch = OPM.Eot THEN + err(5) + END; + + IF isExported THEN + IF i >= OPM.MaxCommentLen THEN + OPM.LogWStr("Warning: commentText overflow"); OPM.LogWLn; + i := OPM.MaxCommentLen - 1 + END; + commentText[i] := 0X; + OPM.StoreComment(commentText) + END; + END Comment; + + + BEGIN + OPM.errpos := OPM.curpos-1; + WHILE ch <= " " DO (*ignore control characters*) + IF ch = OPM.Eot THEN sym := eof; RETURN + ELSE OPM.Get(ch) + END + END ; + CASE ch OF (* ch > " " *) + | 22X, + 27X: Str(s) + | "#": s := neq; OPM.Get(ch) + | "&": s := and; OPM.Get(ch) + | "(": OPM.Get(ch); + IF ch = "*" THEN Comment; Get(s) ELSE s := lparen END + | ")": s := rparen; OPM.Get(ch) + | "*": s := times; OPM.Get(ch) + | "+": s := plus; OPM.Get(ch) + | ",": s := comma; OPM.Get(ch) + | "-": s := minus; OPM.Get(ch) + | ".": OPM.Get(ch); + IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END + | "/": s := slash; OPM.Get(ch) + | "0".."9": Number; s := number + | ":": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END + | ";": s := semicolon; OPM.Get(ch) + | "<": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END + | "=": s := eql; OPM.Get(ch) + | ">": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + | "B": Identifier(s); + IF name = "BEGIN" THEN s := begin + ELSIF name = "BY" THEN s := by + END + | "C": Identifier(s); + IF name = "CASE" THEN s := case + ELSIF name = "CONST" THEN s := const + END + | "D": Identifier(s); + IF name = "DO" THEN s := do + ELSIF name = "DIV" THEN s := div + END + | "E": Identifier(s); + IF name = "END" THEN s := end + ELSIF name = "ELSE" THEN s := else + ELSIF name = "ELSIF" THEN s := elsif + ELSIF name = "EXIT" THEN s := exit + END + | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "I": Identifier(s); + IF name = "IF" THEN s := if + ELSIF name = "IN" THEN s := in + ELSIF name = "IS" THEN s := is + ELSIF name = "IMPORT" THEN s := import + END + | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "M": Identifier(s); + IF name = "MOD" THEN s := mod + ELSIF name = "MODULE" THEN s := module + END + | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "O": Identifier(s); + IF name = "OR" THEN s := or + ELSIF name = "OF" THEN s := of + END + | "P": Identifier(s); + IF name = "PROCEDURE" THEN s := procedure + ELSIF name = "POINTER" THEN s := pointer + END + | "R": Identifier(s); + IF name = "RECORD" THEN s := record + ELSIF name = "REPEAT" THEN s := repeat + ELSIF name = "RETURN" THEN s := return + END + | "T": Identifier(s); + IF name = "THEN" THEN s := then + ELSIF name = "TO" THEN s := to + ELSIF name = "TYPE" THEN s := type + END + | "U": Identifier(s); IF name = "UNTIL" THEN s := until END + | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "W": Identifier(s); + IF name = "WHILE" THEN s := while + ELSIF name = "WITH" THEN s := with + END + | "G".."H", + "J".."K", + "Q", "S", + "X".."Z": Identifier(s) + | "[": s := lbrak; OPM.Get(ch) + | "]": s := rbrak; OPM.Get(ch) + | "^": s := arrow; OPM.Get(ch) + | "a".."z": Identifier(s) + | "{": s := lbrace; OPM.Get(ch) + | "|": s := bar; OPM.Get(ch) + | "}": s := rbrace; OPM.Get(ch) + | "~": s := not; OPM.Get(ch) + | 7FX: s := upto; OPM.Get(ch) + ELSE s := null; OPM.Get(ch) + END ; + sym := s + END Get; + + PROCEDURE Init*; + BEGIN ch := " " + END Init; + +END OPS. diff --git a/src/compiler/OPT.Mod b/src/compiler/OPT.Mod new file mode 100644 index 00000000..228a8226 --- /dev/null +++ b/src/compiler/OPT.Mod @@ -0,0 +1,1702 @@ +(* OPT - Oberon Portable Symbol Table (front end) *) +MODULE OPT; (* NW, RC 6.3.89 / 23.1.92 *) (* object model 24.2.94 *) + +(* +2002-08-20 jt: NewStr: txtpos remains 0 for structs read from symbol file +*) + +IMPORT OPS, OPM, SYSTEM; + + +(* Constants - value of literals *) +TYPE + Const* = POINTER TO ConstDesc; + ConstExt* = POINTER TO OPS.String; + ConstDesc* = RECORD + ext*: ConstExt; (* string or code for code proc *) + intval*: SYSTEM.INT64; (* constant value or adr, proc par size, text position or least case label *) + intval2*: LONGINT; (* string length, proc var size or larger case label *) + setval*: SYSTEM.SET64; (* constant value, procedure body present or "ELSE" present in case *) + realval*: LONGREAL (* real or longreal constant value *) + END; + +CONST + MaxConstLen* = OPS.MaxStrLen; + + (* conval^.setval procedure flags *) + hasBody* = 1; isRedef* = 2; slNeeded* = 3; + + + + +(* Objects - named items - constants, types, variables, procedures *) +TYPE + Object* = POINTER TO ObjDesc; + Struct* = POINTER TO StrDesc; + ObjDesc* = RECORD + left*, right*: Object; + link*, scope*: Object; + name*: OPS.Name; + leaf*: BOOLEAN; + mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *) + vis*: SHORTINT; (* internal, external, externalR *) + history*: SHORTINT; (* relevant if name # "" *) + used*, fpdone*: BOOLEAN; + fprint*: LONGINT; + typ*: Struct; + conval*: Const; + adr*, linkadr*: LONGINT; + x*: INTEGER; (* linkadr and x can be freely used by the backend *) + comment*: ConstExt; + END; + +CONST + (* Object.mode values *) + Var* = 1; VarPar* = 2; Con* = 3; Fld* = 4; Typ* = 5; LProc* = 6; XProc* = 7; + SProc* = 8; CProc* = 9; IProc* = 10; Mod* = 11; Head* = 12; TProc* = 13; + + (* Object.vis - module visibility of objects *) + internal* = 0; external* = 1; externalR* = 2; + + (* Object.history - History of imported objects *) + inserted* = 0; same* = 1; pbmodified* = 2; pvmodified* = 3; removed* = 4; inconsistent* = 5; + + (* Object.adr Function numbers *) + haltfn* = 0; newfn* = 1; absfn* = 2; capfn* = 3; ordfn* = 4; + entierfn* = 5; oddfn* = 6; minfn* = 7; maxfn* = 8; chrfn* = 9; + shortfn* = 10; longfn* = 11; sizefn* = 12; incfn* = 13; decfn* = 14; + inclfn* = 15; exclfn* = 16; lenfn* = 17; copyfn* = 18; ashfn* = 19; + adrfn* = 20; ccfn* = 21; lshfn* = 22; rotfn* = 23; getfn* = 24; (* SYSTEM *) + putfn* = 25; getrfn* = 26; putrfn* = 27; bitfn* = 28; valfn* = 29; (* SYSTEM *) + sysnewfn* = 30; movefn* = 31; (* SYSTEM *) + assertfn* = 32; + + + + +(* Structures - describe types independently of their name *) +TYPE + StrDesc* = RECORD + form*, comp*: SHORTINT; + mno*, extlev*: SHORTINT; + ref*, sysflag*: INTEGER; + n*, size*: LONGINT; + align*, txtpos*: LONGINT; (* align is alignment for records, len is offset for dynarrs *) + allocated*: BOOLEAN; + pbused*, pvused*: BOOLEAN; + fpdone, idfpdone: BOOLEAN; + idfp*, pbfp, pvfp: LONGINT; + BaseTyp*: Struct; + link*, strobj*: Object + END; + +CONST + (* Struct.form values *) + Undef* = 0; Byte* = 1; Bool* = 2; Char* = 3; + Int* = 4; + Real* = 5; LReal* = 6; Set* = 7; String* = 8; + NilTyp* = 9; NoTyp* = 10; Pointer* = 11; ProcTyp* = 12; + Comp* = 13; + + realSet* = {Real, LReal}; + + (* Struct.comp - Composite structure forms *) + Basic* = 1; Array* = 2; DynArr* = 3; Record* = 4; + + + + +(* Nodes - statements, expressions and sub-expressions *) +TYPE + Node* = POINTER TO NodeDesc; + NodeDesc* = RECORD + left*, right*, link*: Node; + class*, subcl*: SHORTINT; + readonly*: BOOLEAN; + typ*: Struct; + obj*: Object; + conval*: Const + END; + +CONST + (* Node.class values *) + Nvar* = 0; Nvarpar* = 1; Nfield* = 2; Nderef* = 3; Nindex* = 4; Nguard* = 5; Neguard* = 6; + Nconst* = 7; Ntype* = 8; Nproc* = 9; Nupto* = 10; Nmop* = 11; Ndop* = 12; Ncall* = 13; + Ninittd* = 14; Nif* = 15; Ncaselse* = 16; Ncasedo* = 17; Nenter* = 18; Nassign* = 19; + Nifelse* = 20; Ncase* = 21; Nwhile* = 22; Nrepeat* = 23; Nloop* = 24; Nexit* = 25; + Nreturn* = 26; Nwith* = 27; Ntrap* = 28; + + + (* Node.subcl values - general *) + assign* = 0; (* Pseudo function number for assignment *) + super* = 1; + + (* Node.subcl values - functions *) + ash* = 17; msk* = 18; len* = 19; + conv* = 20; abs* = 21; cap* = 22; odd* = 23; + + (* Node.subcl values - SYSTEM functions *) + adr* = 24; cc* = 25; bit* = 26; lsh* = 27; rot* = 28; val* = 29; + + (* Note: some object.adr function numbers and some symbol types are + also are used as Node.subcl function ids *) + eql* = OPS.eql; neq* = OPS.neq; lss* = OPS.lss; + leq* = OPS.leq; gtr* = OPS.gtr; geq* = OPS.geq; + + + +CONST + maxImps = 64; (* must be <= MAX(SHORTINT) *) + maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) + FirstRef = Comp + 1; + +VAR + topScope*: Object; + + undftyp*, niltyp*, notyp*, + bytetyp*, cpbytetyp*, booltyp*, chartyp*, + sinttyp*, inttyp*, linttyp*, hinttyp*, + int8typ*, int16typ*, int32typ*, int64typ*, + settyp*, set32typ*, set64typ*, + realtyp*, lrltyp*, stringtyp*, + adrtyp*, sysptrtyp*: Struct; + + sintobj*, intobj*, lintobj*, setobj*: Object; + + nofGmod*: SHORTINT; (*nof imports*) + GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) + + SelfName*: OPS.Name; (* name of module being compiled *) + SYSimported*: BOOLEAN; + + + +CONST + + (* Symbol file items *) + Smname* = 16; Send* = 18; Stype* = 19; Salias* = 20; Svar* = 21; + Srvar* = 22; Svalpar* = 23; Svarpar* = 24; Sfld* = 25; Srfld* = 26; + Shdptr* = 27; Shdpro* = 28; Stpro* = 29; Shdtpro* = 30; Sxpro* = 31; + Sipro* = 32; Scpro* = 33; Sstruct* = 34; Ssys* = 35; Sptr* = 36; + Sarr* = 37; Sdarr* = 38; Srec* = 39; Spro* = 40; Slink* = 37; + Scomment* = 41; + +TYPE + ImpCtxt = RECORD + nextTag, reffp: LONGINT; + nofr, minr, nofm: INTEGER; + self: BOOLEAN; + ref: ARRAY maxStruct OF Struct; + old: ARRAY maxStruct OF Object; + pvfp: ARRAY maxStruct OF LONGINT; (* set only if old # NIL *) + glbmno: ARRAY maxImps OF SHORTINT (* index is local mno *) + END; + + ExpCtxt = RECORD + reffp: LONGINT; + ref: INTEGER; + nofm: SHORTINT; + locmno: ARRAY maxImps OF SHORTINT (* index is global mno *) + END; + +VAR + universe, syslink: Object; + impCtxt: ImpCtxt; + expCtxt: ExpCtxt; + nofhdfld: LONGINT; + newsf, findpc: BOOLEAN; + extsf, sfpresent: BOOLEAN; + symExtended, symNew: BOOLEAN; + recno: LONGINT; (* number of anonymous record types *) + + +(* Linking control - modules whose object files will be required to link a module. *) + +TYPE + Link* = POINTER TO LinkDesc; + LinkDesc* = RECORD + name-: OPS.Name; + next-: Link + END; + +VAR + Links-: Link; + + +PROCEDURE InitRecno*; BEGIN recno := 0 END InitRecno; +PROCEDURE err(n: INTEGER); BEGIN OPM.err(n) END err; + + +PROCEDURE IntSize*(n: SYSTEM.INT64):INTEGER; +(* Determines number of bytes required to store signed value n. *) + VAR bytes: INTEGER; +BEGIN + IF n < 0 THEN n := -(n+1) END; + bytes := 1; WHILE (bytes < 8) & (ASH(n, -(8*bytes-1)) # 0) DO INC(bytes) END; + RETURN bytes +END IntSize; + +PROCEDURE IntType*(size: LONGINT): Struct; +(* Selects smallest standard integer type for given size in bytes *) +BEGIN + IF size <= int8typ.size THEN RETURN int8typ END; + IF size <= int16typ.size THEN RETURN int16typ END; + IF size <= int32typ.size THEN RETURN int32typ END; + RETURN int64typ +END IntType; + +PROCEDURE SetType*(size: LONGINT): Struct; +BEGIN + IF size = set32typ.size THEN RETURN set32typ END; + RETURN set64typ +END SetType; + +PROCEDURE ShorterOrLongerType*(x: Struct; dir: INTEGER): Struct; + VAR i: INTEGER; +BEGIN + ASSERT(x.form = Int); + ASSERT(x.BaseTyp = undftyp); + ASSERT((dir = 1) OR (dir = -1)); + IF dir > 0 THEN + IF x.size < sinttyp.size THEN RETURN sinttyp END; + IF x.size < inttyp.size THEN RETURN inttyp END; + IF x.size < linttyp.size THEN RETURN linttyp END; + RETURN int64typ + ELSE + IF x.size > linttyp.size THEN RETURN linttyp END; + IF x.size > inttyp.size THEN RETURN inttyp END; + IF x.size > sinttyp.size THEN RETURN sinttyp END; + RETURN int8typ + END +END ShorterOrLongerType; + + +PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); +BEGIN + CASE base OF + | 2: INC(adr, adr MOD 2) + | 4: INC(adr, (-adr) MOD 4) + | 8: INC(adr, (-adr) MOD 8) + | 16: INC(adr, (-adr) MOD 16) + ELSE (*1*) (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) + END +END Align; + +PROCEDURE SizeAlignment*(size: LONGINT): LONGINT; + VAR alignment: LONGINT; +BEGIN + IF size < OPM.Alignment THEN + (* Round up to next power of 2 *) + alignment := 1; WHILE alignment < size DO alignment := alignment * 2 END; + ELSE + alignment := OPM.Alignment + END; + RETURN alignment +END SizeAlignment; + +PROCEDURE BaseAlignment*(typ: Struct): LONGINT; + VAR alignment: LONGINT; +BEGIN + IF typ.form = Comp THEN + IF typ.comp = Record THEN + alignment := typ.align MOD 10000H + ELSE + alignment := BaseAlignment(typ.BaseTyp) + END + ELSE + alignment := SizeAlignment(typ.size) + END; + RETURN alignment +END BaseAlignment; + +PROCEDURE TypSize*(typ: Struct); + VAR + f, c: INTEGER; + offset, size, base, fbase, off0: LONGINT; + fld: Object; btyp: Struct; +BEGIN + IF typ = undftyp THEN OPM.err(58) + ELSIF typ.size = -1 THEN + f := typ.form; + c := typ.comp; + IF c = Record THEN btyp := typ.BaseTyp; + IF btyp = NIL THEN offset := 0; base := 1; + ELSE TypSize(btyp); offset := btyp.size - btyp.sysflag DIV 100H; base := btyp.align; + END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; TypSize(btyp); + size := btyp.size; + fbase := BaseAlignment(btyp); + Align(offset, fbase); + fld.adr := offset; INC(offset, size); + IF fbase > base THEN base := fbase END; + fld := fld.link + END; + (* base is now the largest alignment of any field *) + off0 := offset; + IF offset = 0 THEN offset := 1 END; (* 1 byte filler to avoid empty struct *) + Align(offset, base); + IF (typ^.strobj = NIL) & (typ^.align MOD 10000H = 0) THEN INC(recno); INC(base, recno * 10000H) END; + typ.size := offset; + typ.align := base; + (* encode the trailing gap into the symbol table to allow dense packing of extended records *) + typ^.sysflag := typ^.sysflag MOD 100H + SHORT((offset - off0)*100H) + ELSIF c = Array THEN + TypSize(typ.BaseTyp); + typ.size := typ.n * typ.BaseTyp.size; + ELSIF f = Pointer THEN + typ.size := OPM.AddressSize; + IF typ.BaseTyp = undftyp THEN OPM.Mark(128, typ.n) + ELSE TypSize(typ.BaseTyp) + END + ELSIF f = ProcTyp THEN + typ.size := OPM.AddressSize; + ELSIF c = DynArr THEN + btyp := typ.BaseTyp; TypSize(btyp); + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 (* describes dim not size *) + ELSE typ.size := 8 + END + END + END +END TypSize; + + +PROCEDURE NewConst*(): Const; + VAR const: Const; +BEGIN NEW(const); RETURN const +END NewConst; + +PROCEDURE NewObj*(): Object; + VAR obj: Object; +BEGIN + NEW(obj); + (* lets fully init pointers *) + obj^.typ := NIL; + obj^.conval := NIL; + obj^.comment := NIL; + obj^.name := ""; + + RETURN obj +END NewObj; + +PROCEDURE NewStr*(form, comp: SHORTINT): Struct; + VAR typ: Struct; +BEGIN NEW(typ); typ^.form := form; typ^.comp := comp; typ^.ref := maxStruct; (* ref >= maxStruct: not exported yet *) + IF form # Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) + typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ +END NewStr; + +PROCEDURE NewNode*(class: SHORTINT): Node; + VAR node: Node; +BEGIN NEW(node); node^.class := class; RETURN node +END NewNode; + +PROCEDURE NewExt*(): ConstExt; + VAR ext: ConstExt; +BEGIN NEW(ext); RETURN ext +END NewExt; + +PROCEDURE OpenScope*(level: SHORTINT; owner: Object); + VAR head: Object; +BEGIN head := NewObj(); + head^.mode := Head; head^.mnolev := level; head^.link := owner; + IF owner # NIL THEN owner^.scope := head END; + head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head +END OpenScope; + +PROCEDURE CloseScope*; +BEGIN topScope := topScope^.left +END CloseScope; + +PROCEDURE Init*(VAR name: OPS.Name; opt: SET); + CONST nsf = 4; fpc = 8; esf = 9; +BEGIN + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + SelfName := name; topScope^.name := name; + GlbMod[0] := topScope; nofGmod := 1; + newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE; + NEW(Links); Links.name := name +END Init; + +PROCEDURE Close*; + VAR i: INTEGER; +BEGIN (* garbage collection *) + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END +END Close; + +PROCEDURE FindImport*(mod: Object; VAR res: Object); + VAR obj: Object; +BEGIN obj := mod^.scope; + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (*found*) + IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL + ELSE obj^.used := TRUE + END; + EXIT + END + END; + res := obj +END FindImport; + +PROCEDURE Find*(VAR res: Object); + VAR obj, head: Object; +BEGIN head := topScope; + LOOP obj := head^.right; + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (* found, obj^.used not set for local objects *) EXIT + END + END; + IF obj # NIL THEN EXIT END; + head := head^.left; + IF head = NIL THEN EXIT END + END; + res := obj +END Find; + +PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object); + VAR obj: Object; +BEGIN + WHILE typ # NIL DO obj := typ^.link; + WHILE obj # NIL DO + IF name < obj^.name THEN obj := obj^.left + ELSIF name > obj^.name THEN obj := obj^.right + ELSE (*found*) res := obj; RETURN + END + END; + typ := typ^.BaseTyp + END; + res := NIL +END FindField; + +PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object); +VAR + ob0, ob1: Object; + left: BOOLEAN; + mnolev: SHORTINT; + commentText: ARRAY OPM.MaxCommentLen OF CHAR; + j: INTEGER; +BEGIN + ob0 := topScope; + ob1 := ob0^.right; + left := FALSE; + LOOP + IF ob1 # NIL THEN + IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE + ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE + ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right + END + ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); + mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; + (* Attach pending comment *) + OPM.GetComment(commentText); + IF commentText[0] # 0X THEN + NEW(ob1^.comment); + (*COPY(commentText, ob1^.comment^);*) + j := 0; + WHILE (j < OPM.MaxCommentLen - 1) & (commentText[j] # 0X) DO + ob1^.comment^[j] := commentText[j]; + INC(j) + END; + ob1^.comment^[j] := 0X; + END; + EXIT + END + END; + obj := ob1 +END Insert; + +(*-------------------------- Fingerprinting --------------------------*) + +(* Fingerprints prevent structural type equivalence. *) + +PROCEDURE FPrintName(VAR fp: LONGINT; VAR name: ARRAY OF CHAR); + VAR i: INTEGER; ch: CHAR; +BEGIN i := 0; + REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X +END FPrintName; + +PROCEDURE ^IdFPrint*(typ: Struct); + +PROCEDURE DebugStruct(btyp: Struct); +BEGIN + OPM.LogWLn; + IF btyp = NIL THEN OPM.LogWStr("btyp is nil"); OPM.LogWLn END; + OPM.LogWStr("btyp^.strobji^.name = "); OPM.LogWStr(btyp^.strobj^.name); OPM.LogWLn; + OPM.LogWStr("btyp^.form = "); OPM.LogWNum(btyp^.form, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.comp = "); OPM.LogWNum(btyp^.comp, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.mno = "); OPM.LogWNum(btyp^.mno, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.extlev = "); OPM.LogWNum(btyp^.extlev, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.size = "); OPM.LogWNum(btyp^.size, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.align = "); OPM.LogWNum(btyp^.align, 0); OPM.LogWLn; + OPM.LogWStr("btyp^.txtpos = "); OPM.LogWNum(btyp^.txtpos, 0); OPM.LogWLn; +END DebugStruct; + +PROCEDURE FPrintSign(VAR fp: LONGINT; result: Struct; par: Object); +(* depends on assignment compatibility of params only *) +BEGIN + IdFPrint(result); OPM.FPrint(fp, result^.idfp); + WHILE (par # NIL) (*& (par^.typ # NIL)*) DO (* !!! *) + OPM.FPrint(fp, par^.mode); + IdFPrint(par^.typ); + OPM.FPrint(fp, par^.typ^.idfp); + (* par^.name and par^.adr not considered *) + par := par^.link + END +END FPrintSign; + +PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *) +VAR btyp: Struct; strobj: Object; idfp: LONGINT; f, c: INTEGER; +BEGIN + IF ~typ^.idfpdone THEN + typ^.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *) + idfp := 0; + f := typ^.form; OPM.FPrint(idfp, f); IF f IN {Int, Set} THEN OPM.FPrint(idfp, typ.size) END; + c := typ^.comp; OPM.FPrint(idfp, c); + btyp := typ^.BaseTyp; strobj := typ^.strobj; + IF (strobj # NIL) & (strobj^.name # "") THEN + FPrintName(idfp, GlbMod[typ^.mno]^.name); FPrintName(idfp, strobj^.name) + END; + IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN + IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp) + ELSIF c = Array THEN + IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp); OPM.FPrint(idfp, typ^.n) + ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ^.link) + END; + typ^.idfp := idfp + END +END IdFPrint; + +PROCEDURE FPrintStr*(typ: Struct); + VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; + + PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); + + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) + VAR i, j, n: LONGINT; btyp: Struct; + BEGIN + IF typ^.comp = Record THEN FPrintFlds(typ^.link, adr, FALSE) + ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; + IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO + INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN + OPM.FPrint(pvfp, Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN + OPM.FPrint(pvfp, ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld^.mode = Fld) DO + IF (fld^.vis # internal) & visible THEN + OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); + FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) + ELSE + FPrintHdFld(fld^.typ, fld, fld^.adr + adr) + END; + fld := fld^.link + END; + END FPrintFlds; + + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + BEGIN + IF obj # NIL THEN + FPrintTProcs(obj^.left); + IF obj^.mode = TProc THEN + IF obj^.vis # internal THEN + OPM.FPrint(pbfp, TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); + FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) + ELSIF OPM.ExpHdTProc THEN + OPM.FPrint(pvfp, TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) + END + END; + FPrintTProcs(obj^.right) + END; + END FPrintTProcs; + +BEGIN + IF ~typ^.fpdone THEN + IdFPrint(typ); pbfp := typ^.idfp; + IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END; + pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) + typ^.fpdone := TRUE; + f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; + IF f = Pointer THEN + strobj := typ^.strobj; bstrobj := btyp^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN + FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp + ELSE (* c = Record *) + IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END; + OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); + nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END; + FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END + END; + typ^.pbfp := pbfp; typ^.pvfp := pvfp + END +END FPrintStr; + +PROCEDURE FPrintObj*(obj: Object); +VAR fprint: LONGINT; f, m: INTEGER; rval: REAL; ext: ConstExt; +BEGIN + IF ~obj^.fpdone THEN + fprint := 0; obj^.fpdone := TRUE; + OPM.FPrint(fprint, obj^.mode); + IF obj^.mode = Con THEN + f := obj^.typ^.form; OPM.FPrint(fprint, f); + CASE f OF + | Bool, + Char, + Int: OPM.FPrint(fprint, obj^.conval^.intval) + | Set: OPM.FPrintSet(fprint, obj^.conval^.setval) + | Real: rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) + | LReal: OPM.FPrintLReal(fprint, obj^.conval^.realval) + | String: FPrintName(fprint, obj^.conval^.ext^) + | NilTyp: + ELSE err(127) + END + ELSIF obj^.mode = Var THEN + OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + ELSIF obj^.mode IN {XProc, IProc} THEN + FPrintSign(fprint, obj^.typ, obj^.link) + ELSIF obj^.mode = CProc THEN + FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; + m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); + WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; + ELSIF obj^.mode = Typ THEN + FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + END; + obj^.fprint := fprint + END +END FPrintObj; + +PROCEDURE FPrintErr*(obj: Object; errcode: INTEGER); +VAR i, j: INTEGER; ch: CHAR; +BEGIN + IF obj^.mnolev # 0 THEN + COPY(GlbMod[-obj^.mnolev]^.name, OPM.objname); i := 0; + WHILE OPM.objname[i] # 0X DO INC(i) END; + OPM.objname[i] := "."; j := 0; INC(i); + REPEAT ch := obj^.name[j]; OPM.objname[i] := ch; INC(j); INC(i) UNTIL ch = 0X; + ELSE + COPY(obj^.name, OPM.objname) + END; + IF errcode = 249 THEN + IF OPM.noerr THEN err(errcode) END + ELSIF errcode = 253 THEN (* extension *) + IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END; + symExtended := TRUE + ELSE + IF ~symNew & ~newsf THEN err(errcode) END; + symNew := TRUE + END +END FPrintErr; + +(*-------------------------- Import --------------------------*) + +PROCEDURE InsertImport*(obj: Object; VAR root, old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; +BEGIN + IF root = NIL THEN root := obj; old := NIL + ELSE + ob0 := root; ob1 := ob0^.right; left := FALSE; + IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE + ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE + ELSE old := ob0; RETURN + END; + LOOP + IF ob1 # NIL THEN + IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE + ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE + ELSE old := ob1; EXIT + END + ELSE ob1 := obj; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT + END + END + END +END InsertImport; + +PROCEDURE InName(VAR name: ARRAY OF CHAR); +VAR i: INTEGER; ch: CHAR; +BEGIN i := 0; + REPEAT + OPM.SymRCh(ch); name[i] := ch; INC(i) + UNTIL ch = 0X +END InName; + +PROCEDURE InMod(VAR mno: SHORTINT); (* mno is global *) + VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; +BEGIN + mn := OPM.SymRInt(); + IF mn = 0 THEN mno := impCtxt.glbmno[0] + ELSE + IF mn = Smname THEN + InName(name); + IF (name = SelfName) & ~impCtxt.self THEN err(154) END; + i := 0; + WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head^.mode := Head; COPY(name, head^.name); + mno := nofGmod; head^.mnolev := -mno; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-mn] + END + END +END InMod; + +PROCEDURE InLinks; (* Load a list of all modules whose object files we will need to link with *) + VAR linkname: OPS.Name; l: Link; +BEGIN + InName(linkname); + WHILE linkname[0] # 0X DO + l := Links; WHILE (l # NIL) & (l.name # linkname) DO l := l.next END; + IF l = NIL THEN + l := Links; NEW(Links); + Links.next := l; Links.name := linkname + END; + InName(linkname) + END +END InLinks; + +PROCEDURE InConstant(f: LONGINT; conval: Const); + VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; +BEGIN + CASE f OF + | Byte, + Char, + Bool: OPM.SymRCh(ch); conval^.intval := ORD(ch) + | Int: conval^.intval := OPM.SymRInt() + | Set: OPM.SymRSet(conval^.setval) + | Real: OPM.SymRReal(rval); conval^.realval := rval; + conval^.intval := OPM.ConstNotAlloc + | LReal: OPM.SymRLReal(conval^.realval); + conval^.intval := OPM.ConstNotAlloc + | String: ext := NewExt(); conval^.ext := ext; i := 0; + REPEAT + OPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval^.intval2 := i; + conval^.intval := OPM.ConstNotAlloc + | NilTyp: conval^.intval := OPM.nilval + ELSE OPM.LogWStr("unhandled case in InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + OPM.err(155) (* Symbol file corrupted *) + END +END InConstant; + +PROCEDURE ^InStruct(VAR typ: Struct); + +PROCEDURE InSign(mno: SHORTINT; VAR res: Struct; VAR par: Object); + VAR last, new: Object; tag: LONGINT; +BEGIN + InStruct(res); + tag := OPM.SymRInt(); + last := NIL; + WHILE tag # Send DO + + (* Add bounds checking *) + IF (tag < 0) OR (tag > 100) THEN + OPM.LogWStr("ERROR: Invalid tag value in InSign: "); OPM.LogWNum(tag, 0); OPM.LogWLn; + OPM.err(155); (* symbol file corrupted *) + RETURN + END; + + new := NewObj(); + new^.mnolev := -mno; + IF last = NIL THEN par := new ELSE last^.link := new END; + IF tag = Svalpar THEN new^.mode := Var ELSE new^.mode := VarPar END; + InStruct(new^.typ); + new^.adr := OPM.SymRInt(); InName(new^.name); + last := new; + tag := OPM.SymRInt(); + END +END InSign; + +PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) + VAR tag: LONGINT; obj: Object; +BEGIN + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj^.mode := Fld; + IF tag = Srfld THEN obj^.vis := externalR ELSE obj^.vis := external END; + InStruct(obj^.typ); InName(obj^.name); + obj^.adr := OPM.SymRInt() + ELSE + obj^.mode := Fld; + IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END; + obj^.typ := undftyp; obj^.vis := internal; + obj^.adr := OPM.SymRInt() + END; + RETURN obj +END InFld; + +PROCEDURE InTProc(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) + VAR tag: LONGINT; obj: Object; +BEGIN + tag := impCtxt.nextTag; + obj := NewObj(); obj^.mnolev := -mno; + IF tag = Stpro THEN + obj^.mode := TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); obj^.vis := external; InName(obj^.name); + obj^.adr := 10000H*OPM.SymRInt() + ELSE (* tag = Shdtpro *) + obj^.mode := TProc; obj^.name := OPM.HdTProcName; + obj^.link := NewObj(); (* dummy, easier in Browser *) + obj^.typ := undftyp; obj^.vis := internal; + obj^.adr := 10000H*OPM.SymRInt() + END; + RETURN obj +END InTProc; + + +PROCEDURE InTyp(tag: LONGINT): Struct; +BEGIN + IF tag = Int THEN RETURN IntType(OPM.SymRInt()) + ELSIF tag = Set THEN RETURN SetType(OPM.SymRInt()) + ELSE RETURN impCtxt.ref[tag] + END +END InTyp; + + +PROCEDURE InStruct(VAR typ: Struct); + VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; + t: Struct; obj, last, fld, old, dummy: Object; +BEGIN + tag := OPM.SymRInt(); + IF tag # Sstruct THEN typ := InTyp(-tag) + ELSE + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END; + InMod(mno); InName(name); obj := NewObj(); + IF name = "" THEN + IF impCtxt.self THEN + old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE + obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" + END; + typ := NewStr(Undef, Basic) + ELSE + obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(Undef, Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; + typ^.fpdone := FALSE; typ^.idfpdone := FALSE + END + ELSE + typ := NewStr(Undef, Basic) + END + END; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; + typ^.ref := ref + maxStruct; + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ^.mno := mno; typ^.allocated := TRUE; + typ^.strobj := obj; obj^.mode := Typ; obj^.typ := typ; + obj^.mnolev := -mno; obj^.vis := internal; (* name not visible here *) + tag := OPM.SymRInt(); + IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END; + CASE tag OF + | Sptr: typ^.form := Pointer; typ^.size := OPM.AddressSize; + typ^.n := 0; InStruct(typ^.BaseTyp) + | Sarr: typ^.form := Comp; typ^.comp := Array; + InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); + TypSize(typ) (* no bounds address !! *) + | Sdarr: typ^.form := Comp; typ^.comp := DynArr; InStruct(typ^.BaseTyp); + IF typ^.BaseTyp^.comp = DynArr THEN + typ^.n := typ^.BaseTyp^.n + 1 + ELSE + typ^.n := 0 + END; + TypSize(typ) + | Srec: typ^.form := Comp; typ^.comp := Record; + InStruct(typ^.BaseTyp); + IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + (* do not take extlev from base type due to possible cycles! *) + WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO + INC(typ^.extlev); t := t.BaseTyp + END; (* !!! *) + typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); + typ^.n := OPM.SymRInt(); + impCtxt.nextTag := OPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO + fld := InFld(); fld^.mnolev := -mno; + IF last # NIL THEN last^.link := fld END; + last := fld; InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END; + WHILE impCtxt.nextTag # Send DO + fld := InTProc(mno); + InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END + | Spro: typ^.form := ProcTyp; typ^.size := OPM.AddressSize; + InSign(mno, typ^.BaseTyp, typ^.link) + ELSE OPM.LogWStr("unhandled case at InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + END; + IF ref = impCtxt.minr THEN + WHILE (ref < impCtxt.nofr) DO + t := InTyp(ref); FPrintStr(t); + obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) + IF obj^.name # "" THEN FPrintObj(obj) END; + old := impCtxt.old[ref]; + IF old # NIL THEN + t^.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old^.mnolev < 0 THEN + IF old^.history # inconsistent THEN + IF old^.fprint # obj^.fprint THEN + old^.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := pvmodified + END + (* ELSE remain inconsistent *) + END + ELSIF old^.fprint # obj^.fprint THEN + old^.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := pvmodified + ELSIF old^.vis = internal THEN + old^.history := same (* may be changed to "removed" in InObj *) + ELSE + old^.history := inserted (* may be changed to "same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := inconsistent + END; + IF old^.fprint # obj^.fprint THEN + FPrintErr(old, 249) + END + END + ELSIF impCtxt.self THEN + obj^.history := removed + ELSE + obj^.history := same + END; + INC(ref) + END; + impCtxt.minr := maxStruct + END + END +END InStruct; + + +PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) + VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; + tag: LONGINT; ext: ConstExt; + commentText: ARRAY OPM.MaxCommentLen OF CHAR; + hasComment : BOOLEAN; + j: INTEGER; + len: LONGINT; +BEGIN + tag := impCtxt.nextTag; + hasComment := FALSE; + + (* checking for comment first, but not processing it yet *) + WHILE tag = Scomment DO (* Handle multiple consecutive comments *) + len := OPM.SymRInt(); (* read length *) + + (* Ensure length is within bounds *) + IF len < 0 THEN len := 0 END; + IF len > OPS.MaxStrLen - 1 THEN len := OPS.MaxStrLen - 1 END; + + i := 0; + WHILE i < len DO + OPM.SymRCh(commentText[i]); INC(i) + END; + commentText[i] := 0X; + hasComment := TRUE; (* Only keep the last comment if there are multiple *) + + tag := OPM.SymRInt(); (* continue stream *) + END; + + (* Now tag should be a valid object tag *) + (*impCtxt.nextTag := tag;*) + + (* Additional validation for constants *) + IF (tag <= Pointer) & (tag = Undef) THEN + OPM.err(155); (* Symbol file error *) + RETURN NIL + END; + + (* Validate tag value *) + IF (tag < 0) OR (tag > 50) THEN + OPM.LogWStr("ERROR: Invalid tag in InObj: "); OPM.LogWNum(tag, 0); OPM.LogWLn; + OPM.err(155); (* Symbol file error *) + RETURN NIL + END; + + IF tag = Stype THEN + InStruct(typ); obj := typ^.strobj; + IF ~impCtxt.self THEN obj^.vis := external END (* type name visible now, obj^.fprint already done *) + ELSE + obj := NewObj(); obj^.mnolev := -mno; obj^.vis := external; + IF tag <= Pointer THEN (* Constant *) + obj^.mode := Con; obj^.conval := NewConst(); InConstant(tag, obj^.conval); + obj^.typ := InTyp(tag) + ELSIF (tag >= Sxpro) & (tag <= Scpro) THEN (* Procedure tags *) + obj^.conval := NewConst(); + obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); + CASE tag OF + | Sxpro: obj^.mode := XProc + | Sipro: obj^.mode := IProc + | Scpro: obj^.mode := CProc; + ext := NewExt(); obj^.conval^.ext := ext; + s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; + WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END + ELSE OPM.LogWStr("unhandled case at InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + OPM.err(155); RETURN NIL + END + ELSIF tag = Salias THEN + obj^.mode := Typ; InStruct(obj^.typ) + ELSIF (tag = Svar) OR (tag = Srvar) THEN + obj^.mode := Var; + IF tag = Srvar THEN obj^.vis := externalR END; + InStruct(obj^.typ) + ELSE + OPM.LogWStr("ERROR: Unexpected tag in InObj: "); OPM.LogWNum(tag, 0); OPM.LogWLn; + OPM.err(155); (* Symbol file error *) + RETURN NIL + END; + InName(obj^.name) + END; + + (* attaching exported comment after the object was created *) + IF hasComment & (obj # NIL) THEN + NEW(obj^.comment); + j := 0; + WHILE (j < OPM.MaxCommentLen - 1) & (j < len) & (commentText[j] # 0X) DO + obj^.comment^[j] := commentText[j]; + INC(j) + END; + obj^.comment^[j] := 0X; + END; + + FPrintObj(obj); + IF (obj^.mode = Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) + END; + IF tag # Stype THEN + InsertImport(obj, GlbMod[mno].right, old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old^.vis = internal THEN old^.history := removed + ELSE FPrintObj(old); (* FPrint(obj) already called *) + IF obj^.fprint # old^.fprint THEN old^.history := pbmodified + ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := pvmodified + ELSE old^.history := same + END + END + ELSE obj^.history := removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already inserted in InStruct *) + IF impCtxt.self THEN (* obj^.mnolev = 0 *) + IF obj^.vis = internal THEN obj^.history := removed + ELSIF obj^.history = inserted THEN obj^.history := same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END; +RETURN obj +END InObj; + + + +PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); + VAR obj: Object; mno: SHORTINT; (* done used in Browser *) +BEGIN + IF name = "SYSTEM" THEN SYSimported := TRUE; + Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp + ELSE + impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + IF impCtxt.self & (OPM.forcenewsym IN OPM.Options) THEN + OPM.DeleteSym(name); done := FALSE + ELSE + OPM.OldSym(name, done) + END; + IF done THEN + InMod(mno); InLinks; + impCtxt.nextTag := OPM.SymRInt(); + WHILE ~OPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() + END; + Insert(aliasName, obj); + obj^.mode := Mod; obj^.scope := GlbMod[mno].right; + GlbMod[mno].link := obj; + obj^.mnolev := -mno; obj^.typ := notyp; + OPM.CloseOldSym + ELSIF impCtxt.self THEN + newsf := TRUE; extsf := TRUE; sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END +END Import; + +(*-------------------------- Export --------------------------*) + + PROCEDURE OutName(VAR name: ARRAY OF CHAR); + VAR i: INTEGER; ch: CHAR; + BEGIN i := 0; + REPEAT ch := name[i]; OPM.SymWCh(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE OutMod(mno: INTEGER); + BEGIN + IF expCtxt.locmno[mno] < 0 THEN (* new mod *) + OPM.SymWInt(Smname); + expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm); + OutName(GlbMod[mno].name) + ELSE OPM.SymWInt(-expCtxt.locmno[mno]) + END + END OutMod; + + PROCEDURE OutLinks; + VAR l: Link; + BEGIN + l := Links; WHILE l # NIL DO OutName(l.name); l := l.next END; + OPM.SymWCh(0X) + END OutLinks; + + PROCEDURE ^OutStr(typ: Struct); + PROCEDURE ^OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); + + PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: LONGINT); + VAR i, j, n: LONGINT; btyp: Struct; + BEGIN + IF typ^.comp = Record THEN OutFlds(typ^.link, adr, FALSE) + ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; + IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN + j := nofhdfld; OutHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO + INC(adr, btyp^.size); OutHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN + OPM.SymWInt(Shdptr); OPM.SymWInt(adr); INC(nofhdfld) + ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN + OPM.SymWInt(Shdpro); OPM.SymWInt(adr); INC(nofhdfld) + END + END OutHdFld; + + PROCEDURE OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); + BEGIN + WHILE (fld # NIL) & (fld^.mode = Fld) DO + IF (fld^.vis # internal) & visible THEN + IF fld^.vis = externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END; + OutStr(fld^.typ); OutName(fld^.name); OPM.SymWInt(fld^.adr) + ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr) + END; + fld := fld^.link + END + END OutFlds; + + PROCEDURE OutSign(result: Struct; par: Object); (* Procedure signature *) + BEGIN + OutStr(result); + WHILE par # NIL DO + IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END; + OutStr(par^.typ); + OPM.SymWInt(par^.adr); + OutName(par^.name); par := par^.link + END; + OPM.SymWInt(Send) + END OutSign; + + PROCEDURE OutTProcs(typ: Struct; obj: Object); (* Type bound procedures *) + BEGIN + IF obj # NIL THEN + OutTProcs(typ, obj^.left); + IF obj^.mode = TProc THEN + IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = internal) THEN + OPM.Mark(109, typ^.txtpos) + (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) + END; + IF OPM.ExpHdTProc OR (obj^.vis # internal) THEN + IF obj^.vis # internal THEN + OPM.SymWInt(Stpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name); + OPM.SymWInt(obj^.adr DIV 10000H) + ELSE + OPM.SymWInt(Shdtpro); + OPM.SymWInt(obj^.adr DIV 10000H) + END + END + END; + OutTProcs(typ, obj^.right) + END + END OutTProcs; + + PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *) + VAR strobj: Object; + BEGIN + IF (typ^.ref < expCtxt.ref) THEN OPM.SymWInt(-typ^.ref); + IF typ.ref IN {Int, Set} THEN OPM.SymWInt(typ.size) END + ELSE + OPM.SymWInt(Sstruct); + typ^.ref := expCtxt.ref; INC(expCtxt.ref); + IF expCtxt.ref >= maxStruct THEN err(228) END; + OutMod(typ^.mno); strobj := typ^.strobj; + + IF (strobj # NIL) & (strobj^.name # "") THEN OutName(strobj^.name); + CASE strobj^.history OF + | pbmodified: FPrintErr(strobj, 252) + | pvmodified: FPrintErr(strobj, 251) + | inconsistent: FPrintErr(strobj, 249) + ELSE (* checked in OutObj or correct indirect export *) + (* OPM.LogWStr("unhandled case at OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) + END + ELSE OPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) + END; + IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END; + CASE typ^.form OF + | Pointer: OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) + | ProcTyp: OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) + | Comp: CASE typ^.comp OF + | Array: OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) + | DynArr: OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) + | Record: OPM.SymWInt(Srec); + IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END; + (* BaseTyp should be Notyp, too late to change *) + OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); + nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END; + OutTProcs(typ, typ^.link); OPM.SymWInt(Send) + ELSE OPM.LogWStr("unhandled case at OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; + END + ELSE OPM.LogWStr("unhandled case at OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; + END + END + END OutStr; + + PROCEDURE OutConstant(obj: Object); + VAR f: INTEGER; rval: REAL; + BEGIN + f := obj^.typ^.form; OPM.SymWInt(f); + CASE f OF + | Bool, + Char: OPM.SymWCh(CHR(obj^.conval^.intval)) + | Int: OPM.SymWInt(obj^.conval^.intval); OPM.SymWInt(obj.typ.size) + | Set: OPM.SymWSet(obj^.conval^.setval); OPM.SymWInt(obj.typ.size) + | Real: rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) + | LReal: OPM.SymWLReal(obj^.conval^.realval) + | String: OutName(obj^.conval^.ext^) + | NilTyp: + ELSE err(127) + END + END OutConstant; + +PROCEDURE OutTruncatedName(text: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN + i := 0; + WHILE (i < OPS.MaxStrLen - 1) & (text[i] # 0X) DO + OPM.SymWCh(text[i]); INC(i) + END; + OPM.SymWCh(0X) +END OutTruncatedName; + + +PROCEDURE OutObj(obj: Object); + VAR i, j: INTEGER; ext: ConstExt; + k, l: INTEGER; +BEGIN + IF obj # NIL THEN + OutObj(obj^.left); + IF obj^.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN + (* Write comment BEFORE the object *) + IF obj^.comment # NIL THEN + (* Only write comments for objects that make sense *) + IF (obj^.mode IN {Con, Typ, Var, XProc, IProc, CProc}) & (obj^.vis # internal) THEN + OPM.SymWInt(Scomment); + (* Calculate actual length of comment text *) + k := 0; + WHILE (k < OPM.MaxCommentLen - 1) & (obj^.comment^[k] # 0X) DO INC(k) END; + OPM.SymWInt(k); (* length prefix *) + (* Write comment data as individual characters *) + l := 0; + WHILE l < k DO + OPM.SymWCh(obj^.comment^[l]); INC(l) + END + END + (* If condition is false, we skip the comment entirely *) + END; + + IF obj^.history = removed THEN FPrintErr(obj, 250) + ELSIF obj^.vis # internal THEN + CASE obj^.history OF + | inserted: FPrintErr(obj, 253) + | same: (* ok *) + | pbmodified: FPrintErr(obj, 252) + | pvmodified: FPrintErr(obj, 251) + ELSE OPM.LogWStr("unhandled case at OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; + END; + CASE obj^.mode OF + | Con: OutConstant(obj); OutName(obj^.name) + | Typ: IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) + ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) + END + | Var: IF obj^.vis = externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END; + OutStr(obj^.typ); OutName(obj^.name); + IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN + (* compute fingerprint to avoid structural type equivalence *) + OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) + END + | XProc: OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | IProc: OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | CProc: OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; + j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); + WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END; + OutName(obj^.name) + ELSE OPM.LogWStr("unhandled case at OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; + END + END + END; + OutObj(obj^.right) + END +END OutObj; + + PROCEDURE Export*(VAR ext, new: BOOLEAN); + VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; + BEGIN + symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; + Import("@self", SelfName, done); nofGmod := nofmod; + IF OPM.noerr THEN (* ~OPM.noerr => ~done *) + OPM.NewSym(SelfName); + IF OPM.noerr THEN + OPM.SymWInt(Smname); OutName(SelfName); OutLinks; + expCtxt.reffp := 0; expCtxt.ref := FirstRef(*Comp+1*); + expCtxt.nofm := 1; expCtxt.locmno[0] := 0; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END; + OutObj(topScope^.right); + ext := sfpresent & symExtended; + new := ~sfpresent OR symNew OR (OPM.forcenewsym IN OPM.Options); + IF OPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN + new := TRUE; + IF ~extsf THEN err(155) END + END; + newsf := FALSE; symNew := FALSE; (* because of call to FPrintErr from OPL *) + IF ~OPM.noerr OR findpc THEN + OPM.DeleteSym(SelfName) + END + (* OPM.RegisterNewSym is called in OP2 after writing the object file *) + END + END + END Export; (* no new symbol file if ~OPM.noerr or findpc *) + + +(*------------------------- Initialise types --------------------------*) + + PROCEDURE InitStruct(VAR typ: Struct; form: SHORTINT); + BEGIN + typ := NewStr(form, Basic); typ^.ref := form; typ^.size := 1; typ^.allocated := TRUE; + typ^.strobj := NewObj(); typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; + typ^.idfp := form; typ^.idfpdone := TRUE + END InitStruct; + + PROCEDURE EnterBoolConst(name: OPS.Name; value: LONGINT); + VAR obj: Object; + BEGIN + Insert(name, obj); obj^.conval := NewConst(); + obj^.mode := Con; obj^.typ := booltyp; obj^.conval^.intval := value + END EnterBoolConst; + + PROCEDURE EnterTyp(name: OPS.Name; form: SHORTINT; size: INTEGER; VAR res: Struct); + VAR obj: Object; typ: Struct; + BEGIN + Insert(name, obj); + typ := NewStr(form, Basic); obj^.mode := Typ; obj^.typ := typ; obj^.vis := external; + typ^.strobj := obj; typ^.size := size; typ^.ref := form; typ^.allocated := TRUE; + typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; + typ^.idfp := form; typ^.idfpdone := TRUE; + IF form IN {Int, Set} THEN OPM.FPrint(typ.idfp, typ.size) END; + res := typ + END EnterTyp; + + PROCEDURE EnterTypeAlias(name: OPS.Name; VAR res: Object); + VAR obj: Object; + BEGIN + Insert(name, obj); obj^.mode := Typ; obj^.typ := NIL; obj^.vis := external; + res := obj + END EnterTypeAlias; + + PROCEDURE EnterProc(name: OPS.Name; num: INTEGER); + VAR obj: Object; + BEGIN Insert(name, obj); + obj^.mode := SProc; obj^.typ := notyp; obj^.adr := num + END EnterProc; + + + +BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0; + InitStruct(undftyp, Undef); undftyp^.BaseTyp := undftyp; + InitStruct(notyp, NoTyp); + InitStruct(stringtyp, String); + InitStruct(niltyp, NilTyp); + + (*initialization of module SYSTEM*) + EnterTyp("BYTE", Byte, 1, bytetyp); + EnterTyp("PTR", Pointer, -1, sysptrtyp); (* Size set in Compiler.PropagateElementaryTypeSize *) + EnterTyp("ADDRESS", Int, -1, adrtyp); (* Size set in Compiler.PropagateElementaryTypeSize *) + EnterTyp("INT8", Int, 1, int8typ); + EnterTyp("INT16", Int, 2, int16typ); + EnterTyp("INT32", Int, 4, int32typ); + EnterTyp("INT64", Int, 8, int64typ); + EnterTyp("SET32", Set, 4, set32typ); + EnterTyp("SET64", Set, 8, set64typ); + + EnterProc("ADR", adrfn); + EnterProc("CC", ccfn); + EnterProc("LSH", lshfn); + EnterProc("ROT", rotfn); + EnterProc("GET", getfn); + EnterProc("PUT", putfn); + EnterProc("GETREG", getrfn); + EnterProc("PUTREG", putrfn); + EnterProc("BIT", bitfn); + EnterProc("VAL", valfn); + EnterProc("NEW", sysnewfn); + EnterProc("MOVE", movefn); + + + syslink := topScope^.right; + universe := topScope; topScope^.right := NIL; + + EnterTyp("BOOLEAN", Bool, 1, booltyp); + EnterTyp("CHAR", Char, 1, chartyp); + EnterTyp("REAL", Real, 4, realtyp); + EnterTyp("LONGREAL", LReal, 8, lrltyp); + EnterTyp("HUGEINT", Int, 8, hinttyp); + EnterTyp("BYTE@", Int, 1, cpbytetyp); (* Component Pascal byte type, enabled in Compiler.PropagateElementaryTypeSize *) + + (* Type aliases for standard integer and set types are linked to real types in Compiler.PropagateElementaryTypeSize *) + EnterTypeAlias("SHORTINT", sintobj); + EnterTypeAlias("INTEGER", intobj); + EnterTypeAlias("LONGINT", lintobj); + EnterTypeAlias("SET", setobj); + + + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) + EnterBoolConst("TRUE", 1); + + EnterProc("HALT", haltfn); + EnterProc("NEW", newfn); + EnterProc("ABS", absfn); + EnterProc("CAP", capfn); + EnterProc("ORD", ordfn); + EnterProc("ENTIER", entierfn); + EnterProc("ODD", oddfn); + EnterProc("MIN", minfn); + EnterProc("MAX", maxfn); + EnterProc("CHR", chrfn); + EnterProc("SHORT", shortfn); + EnterProc("LONG", longfn); + EnterProc("SIZE", sizefn); + EnterProc("INC", incfn); + EnterProc("DEC", decfn); + EnterProc("INCL", inclfn); + EnterProc("EXCL", exclfn); + EnterProc("LEN", lenfn); + EnterProc("COPY", copyfn); + EnterProc("ASH", ashfn); + EnterProc("ASSERT", assertfn); + + impCtxt.ref[Undef] := undftyp; + impCtxt.ref[Byte] := bytetyp; + impCtxt.ref[Bool] := booltyp; + impCtxt.ref[Char] := chartyp; + impCtxt.ref[Int] := int32typ; + impCtxt.ref[Real] := realtyp; + impCtxt.ref[LReal] := lrltyp; + impCtxt.ref[Set] := settyp; + impCtxt.ref[String] := stringtyp; + impCtxt.ref[NilTyp] := niltyp; + impCtxt.ref[NoTyp] := notyp; + impCtxt.ref[Pointer] := sysptrtyp; + +END OPT. + +Objects: + + mode | adr conval link scope leaf + ------------------------------------------------ + Undef | Not used + Var | vadr next regopt Glob or loc var or proc value parameter + VarPar| vadr next regopt Procedure var parameter + Con | val Constant + Fld | off next Record field + Typ | Named type + LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end + XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end + SProc | fno sizes Standard procedure + CProc | code firstpar scope Code procedure + IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end + Mod | scope Module + Head | txtpos owner firstvar Scope anchor + TProc | index sizes firstpar scope leaf Bound procedure, index = 10000H*mthno+entry, entry adr set in back-end + + Structures: + + form comp | n BaseTyp link mno txtpos sysflag + ---------------------------------------------------------------------------------- + Undef Basic | + Byte Basic | + Bool Basic | + Char Basic | + Int Basic | size determine SHORT vs LONG + XInt Basic | bits + Real Basic | + LReal Basic | + Set Basic | + String Basic | + NilTyp Basic | + NoTyp Basic | + Pointer Basic | PBaseTyp mno txtpos sysflag + ProcTyp Basic | ResTyp params mno txtpos sysflag + Comp Array | nofel ElemTyp mno txtpos sysflag + Comp DynArr| dim ElemTyp mno txtpos sysflag + Comp Record| nofmth RBaseTyp fields mno txtpos sysflag + +Nodes: + +design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc. +expr = design|Nconst|Nupto|Nmop|Ndop|Ncall. +nextexpr = NIL|expr. +ifstat = NIL|Nif. +casestat = Ncaselse. +sglcase = NIL|Ncasedo. +stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat| + Nloop|Nexit|Nreturn|Nwith|Ntrap. + + + class subcl obj left right link + --------------------------------------------------------- + +design Nvar var nextexpr + Nvarpar varpar nextexpr + Nfield field design nextexpr + Nderef design nextexpr + Nindex design expr nextexpr + Nguard design nextexpr (typ = guard type) + Neguard design nextexpr (typ = guard type) + Ntype type nextexpr + Nproc normal proc nextexpr + super proc nextexpr + + +expr design + Nconst const (val = node^.conval) + Nupto expr expr nextexpr + Nmop not expr nextexpr + minus expr nextexpr + is tsttype expr nextexpr + conv expr nextexpr + abs expr nextexpr + cap expr nextexpr + odd expr nextexpr + adr expr nextexpr SYSTEM.ADR + cc Nconst nextexpr SYSTEM.CC + val expr nextexpr SYSTEM.VAL + Ndop times expr expr nextexpr + slash expr expr nextexpr + div expr expr nextexpr + mod expr expr nextexpr + and expr expr nextexpr + plus expr expr nextexpr + minus expr expr nextexpr + or expr expr nextexpr + eql expr expr nextexpr + neq expr expr nextexpr + lss expr expr nextexpr + leq expr expr nextexpr + grt expr expr nextexpr + geq expr expr nextexpr + in expr expr nextexpr + ash expr expr nextexpr + msk expr Nconst nextexpr + len design Nconst nextexpr + bit expr expr nextexpr SYSTEM.BIT + lsh expr expr nextexpr SYSTEM.LSH + rot expr expr nextexpr SYSTEM.ROT + Ncall fpar design nextexpr nextexpr + +nextexpr NIL + expr + +ifstat NIL + Nif expr stat ifstat + +casestat Ncaselse sglcase stat (minmax = node^.conval) + +sglcase NIL + Ncasedo Nconst stat sglcase + +stat NIL + Ninittd stat (of node^.typ) + Nenter proc stat stat stat (proc=NIL for mod) + Nassign assign design expr stat + newfn design stat + incfn design expr stat + decfn design expr stat + inclfn design expr stat + exclfn design expr stat + copyfn design expr stat + getfn design expr stat SYSTEM.GET + putfn expr expr stat SYSTEM.PUT + getrfn design Nconst stat SYSTEM.GETREG + putrfn Nconst expr stat SYSTEM.PUTREG + sysnewfn design expr stat SYSTEM.NEW + movefn expr expr stat SYSTEM.MOVE + (right^.link = 3rd par) + Ncall fpar design nextexpr stat + Nifelse ifstat stat stat + Ncase expr casestat stat + Nwhile expr stat stat + Nrepeat stat expr stat + Nloop stat stat + Nexit stat + Nreturn proc nextexpr stat (proc = NIL for mod) + Nwith ifstat stat stat + Ntrap expr stat diff --git a/src/compiler/OPV.Mod b/src/compiler/OPV.Mod new file mode 100644 index 00000000..c6b26c05 --- /dev/null +++ b/src/compiler/OPV.Mod @@ -0,0 +1,934 @@ +(* OPV - parse tree traverser (back end) *) +MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 + + 26.7.2002 jt bug fix OPS.in Len: wrong result if called for fixed OPT.Array + 31.1.2007 jt synchronized with BlackBox version, in particular: + various promotion rules changed (long) => (LONGINT), xxxL avoided +*) + + IMPORT OPT, OPC, OPM, OPS, SYSTEM; + + CONST + UndefinedType = 0; (* named type not yet defined *) + ProcessingType = 1; (* pointer type is being processed *) + PredefinedType = 2; (* for all predefined types *) + DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) + DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) + + OpenParen = "("; + CloseParen = ")"; + OpenBracket = "["; + CloseBracket = "]"; + Blank = " "; + Comma = ", "; + Deref = "*"; + EntierFunc = "__ENTIER("; + IsFunc = "__IS("; + IsPFunc = "__ISP("; + GuardPtrFunc = "__GUARDP("; + GuardRecFunc = "__GUARDR("; + TypeFunc = "__TYPEOF("; + CopyFunc = "__COPY("; + MoveFunc = "__MOVE("; + GetFunc = "__GET("; + PutFunc = "__PUT("; + DynTypExt = "__typ"; + WithChk = "__WITHCHK"; + Break = "break"; + ElseStat = "else "; + + MinPrec = -1; + MaxPrec = 12; + ProcTypeVar = 11; (* precedence number when a call is made with a proc type variable *) + + + TYPE + ExitInfo = RECORD level, label: INTEGER END ; + + + VAR + stamp: INTEGER; (* unique number for nested objects *) + + exit: ExitInfo; (* to check if EXIT is simply a break *) + nofExitLabels: INTEGER; + + + PROCEDURE Init*; + BEGIN + stamp := 0; nofExitLabels := 0; + END Init; + + PROCEDURE ^Traverse (obj, outerScope: OPT.Object; exported: BOOLEAN); + + PROCEDURE GetTProcNum(obj: OPT.Object); + VAR oldPos: LONGINT; typ: OPT.Struct; redef: OPT.Object; + BEGIN + oldPos := OPM.errpos; OPM.errpos := obj^.scope^.adr; + typ := obj^.link^.typ; + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + OPT.FindField(obj^.name, typ^.BaseTyp, redef); + IF redef # NIL THEN obj^.adr := 10000H*(redef^.adr DIV 10000H) (*mthno*); + IF ~(OPT.isRedef IN obj^.conval^.setval) THEN OPM.err(119) END + ELSE INC(obj^.adr, 10000H*typ^.n); INC(typ^.n) + END ; + OPM.errpos := oldPos + END GetTProcNum; + + PROCEDURE TraverseRecord(typ: OPT.Struct); + BEGIN + IF ~typ^.allocated THEN + IF typ^.BaseTyp # NIL THEN TraverseRecord(typ^.BaseTyp); typ^.n := typ^.BaseTyp^.n END ; + typ^.allocated := TRUE; Traverse(typ^.link, typ^.strobj, FALSE) + END + END TraverseRecord; + + PROCEDURE Stamp(VAR s: OPS.Name); + VAR i, j, k: INTEGER; n: ARRAY 10 OF CHAR; + BEGIN INC(stamp); + i := 0; j := stamp; + WHILE s[i] # 0X DO INC(i) END ; + IF i > 25 THEN i := 25 END ; + s[i] := "_"; s[i+1] := "_"; INC(i, 2); k := 0; + REPEAT n[k] := CHR((j MOD 10) + ORD("0")); j := j DIV 10; INC(k) UNTIL j = 0; + REPEAT DEC(k); s[i] := n[k]; INC(i) UNTIL k = 0; + s[i] := 0X; + END Stamp; + + PROCEDURE Traverse (obj, outerScope: OPT.Object; exported: BOOLEAN); + VAR mode: INTEGER; scope: OPT.Object; typ: OPT.Struct; + BEGIN + IF obj # NIL THEN + Traverse(obj^.left, outerScope, exported); + IF obj^.name[0] = "@" THEN obj^.name[0] := "_"; Stamp(obj^.name) END ; (* translate and make unique @for, ... *) + obj^.linkadr := UndefinedType; + mode := obj^.mode; + IF (mode = OPT.Typ) & ((obj^.vis # OPT.internal) = exported) THEN + typ := obj^.typ; OPT.TypSize(obj^.typ); + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.comp = OPT.Record THEN TraverseRecord(typ) END + ELSIF mode = OPT.TProc THEN GetTProcNum(obj) + ELSIF mode = OPT.Var THEN OPT.TypSize(obj^.typ) + END ; + IF ~exported THEN (* do this only once *) + IF (mode IN {OPT.LProc, OPT.Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; + IF mode IN {OPT.Var, OPT.VarPar, OPT.Typ} THEN + obj^.scope := outerScope + ELSIF mode IN {OPT.LProc, OPT.XProc, OPT.TProc, OPT.CProc, OPT.IProc} THEN + IF obj^.conval^.setval = {} THEN OPM.err(129) END ; + scope := obj^.scope; + scope^.leaf := TRUE; + scope^.name := obj^.name; Stamp(scope^.name); + IF mode = OPT.CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; + IF scope^.mnolev > 1 THEN outerScope^.leaf := FALSE END ; + Traverse (obj^.scope^.right, obj^.scope, FALSE) + END + END; + Traverse(obj^.right, outerScope, exported); + END + END Traverse; + + PROCEDURE AdrAndSize* (topScope: OPT.Object); + BEGIN + ASSERT(OPT.sinttyp # NIL); ASSERT(OPT.inttyp # NIL); ASSERT(OPT.linttyp # NIL); + + OPM.errpos := topScope^.adr; (* text position of scope used if error *) + topScope^.leaf := TRUE; + Traverse(topScope^.right, topScope, TRUE); (* first pass only on exported types and procedures *) + Traverse(topScope^.right, topScope, FALSE); (* second pass *) + + (* mark basic types as predefined, OPC.Ident can avoid qualification*) + OPT.chartyp^.strobj^.linkadr := PredefinedType; + OPT.cpbytetyp^.strobj^.linkadr := PredefinedType; + OPT.settyp^.strobj^.linkadr := PredefinedType; + OPT.realtyp^.strobj^.linkadr := PredefinedType; + OPT.adrtyp^.strobj^.linkadr := PredefinedType; + OPT.int8typ^.strobj^.linkadr := PredefinedType; + OPT.int16typ^.strobj^.linkadr := PredefinedType; + OPT.int32typ^.strobj^.linkadr := PredefinedType; + OPT.int64typ^.strobj^.linkadr := PredefinedType; + OPT.set32typ^.strobj^.linkadr := PredefinedType; + OPT.set64typ^.strobj^.linkadr := PredefinedType; + OPT.hinttyp.strobj.linkadr := PredefinedType; + OPT.lrltyp^.strobj^.linkadr := PredefinedType; + OPT.booltyp^.strobj^.linkadr := PredefinedType; + OPT.bytetyp^.strobj^.linkadr := PredefinedType; + OPT.sysptrtyp^.strobj^.linkadr := PredefinedType; + END AdrAndSize; + +(* ____________________________________________________________________________________________________________________________________________________________________ *) + + PROCEDURE Precedence (class, subclass, form, comp: INTEGER): INTEGER; + BEGIN + CASE class OF + | OPT.Nconst, + OPT.Nvar, + OPT.Nfield, + OPT.Nindex, + OPT.Nproc, + OPT.Ncall: RETURN 10 + | OPT.Nguard: IF OPM.typchk IN OPM.Options THEN RETURN 10 ELSE RETURN 9 (*cast*) END + | OPT.Nvarpar: IF comp IN {OPT.Array, OPT.DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) + | OPT.Nderef: RETURN 9 + | OPT.Nmop: CASE subclass OF + | OPS.not, OPS.minus, OPT.adr, OPT.val, OPT.conv: RETURN 9 + | OPS.is, OPT.abs, OPT.cap, OPT.odd, OPT.cc: RETURN 10 + ELSE OPM.LogWStr("unhandled case in OPV.Precedence OPT.Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END + | OPT.Ndop: CASE subclass OF + | OPS.times: IF form = OPT.Set THEN RETURN 4 ELSE RETURN 8 END + | OPS.slash: IF form = OPT.Set THEN RETURN 3 ELSE RETURN 8 END + | OPS.div, + OPS.mod: RETURN 10 (* div/mod are replaced by functions *) + | OPS.plus: IF form = OPT.Set THEN RETURN 2 ELSE RETURN 7 END + | OPS.minus: IF form = OPT.Set THEN RETURN 4 ELSE RETURN 7 END + | OPS.lss, + OPS.leq, + OPS.gtr, + OPS.geq: RETURN 6 + | OPS.eql, + OPS.neq: RETURN 5 + | OPS.and: RETURN 1 + | OPS.or: RETURN 0 + | OPT.len, + OPS.in, + OPT.ash, + OPT.msk, + OPT.bit, + OPT.lsh, + OPT.rot: RETURN 10 + ELSE OPM.LogWStr("unhandled case in OPV.Precedence OPT.Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END; + | OPT.Nupto: RETURN 10 + | OPT.Ntype, + OPT.Neguard: (* ignored anyway *) RETURN MaxPrec + ELSE OPM.LogWStr("unhandled case in OPV.Precedence, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; + END; + END Precedence; + + PROCEDURE^ expr (n: OPT.Node; prec: INTEGER); + PROCEDURE^ design(n: OPT.Node; prec: INTEGER); + + PROCEDURE Len(n: OPT.Node; dim: SYSTEM.INT64); + VAR + d: SYSTEM.INT64; array: OPT.Struct; + BEGIN + WHILE (n^.class = OPT.Nindex) & (n^.typ^.comp = OPT.DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; + IF (n^.class = OPT.Nderef) & (n^.typ^.comp = OPT.DynArr) THEN + d := dim; array := n^.typ; + WHILE d > 0 DO array := array^.BaseTyp; DEC(d) END; + IF array^.comp = OPT.DynArr THEN + design(n^.left, 10); OPM.WriteString("->len["); OPM.WriteInt(dim); OPM.Write("]") + ELSE + OPM.WriteInt(array^.n) + END + ELSE + OPC.Len(n^.obj, n^.typ, dim) + END + END Len; + + PROCEDURE SideEffects(n: OPT.Node): BOOLEAN; + BEGIN + IF n # NIL THEN RETURN (n^.class = OPT.Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) + ELSE RETURN FALSE + END + END SideEffects; + + PROCEDURE Entier(n: OPT.Node; prec: INTEGER); + BEGIN + IF n^.typ^.form IN {OPT.Real, OPT.LReal} THEN + OPM.WriteString(EntierFunc); expr(n, MinPrec); OPM.Write(CloseParen) + ELSE expr(n, prec) + END + END Entier; + + PROCEDURE SizeCast(n: OPT.Node; to: LONGINT); + BEGIN + IF (to < n.typ.size) & (OPM.ranchk IN OPM.Options) THEN + OPM.WriteString("__SHORT"); IF SideEffects(n) THEN OPM.Write("F") END; + OPM.Write(OpenParen); Entier(n, MinPrec); OPM.WriteString(Comma); + OPM.WriteInt(OPM.SignedMaximum(to) + 1); OPM.Write(CloseParen) + ELSE + IF (n.typ.size # to) & ((n.typ.size > OPM.CIntSize) OR (to # OPM.CIntSize)) THEN + OPM.WriteString("(INT"); OPM.WriteInt(to*8); OPM.WriteString(")") + END; + Entier(n, 9) + END + END SizeCast; + + PROCEDURE Convert(n: OPT.Node; newtype: OPT.Struct; prec: INTEGER); + VAR from, to: INTEGER; + BEGIN from := n^.typ^.form; to := newtype.form; + IF to = OPT.Set THEN + IF from = OPT.Set THEN (* Sets of different size *) + SizeCast(n, newtype.size); + ELSE (* Set from integer *) + OPM.WriteString("__SETOF("); Entier(n, MinPrec); + OPM.WriteString(","); OPM.WriteInt(newtype.size*8); OPM.Write(CloseParen) + END + ELSIF to = OPT.Int THEN (* integers of different size *) + SizeCast(n, newtype.size); + ELSIF to = OPT.Char THEN + IF OPM.ranchk IN OPM.Options THEN OPM.WriteString("__CHR"); + IF SideEffects(n) THEN OPM.Write("F") END ; + OPM.Write(OpenParen); Entier(n, MinPrec); OPM.Write(CloseParen) + ELSE OPM.WriteString("(CHAR)"); Entier(n, 9) + END + ELSE expr(n, prec) + END + END Convert; + + PROCEDURE TypeOf(n: OPT.Node); + BEGIN + IF n^.typ^.form = OPT.Pointer THEN + OPM.WriteString(TypeFunc); expr(n, MinPrec); OPM.Write(")") + ELSIF n^.class IN {OPT.Nvar, OPT.Nindex, OPT.Nfield} THEN (* dyn rec type = stat rec type *) + OPC.Andent(n^.typ); OPM.WriteString(DynTypExt) + ELSIF n^.class = OPT.Nderef THEN (* p^ *) + OPM.WriteString(TypeFunc); expr(n^.left, MinPrec); OPM.Write(")") + ELSIF n^.class = OPT.Nguard THEN (* r(T) *) + TypeOf(n^.left) (* skip guard *) + ELSIF (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN + (*SYSTEM.VAL(typ, var par rec)*) + OPC.TypeOf(n^.left^.obj) + ELSE (* var par rec *) + OPC.TypeOf(n^.obj) + END + END TypeOf; + + PROCEDURE Index(n, d: OPT.Node; prec, dim: INTEGER); + BEGIN + IF ~(OPM.inxchk IN OPM.Options) + OR (n^.right^.class = OPT.Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # OPT.DynArr)) THEN + expr(n^.right, prec) + ELSE + IF SideEffects(n^.right) THEN OPM.WriteString("__XF(") ELSE OPM.WriteString("__X(") END ; + expr(n^.right, MinPrec); OPM.WriteString(Comma); Len(d, dim); OPM.Write(CloseParen) + END + END Index; + + PROCEDURE design(n: OPT.Node; prec: INTEGER); + VAR obj: OPT.Object; typ: OPT.Struct; + class, designPrec, comp: INTEGER; + d, x: OPT.Node; dims, i: INTEGER; + BEGIN + comp := n^.typ^.comp; obj := n^.obj; class := n^.class; + designPrec := Precedence(class, n^.subcl, n^.typ^.form, comp); + IF (class = OPT.Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; + IF prec > designPrec THEN OPM.Write(OpenParen) END; + IF prec = ProcTypeVar THEN OPM.Write(Deref) END; (* proc var calls must be dereferenced in K&R C *) + CASE class OF + | OPT.Nproc: OPC.Ident(n^.obj) + | OPT.Nvar: OPC.CompleteIdent(n^.obj) + | OPT.Nvarpar: IF ~(comp IN {OPT.Array, OPT.DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) + OPC.CompleteIdent(n^.obj) + | OPT.Nfield: IF n^.left^.class = OPT.Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") + ELSE design(n^.left, designPrec); OPM.Write(".") + END ; + OPC.Ident(n^.obj) + | OPT.Nderef: IF n^.typ^.comp = OPT.DynArr THEN design(n^.left, 10); OPM.WriteString("->data") + ELSE OPM.Write(Deref); design(n^.left, designPrec) + END + | OPT.Nindex: d := n^.left; + IF d^.typ^.comp = OPT.DynArr THEN dims := 0; + WHILE d^.class = OPT.Nindex DO d := d^.left; INC(dims) END ; + IF n^.typ^.comp = OPT.DynArr THEN OPM.Write("&") END ; + design(d, designPrec); + OPM.Write(OpenBracket); + IF n^.typ^.comp = OPT.DynArr THEN OPM.Write("(") END ; + i := dims; x := n; + WHILE x # d DO (* apply Horner schema *) + IF x^.left # d THEN Index(x, d, 7, i); OPM.WriteString(" + "); Len(d, i); OPM.WriteString(" * ("); DEC(i) + ELSE Index(x, d, MinPrec, i) + END ; + x := x^.left + END ; + FOR i := 1 TO dims DO OPM.Write(")") END ; + IF n^.typ^.comp = OPT.DynArr THEN + (* element type is OPT.DynArr; finish Horner schema with virtual indices = 0*) + OPM.Write(")"); + WHILE i < (d^.typ^.size - 4) DIV 4 DO + OPM.WriteString(" * "); Len(d, i); + INC(i) + END + END ; + OPM.Write(CloseBracket) + ELSE + design(n^.left, designPrec); + OPM.Write(OpenBracket); + Index(n, n^.left, MinPrec, 0); + OPM.Write(CloseBracket) + END + | OPT.Nguard: typ := n^.typ; obj := n^.left^.obj; + IF OPM.typchk IN OPM.Options THEN + IF typ^.comp = OPT.Record THEN OPM.WriteString(GuardRecFunc); + IF obj^.mnolev # OPM.level THEN (*intermediate level var-par record*) + OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString("__curr->"); OPC.Ident(obj) + ELSE (*local var-par record*) + OPC.Ident(obj) + END ; + ELSE (*Pointer*) + IF typ^.BaseTyp^.strobj = NIL THEN OPM.WriteString("__GUARDA(") ELSE OPM.WriteString(GuardPtrFunc) END ; + expr(n^.left, MinPrec); typ := typ^.BaseTyp + END ; + OPM.WriteString(Comma); + OPC.Andent(typ); OPM.WriteString(Comma); + OPM.WriteInt(typ^.extlev); OPM.Write(")") + ELSE + IF typ^.comp = OPT.Record THEN (* do not cast record directly, cast pointer to record *) + OPM.WriteString("*("); OPC.Ident(typ^.strobj); OPM.WriteString("*)"); OPC.CompleteIdent(obj) + ELSE (*simply cast pointer*) + OPM.Write("("); OPC.Ident(typ^.strobj); OPM.Write(")"); expr(n^.left, designPrec) + END + END + | OPT.Neguard: IF OPM.typchk IN OPM.Options THEN + IF n^.left^.class = OPT.Nvarpar THEN OPM.WriteString("__GUARDEQR("); + OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left); + ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec) + END ; (* __GUARDEQx includes deref *) + OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(")") + ELSE + expr(n^.left, MinPrec) (* always lhs of assignment *) + END + | OPT.Nmop: IF n^.subcl = OPT.val THEN design(n^.left, prec) END + ELSE OPM.LogWStr("unhandled case in OPV.design, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; + END ; + IF prec > designPrec THEN OPM.Write(CloseParen) END + END design; + + PROCEDURE ParIntLiteral(n: SYSTEM.INT64; size: LONGINT); + BEGIN + (* Literal parameters (other than varargs) do not need an explicit size cast on ansi C compilers. *) + OPM.WriteInt(n) + END ParIntLiteral; + + PROCEDURE ActualPar(n: OPT.Node; fp: OPT.Object); + VAR typ, aptyp: OPT.Struct; comp, form, mode, prec, dim: INTEGER; + BEGIN + OPM.Write(OpenParen); + WHILE n # NIL DO typ := fp^.typ; + comp := typ^.comp; form := typ^.form; mode := fp^.mode; prec := MinPrec; + IF (mode = OPT.VarPar) & (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN (* avoid cast in lvalue *) + OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.WriteString("*)"); prec := 10 + END ; + IF ~(n^.typ^.comp IN {OPT.Array, OPT.DynArr}) THEN + IF mode = OPT.VarPar THEN + IF typ # n^.typ THEN OPM.WriteString("(void*)") END; + OPM.Write("&"); prec := 9 + ELSE + IF (comp IN {OPT.Array, OPT.DynArr}) & (n^.class = OPT.Nconst) THEN + OPM.WriteString("(CHAR*)") (* force to unsigned char *) + ELSIF (form = OPT.Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN + OPM.WriteString("(void*)") (* type extension *) + END + END + ELSE + (* casting of params should be simplified eventually *) + IF (mode = OPT.VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END + END; + IF (mode = OPT.VarPar) & (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN + expr(n^.left, prec) (* avoid cast in lvalue *) + ELSIF (form = OPT.Int) & (n^.class = OPT.Nconst) THEN + ParIntLiteral(n.conval.intval, n.typ.size) + ELSE + expr(n, prec) + END; + IF (comp = OPT.Record) & (mode = OPT.VarPar) THEN + OPM.WriteString(", "); TypeOf(n) + ELSIF comp = OPT.DynArr THEN + IF n^.class = OPT.Nconst THEN (* ap is string constant *) + OPM.WriteString(Comma); ParIntLiteral(n.conval.intval2, OPM.AddressSize) + ELSE + aptyp := n^.typ; dim := 0; + WHILE (typ^.comp = OPT.DynArr) & (typ^.BaseTyp^.form # OPT.Byte) DO + OPM.WriteString(Comma); Len(n, dim); + typ := typ^.BaseTyp; aptyp := aptyp^.BaseTyp; INC(dim) + END ; + IF (typ^.comp = OPT.DynArr) & (typ^.BaseTyp^.form = OPT.Byte) THEN + OPM.WriteString(Comma); + WHILE aptyp^.comp = OPT.DynArr DO + Len(n, dim); OPM.WriteString(" * "); INC(dim); aptyp := aptyp^.BaseTyp + END ; + (*OPM.WriteString("((LONGINT)("); OPM.WriteInt(aptyp^.size); OPM.WriteString("))");*) + ParIntLiteral(aptyp.size, OPM.AddressSize) + END + END + END ; + n := n^.link; fp := fp^.link; + IF n # NIL THEN OPM.WriteString(Comma) END + END ; + OPM.Write(CloseParen) + END ActualPar; + + PROCEDURE SuperProc(n: OPT.Node): OPT.Object; + VAR obj: OPT.Object; typ: OPT.Struct; + BEGIN typ := n^.right^.typ; (* receiver type *) + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + OPT.FindField(n^.left^.obj^.name, typ^.BaseTyp, obj); + RETURN obj + END SuperProc; + + PROCEDURE expr (n: OPT.Node; prec: INTEGER); + VAR + class: INTEGER; + subclass: INTEGER; + form: INTEGER; + exprPrec: INTEGER; + typ: OPT.Struct; + l, r: OPT.Node; + proc: OPT.Object; + BEGIN + class := n^.class; subclass := n^.subcl; form := n^.typ^.form; + l := n^.left; r := n^.right; + exprPrec := Precedence (class, subclass, form, n^.typ^.comp); + IF (exprPrec <= prec) & (class IN {OPT.Nconst, OPT.Nupto, OPT.Nmop, OPT.Ndop, OPT.Ncall, OPT.Nguard, OPT.Neguard}) THEN + OPM.Write(OpenParen); + END; + CASE class OF + | OPT.Nconst: OPC.Constant(n^.conval, form) + | OPT.Nupto: (* n^.typ = OPT.settyp *) + OPM.WriteString("__SETRNG("); expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); + OPM.WriteString(Comma); OPM.WriteInt(n.typ.size*8); OPM.Write(CloseParen) + | OPT.Nmop: + CASE subclass OF + | OPS.not: OPM.Write("!"); expr(l, exprPrec) + | OPS.minus: IF form = OPT.Set THEN OPM.Write("~") ELSE OPM.Write("-") END; + expr(l, exprPrec) + | OPS.is: typ := n^.obj^.typ; + IF l^.typ^.comp = OPT.Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) + ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp + END ; + OPM.WriteString(Comma); + OPC.Andent(typ); OPM.WriteString(Comma); + OPM.WriteInt(typ^.extlev); OPM.Write(")") + | OPT.conv: Convert(l, n.typ, exprPrec) + | OPT.abs: IF SideEffects(l) THEN + IF l^.typ^.form < OPT.Real THEN + IF l.typ.size <= OPM.CIntSize THEN OPM.WriteString("(int)") END ; + OPM.WriteString("__ABSF(") + ELSE OPM.WriteString("__ABSFD(") + END + ELSE OPM.WriteString("__ABS(") + END ; + expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.cap: OPM.WriteString("__CAP("); expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.odd: OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.adr: OPM.WriteString("(ADDRESS)"); (*SYSTEM*) + IF l^.class = OPT.Nvarpar THEN OPC.CompleteIdent(l^.obj) + ELSE + IF (l^.typ^.form # OPT.String) & ~(l^.typ^.comp IN {OPT.Array, OPT.DynArr}) THEN OPM.Write("&") END ; + expr(l, exprPrec) + END + | OPT.val: IF ~(l^.class IN {OPT.Nvar, OPT.Nvarpar, OPT.Nfield, OPT.Nindex}) (*SYSTEM*) + OR (n^.typ^.form IN {OPT.Int, OPT.Pointer, OPT.Set, OPT.ProcTyp}) + & (l^.typ^.form IN {OPT.Int, OPT.Pointer, OPT.Set, OPT.ProcTyp}) + & (n^.typ^.size = l^.typ^.size) + THEN + OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen); + IF (n^.typ^.form IN {OPT.Pointer, OPT.ProcTyp}) OR (l^.typ^.form IN {OPT.Pointer, OPT.ProcTyp}) THEN + OPM.WriteString("(ADDRESS)") + END; + expr(l, exprPrec) + ELSE + OPM.WriteString("__VAL("); + OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma); + expr(l, MinPrec); OPM.Write(CloseParen) + END + ELSE OPM.err(200) + END + | OPT.Ndop: CASE subclass OF + | OPT.len: Len(l, r^.conval^.intval) + | OPS.in, + OPT.ash, + OPT.msk, + OPT.bit, + OPT.lsh, + OPT.rot, + OPS.div, + OPS.mod: CASE subclass OF + | OPS.in: OPM.WriteString("__IN(") + | OPT.ash: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ASHL(") + ELSE OPM.WriteString("__ASHR(") + END + ELSIF SideEffects(r) THEN OPM.WriteString("__ASHF(") + ELSE OPM.WriteString("__ASH(") + END + | OPT.msk: OPM.WriteString("__MASK("); + | OPT.bit: OPM.WriteString("__BIT(") + | OPT.lsh: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__LSHL(") + ELSE OPM.WriteString("__LSHR(") + END + ELSE OPM.WriteString("__LSH(") + END + | OPT.rot: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ROTL(") + ELSE OPM.WriteString("__ROTR(") + END + ELSE OPM.WriteString("__ROT(") + END + | OPS.div: IF SideEffects(n) THEN + IF n.typ.size <= OPM.CIntSize THEN OPM.WriteString("(int)") END; + OPM.WriteString("__DIVF(") + ELSE OPM.WriteString("__DIV(") + END + | OPS.mod: IF n.typ.size <= OPM.CIntSize THEN OPM.WriteString("(int)") END; + IF SideEffects(n) THEN OPM.WriteString("__MODF(") + ELSE OPM.WriteString("__MOD(") + END; + ELSE OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END ; + expr(l, MinPrec); + OPM.WriteString(Comma); + IF (subclass IN {OPT.ash, OPT.lsh, OPT.rot}) & (r^.class = OPT.Nconst) & (r^.conval^.intval < 0) THEN + OPM.WriteInt(-r^.conval^.intval) + ELSE expr(r, MinPrec) + END; + IF subclass IN {OPS.in, OPT.lsh, OPT.rot} THEN + OPM.WriteString(Comma); + IF subclass = OPS.in THEN OPM.WriteInt(r.typ.size*8) ELSE OPM.WriteInt(l.typ.size*8) END + END; + OPM.Write(CloseParen) + | OPS.eql + .. OPS.geq: IF l^.typ^.form IN {OPT.String, OPT.Comp} THEN + OPM.WriteString("__STRCMP("); + expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); OPM.Write(CloseParen); + OPC.Cmp(subclass); OPM.Write("0") + ELSE + expr(l, exprPrec); OPC.Cmp(subclass); + typ := l^.typ; + IF (typ^.form = OPT.Pointer) & (r^.typ.form # OPT.NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN + OPM.WriteString("(void *) ") + END ; + expr(r, exprPrec) + END + ELSE IF (subclass = OPS.and) OR ((form = OPT.Set) & ((subclass = OPS.times) OR (subclass = OPS.minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) + expr(l, exprPrec); + CASE subclass OF + | OPS.times: IF form = OPT.Set THEN OPM.WriteString(" & ") + ELSE OPM.WriteString(" * ") + END + | OPS.slash: IF form = OPT.Set THEN OPM.WriteString(" ^ ") + ELSE OPM.WriteString(" / "); + IF (r^.obj = NIL) OR (r^.obj^.typ^.form = OPT.Int) THEN + OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen) + END + END + | OPS.and: OPM.WriteString(" && ") + | OPS.plus: IF form = OPT.Set THEN OPM.WriteString(" | ") + ELSE OPM.WriteString(" + ") + END + | OPS.minus: IF form = OPT.Set THEN OPM.WriteString(" & ~") + ELSE OPM.WriteString(" - ") + END; + | OPS.or: OPM.WriteString(" || "); + ELSE OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END; + expr(r, exprPrec); + IF (subclass = OPS.and) OR ((form = OPT.Set) & ((subclass = OPS.times) OR (subclass = OPS.minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) + END + | OPT.Ncall: IF (l^.obj # NIL) & (l^.obj^.mode = OPT.TProc) THEN + IF l^.subcl = OPT.super THEN proc := SuperProc(n) + ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj) + END ; + OPC.Ident(proc); + n^.obj := proc^.link + ELSIF l^.class = OPT.Nproc THEN design(l, 10) + ELSE design(l, ProcTypeVar) + END ; + ActualPar(r, n^.obj) + ELSE design(n, prec); (* not exprPrec! *) + END; + IF (exprPrec <= prec) & (class IN {OPT.Nconst, OPT.Nupto, OPT.Nmop, OPT.Ndop, OPT.Ncall, OPT.Nguard}) THEN + OPM.Write(CloseParen) + END + END expr; + + PROCEDURE^ stat(n: OPT.Node; outerProc: OPT.Object); + + PROCEDURE IfStat(n: OPT.Node; withtrap: BOOLEAN; outerProc: OPT.Object); + VAR if: OPT.Node; obj: OPT.Object; typ: OPT.Struct; adr: LONGINT; + BEGIN (* n^.class IN {OPT.Nifelse, OPT.Nwith} *) + if := n^.left; (* name := ""; *) + WHILE if # NIL DO + OPM.WriteString("if "); expr(if^.left, MaxPrec); (* if *) + OPM.Write(Blank); OPC.BegBlk; + IF (n^.class = OPT.Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) + obj := if^.left^.left^.obj; typ := obj^.typ; adr := obj^.adr; + IF typ^.comp = OPT.Record THEN + (* introduce alias pointer for var records; T1 *name__ = rec; *) + OPC.BegStat; OPC.Ident(if^.left^.obj); OPM.WriteString(" *"); + OPM.WriteString(obj.name); OPM.WriteString("__ = (void*)"); + obj^.adr := 0; (* for nested WITH with same variable; always take the original name *) + OPC.CompleteIdent(obj); + OPC.EndStat + END ; + obj^.adr := 1; (* signal special handling of variable name to OPC.CompleteIdent *) + obj^.typ := if^.left^.obj^.typ; + stat(if^.right, outerProc); + obj^.typ := typ; obj^.adr := adr + ELSE + stat(if^.right, outerProc) + END ; + if := if^.link; + IF (if # NIL) OR (n^.right # NIL) OR withtrap THEN OPC.EndBlk0(); OPM.WriteString(" else "); + ELSE OPC.EndBlk() + END + END ; + IF withtrap THEN OPM.WriteString(WithChk); OPC.EndStat() + ELSIF n^.right # NIL THEN OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk + END + END IfStat; + + PROCEDURE CaseStat(n: OPT.Node; outerProc: OPT.Object); + VAR switchCase, label: OPT.Node; + low, high: SYSTEM.INT64; form, i: INTEGER; + BEGIN + OPM.WriteString("switch "); expr(n^.left, MaxPrec); + OPM.Write(Blank); OPC.BegBlk; + form := n^.left^.typ^.form; + switchCase := n^.right^.left; + WHILE switchCase # NIL DO (* switchCase^.class = Ncasedo *) + label := switchCase^.left; + i := 0; + WHILE label # NIL DO (* label^.class = NConst *) + low := label^.conval^.intval; + high := label^.conval^.intval2; + WHILE low <= high DO + IF i = 0 THEN OPC.BegStat END ; + OPC.Case(low, form); + INC(low); INC(i); + IF i = 5 THEN OPM.WriteLn; i := 0 END + END ; + label := label^.link + END ; + IF i > 0 THEN OPM.WriteLn END ; + OPC.Indent(1); + stat(switchCase^.right, outerProc); + OPC.BegStat; OPM.WriteString(Break); OPC.EndStat; + OPC.Indent(-1); + switchCase := switchCase^.link + END ; + OPC.BegStat; OPM.WriteString("default: "); + IF n^.right^.conval^.setval # {} THEN (* else branch *) + OPC.Indent(1); OPM.WriteLn; stat(n^.right^.right, outerProc); + OPC.BegStat; OPM.WriteString(Break); OPC.Indent(-1) + ELSE + OPM.WriteString("__CASECHK") + END ; + OPC.EndStat; OPC.EndBlk + END CaseStat; + + PROCEDURE ImplicitReturn(n: OPT.Node): BOOLEAN; + BEGIN + WHILE (n # NIL) & (n.class # OPT.Nreturn) DO n := n^.link END ; + RETURN n = NIL + END ImplicitReturn; + + PROCEDURE NewArr(d, x: OPT.Node); + VAR typ, base: OPT.Struct; nofdim, nofdyn: INTEGER; + BEGIN + typ := d^.typ^.BaseTyp; base := typ; nofdim := 0; nofdyn := 0; + WHILE base^.comp = OPT.DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; + design(d, MinPrec); OPM.WriteString(" = __NEWARR("); + WHILE base^.comp = OPT.Array DO INC(nofdim); base := base^.BaseTyp END ; + IF (base^.comp = OPT.Record) & (OPC.NofPtrs(base) # 0) THEN + OPC.Andent(base); OPM.WriteString(DynTypExt) + ELSIF base^.form = OPT.Pointer THEN OPM.WriteString("POINTER__typ") + ELSE OPM.WriteString("NIL") + END ; + OPM.WriteString(", "); OPM.WriteInt(base.size); + OPM.WriteString(", "); OPM.WriteInt(OPT.BaseAlignment(base)); (* element alignment *) + OPM.WriteString(", "); OPM.WriteInt(nofdim); (* total number of dimensions = number of additional parameters *) + OPM.WriteString(", "); OPM.WriteInt(nofdyn); (* number of dynamic dimensions *) + WHILE typ # base DO + OPM.WriteString(", "); + IF typ^.comp = OPT.DynArr THEN + IF x^.class = OPT.Nconst THEN + OPC.IntLiteral(x.conval.intval, OPM.AddressSize) + ELSE OPM.WriteString("((ADDRESS)("); expr(x, 10); OPM.WriteString("))") + END ; + x := x^.link + ELSE + OPC.IntLiteral(typ.n, OPM.AddressSize) + END ; + typ := typ^.BaseTyp + END ; + OPM.Write(")") + END NewArr; + + PROCEDURE DefineTDescs(n: OPT.Node); + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END + END DefineTDescs; + + PROCEDURE InitTDescs(n: OPT.Node); + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END + END InitTDescs; + + PROCEDURE stat(n: OPT.Node; outerProc: OPT.Object); + VAR proc: OPT.Object; saved: ExitInfo; l, r: OPT.Node; + BEGIN + WHILE (n # NIL) & OPM.noerr DO + OPM.errpos := OPM.Longint(n^.conval^.intval); + IF n^.class # OPT.Ninittd THEN OPC.BegStat END; + CASE n^.class OF + | OPT.Nenter: IF n^.obj = NIL THEN (* enter module *) + INC(OPM.level); stat(n^.left, outerProc); DEC(OPM.level); + OPC.GenEnumPtrs(OPT.topScope^.scope); + DefineTDescs(n^.right); OPC.EnterBody; InitTDescs(n^.right); + OPM.WriteString("/* BEGIN */"); OPM.WriteLn; + stat(n^.right, outerProc); OPC.ExitBody + ELSE (* enter proc *) + proc := n^.obj; + OPC.TypeDefs(proc^.scope^.right, 0); + IF ~proc^.scope^.leaf THEN OPC.DefineInter (proc) END ; (* define intermediate procedure scope *) + INC(OPM.level); stat(n^.left, proc); DEC(OPM.level); + OPC.EnterProc(proc); stat(n^.right, proc); + OPC.ExitProc(proc, TRUE, ImplicitReturn(n^.right)); + END + | OPT.Ninittd: (* done in enter module *) + | OPT.Nassign: CASE n^.subcl OF + | OPT.assign: l := n^.left; r := n^.right; + IF l^.typ^.comp = OPT.Array THEN (* includes string assignment but not COPY *) + OPM.WriteString(MoveFunc); + expr(r, MinPrec); OPM.WriteString(Comma); expr(l, MinPrec); OPM.WriteString(Comma); + IF r^.typ = OPT.stringtyp THEN OPM.WriteInt(r^.conval^.intval2) + ELSIF r.typ.comp = OPT.DynArr THEN + (* Dynamic array to array copy *) + OPM.WriteString("__X("); + OPC.Len(r.obj, r.typ, 0); OPM.WriteString(" * "); OPM.WriteInt(r.typ.BaseTyp.size); + OPM.WriteString(", "); + OPM.WriteInt(l.typ.size+1); (* _X validates 0 .. n-1 so we need top+1. *) + OPM.Write(")") + ELSE (* Array to array copy. *) + ASSERT(r.typ.comp = OPT.Array); ASSERT(r.typ.size <= l.typ.size); + OPM.WriteInt(r^.typ^.size) + END; + OPM.Write(CloseParen) + ELSE + IF (l^.typ^.form = OPT.Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = OPT.Var) THEN + l^.obj^.adr := 0; design(l, MinPrec); l^.obj^.adr := 1; (* avoid cast of WITH-variable *) + IF r^.typ^.form # OPT.NilTyp THEN OPM.WriteString(" = (void*)") + ELSE OPM.WriteString(" = ") + END + ELSE + design(l, MinPrec); OPM.WriteString(" = ") + END ; + IF l^.typ = r^.typ THEN expr(r, MinPrec) + ELSIF (l^.typ^.form = OPT.Pointer) & (r^.typ^.form # OPT.NilTyp) & (l^.typ^.strobj # NIL) THEN + OPM.Write("("); OPC.Ident(l^.typ^.strobj); OPM.Write(")"); expr(r, MinPrec) + ELSIF l^.typ^.comp = OPT.Record THEN + OPM.WriteString("*("); OPC.Andent(l^.typ); OPM.WriteString("*)&"); expr(r, 9) + ELSE expr(r, MinPrec) + END + END + | OPT.newfn: IF n^.left^.typ^.BaseTyp^.comp = OPT.Record THEN + OPM.WriteString("__NEW("); design(n^.left, MinPrec); OPM.WriteString(", "); + OPC.Andent(n^.left^.typ^.BaseTyp); OPM.WriteString(")") + ELSIF n^.left^.typ^.BaseTyp^.comp IN {OPT.Array, OPT.DynArr} THEN + NewArr(n^.left, n^.right) + END + | OPT.incfn, + OPT.decfn: expr(n^.left, MinPrec); OPC.Increment(n^.subcl = OPT.decfn); expr(n^.right, MinPrec) + | OPT.inclfn, + OPT.exclfn: expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = OPT.exclfn); + OPM.WriteString("__SETOF("); expr(n^.right, MinPrec); + OPM.WriteString(","); OPM.WriteInt(n.left.typ.size*8); OPM.Write(CloseParen) + | OPT.copyfn: OPM.WriteString(CopyFunc); + expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); + Len(n^.left, 0); OPM.Write(CloseParen) + | OPT.movefn: (*SYSTEM*) + OPM.WriteString(MoveFunc); + expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); + expr(n^.right^.link, MinPrec); + OPM.Write(CloseParen) + | OPT.getfn: (*SYSTEM*) + OPM.WriteString(GetFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); + OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(CloseParen) + | OPT.putfn: (*SYSTEM*) + OPM.WriteString(PutFunc); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right, MinPrec); + OPM.WriteString(Comma); OPC.Ident(n^.right^.typ^.strobj); OPM.Write(CloseParen) + | OPT.getrfn, (*SYSTEM*) + OPT.putrfn: (*SYSTEM*) OPM.err(200) + | OPT.sysnewfn: (*SYSTEM*) + OPM.WriteString("__SYSNEW("); + design(n^.left, MinPrec); OPM.WriteString(", "); + expr(n^.right, MinPrec); + OPM.Write(")") + ELSE OPM.LogWStr("unhandled case in OPV.expr, n^.subcl = "); OPM.LogWNum(n^.subcl, 0); OPM.LogWLn; + END + | OPT.Ncall: IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = OPT.TProc) THEN + IF n^.left^.subcl = OPT.super THEN proc := SuperProc(n) + ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(n^.left^.obj) + END ; + OPC.Ident(proc); + n^.obj := proc^.link + ELSIF n^.left^.class = OPT.Nproc THEN design(n^.left, 10) + ELSE design(n^.left, ProcTypeVar) + END ; + ActualPar(n^.right, n^.obj) + | OPT.Nifelse: IF n^.subcl # OPT.assertfn THEN IfStat(n, FALSE, outerProc) + ELSIF OPM.assert IN OPM.Options THEN + OPM.WriteString("__ASSERT("); expr(n^.left^.left^.left, MinPrec); OPM.WriteString(Comma); + OPM.WriteInt(n^.left^.right^.right^.conval^.intval); OPM.Write(CloseParen); OPC.EndStat + END + | OPT.Ncase: INC(exit.level); CaseStat(n, outerProc); DEC(exit.level) + | OPT.Nwhile: INC(exit.level); OPM.WriteString("while "); expr(n^.left, MaxPrec); + OPM.Write(Blank); OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk; + DEC(exit.level) + | OPT.Nrepeat: INC(exit.level); OPM.WriteString("do "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk0; + OPM.WriteString(" while (!"); expr(n^.right, 9); OPM.Write(CloseParen); + DEC(exit.level) + | OPT.Nloop: saved := exit; exit.level := 0; exit.label := -1; + OPM.WriteString("for (;;) "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk; + IF exit.label # -1 THEN + OPC.BegStat; OPM.WriteString("exit__"); OPM.WriteInt(exit.label); OPM.Write(":"); OPC.EndStat + END ; + exit := saved + | OPT.Nexit: IF exit.level = 0 THEN OPM.WriteString(Break) + ELSE + IF exit.label = -1 THEN exit.label := nofExitLabels; INC(nofExitLabels) END ; + OPM.WriteString("goto exit__"); OPM.WriteInt(exit.label) + END + | OPT.Nreturn: IF OPM.level = 0 THEN + IF OPM.mainprog IN OPM.Options THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END + ELSIF OPC.NeedsRetval(outerProc) THEN + OPM.WriteString("__retval = "); + IF (n^.left^.typ^.form = OPT.Pointer) & (n^.obj^.typ # n^.left^.typ) THEN + OPM.WriteString("(void*)"); expr(n^.left, 10) + ELSE + expr(n^.left, MinPrec) + END ; + OPC.EndStat; + OPC.BegStat; OPC.ExitProc(outerProc, FALSE, FALSE); OPC.EndStat; + OPC.BegStat; OPM.WriteString("return __retval"); + ELSE + OPC.ExitProc(outerProc, FALSE, FALSE); + OPM.WriteString("return"); + IF n^.left # NIL THEN + OPM.Write(Blank); + IF (n^.left^.typ^.form = OPT.Pointer) & (n^.obj^.typ # n^.left^.typ) THEN + OPM.WriteString("(void*)"); expr(n^.left, 10) + ELSE + expr(n^.left, MinPrec) + END + END + END + | OPT.Nwith: IfStat(n, n^.subcl = 0, outerProc) + | OPT.Ntrap: OPC.Halt(OPM.Longint(n^.right^.conval^.intval)) + ELSE OPM.LogWStr("unhandled case in OPV.expr, n^.class = "); OPM.LogWNum(n^.class, 0); OPM.LogWLn; + END; + IF ~(n^.class IN {OPT.Nenter, OPT.Ninittd, OPT.Nifelse, OPT.Nwith, OPT.Ncase, OPT.Nwhile, OPT.Nloop}) THEN OPC.EndStat END ; + n := n^.link + END + END stat; + + PROCEDURE Module*(prog: OPT.Node); + BEGIN + IF ~(OPM.mainprog IN OPM.Options) THEN OPC.GenHdr(prog^.right); OPC.GenHdrIncludes END ; + OPC.GenBdy(prog^.right); stat(prog, NIL) + END Module; + +END OPV. diff --git a/src/compiler/extTools.Mod b/src/compiler/extTools.Mod new file mode 100644 index 00000000..c51d8c4d --- /dev/null +++ b/src/compiler/extTools.Mod @@ -0,0 +1,124 @@ +MODULE extTools; + +IMPORT Strings, Out, Configuration, Platform, Modules, Heap, OPM; + +TYPE CommandString = ARRAY 4096 OF CHAR; + +VAR CFLAGS: CommandString; + + +PROCEDURE execute(title: ARRAY OF CHAR; cmd: ARRAY OF CHAR); + VAR r, status, exitcode: INTEGER; fullcmd: CommandString; +BEGIN + IF OPM.verbose IN OPM.Options THEN + Out.String(" "); Out.String(cmd); Out.Ln + END; + + (* Hack to suppress unwanted filename display by Microsoft C compiler on successful compilations. *) + IF Configuration.compiler = "MSC" THEN + fullcmd := "cmd /c "; + Strings.Append(cmd, fullcmd); + Strings.Append(" >msc-listing || type msc-listing", fullcmd) + ELSE + COPY(cmd, fullcmd); + END; + + (* Get GC to run file finalizers closing generated C files as otherwise Microsoft C cannot open them. *) + Heap.GC(FALSE); + + r := Platform.System(fullcmd); + + status := r MOD 128; exitcode := r DIV 256; + IF exitcode > 127 THEN exitcode := exitcode - 256 END; (* Handle signed exit code *) + + IF r # 0 THEN + Out.String(title); Out.String(cmd); Out.Ln; + Out.String("-- failed: status "); Out.Int(status,1); + Out.String(", exitcode "); Out.Int(exitcode,1); + Out.String("."); Out.Ln; + IF (status = 0) & (exitcode = 127) THEN + Out.String("Is the C compiler in the current command path?"); Out.Ln + END; + IF status # 0 THEN Modules.Halt(status) ELSE Modules.Halt(exitcode) END + END; +END execute; + + +PROCEDURE InitialiseCompilerCommand(VAR s: ARRAY OF CHAR; additionalopts: ARRAY OF CHAR); +BEGIN + COPY(Configuration.compile, s); + Strings.Append(' -I "', s); + Strings.Append(OPM.ResourceDir, s); + Strings.Append('/include" ', s); + Strings.Append(additionalopts, s); + Strings.Append(" ", s); + Platform.GetEnv("CFLAGS", CFLAGS); + Strings.Append (CFLAGS, s); + Strings.Append (" ", s); +END InitialiseCompilerCommand; + + +PROCEDURE Assemble*(moduleName: ARRAY OF CHAR); + VAR + cmd: CommandString; + BEGIN + InitialiseCompilerCommand(cmd, ""); + Strings.Append("-c ", cmd); + Strings.Append(moduleName, cmd); + Strings.Append(".c", cmd); + execute("C compile: ", cmd); + END Assemble; + + +PROCEDURE LinkMain*(VAR moduleName: ARRAY OF CHAR; statically: BOOLEAN; additionalopts: ARRAY OF CHAR); + VAR + cmd: CommandString; + BEGIN + InitialiseCompilerCommand(cmd, additionalopts); + Strings.Append(moduleName, cmd); + Strings.Append(".c ", cmd); + IF statically THEN + IF Configuration.os = "darwin" THEN + Strings.Append(OPM.InstallDir, cmd); + Strings.Append('/lib/lib', cmd); + Strings.Append(Configuration.name, cmd); + Strings.Append('-O', cmd); + Strings.Append(OPM.Model, cmd); + Strings.Append('.a', cmd); + ELSE + Strings.Append(Configuration.staticLink, cmd) + END + END; + Strings.Append(Configuration.objflag, cmd); + Strings.Append(moduleName, cmd); + IF (~statically) OR ~(Configuration.os = "darwin") THEN + Strings.Append(Configuration.linkflags, cmd); + Strings.Append(OPM.InstallDir, cmd); + Strings.Append('/lib"', cmd); + Strings.Append(Configuration.libspec, cmd); + Strings.Append('-O', cmd); + Strings.Append(OPM.Model, cmd); + Strings.Append(Configuration.libext, cmd) + END; + execute("C compile and link: ", cmd); + + IF (Configuration.os = "darwin") & ~statically THEN + (* Darwin requires an extra command to set the library directory into the binary *) + cmd := "install_name_tool -change lib"; + Strings.Append(Configuration.name, cmd); + Strings.Append('-O', cmd); + Strings.Append(OPM.Model, cmd); + Strings.Append('.dylib "', cmd); + Strings.Append(OPM.InstallDir, cmd); + Strings.Append('/lib/lib', cmd); + Strings.Append(Configuration.name, cmd); + Strings.Append('-O', cmd); + Strings.Append(OPM.Model, cmd); + Strings.Append('.dylib" ', cmd); + Strings.Append(moduleName, cmd); + execute("Set library directory: ", cmd) + END + END LinkMain; + + +END extTools. diff --git a/src/lib/ooc/darwin/clang/x86_64/oocC.Mod b/src/lib/ooc/darwin/clang/x86_64/oocC.Mod deleted file mode 100644 index 14638e75..00000000 --- a/src/lib/ooc/darwin/clang/x86_64/oocC.Mod +++ /dev/null @@ -1,71 +0,0 @@ -(* $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. diff --git a/src/lib/ooc/freebsd/clang/x86_64/oocC.Mod b/src/lib/ooc/freebsd/clang/x86_64/oocC.Mod deleted file mode 100644 index 14638e75..00000000 --- a/src/lib/ooc/freebsd/clang/x86_64/oocC.Mod +++ /dev/null @@ -1,71 +0,0 @@ -(* $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. diff --git a/src/lib/ooc/linux/clang/x86/oocC.Mod b/src/lib/ooc/linux/clang/x86/oocC.Mod deleted file mode 100644 index 2e7751ff..00000000 --- a/src/lib/ooc/linux/clang/x86/oocC.Mod +++ /dev/null @@ -1,72 +0,0 @@ -(* $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* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - 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 TO ARRAY OF char; - -TYPE - Proc* = PROCEDURE; - -END oocC. diff --git a/src/lib/ooc/linux/clang/x86_64/oocC.Mod b/src/lib/ooc/linux/clang/x86_64/oocC.Mod deleted file mode 100644 index 14638e75..00000000 --- a/src/lib/ooc/linux/clang/x86_64/oocC.Mod +++ /dev/null @@ -1,71 +0,0 @@ -(* $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. diff --git a/src/lib/ooc/linux/gcc/armv6j/oocC.Mod b/src/lib/ooc/linux/gcc/armv6j/oocC.Mod deleted file mode 100644 index 2e7751ff..00000000 --- a/src/lib/ooc/linux/gcc/armv6j/oocC.Mod +++ /dev/null @@ -1,72 +0,0 @@ -(* $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* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - 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 TO ARRAY OF char; - -TYPE - Proc* = PROCEDURE; - -END oocC. diff --git a/src/lib/ooc/linux/gcc/armv6j_hardfp/oocC.Mod b/src/lib/ooc/linux/gcc/armv6j_hardfp/oocC.Mod deleted file mode 100644 index 2e7751ff..00000000 --- a/src/lib/ooc/linux/gcc/armv6j_hardfp/oocC.Mod +++ /dev/null @@ -1,72 +0,0 @@ -(* $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* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - 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 TO ARRAY OF char; - -TYPE - Proc* = PROCEDURE; - -END oocC. diff --git a/src/lib/ooc/linux/gcc/powerpc/oocC.Mod b/src/lib/ooc/linux/gcc/powerpc/oocC.Mod deleted file mode 100644 index 2e7751ff..00000000 --- a/src/lib/ooc/linux/gcc/powerpc/oocC.Mod +++ /dev/null @@ -1,72 +0,0 @@ -(* $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* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - 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 TO ARRAY OF char; - -TYPE - Proc* = PROCEDURE; - -END oocC. diff --git a/src/lib/ooc/linux/gcc/x86/oocC.Mod b/src/lib/ooc/linux/gcc/x86/oocC.Mod deleted file mode 100644 index 2e7751ff..00000000 --- a/src/lib/ooc/linux/gcc/x86/oocC.Mod +++ /dev/null @@ -1,72 +0,0 @@ -(* $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* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - 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 TO ARRAY OF char; - -TYPE - Proc* = PROCEDURE; - -END oocC. diff --git a/src/lib/ooc/linux/gcc/x86_64/oocC.Mod b/src/lib/ooc/linux/gcc/x86_64/oocC.Mod deleted file mode 100644 index 14638e75..00000000 --- a/src/lib/ooc/linux/gcc/x86_64/oocC.Mod +++ /dev/null @@ -1,71 +0,0 @@ -(* $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. diff --git a/src/lib/ooc/oocRts.Mod b/src/lib/ooc/oocRts.Mod deleted file mode 100644 index 87461561..00000000 --- a/src/lib/ooc/oocRts.Mod +++ /dev/null @@ -1,78 +0,0 @@ -MODULE oocRts; (* module is written from scratch by noch to wrap around Unix.Mod and Args.Mod and provide compatibility for some ooc libraries *) -IMPORT Args, Unix, Files, Strings := oocStrings(*, Console*); -CONST - pathSeperator* = "/"; - -VAR i : INTEGER; -b : BOOLEAN; -str0 : ARRAY 128 OF CHAR; - -PROCEDURE System* (command : ARRAY OF CHAR) : INTEGER; -(* Executes `command' as a shell command. Result is the value returned by - the libc `system' function. *) -BEGIN -RETURN Unix.System(command) - -END System; - -PROCEDURE GetEnv* (VAR var: ARRAY OF CHAR; name: ARRAY OF CHAR): BOOLEAN; -(* If an environment variable `name' exists, copy its value into `var' and - return TRUE. Otherwise return FALSE. *) -BEGIN -RETURN Args.getEnv(name, var); -END GetEnv; - - -PROCEDURE GetUserHome* (VAR home: ARRAY OF CHAR; user: ARRAY OF CHAR); -(* Get the user's home directory path (stored in /etc/passwd) - or the current user's home directory if user="". *) -VAR -f : Files.File; -r : Files.Rider; -str, str1 : ARRAY 1024 OF CHAR; -found, found1 : BOOLEAN; -p, p1, p2 : INTEGER; -BEGIN -f := Files.Old("/etc/passwd"); -Files.Set(r, f, 0); - -REPEAT - Files.ReadLine(r, str); - -(* Console.String(str); Console.Ln;*) - - Strings.Extract(str, 0, SHORT(LEN(user)-1), str1); -(* Console.String(str1); Console.Ln;*) - - IF Strings.Equal(user, str1) THEN found := TRUE END; - - UNTIL found OR r.eof; - - IF found THEN - found1 := FALSE; - Strings.FindNext(":", str, SHORT(LEN(user)), found1, p); p2 := p + 1; - Strings.FindNext(":", str, p2, found1, p); p2 := p + 1; - Strings.FindNext(":", str, p2, found1, p); p2 := p + 1; - Strings.FindNext(":", str, p2, found1, p); p2 := p + 1; - Strings.FindNext(":", str, p2, found1, p1); - Strings.Extract(str,p+1,p1-p-1, home); - (*Console.String(home); Console.Ln;*) - ELSE - (* current user's home *) - found1 := GetEnv(home, "HOME"); - (*Console.String("not found"); Console.Ln; Console.String (home); Console.Ln;*) - END - - -END GetUserHome; - -BEGIN -(* test *) -(* -i := System("ls"); -b := GetEnv(str0, "HOME"); -IF b THEN Console.String(str0); Console.Ln END; - -GetUserHome(str0, "noch"); -*) -END oocRts. diff --git a/src/lib/ooc/oocSysClock.Mod b/src/lib/ooc/oocSysClock.Mod deleted file mode 100644 index da43fea4..00000000 --- a/src/lib/ooc/oocSysClock.Mod +++ /dev/null @@ -1,110 +0,0 @@ -MODULE oocSysClock; -IMPORT Unix; - -CONST - maxSecondParts* = 999; (* Most systems have just millisecond accuracy *) - - zoneMin* = -780; (* time zone minimum minutes *) - zoneMax* = 720; (* time zone maximum minutes *) - - localTime* = MIN(INTEGER); (* time zone is inactive & time is local *) - unknownZone* = localTime+1; (* time zone is unknown *) - - (* daylight savings mode values *) - unknown* = -1; (* current daylight savings status is unknown *) - inactive* = 0; (* daylight savings adjustments are not in effect *) - active* = 1; (* daylight savings adjustments are being used *) - -TYPE - (* The DateTime type is a system-independent time format whose fields - are defined as follows: - - year > 0 - month = 1 .. 12 - day = 1 .. 31 - hour = 0 .. 23 - minute = 0 .. 59 - second = 0 .. 59 - fractions = 0 .. maxSecondParts - zone = -780 .. 720 - *) - DateTime* = - RECORD - year*: INTEGER; - month*: SHORTINT; - day*: SHORTINT; - hour*: SHORTINT; - minute*: SHORTINT; - second*: SHORTINT; - summerTimeFlag*: SHORTINT; (* daylight savings mode (see above) *) - fractions*: INTEGER; (* parts of a second in milliseconds *) - zone*: INTEGER; (* Time zone differential factor which - is the number of minutes to add to - local time to obtain UTC or is set - to localTime when time zones are - inactive. *) - END; - - -PROCEDURE CanGetClock*(): BOOLEAN; -(* Returns TRUE if a system clock can be read; FALSE otherwise. *) -VAR timeval: Unix.Timeval; timezone: Unix.Timezone; -l : LONGINT; -BEGIN - l := Unix.Gettimeofday(timeval, timezone); - IF l = 0 THEN RETURN TRUE ELSE RETURN FALSE END -END CanGetClock; -(* -PROCEDURE CanSetClock*(): BOOLEAN; -(* Returns TRUE if a system clock can be set; FALSE otherwise. *) -*) -(* -PROCEDURE IsValidDateTime* (d: DateTime): BOOLEAN; -(* Returns TRUE if the value of `d' represents a valid date and time; - FALSE otherwise. *) -*) - - - (* -PROCEDURE SetClock* (userData: DateTime); -(* If possible, sets the system clock to the values of `userData'. *) -*) -(* -PROCEDURE MakeLocalTime * (VAR c: DateTime); -(* Fill in the daylight savings mode and time zone for calendar date `c'. - The fields `zone' and `summerTimeFlag' given in `c' are ignored, assuming - that the rest of the record describes a local time. - Note 1: On most Unix systems the time zone information is only available for - dates falling within approx. 1 Jan 1902 to 31 Dec 2037. Outside this range - the field `zone' will be set to the unspecified `localTime' value (see - above), and `summerTimeFlag' will be set to `unknown'. - Note 2: The time zone information might not be fully accurate for past (and - future) years that apply different DST rules than the current year. - Usually the current set of rules is used for _all_ years between 1902 and - 2037. - Note 3: With DST there is one hour in the year that happens twice: the - hour after which the clock is turned back for a full hour. It is undefined - which time zone will be selected for dates refering to this hour, i.e. - whether DST or normal time zone will be chosen. *) -*) - -PROCEDURE GetTimeOfDay* (VAR sec, usec: LONGINT): LONGINT; -(* PRIVAT. Don't use this. Take Time.GetTime instead. - Equivalent to the C function `gettimeofday'. The return value is `0' on - success and `-1' on failure; in the latter case `sec' and `usec' are set to - zero. *) - VAR timeval: Unix.Timeval; timezone: Unix.Timezone; - l : LONGINT; -BEGIN - l := Unix.Gettimeofday (timeval, timezone); - IF l = 0 THEN - sec := timeval.sec; - usec := timeval.usec; - ELSE - sec := 0; - usec := 0; - END; - RETURN l; -END GetTimeOfDay; - -END oocSysClock. diff --git a/src/lib/ooc2/freebsd/clang/oocwrapperlibc.Mod b/src/lib/ooc2/freebsd/clang/oocwrapperlibc.Mod deleted file mode 100644 index 0d0cf9b6..00000000 --- a/src/lib/ooc2/freebsd/clang/oocwrapperlibc.Mod +++ /dev/null @@ -1,34 +0,0 @@ -MODULE oocwrapperlibc; -IMPORT SYSTEM; -PROCEDURE -includeStdio() - "#include "; - -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. diff --git a/src/lib/ooc2/linux/clang/oocwrapperlibc.Mod b/src/lib/ooc2/linux/clang/oocwrapperlibc.Mod deleted file mode 100644 index 0d0cf9b6..00000000 --- a/src/lib/ooc2/linux/clang/oocwrapperlibc.Mod +++ /dev/null @@ -1,34 +0,0 @@ -MODULE oocwrapperlibc; -IMPORT SYSTEM; -PROCEDURE -includeStdio() - "#include "; - -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. diff --git a/src/lib/ooc2/linux/gcc/oocwrapperlibc.Mod b/src/lib/ooc2/linux/gcc/oocwrapperlibc.Mod deleted file mode 100644 index 0d0cf9b6..00000000 --- a/src/lib/ooc2/linux/gcc/oocwrapperlibc.Mod +++ /dev/null @@ -1,34 +0,0 @@ -MODULE oocwrapperlibc; -IMPORT SYSTEM; -PROCEDURE -includeStdio() - "#include "; - -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. diff --git a/src/lib/s3/powerpc/ethReals.Mod b/src/lib/s3/powerpc/ethReals.Mod deleted file mode 100644 index e11e160e..00000000 --- a/src/lib/s3/powerpc/ethReals.Mod +++ /dev/null @@ -1,305 +0,0 @@ -(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. -Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) - -MODULE ethReals; (** portable *) - -(** Implementation of the non-portable components of IEEE REAL and -LONGREAL manipulation. The routines here are required to do conversion -of reals to strings and back. -Implemented by Bernd Moesli, Seminar for Applied Mathematics, -Swiss Federal Institute of Technology Zrich. -*) - -IMPORT SYSTEM; - -(* Bernd Moesli - Seminar for Applied Mathematics - Swiss Federal Institute of Technology Zurich - Copyright 1993 - - Support module for IEEE floating-point numbers - - Please change constant definitions of H, L depending on byte ordering - Use bm.TestReals.Do for testing the implementation. - - Expo, ExpoL return the shifted binary exponent (0 <= e < 256 (2048 resp.)) - SetExpo, SetExpoL set the shifted binary exponent - Real, RealL convert hexadecimals to reals - Int, IntL convert reals to hexadecimals - Ten returns 10^e (e <= 308, 308 < e delivers NaN) - - 1993.4.22 IEEE format only, 32-bits LONGINTs only - 30.8.1993 mh: changed RealX to avoid compiler warnings; - 7.11.1995 jt: dynamic endianess test - 22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps) - 05.01.98 prk: NaN with INF support -*) - -VAR - DefaultFCR*: SET; - tene: ARRAY 23 OF LONGREAL; (* e = 0..22: exact values of 10^e *) - ten: ARRAY 27 OF LONGREAL; - eq, gr: ARRAY 20 OF SET; - H, L: INTEGER; - -(** Returns the shifted binary exponent (0 <= e < 256). *) -PROCEDURE Expo* (x: REAL): LONGINT; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 -END Expo; - -(** Returns the shifted binary exponent (0 <= e < 2048). *) -PROCEDURE ExpoL* (x: LONGREAL): LONGINT; - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 -END ExpoL; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpo* (e: LONGINT; VAR x: REAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x), i); - i:= ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23); - SYSTEM.PUT(SYSTEM.ADR(x), i) -END SetExpo; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); - i:= ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20); - SYSTEM.PUT(SYSTEM.ADR(x) + H, i) -END SetExpoL; - -(** Convert hexadecimal to REAL. *) -PROCEDURE Real* (h: LONGINT): REAL; - VAR x: REAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x), h); RETURN x -END Real; - -(** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*) -PROCEDURE RealL* (h, l: LONGINT): LONGREAL; - VAR x: LONGREAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x) + H, h); SYSTEM.PUT(SYSTEM.ADR(x) + L, l); RETURN x -END RealL; - -(** Convert REAL to hexadecimal. *) -PROCEDURE Int* (x: REAL): LONGINT; - VAR i: LONGINT; -BEGIN SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i -END Int; - -(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *) -PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l) -END IntL; - -(** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *) -PROCEDURE Ten* (e: LONGINT): LONGREAL; - VAR E: LONGINT; r: LONGREAL; -BEGIN - IF e < -307 THEN RETURN 0 ELSIF 308 < e THEN RETURN RealL(2146435072, 0) END; - INC(e, 307); r:= ten[e DIV 23] * tene[e MOD 23]; - IF e MOD 32 IN eq[e DIV 32] THEN RETURN r - ELSE - E:= ExpoL(r); SetExpoL(1023+52, r); - IF e MOD 32 IN gr[e DIV 32] THEN r:= r-1 ELSE r:= r+1 END; - SetExpoL(E, r); RETURN r - END -END Ten; - -(** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *) -PROCEDURE NaNCode* (x: REAL): LONGINT; -BEGIN - IF ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 THEN (* Infinite or NaN *) - RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *) - ELSE - RETURN -1 - END -END NaNCode; - -(** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *) -PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l); - IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *) - h := h MOD 100000H (* lowest 20 bits *) - ELSE - h := -1; l := -1 - END -END NaNCodeL; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaN* (x: REAL): BOOLEAN; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 -END IsNaN; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaNL* (x: LONGREAL): BOOLEAN; -VAR h: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); - RETURN ASH(h, -20) MOD 2048 = 2047 -END IsNaNL; - -(** Returns NaN with specified code (0 <= l < 8399608). *) -PROCEDURE NaN* (l: LONGINT): REAL; -VAR x: REAL; -BEGIN - SYSTEM.PUT(SYSTEM.ADR(x), (l MOD 800000H) + 7F800000H); - RETURN x -END NaN; - -(** Returns NaN with specified code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)). *) -PROCEDURE NaNL* (h, l: LONGINT): LONGREAL; -VAR x: LONGREAL; -BEGIN - h := (h MOD 100000H) + 7FF00000H; - SYSTEM.PUT(SYSTEM.ADR(x) + H, h); - SYSTEM.PUT(SYSTEM.ADR(x) + L, l); - RETURN x -END NaNL; -(* -PROCEDURE fcr(): SET; -CODE {SYSTEM.i386, SYSTEM.FPU} - PUSH 0 - FSTCW [ESP] - FWAIT - POP EAX -END fcr; -*) (* commented out -- noch *) -(** Return state of the floating-point control register. *) -(*PROCEDURE FCR*(): SET; -BEGIN - IF Kernel.copro THEN - RETURN fcr() - ELSE - RETURN DefaultFCR - END -END FCR; -*) -(*PROCEDURE setfcr(s: SET); -CODE {SYSTEM.i386, SYSTEM.FPU} - FLDCW s[EBP] -END setfcr; -*) -(** Set state of floating-point control register. Traps reset this to the default & ENTIER resets the rounding mode. *) -(*PROCEDURE SetFCR*(s: SET); -BEGIN - IF Kernel.copro THEN setfcr(s) END -END SetFCR; -*) -PROCEDURE RealX (h, l: LONGINT; adr: LONGINT); -BEGIN SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l); -END RealX; - -PROCEDURE InitHL; - VAR (*i: LONGINT; dmy: INTEGER;*) littleEndian: BOOLEAN; -BEGIN - (*DefaultFCR := (FCR() - {0,2,3,10,11}) + {0..5,8,9}; - SetFCR(DefaultFCR); - - dmy := 1; i := SYSTEM.ADR(dmy); - SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)*) - littleEndian := FALSE; (* endianness will be set for each architecture -- noch *) - IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END -END InitHL; - -BEGIN InitHL; - RealX(03FF00000H, 0, SYSTEM.ADR(tene[0])); - RealX(040240000H, 0, SYSTEM.ADR(tene[1])); (* 1 *) - RealX(040590000H, 0, SYSTEM.ADR(tene[2])); (* 2 *) - RealX(0408F4000H, 0, SYSTEM.ADR(tene[3])); (* 3 *) - RealX(040C38800H, 0, SYSTEM.ADR(tene[4])); (* 4 *) - RealX(040F86A00H, 0, SYSTEM.ADR(tene[5])); (* 5 *) - RealX(0412E8480H, 0, SYSTEM.ADR(tene[6])); (* 6 *) - RealX(0416312D0H, 0, SYSTEM.ADR(tene[7])); (* 7 *) - RealX(04197D784H, 0, SYSTEM.ADR(tene[8])); (* 8 *) - RealX(041CDCD65H, 0, SYSTEM.ADR(tene[9])); (* 9 *) - RealX(04202A05FH, 020000000H, SYSTEM.ADR(tene[10])); (* 10 *) - RealX(042374876H, 0E8000000H, SYSTEM.ADR(tene[11])); (* 11 *) - RealX(0426D1A94H, 0A2000000H, SYSTEM.ADR(tene[12])); (* 12 *) - RealX(042A2309CH, 0E5400000H, SYSTEM.ADR(tene[13])); (* 13 *) - RealX(042D6BCC4H, 01E900000H, SYSTEM.ADR(tene[14])); (* 14 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(tene[15])); (* 15 *) - RealX(04341C379H, 037E08000H, SYSTEM.ADR(tene[16])); (* 16 *) - RealX(043763457H, 085D8A000H, SYSTEM.ADR(tene[17])); (* 17 *) - RealX(043ABC16DH, 0674EC800H, SYSTEM.ADR(tene[18])); (* 18 *) - RealX(043E158E4H, 060913D00H, SYSTEM.ADR(tene[19])); (* 19 *) - RealX(04415AF1DH, 078B58C40H, SYSTEM.ADR(tene[20])); (* 20 *) - RealX(0444B1AE4H, 0D6E2EF50H, SYSTEM.ADR(tene[21])); (* 21 *) - RealX(04480F0CFH, 064DD592H, SYSTEM.ADR(tene[22])); (* 22 *) - - RealX(031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *) - RealX(04F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *) - RealX(09BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *) - RealX(0E84D669H, 05B193BF8H, SYSTEM.ADR(ten[3])); (* -238 *) - RealX(0134B9408H, 0EEFEA839H, SYSTEM.ADR(ten[4])); (* -215 *) - RealX(018123FF0H, 06EEA847AH, SYSTEM.ADR(ten[5])); (* -192 *) - RealX(01CD82742H, 091C6065BH, SYSTEM.ADR(ten[6])); (* -169 *) - RealX(0219FF779H, 0FD329CB9H, SYSTEM.ADR(ten[7])); (* -146 *) - RealX(02665275EH, 0D8D8F36CH, SYSTEM.ADR(ten[8])); (* -123 *) - RealX(02B2BFF2EH, 0E48E0530H, SYSTEM.ADR(ten[9])); (* -100 *) - RealX(02FF286D8H, 0EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *) - RealX(034B8851AH, 0B548EA4H, SYSTEM.ADR(ten[11])); (* -54 *) - RealX(0398039D6H, 065896880H, SYSTEM.ADR(ten[12])); (* -31 *) - RealX(03E45798EH, 0E2308C3AH, SYSTEM.ADR(ten[13])); (* -8 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(ten[14])); (* 15 *) - RealX(047D2CED3H, 02A16A1B1H, SYSTEM.ADR(ten[15])); (* 38 *) - RealX(04C98E45EH, 01DF3B015H, SYSTEM.ADR(ten[16])); (* 61 *) - RealX(0516078E1H, 011C3556DH, SYSTEM.ADR(ten[17])); (* 84 *) - RealX(05625CCFEH, 03D35D80EH, SYSTEM.ADR(ten[18])); (* 107 *) - RealX(05AECDA62H, 055B2D9EH, SYSTEM.ADR(ten[19])); (* 130 *) - RealX(05FB317E5H, 0EF3AB327H, SYSTEM.ADR(ten[20])); (* 153 *) - RealX(064794514H, 05230B378H, SYSTEM.ADR(ten[21])); (* 176 *) - RealX(06940B8E0H, 0ACAC4EAFH, SYSTEM.ADR(ten[22])); (* 199 *) - RealX(06E0621B1H, 0C28AC20CH, SYSTEM.ADR(ten[23])); (* 222 *) - RealX(072CD4A7BH, 0EBFA31ABH, SYSTEM.ADR(ten[24])); (* 245 *) - RealX(077936214H, 09CBD3226H, SYSTEM.ADR(ten[25])); (* 268 *) - RealX(07C59A742H, 0461887F6H, SYSTEM.ADR(ten[26])); (* 291 *) - - eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31}; - eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31}; - eq[2]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28}; - eq[3]:= {0, 1, 2, 3, 5, 6, 7, 8, 9, 11, 14, 15, 16, 17, 18, 19, 20, 22, 27, 28, 29, 30, 31}; - eq[4]:= {0, 6, 7, 10, 11, 12, 13, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[5]:= {0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[6]:= {0, 1, 4, 5, 7, 8, 10, 14, 15, 16, 18, 20, 21, 23, 24, 25, 26, 28, 29, 30, 31}; - eq[7]:= {0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 23, 24, 26, 28, 29, 30, 31}; - eq[8]:= {0, 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 14, 16, 17, 18, 19, 20, 21, 24, 25, 26, 29}; - eq[9]:= {1, 2, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[10]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30}; - eq[11]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 13, 14, 15, 16, 19, 20, 21, 22, 23, 27, 28, 29, 30}; - eq[12]:= {0, 1, 2, 3, 4, 5, 7, 8, 9, 10, 12, 14, 15, 16, 17, 18, 19, 20, 21, 23, 26, 27, 29, 30, 31}; - eq[13]:= {0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 13, 14, 15, 16, 17, 18, 20, 21, 23, 24, 27, 28, 29, 30, 31}; - eq[14]:= {0, 1, 2, 3, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[15]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 28}; - eq[16]:= {1, 2, 4, 11, 13, 16, 17, 18, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[17]:= {1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 14, 15, 18, 19, 20, 21, 23, 25, 26, 27, 28, 29, 31}; - eq[18]:= {0, 2, 4, 5, 6, 8, 9, 11, 12, 13, 14, 16, 17, 19, 20, 22, 23, 24, 26, 27, 28, 29}; - eq[19]:= {2, 3, 4, 5, 6, 7}; - - gr[0]:= {24, 27, 29, 30}; - gr[1]:= {0, 1, 3, 4, 7}; - gr[2]:= {29, 30, 31}; - gr[3]:= {4, 10, 12, 13, 21, 23, 24, 25, 26}; - gr[4]:= {1, 2, 3, 4, 5, 8, 9, 16, 17}; - gr[5]:= {2, 3, 4, 18}; - gr[6]:= {2, 3, 6, 9, 11, 12, 13, 17, 19, 22, 27}; - gr[7]:= {2}; - gr[8]:= {7, 12, 13, 15, 22, 23, 27, 28, 30, 31}; - gr[9]:= {0, 3, 5, 7, 8}; - gr[10]:= {}; - gr[11]:= {}; - gr[12]:= {11, 13, 22, 24, 25, 28}; - gr[13]:= {22, 25, 26}; - gr[14]:= {4, 5}; - gr[15]:= {10, 14, 27, 29, 30, 31}; - gr[16]:= {0, 3, 5, 6, 7, 8, 9, 10, 12, 14, 15, 20, 21, 23}; - gr[17]:= {0, 10, 12, 13, 16, 17, 22, 24, 30}; - gr[18]:= {}; - gr[19]:= {} -END ethReals. diff --git a/src/lib/s3/x86/ethReals.Mod b/src/lib/s3/x86/ethReals.Mod deleted file mode 100644 index a7189089..00000000 --- a/src/lib/s3/x86/ethReals.Mod +++ /dev/null @@ -1,305 +0,0 @@ -(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. -Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) - -MODULE ethReals; (** portable *) - -(** Implementation of the non-portable components of IEEE REAL and -LONGREAL manipulation. The routines here are required to do conversion -of reals to strings and back. -Implemented by Bernd Moesli, Seminar for Applied Mathematics, -Swiss Federal Institute of Technology Zrich. -*) - -IMPORT SYSTEM; - -(* Bernd Moesli - Seminar for Applied Mathematics - Swiss Federal Institute of Technology Zurich - Copyright 1993 - - Support module for IEEE floating-point numbers - - Please change constant definitions of H, L depending on byte ordering - Use bm.TestReals.Do for testing the implementation. - - Expo, ExpoL return the shifted binary exponent (0 <= e < 256 (2048 resp.)) - SetExpo, SetExpoL set the shifted binary exponent - Real, RealL convert hexadecimals to reals - Int, IntL convert reals to hexadecimals - Ten returns 10^e (e <= 308, 308 < e delivers NaN) - - 1993.4.22 IEEE format only, 32-bits LONGINTs only - 30.8.1993 mh: changed RealX to avoid compiler warnings; - 7.11.1995 jt: dynamic endianess test - 22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps) - 05.01.98 prk: NaN with INF support -*) - -VAR - DefaultFCR*: SET; - tene: ARRAY 23 OF LONGREAL; (* e = 0..22: exact values of 10^e *) - ten: ARRAY 27 OF LONGREAL; - eq, gr: ARRAY 20 OF SET; - H, L: INTEGER; - -(** Returns the shifted binary exponent (0 <= e < 256). *) -PROCEDURE Expo* (x: REAL): LONGINT; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 -END Expo; - -(** Returns the shifted binary exponent (0 <= e < 2048). *) -PROCEDURE ExpoL* (x: LONGREAL): LONGINT; - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 -END ExpoL; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpo* (e: LONGINT; VAR x: REAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x), i); - i:= ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23); - SYSTEM.PUT(SYSTEM.ADR(x), i) -END SetExpo; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); - i:= ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20); - SYSTEM.PUT(SYSTEM.ADR(x) + H, i) -END SetExpoL; - -(** Convert hexadecimal to REAL. *) -PROCEDURE Real* (h: LONGINT): REAL; - VAR x: REAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x), h); RETURN x -END Real; - -(** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*) -PROCEDURE RealL* (h, l: LONGINT): LONGREAL; - VAR x: LONGREAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x) + H, h); SYSTEM.PUT(SYSTEM.ADR(x) + L, l); RETURN x -END RealL; - -(** Convert REAL to hexadecimal. *) -PROCEDURE Int* (x: REAL): LONGINT; - VAR i: LONGINT; -BEGIN SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i -END Int; - -(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *) -PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l) -END IntL; - -(** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *) -PROCEDURE Ten* (e: LONGINT): LONGREAL; - VAR E: LONGINT; r: LONGREAL; -BEGIN - IF e < -307 THEN RETURN 0 ELSIF 308 < e THEN RETURN RealL(2146435072, 0) END; - INC(e, 307); r:= ten[e DIV 23] * tene[e MOD 23]; - IF e MOD 32 IN eq[e DIV 32] THEN RETURN r - ELSE - E:= ExpoL(r); SetExpoL(1023+52, r); - IF e MOD 32 IN gr[e DIV 32] THEN r:= r-1 ELSE r:= r+1 END; - SetExpoL(E, r); RETURN r - END -END Ten; - -(** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *) -PROCEDURE NaNCode* (x: REAL): LONGINT; -BEGIN - IF ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 THEN (* Infinite or NaN *) - RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *) - ELSE - RETURN -1 - END -END NaNCode; - -(** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *) -PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l); - IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *) - h := h MOD 100000H (* lowest 20 bits *) - ELSE - h := -1; l := -1 - END -END NaNCodeL; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaN* (x: REAL): BOOLEAN; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 -END IsNaN; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaNL* (x: LONGREAL): BOOLEAN; -VAR h: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); - RETURN ASH(h, -20) MOD 2048 = 2047 -END IsNaNL; - -(** Returns NaN with specified code (0 <= l < 8399608). *) -PROCEDURE NaN* (l: LONGINT): REAL; -VAR x: REAL; -BEGIN - SYSTEM.PUT(SYSTEM.ADR(x), (l MOD 800000H) + 7F800000H); - RETURN x -END NaN; - -(** Returns NaN with specified code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)). *) -PROCEDURE NaNL* (h, l: LONGINT): LONGREAL; -VAR x: LONGREAL; -BEGIN - h := (h MOD 100000H) + 7FF00000H; - SYSTEM.PUT(SYSTEM.ADR(x) + H, h); - SYSTEM.PUT(SYSTEM.ADR(x) + L, l); - RETURN x -END NaNL; -(* -PROCEDURE fcr(): SET; -CODE {SYSTEM.i386, SYSTEM.FPU} - PUSH 0 - FSTCW [ESP] - FWAIT - POP EAX -END fcr; -*) (* commented out -- noch *) -(** Return state of the floating-point control register. *) -(*PROCEDURE FCR*(): SET; -BEGIN - IF Kernel.copro THEN - RETURN fcr() - ELSE - RETURN DefaultFCR - END -END FCR; -*) -(*PROCEDURE setfcr(s: SET); -CODE {SYSTEM.i386, SYSTEM.FPU} - FLDCW s[EBP] -END setfcr; -*) -(** Set state of floating-point control register. Traps reset this to the default & ENTIER resets the rounding mode. *) -(*PROCEDURE SetFCR*(s: SET); -BEGIN - IF Kernel.copro THEN setfcr(s) END -END SetFCR; -*) -PROCEDURE RealX (h, l: LONGINT; adr: LONGINT); -BEGIN SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l); -END RealX; - -PROCEDURE InitHL; - VAR (*i: LONGINT; dmy: INTEGER;*) littleEndian: BOOLEAN; -BEGIN - (*DefaultFCR := (FCR() - {0,2,3,10,11}) + {0..5,8,9}; - SetFCR(DefaultFCR); - - dmy := 1; i := SYSTEM.ADR(dmy); - SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)*) - littleEndian := TRUE; (* endianness will be set for each architecture -- noch *) - IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END -END InitHL; - -BEGIN InitHL; - RealX(03FF00000H, 0, SYSTEM.ADR(tene[0])); - RealX(040240000H, 0, SYSTEM.ADR(tene[1])); (* 1 *) - RealX(040590000H, 0, SYSTEM.ADR(tene[2])); (* 2 *) - RealX(0408F4000H, 0, SYSTEM.ADR(tene[3])); (* 3 *) - RealX(040C38800H, 0, SYSTEM.ADR(tene[4])); (* 4 *) - RealX(040F86A00H, 0, SYSTEM.ADR(tene[5])); (* 5 *) - RealX(0412E8480H, 0, SYSTEM.ADR(tene[6])); (* 6 *) - RealX(0416312D0H, 0, SYSTEM.ADR(tene[7])); (* 7 *) - RealX(04197D784H, 0, SYSTEM.ADR(tene[8])); (* 8 *) - RealX(041CDCD65H, 0, SYSTEM.ADR(tene[9])); (* 9 *) - RealX(04202A05FH, 020000000H, SYSTEM.ADR(tene[10])); (* 10 *) - RealX(042374876H, 0E8000000H, SYSTEM.ADR(tene[11])); (* 11 *) - RealX(0426D1A94H, 0A2000000H, SYSTEM.ADR(tene[12])); (* 12 *) - RealX(042A2309CH, 0E5400000H, SYSTEM.ADR(tene[13])); (* 13 *) - RealX(042D6BCC4H, 01E900000H, SYSTEM.ADR(tene[14])); (* 14 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(tene[15])); (* 15 *) - RealX(04341C379H, 037E08000H, SYSTEM.ADR(tene[16])); (* 16 *) - RealX(043763457H, 085D8A000H, SYSTEM.ADR(tene[17])); (* 17 *) - RealX(043ABC16DH, 0674EC800H, SYSTEM.ADR(tene[18])); (* 18 *) - RealX(043E158E4H, 060913D00H, SYSTEM.ADR(tene[19])); (* 19 *) - RealX(04415AF1DH, 078B58C40H, SYSTEM.ADR(tene[20])); (* 20 *) - RealX(0444B1AE4H, 0D6E2EF50H, SYSTEM.ADR(tene[21])); (* 21 *) - RealX(04480F0CFH, 064DD592H, SYSTEM.ADR(tene[22])); (* 22 *) - - RealX(031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *) - RealX(04F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *) - RealX(09BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *) - RealX(0E84D669H, 05B193BF8H, SYSTEM.ADR(ten[3])); (* -238 *) - RealX(0134B9408H, 0EEFEA839H, SYSTEM.ADR(ten[4])); (* -215 *) - RealX(018123FF0H, 06EEA847AH, SYSTEM.ADR(ten[5])); (* -192 *) - RealX(01CD82742H, 091C6065BH, SYSTEM.ADR(ten[6])); (* -169 *) - RealX(0219FF779H, 0FD329CB9H, SYSTEM.ADR(ten[7])); (* -146 *) - RealX(02665275EH, 0D8D8F36CH, SYSTEM.ADR(ten[8])); (* -123 *) - RealX(02B2BFF2EH, 0E48E0530H, SYSTEM.ADR(ten[9])); (* -100 *) - RealX(02FF286D8H, 0EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *) - RealX(034B8851AH, 0B548EA4H, SYSTEM.ADR(ten[11])); (* -54 *) - RealX(0398039D6H, 065896880H, SYSTEM.ADR(ten[12])); (* -31 *) - RealX(03E45798EH, 0E2308C3AH, SYSTEM.ADR(ten[13])); (* -8 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(ten[14])); (* 15 *) - RealX(047D2CED3H, 02A16A1B1H, SYSTEM.ADR(ten[15])); (* 38 *) - RealX(04C98E45EH, 01DF3B015H, SYSTEM.ADR(ten[16])); (* 61 *) - RealX(0516078E1H, 011C3556DH, SYSTEM.ADR(ten[17])); (* 84 *) - RealX(05625CCFEH, 03D35D80EH, SYSTEM.ADR(ten[18])); (* 107 *) - RealX(05AECDA62H, 055B2D9EH, SYSTEM.ADR(ten[19])); (* 130 *) - RealX(05FB317E5H, 0EF3AB327H, SYSTEM.ADR(ten[20])); (* 153 *) - RealX(064794514H, 05230B378H, SYSTEM.ADR(ten[21])); (* 176 *) - RealX(06940B8E0H, 0ACAC4EAFH, SYSTEM.ADR(ten[22])); (* 199 *) - RealX(06E0621B1H, 0C28AC20CH, SYSTEM.ADR(ten[23])); (* 222 *) - RealX(072CD4A7BH, 0EBFA31ABH, SYSTEM.ADR(ten[24])); (* 245 *) - RealX(077936214H, 09CBD3226H, SYSTEM.ADR(ten[25])); (* 268 *) - RealX(07C59A742H, 0461887F6H, SYSTEM.ADR(ten[26])); (* 291 *) - - eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31}; - eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31}; - eq[2]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28}; - eq[3]:= {0, 1, 2, 3, 5, 6, 7, 8, 9, 11, 14, 15, 16, 17, 18, 19, 20, 22, 27, 28, 29, 30, 31}; - eq[4]:= {0, 6, 7, 10, 11, 12, 13, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[5]:= {0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[6]:= {0, 1, 4, 5, 7, 8, 10, 14, 15, 16, 18, 20, 21, 23, 24, 25, 26, 28, 29, 30, 31}; - eq[7]:= {0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 23, 24, 26, 28, 29, 30, 31}; - eq[8]:= {0, 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 14, 16, 17, 18, 19, 20, 21, 24, 25, 26, 29}; - eq[9]:= {1, 2, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[10]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30}; - eq[11]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 13, 14, 15, 16, 19, 20, 21, 22, 23, 27, 28, 29, 30}; - eq[12]:= {0, 1, 2, 3, 4, 5, 7, 8, 9, 10, 12, 14, 15, 16, 17, 18, 19, 20, 21, 23, 26, 27, 29, 30, 31}; - eq[13]:= {0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 13, 14, 15, 16, 17, 18, 20, 21, 23, 24, 27, 28, 29, 30, 31}; - eq[14]:= {0, 1, 2, 3, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[15]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 28}; - eq[16]:= {1, 2, 4, 11, 13, 16, 17, 18, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[17]:= {1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 14, 15, 18, 19, 20, 21, 23, 25, 26, 27, 28, 29, 31}; - eq[18]:= {0, 2, 4, 5, 6, 8, 9, 11, 12, 13, 14, 16, 17, 19, 20, 22, 23, 24, 26, 27, 28, 29}; - eq[19]:= {2, 3, 4, 5, 6, 7}; - - gr[0]:= {24, 27, 29, 30}; - gr[1]:= {0, 1, 3, 4, 7}; - gr[2]:= {29, 30, 31}; - gr[3]:= {4, 10, 12, 13, 21, 23, 24, 25, 26}; - gr[4]:= {1, 2, 3, 4, 5, 8, 9, 16, 17}; - gr[5]:= {2, 3, 4, 18}; - gr[6]:= {2, 3, 6, 9, 11, 12, 13, 17, 19, 22, 27}; - gr[7]:= {2}; - gr[8]:= {7, 12, 13, 15, 22, 23, 27, 28, 30, 31}; - gr[9]:= {0, 3, 5, 7, 8}; - gr[10]:= {}; - gr[11]:= {}; - gr[12]:= {11, 13, 22, 24, 25, 28}; - gr[13]:= {22, 25, 26}; - gr[14]:= {4, 5}; - gr[15]:= {10, 14, 27, 29, 30, 31}; - gr[16]:= {0, 3, 5, 6, 7, 8, 9, 10, 12, 14, 15, 20, 21, 23}; - gr[17]:= {0, 10, 12, 13, 16, 17, 22, 24, 30}; - gr[18]:= {}; - gr[19]:= {} -END ethReals. diff --git a/src/lib/s3/x86_64/ethReals.Mod b/src/lib/s3/x86_64/ethReals.Mod deleted file mode 100644 index a7189089..00000000 --- a/src/lib/s3/x86_64/ethReals.Mod +++ /dev/null @@ -1,305 +0,0 @@ -(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. -Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) - -MODULE ethReals; (** portable *) - -(** Implementation of the non-portable components of IEEE REAL and -LONGREAL manipulation. The routines here are required to do conversion -of reals to strings and back. -Implemented by Bernd Moesli, Seminar for Applied Mathematics, -Swiss Federal Institute of Technology Zrich. -*) - -IMPORT SYSTEM; - -(* Bernd Moesli - Seminar for Applied Mathematics - Swiss Federal Institute of Technology Zurich - Copyright 1993 - - Support module for IEEE floating-point numbers - - Please change constant definitions of H, L depending on byte ordering - Use bm.TestReals.Do for testing the implementation. - - Expo, ExpoL return the shifted binary exponent (0 <= e < 256 (2048 resp.)) - SetExpo, SetExpoL set the shifted binary exponent - Real, RealL convert hexadecimals to reals - Int, IntL convert reals to hexadecimals - Ten returns 10^e (e <= 308, 308 < e delivers NaN) - - 1993.4.22 IEEE format only, 32-bits LONGINTs only - 30.8.1993 mh: changed RealX to avoid compiler warnings; - 7.11.1995 jt: dynamic endianess test - 22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps) - 05.01.98 prk: NaN with INF support -*) - -VAR - DefaultFCR*: SET; - tene: ARRAY 23 OF LONGREAL; (* e = 0..22: exact values of 10^e *) - ten: ARRAY 27 OF LONGREAL; - eq, gr: ARRAY 20 OF SET; - H, L: INTEGER; - -(** Returns the shifted binary exponent (0 <= e < 256). *) -PROCEDURE Expo* (x: REAL): LONGINT; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 -END Expo; - -(** Returns the shifted binary exponent (0 <= e < 2048). *) -PROCEDURE ExpoL* (x: LONGREAL): LONGINT; - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 -END ExpoL; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpo* (e: LONGINT; VAR x: REAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x), i); - i:= ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23); - SYSTEM.PUT(SYSTEM.ADR(x), i) -END SetExpo; - -(** Sets the shifted binary exponent. *) -PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL); - VAR i: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); - i:= ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20); - SYSTEM.PUT(SYSTEM.ADR(x) + H, i) -END SetExpoL; - -(** Convert hexadecimal to REAL. *) -PROCEDURE Real* (h: LONGINT): REAL; - VAR x: REAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x), h); RETURN x -END Real; - -(** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*) -PROCEDURE RealL* (h, l: LONGINT): LONGREAL; - VAR x: LONGREAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x) + H, h); SYSTEM.PUT(SYSTEM.ADR(x) + L, l); RETURN x -END RealL; - -(** Convert REAL to hexadecimal. *) -PROCEDURE Int* (x: REAL): LONGINT; - VAR i: LONGINT; -BEGIN SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i -END Int; - -(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *) -PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l) -END IntL; - -(** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *) -PROCEDURE Ten* (e: LONGINT): LONGREAL; - VAR E: LONGINT; r: LONGREAL; -BEGIN - IF e < -307 THEN RETURN 0 ELSIF 308 < e THEN RETURN RealL(2146435072, 0) END; - INC(e, 307); r:= ten[e DIV 23] * tene[e MOD 23]; - IF e MOD 32 IN eq[e DIV 32] THEN RETURN r - ELSE - E:= ExpoL(r); SetExpoL(1023+52, r); - IF e MOD 32 IN gr[e DIV 32] THEN r:= r-1 ELSE r:= r+1 END; - SetExpoL(E, r); RETURN r - END -END Ten; - -(** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *) -PROCEDURE NaNCode* (x: REAL): LONGINT; -BEGIN - IF ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 THEN (* Infinite or NaN *) - RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *) - ELSE - RETURN -1 - END -END NaNCode; - -(** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *) -PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l); - IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *) - h := h MOD 100000H (* lowest 20 bits *) - ELSE - h := -1; l := -1 - END -END NaNCodeL; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaN* (x: REAL): BOOLEAN; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 -END IsNaN; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaNL* (x: LONGREAL): BOOLEAN; -VAR h: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); - RETURN ASH(h, -20) MOD 2048 = 2047 -END IsNaNL; - -(** Returns NaN with specified code (0 <= l < 8399608). *) -PROCEDURE NaN* (l: LONGINT): REAL; -VAR x: REAL; -BEGIN - SYSTEM.PUT(SYSTEM.ADR(x), (l MOD 800000H) + 7F800000H); - RETURN x -END NaN; - -(** Returns NaN with specified code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)). *) -PROCEDURE NaNL* (h, l: LONGINT): LONGREAL; -VAR x: LONGREAL; -BEGIN - h := (h MOD 100000H) + 7FF00000H; - SYSTEM.PUT(SYSTEM.ADR(x) + H, h); - SYSTEM.PUT(SYSTEM.ADR(x) + L, l); - RETURN x -END NaNL; -(* -PROCEDURE fcr(): SET; -CODE {SYSTEM.i386, SYSTEM.FPU} - PUSH 0 - FSTCW [ESP] - FWAIT - POP EAX -END fcr; -*) (* commented out -- noch *) -(** Return state of the floating-point control register. *) -(*PROCEDURE FCR*(): SET; -BEGIN - IF Kernel.copro THEN - RETURN fcr() - ELSE - RETURN DefaultFCR - END -END FCR; -*) -(*PROCEDURE setfcr(s: SET); -CODE {SYSTEM.i386, SYSTEM.FPU} - FLDCW s[EBP] -END setfcr; -*) -(** Set state of floating-point control register. Traps reset this to the default & ENTIER resets the rounding mode. *) -(*PROCEDURE SetFCR*(s: SET); -BEGIN - IF Kernel.copro THEN setfcr(s) END -END SetFCR; -*) -PROCEDURE RealX (h, l: LONGINT; adr: LONGINT); -BEGIN SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l); -END RealX; - -PROCEDURE InitHL; - VAR (*i: LONGINT; dmy: INTEGER;*) littleEndian: BOOLEAN; -BEGIN - (*DefaultFCR := (FCR() - {0,2,3,10,11}) + {0..5,8,9}; - SetFCR(DefaultFCR); - - dmy := 1; i := SYSTEM.ADR(dmy); - SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)*) - littleEndian := TRUE; (* endianness will be set for each architecture -- noch *) - IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END -END InitHL; - -BEGIN InitHL; - RealX(03FF00000H, 0, SYSTEM.ADR(tene[0])); - RealX(040240000H, 0, SYSTEM.ADR(tene[1])); (* 1 *) - RealX(040590000H, 0, SYSTEM.ADR(tene[2])); (* 2 *) - RealX(0408F4000H, 0, SYSTEM.ADR(tene[3])); (* 3 *) - RealX(040C38800H, 0, SYSTEM.ADR(tene[4])); (* 4 *) - RealX(040F86A00H, 0, SYSTEM.ADR(tene[5])); (* 5 *) - RealX(0412E8480H, 0, SYSTEM.ADR(tene[6])); (* 6 *) - RealX(0416312D0H, 0, SYSTEM.ADR(tene[7])); (* 7 *) - RealX(04197D784H, 0, SYSTEM.ADR(tene[8])); (* 8 *) - RealX(041CDCD65H, 0, SYSTEM.ADR(tene[9])); (* 9 *) - RealX(04202A05FH, 020000000H, SYSTEM.ADR(tene[10])); (* 10 *) - RealX(042374876H, 0E8000000H, SYSTEM.ADR(tene[11])); (* 11 *) - RealX(0426D1A94H, 0A2000000H, SYSTEM.ADR(tene[12])); (* 12 *) - RealX(042A2309CH, 0E5400000H, SYSTEM.ADR(tene[13])); (* 13 *) - RealX(042D6BCC4H, 01E900000H, SYSTEM.ADR(tene[14])); (* 14 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(tene[15])); (* 15 *) - RealX(04341C379H, 037E08000H, SYSTEM.ADR(tene[16])); (* 16 *) - RealX(043763457H, 085D8A000H, SYSTEM.ADR(tene[17])); (* 17 *) - RealX(043ABC16DH, 0674EC800H, SYSTEM.ADR(tene[18])); (* 18 *) - RealX(043E158E4H, 060913D00H, SYSTEM.ADR(tene[19])); (* 19 *) - RealX(04415AF1DH, 078B58C40H, SYSTEM.ADR(tene[20])); (* 20 *) - RealX(0444B1AE4H, 0D6E2EF50H, SYSTEM.ADR(tene[21])); (* 21 *) - RealX(04480F0CFH, 064DD592H, SYSTEM.ADR(tene[22])); (* 22 *) - - RealX(031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *) - RealX(04F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *) - RealX(09BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *) - RealX(0E84D669H, 05B193BF8H, SYSTEM.ADR(ten[3])); (* -238 *) - RealX(0134B9408H, 0EEFEA839H, SYSTEM.ADR(ten[4])); (* -215 *) - RealX(018123FF0H, 06EEA847AH, SYSTEM.ADR(ten[5])); (* -192 *) - RealX(01CD82742H, 091C6065BH, SYSTEM.ADR(ten[6])); (* -169 *) - RealX(0219FF779H, 0FD329CB9H, SYSTEM.ADR(ten[7])); (* -146 *) - RealX(02665275EH, 0D8D8F36CH, SYSTEM.ADR(ten[8])); (* -123 *) - RealX(02B2BFF2EH, 0E48E0530H, SYSTEM.ADR(ten[9])); (* -100 *) - RealX(02FF286D8H, 0EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *) - RealX(034B8851AH, 0B548EA4H, SYSTEM.ADR(ten[11])); (* -54 *) - RealX(0398039D6H, 065896880H, SYSTEM.ADR(ten[12])); (* -31 *) - RealX(03E45798EH, 0E2308C3AH, SYSTEM.ADR(ten[13])); (* -8 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(ten[14])); (* 15 *) - RealX(047D2CED3H, 02A16A1B1H, SYSTEM.ADR(ten[15])); (* 38 *) - RealX(04C98E45EH, 01DF3B015H, SYSTEM.ADR(ten[16])); (* 61 *) - RealX(0516078E1H, 011C3556DH, SYSTEM.ADR(ten[17])); (* 84 *) - RealX(05625CCFEH, 03D35D80EH, SYSTEM.ADR(ten[18])); (* 107 *) - RealX(05AECDA62H, 055B2D9EH, SYSTEM.ADR(ten[19])); (* 130 *) - RealX(05FB317E5H, 0EF3AB327H, SYSTEM.ADR(ten[20])); (* 153 *) - RealX(064794514H, 05230B378H, SYSTEM.ADR(ten[21])); (* 176 *) - RealX(06940B8E0H, 0ACAC4EAFH, SYSTEM.ADR(ten[22])); (* 199 *) - RealX(06E0621B1H, 0C28AC20CH, SYSTEM.ADR(ten[23])); (* 222 *) - RealX(072CD4A7BH, 0EBFA31ABH, SYSTEM.ADR(ten[24])); (* 245 *) - RealX(077936214H, 09CBD3226H, SYSTEM.ADR(ten[25])); (* 268 *) - RealX(07C59A742H, 0461887F6H, SYSTEM.ADR(ten[26])); (* 291 *) - - eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31}; - eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31}; - eq[2]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28}; - eq[3]:= {0, 1, 2, 3, 5, 6, 7, 8, 9, 11, 14, 15, 16, 17, 18, 19, 20, 22, 27, 28, 29, 30, 31}; - eq[4]:= {0, 6, 7, 10, 11, 12, 13, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[5]:= {0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[6]:= {0, 1, 4, 5, 7, 8, 10, 14, 15, 16, 18, 20, 21, 23, 24, 25, 26, 28, 29, 30, 31}; - eq[7]:= {0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 23, 24, 26, 28, 29, 30, 31}; - eq[8]:= {0, 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 14, 16, 17, 18, 19, 20, 21, 24, 25, 26, 29}; - eq[9]:= {1, 2, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[10]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30}; - eq[11]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 13, 14, 15, 16, 19, 20, 21, 22, 23, 27, 28, 29, 30}; - eq[12]:= {0, 1, 2, 3, 4, 5, 7, 8, 9, 10, 12, 14, 15, 16, 17, 18, 19, 20, 21, 23, 26, 27, 29, 30, 31}; - eq[13]:= {0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 13, 14, 15, 16, 17, 18, 20, 21, 23, 24, 27, 28, 29, 30, 31}; - eq[14]:= {0, 1, 2, 3, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[15]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 28}; - eq[16]:= {1, 2, 4, 11, 13, 16, 17, 18, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31}; - eq[17]:= {1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 14, 15, 18, 19, 20, 21, 23, 25, 26, 27, 28, 29, 31}; - eq[18]:= {0, 2, 4, 5, 6, 8, 9, 11, 12, 13, 14, 16, 17, 19, 20, 22, 23, 24, 26, 27, 28, 29}; - eq[19]:= {2, 3, 4, 5, 6, 7}; - - gr[0]:= {24, 27, 29, 30}; - gr[1]:= {0, 1, 3, 4, 7}; - gr[2]:= {29, 30, 31}; - gr[3]:= {4, 10, 12, 13, 21, 23, 24, 25, 26}; - gr[4]:= {1, 2, 3, 4, 5, 8, 9, 16, 17}; - gr[5]:= {2, 3, 4, 18}; - gr[6]:= {2, 3, 6, 9, 11, 12, 13, 17, 19, 22, 27}; - gr[7]:= {2}; - gr[8]:= {7, 12, 13, 15, 22, 23, 27, 28, 30, 31}; - gr[9]:= {0, 3, 5, 7, 8}; - gr[10]:= {}; - gr[11]:= {}; - gr[12]:= {11, 13, 22, 24, 25, 28}; - gr[13]:= {22, 25, 26}; - gr[14]:= {4, 5}; - gr[15]:= {10, 14, 27, 29, 30, 31}; - gr[16]:= {0, 3, 5, 6, 7, 8, 9, 10, 12, 14, 15, 20, 21, 23}; - gr[17]:= {0, 10, 12, 13, 16, 17, 22, 24, 30}; - gr[18]:= {}; - gr[19]:= {} -END ethReals. diff --git a/src/lib/system/darwin/clang/Args.Mod b/src/lib/system/darwin/clang/Args.Mod deleted file mode 100644 index c6b7b56e..00000000 --- a/src/lib/system/darwin/clang/Args.Mod +++ /dev/null @@ -1,65 +0,0 @@ -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 ";*) - 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. diff --git a/src/lib/system/darwin/clang/Console.Mod b/src/lib/system/darwin/clang/Console.Mod deleted file mode 100644 index 93be9373..00000000 --- a/src/lib/system/darwin/clang/Console.Mod +++ /dev/null @@ -1,89 +0,0 @@ -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 "; - - 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. diff --git a/src/lib/system/darwin/clang/Files.Mod b/src/lib/system/darwin/clang/Files.Mod deleted file mode 100644 index c8f42ca5..00000000 --- a/src/lib/system/darwin/clang/Files.Mod +++ /dev/null @@ -1,664 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/darwin/clang/Files0.Mod b/src/lib/system/darwin/clang/Files0.Mod deleted file mode 100644 index 1d9cd953..00000000 --- a/src/lib/system/darwin/clang/Files0.Mod +++ /dev/null @@ -1,636 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/darwin/clang/Kernel.Mod b/src/lib/system/darwin/clang/Kernel.Mod deleted file mode 100644 index e84e5eae..00000000 --- a/src/lib/system/darwin/clang/Kernel.Mod +++ /dev/null @@ -1,167 +0,0 @@ -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. diff --git a/src/lib/system/darwin/clang/Kernel0.Mod b/src/lib/system/darwin/clang/Kernel0.Mod deleted file mode 100644 index c128b73d..00000000 --- a/src/lib/system/darwin/clang/Kernel0.Mod +++ /dev/null @@ -1,179 +0,0 @@ -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. diff --git a/src/lib/system/darwin/clang/SYSTEM.Mod b/src/lib/system/darwin/clang/SYSTEM.Mod deleted file mode 100644 index 6fc08dcf..00000000 --- a/src/lib/system/darwin/clang/SYSTEM.Mod +++ /dev/null @@ -1,520 +0,0 @@ -(* -* 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. diff --git a/src/lib/system/darwin/clang/x86_64/SYSTEM.c0 b/src/lib/system/darwin/clang/x86_64/SYSTEM.c0 deleted file mode 100644 index 17801802..00000000 --- a/src/lib/system/darwin/clang/x86_64/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* 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 ------------- */ - diff --git a/src/lib/system/darwin/clang/x86_64/SYSTEM.h b/src/lib/system/darwin/clang/x86_64/SYSTEM.h deleted file mode 100644 index 71ec724f..00000000 --- a/src/lib/system/darwin/clang/x86_64/SYSTEM.h +++ /dev/null @@ -1,239 +0,0 @@ -#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 -#include /* for type sizes -- noch */ -//#include - -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 -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* 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)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/darwin/clang/x86_64/Unix.Mod b/src/lib/system/darwin/clang/x86_64/Unix.Mod deleted file mode 100644 index 635aacef..00000000 --- a/src/lib/system/darwin/clang/x86_64/Unix.Mod +++ /dev/null @@ -1,541 +0,0 @@ -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 ; - -(* 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 "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - (* for kill() *) - PROCEDURE -includeSignal() - "#include "; - - (* for read() also *) - PROCEDURE -includeTypes() - "#include "; - - PROCEDURE -includeUio() - "#include "; - - (* for getpid(), lseek(), close(), fsync(), ftruncate(), read(), sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - - (* for rename() *) - PROCEDURE -includeStdio() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for open() *) - PROCEDURE -includeFcntl() - "#include "; - - PROCEDURE -err(): INTEGER - "errno"; - - PROCEDURE errno*(): INTEGER; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: INTEGER) - "exit(n)"; - - PROCEDURE -Fork*(): INTEGER - "fork()"; - - PROCEDURE -Wait*(VAR status: INTEGER): INTEGER - "wait(status)"; - - PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: INTEGER): INTEGER - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): INTEGER - "pipe(fds)"; - - PROCEDURE -Getpid*(): INTEGER - "getpid()"; - - PROCEDURE -Getuid*(): INTEGER - "getuid()"; - - PROCEDURE -Geteuid*(): INTEGER - "geteuid()"; - - PROCEDURE -Getgid*(): INTEGER - "getgid()"; - - PROCEDURE -Getegid*(): INTEGER - "getegid()"; - - PROCEDURE -Unlink*(name: Name): INTEGER - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: INTEGER): INTEGER - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER; VAR statbuf: Status): INTEGER - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER): INTEGER - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: INTEGER): INTEGER - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): INTEGER - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): INTEGER - "chdir(path)"; - - PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: INTEGER): INTEGER - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER - "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): INTEGER - "gethostname(name, name__len)"; - - PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER - "socket(af, type, protocol)"; - - PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "connect(socket, &(name), namelen)"; - - PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER - "getsockname(socket, name, namelen)"; - - PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "bind(socket, &(name), namelen)"; - - PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER - "listen(socket, backlog)"; - - PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT - "accept(socket, addr, addrlen)"; - - PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "recv(socket, bufadr, buflen, flags)"; - - PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): 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. diff --git a/src/lib/system/freebsd/clang/Args.Mod b/src/lib/system/freebsd/clang/Args.Mod deleted file mode 100644 index c6b7b56e..00000000 --- a/src/lib/system/freebsd/clang/Args.Mod +++ /dev/null @@ -1,65 +0,0 @@ -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 ";*) - 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. diff --git a/src/lib/system/freebsd/clang/Kernel.Mod b/src/lib/system/freebsd/clang/Kernel.Mod deleted file mode 100644 index e84e5eae..00000000 --- a/src/lib/system/freebsd/clang/Kernel.Mod +++ /dev/null @@ -1,167 +0,0 @@ -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. diff --git a/src/lib/system/freebsd/clang/Kernel0.Mod b/src/lib/system/freebsd/clang/Kernel0.Mod deleted file mode 100644 index c128b73d..00000000 --- a/src/lib/system/freebsd/clang/Kernel0.Mod +++ /dev/null @@ -1,179 +0,0 @@ -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. diff --git a/src/lib/system/freebsd/clang/SYSTEM.Mod b/src/lib/system/freebsd/clang/SYSTEM.Mod deleted file mode 100644 index 6fc08dcf..00000000 --- a/src/lib/system/freebsd/clang/SYSTEM.Mod +++ /dev/null @@ -1,520 +0,0 @@ -(* -* 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. diff --git a/src/lib/system/freebsd/clang/x86_64/Files.Mod b/src/lib/system/freebsd/clang/x86_64/Files.Mod deleted file mode 100644 index c8f42ca5..00000000 --- a/src/lib/system/freebsd/clang/x86_64/Files.Mod +++ /dev/null @@ -1,664 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/freebsd/clang/x86_64/Files0.Mod b/src/lib/system/freebsd/clang/x86_64/Files0.Mod deleted file mode 100644 index 1d9cd953..00000000 --- a/src/lib/system/freebsd/clang/x86_64/Files0.Mod +++ /dev/null @@ -1,636 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/freebsd/clang/x86_64/SYSTEM.c0 b/src/lib/system/freebsd/clang/x86_64/SYSTEM.c0 deleted file mode 100644 index 17801802..00000000 --- a/src/lib/system/freebsd/clang/x86_64/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* 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 ------------- */ - diff --git a/src/lib/system/freebsd/clang/x86_64/SYSTEM.h b/src/lib/system/freebsd/clang/x86_64/SYSTEM.h deleted file mode 100644 index 90bdadd4..00000000 --- a/src/lib/system/freebsd/clang/x86_64/SYSTEM.h +++ /dev/null @@ -1,242 +0,0 @@ -#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 -//#include -#include /* for type sizes -- noch */ -//#include - -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 -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* 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 __DEL(x) free(x) -#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 - diff --git a/src/lib/system/freebsd/clang/x86_64/Unix.Mod b/src/lib/system/freebsd/clang/x86_64/Unix.Mod deleted file mode 100644 index 48e60a99..00000000 --- a/src/lib/system/freebsd/clang/x86_64/Unix.Mod +++ /dev/null @@ -1,562 +0,0 @@ -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 "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - (* for kill() *) - PROCEDURE -includeSignal() - "#include "; - - (* for read() also *) - PROCEDURE -includeTypes() - "#include "; - - PROCEDURE -includeUio() - "#include "; - - (* for getpid(), lseek(), close(), fsync(), ftruncate(), read(), sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - - (* for rename() *) - PROCEDURE -includeStdio() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for open() *) - PROCEDURE -includeFcntl() - "#include "; - - PROCEDURE -err(): INTEGER - "errno"; - - PROCEDURE errno*(): INTEGER; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: INTEGER) - "exit(n)"; - - PROCEDURE -Fork*(): INTEGER - "fork()"; - - PROCEDURE -Wait*(VAR status: INTEGER): INTEGER - "wait(status)"; - - PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: INTEGER): INTEGER - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): INTEGER - "pipe(fds)"; - - PROCEDURE -Getpid*(): INTEGER - "getpid()"; - - PROCEDURE -Getuid*(): INTEGER - "getuid()"; - - PROCEDURE -Geteuid*(): INTEGER - "geteuid()"; - - PROCEDURE -Getgid*(): INTEGER - "getgid()"; - - PROCEDURE -Getegid*(): INTEGER - "getegid()"; - - PROCEDURE -Unlink*(name: Name): INTEGER - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: INTEGER): INTEGER - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER; VAR statbuf: Status): INTEGER - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER): INTEGER - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: INTEGER): INTEGER - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): INTEGER - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): INTEGER - "chdir(path)"; - - PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: INTEGER): INTEGER - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER - "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): INTEGER - "gethostname(name, name__len)"; - - PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER - "socket(af, type, protocol)"; - - PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "connect(socket, &(name), namelen)"; - - PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER - "getsockname(socket, name, namelen)"; - - PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "bind(socket, &(name), namelen)"; - - PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER - "listen(socket, backlog)"; - - PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT - "accept(socket, addr, addrlen)"; - - PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "recv(socket, bufadr, buflen, flags)"; - - PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): 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. diff --git a/src/lib/system/linux/clang/Args.Mod b/src/lib/system/linux/clang/Args.Mod deleted file mode 100644 index c6b7b56e..00000000 --- a/src/lib/system/linux/clang/Args.Mod +++ /dev/null @@ -1,65 +0,0 @@ -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 ";*) - 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. diff --git a/src/lib/system/linux/clang/Console.Mod b/src/lib/system/linux/clang/Console.Mod deleted file mode 100644 index e523ef7b..00000000 --- a/src/lib/system/linux/clang/Console.Mod +++ /dev/null @@ -1,86 +0,0 @@ -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 -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. diff --git a/src/lib/system/linux/clang/Kernel.Mod b/src/lib/system/linux/clang/Kernel.Mod deleted file mode 100644 index e84e5eae..00000000 --- a/src/lib/system/linux/clang/Kernel.Mod +++ /dev/null @@ -1,167 +0,0 @@ -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. diff --git a/src/lib/system/linux/clang/Kernel0.Mod b/src/lib/system/linux/clang/Kernel0.Mod deleted file mode 100644 index c128b73d..00000000 --- a/src/lib/system/linux/clang/Kernel0.Mod +++ /dev/null @@ -1,179 +0,0 @@ -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. diff --git a/src/lib/system/linux/clang/SYSTEM.Mod b/src/lib/system/linux/clang/SYSTEM.Mod deleted file mode 100644 index 6fc08dcf..00000000 --- a/src/lib/system/linux/clang/SYSTEM.Mod +++ /dev/null @@ -1,520 +0,0 @@ -(* -* 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. diff --git a/src/lib/system/linux/clang/armv6j_hardfp/Files.Mod b/src/lib/system/linux/clang/armv6j_hardfp/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/clang/armv6j_hardfp/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/armv6j_hardfp/Files0.Mod b/src/lib/system/linux/clang/armv6j_hardfp/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/clang/armv6j_hardfp/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.c0 b/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.h b/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/clang/armv6j_hardfp/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/clang/armv6j_hardfp/Unix.Mod b/src/lib/system/linux/clang/armv6j_hardfp/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/clang/armv6j_hardfp/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/clang/powerpc/Files.Mod b/src/lib/system/linux/clang/powerpc/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/clang/powerpc/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/powerpc/Files0.Mod b/src/lib/system/linux/clang/powerpc/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/clang/powerpc/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/powerpc/SYSTEM.c0 b/src/lib/system/linux/clang/powerpc/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/clang/powerpc/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/clang/powerpc/SYSTEM.h b/src/lib/system/linux/clang/powerpc/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/clang/powerpc/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/clang/powerpc/Unix.Mod b/src/lib/system/linux/clang/powerpc/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/clang/powerpc/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/clang/x86/Files.Mod b/src/lib/system/linux/clang/x86/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/clang/x86/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/x86/Files0.Mod b/src/lib/system/linux/clang/x86/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/clang/x86/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/clang/x86/SYSTEM.c0 b/src/lib/system/linux/clang/x86/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/clang/x86/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/clang/x86/SYSTEM.h b/src/lib/system/linux/clang/x86/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/clang/x86/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/clang/x86/Unix.Mod b/src/lib/system/linux/clang/x86/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/clang/x86/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/clang/x86_64/Files.Mod b/src/lib/system/linux/clang/x86_64/Files.Mod deleted file mode 100644 index c8f42ca5..00000000 --- a/src/lib/system/linux/clang/x86_64/Files.Mod +++ /dev/null @@ -1,664 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/linux/clang/x86_64/Files0.Mod b/src/lib/system/linux/clang/x86_64/Files0.Mod deleted file mode 100644 index 1d9cd953..00000000 --- a/src/lib/system/linux/clang/x86_64/Files0.Mod +++ /dev/null @@ -1,636 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/linux/clang/x86_64/SYSTEM.c0 b/src/lib/system/linux/clang/x86_64/SYSTEM.c0 deleted file mode 100644 index 3d875068..00000000 --- a/src/lib/system/linux/clang/x86_64/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* 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(unsigned long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/clang/x86_64/SYSTEM.h b/src/lib/system/linux/clang/x86_64/SYSTEM.h deleted file mode 100644 index 2c8e71d0..00000000 --- a/src/lib/system/linux/clang/x86_64/SYSTEM.h +++ /dev/null @@ -1,238 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -voc (jet backend) runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -extern void *memcpy(void *dest, const void *src, unsigned long n); -extern void *malloc(unsigned long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -//typedef char BOOLEAN; -#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 -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* 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)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/clang/x86_64/Unix.Mod b/src/lib/system/linux/clang/x86_64/Unix.Mod deleted file mode 100644 index e44840d0..00000000 --- a/src/lib/system/linux/clang/x86_64/Unix.Mod +++ /dev/null @@ -1,524 +0,0 @@ -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 - (*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; - (* 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* : LONGINT; (* dev_t 8 *) - ino* : LONGINT; (* ino 8 *) - nlink* : LONGINT; - mode* : INTEGER; - uid*, gid*: INTEGER; - pad0* : INTEGER; - rdev* : LONGINT; - size* : LONGINT; - blksize* : LONGINT; - blocks* : LONGINT; - atime* : LONGINT; - atimences* : LONGINT; - mtime* : LONGINT; - mtimensec* : LONGINT; - ctime* : LONGINT; - ctimensec* : LONGINT; - unused0*, unused1*, unused2*: LONGINT; - 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 - family0*, family1*: SHORTINT; - pad0, pad1: SHORTINT; - pad2 : INTEGER; - (*port*: INTEGER; - internetAddr*: LONGINT;*) - pad*: ARRAY 14 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: INTEGER; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) - PROCEDURE -includeStdlib() - "#include "; - - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): INTEGER - "errno"; - - PROCEDURE errno*(): INTEGER; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: INTEGER) - "exit(n)"; - - PROCEDURE -Fork*(): INTEGER - "fork()"; - - PROCEDURE -Wait*(VAR status: INTEGER): INTEGER - "wait(status)"; - - PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: INTEGER): INTEGER - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): INTEGER - "pipe(fds)"; - - PROCEDURE -Getpid*(): INTEGER - "getpid()"; - - PROCEDURE -Getuid*(): INTEGER - "getuid()"; - - PROCEDURE -Geteuid*(): INTEGER - "geteuid()"; - - PROCEDURE -Getgid*(): INTEGER - "getgid()"; - - PROCEDURE -Getegid*(): INTEGER - "getegid()"; - - PROCEDURE -Unlink*(name: Name): INTEGER - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: INTEGER): INTEGER - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER; VAR statbuf: Status): INTEGER - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER): INTEGER - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: INTEGER): INTEGER - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): INTEGER - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): INTEGER - "chdir(path)"; - - PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): INTEGER - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: INTEGER): INTEGER - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : INTEGER): INTEGER - "(INTEGER)sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): INTEGER - "(INTEGER)nanosleep(req, rem)"; - - (* TCP/IP networking *) - - PROCEDURE -Gethostbyname*(name: Name): HostEntry - "(Unix_HostEntry)gethostbyname(name)"; - - PROCEDURE -Gethostname*(VAR name: Name): INTEGER - "gethostname(name, name__len)"; - - PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER - "socket(af, type, protocol)"; - - PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "connect(socket, &(name), namelen)"; - - PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER - "getsockname(socket, name, namelen)"; - - PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "bind(socket, &(name), namelen)"; - - PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER - "listen(socket, backlog)"; - - PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT - "accept(socket, addr, addrlen)"; - - PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "recv(socket, bufadr, buflen, flags)"; - - PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): 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. diff --git a/src/lib/system/linux/gcc/Args.Mod b/src/lib/system/linux/gcc/Args.Mod deleted file mode 100644 index c6b7b56e..00000000 --- a/src/lib/system/linux/gcc/Args.Mod +++ /dev/null @@ -1,65 +0,0 @@ -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 ";*) - 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. diff --git a/src/lib/system/linux/gcc/Console.Mod b/src/lib/system/linux/gcc/Console.Mod deleted file mode 100644 index e523ef7b..00000000 --- a/src/lib/system/linux/gcc/Console.Mod +++ /dev/null @@ -1,86 +0,0 @@ -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 -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. diff --git a/src/lib/system/linux/gcc/Kernel.Mod b/src/lib/system/linux/gcc/Kernel.Mod deleted file mode 100644 index e84e5eae..00000000 --- a/src/lib/system/linux/gcc/Kernel.Mod +++ /dev/null @@ -1,167 +0,0 @@ -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. diff --git a/src/lib/system/linux/gcc/Kernel0.Mod b/src/lib/system/linux/gcc/Kernel0.Mod deleted file mode 100644 index c128b73d..00000000 --- a/src/lib/system/linux/gcc/Kernel0.Mod +++ /dev/null @@ -1,179 +0,0 @@ -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. diff --git a/src/lib/system/linux/gcc/SYSTEM.Mod b/src/lib/system/linux/gcc/SYSTEM.Mod deleted file mode 100644 index 6fc08dcf..00000000 --- a/src/lib/system/linux/gcc/SYSTEM.Mod +++ /dev/null @@ -1,520 +0,0 @@ -(* -* 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. diff --git a/src/lib/system/linux/gcc/armv6j_hardfp/Files.Mod b/src/lib/system/linux/gcc/armv6j_hardfp/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/gcc/armv6j_hardfp/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/armv6j_hardfp/Files0.Mod b/src/lib/system/linux/gcc/armv6j_hardfp/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/gcc/armv6j_hardfp/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.c0 b/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.h b/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/gcc/armv6j_hardfp/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/gcc/armv6j_hardfp/Unix.Mod b/src/lib/system/linux/gcc/armv6j_hardfp/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/gcc/armv6j_hardfp/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/gcc/powerpc/Files.Mod b/src/lib/system/linux/gcc/powerpc/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/gcc/powerpc/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/powerpc/Files0.Mod b/src/lib/system/linux/gcc/powerpc/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/gcc/powerpc/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/powerpc/SYSTEM.c0 b/src/lib/system/linux/gcc/powerpc/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/gcc/powerpc/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/gcc/powerpc/SYSTEM.h b/src/lib/system/linux/gcc/powerpc/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/gcc/powerpc/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/gcc/powerpc/Unix.Mod b/src/lib/system/linux/gcc/powerpc/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/gcc/powerpc/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/gcc/x86/Files.Mod b/src/lib/system/linux/gcc/x86/Files.Mod deleted file mode 100644 index 6307407d..00000000 --- a/src/lib/system/linux/gcc/x86/Files.Mod +++ /dev/null @@ -1,663 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/x86/Files0.Mod b/src/lib/system/linux/gcc/x86/Files0.Mod deleted file mode 100644 index 4f021ede..00000000 --- a/src/lib/system/linux/gcc/x86/Files0.Mod +++ /dev/null @@ -1,635 +0,0 @@ -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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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. diff --git a/src/lib/system/linux/gcc/x86/SYSTEM.c0 b/src/lib/system/linux/gcc/x86/SYSTEM.c0 deleted file mode 100644 index 580449aa..00000000 --- a/src/lib/system/linux/gcc/x86/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* The body prefix file of the Ofront runtime system, Version 1.0 -* -* Copyright (c) Software Templ, 1994, 1995 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -* -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings -* -*/ - -#include "SYSTEM.h" -#ifdef __STDC__ -#include "stdarg.h" -#else -#include "varargs.h" -#endif - -extern void *malloc(long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/gcc/x86/SYSTEM.h b/src/lib/system/linux/gcc/x86/SYSTEM.h deleted file mode 100644 index ea9ae5d6..00000000 --- a/src/lib/system/linux/gcc/x86/SYSTEM.h +++ /dev/null @@ -1,220 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -the Ofront runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -//extern void *memcpy(void *dest, const void *src, long n); -extern void *memcpy(void *dest, const void *src, size_t n); -extern void *malloc(long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -typedef char BOOLEAN; -typedef unsigned char CHAR; -typedef signed char SHORTINT; -typedef short int INTEGER; -typedef long LONGINT; -typedef float REAL; -typedef double LONGREAL; -typedef unsigned long SET; -typedef void *SYSTEM_PTR; -typedef unsigned char SYSTEM_BYTE; -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); -#else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); - -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) - -/* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) - -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/gcc/x86/Unix.Mod b/src/lib/system/linux/gcc/x86/Unix.Mod deleted file mode 100644 index e2a25ec5..00000000 --- a/src/lib/system/linux/gcc/x86/Unix.Mod +++ /dev/null @@ -1,441 +0,0 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* system procedure added by noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - -IMPORT SYSTEM; - -CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - - -TYPE - JmpBuf* = RECORD - bx*, si*, di*, bp*, sp*, pc*: LONGINT; - maskWasSaved*, savedMask*: LONGINT; - END ; - - Status* = RECORD (* struct stat *) - dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad1: INTEGER; - ino*, mode*, nlink*, uid*, gid*: LONGINT; - rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *) - pad2: INTEGER; - size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*, - unused3*, unused4*, unused5*: LONGINT; - END ; - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - Timezone* = RECORD - minuteswest*, dsttime*: LONGINT - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family*: INTEGER; - port*: INTEGER; - internetAddr*: LONGINT; - pad*: ARRAY 8 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: LONGINT; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) -(* commented, doesn't compile on 32bit GNU/Linux platforms - PROCEDURE -includeStdlib() - "#include "; -*) - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): LONGINT - "errno"; - - PROCEDURE errno*(): LONGINT; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -Fork*(): LONGINT - "fork()"; - - PROCEDURE -Wait*(VAR status: LONGINT): LONGINT - "wait(status)"; - - PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: LONGINT): LONGINT - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): LONGINT - "pipe(fds)"; - - PROCEDURE -Getpid*(): LONGINT - "getpid()"; - - PROCEDURE -Getuid*(): LONGINT - "getuid()"; - - PROCEDURE -Geteuid*(): LONGINT - "geteuid()"; - - PROCEDURE -Getgid*(): LONGINT - "getgid()"; - - PROCEDURE -Getegid*(): LONGINT - "getegid()"; - - PROCEDURE -Unlink*(name: Name): LONGINT - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: LONGINT): LONGINT - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Stat; - - PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT; - VAR res: LONGINT; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); - RETURN res; - END Fstat; - - PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: LONGINT): LONGINT - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): LONGINT - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): LONGINT - "chdir(path)"; - - PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : LONGINT): LONGINT - "sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): LONGINT - "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. diff --git a/src/lib/system/linux/gcc/x86_64/Files.Mod b/src/lib/system/linux/gcc/x86_64/Files.Mod deleted file mode 100644 index c8f42ca5..00000000 --- a/src/lib/system/linux/gcc/x86_64/Files.Mod +++ /dev/null @@ -1,664 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/linux/gcc/x86_64/Files0.Mod b/src/lib/system/linux/gcc/x86_64/Files0.Mod deleted file mode 100644 index 1d9cd953..00000000 --- a/src/lib/system/linux/gcc/x86_64/Files0.Mod +++ /dev/null @@ -1,636 +0,0 @@ -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-: INTEGER; - 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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({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, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); 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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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: INTEGER; 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, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {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. diff --git a/src/lib/system/linux/gcc/x86_64/SYSTEM.c0 b/src/lib/system/linux/gcc/x86_64/SYSTEM.c0 deleted file mode 100644 index 3d875068..00000000 --- a/src/lib/system/linux/gcc/x86_64/SYSTEM.c0 +++ /dev/null @@ -1,205 +0,0 @@ -/* -* 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(unsigned long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/lib/system/linux/gcc/x86_64/SYSTEM.h b/src/lib/system/linux/gcc/x86_64/SYSTEM.h deleted file mode 100644 index 2c8e71d0..00000000 --- a/src/lib/system/linux/gcc/x86_64/SYSTEM.h +++ /dev/null @@ -1,238 +0,0 @@ -#ifndef SYSTEM__h -#define SYSTEM__h - -/* - -voc (jet backend) runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 - -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -extern void *memcpy(void *dest, const void *src, unsigned long n); -extern void *malloc(unsigned long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -//typedef char BOOLEAN; -#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 -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* 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)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) - -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) - -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc - -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) - -#define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) - -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist - -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; - -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ - -#endif - diff --git a/src/lib/system/linux/gcc/x86_64/Unix.Mod b/src/lib/system/linux/gcc/x86_64/Unix.Mod deleted file mode 100644 index e44840d0..00000000 --- a/src/lib/system/linux/gcc/x86_64/Unix.Mod +++ /dev/null @@ -1,524 +0,0 @@ -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 - (*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; - (* 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* : LONGINT; (* dev_t 8 *) - ino* : LONGINT; (* ino 8 *) - nlink* : LONGINT; - mode* : INTEGER; - uid*, gid*: INTEGER; - pad0* : INTEGER; - rdev* : LONGINT; - size* : LONGINT; - blksize* : LONGINT; - blocks* : LONGINT; - atime* : LONGINT; - atimences* : LONGINT; - mtime* : LONGINT; - mtimensec* : LONGINT; - ctime* : LONGINT; - ctimensec* : LONGINT; - unused0*, unused1*, unused2*: LONGINT; - 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 - family0*, family1*: SHORTINT; - pad0, pad1: SHORTINT; - pad2 : INTEGER; - (*port*: INTEGER; - internetAddr*: LONGINT;*) - pad*: ARRAY 14 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: INTEGER; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) - END; - - Name* = ARRAY OF CHAR; - - PROCEDURE -includeStat() - "#include "; - - PROCEDURE -includeErrno() - "#include "; - - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; - - (* for system() *) - PROCEDURE -includeStdlib() - "#include "; - - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; - - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - - PROCEDURE -err(): INTEGER - "errno"; - - PROCEDURE errno*(): INTEGER; - BEGIN - RETURN err() - END errno; - - PROCEDURE -Exit*(n: INTEGER) - "exit(n)"; - - PROCEDURE -Fork*(): INTEGER - "fork()"; - - PROCEDURE -Wait*(VAR status: INTEGER): INTEGER - "wait(status)"; - - PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER - "select(width, readfds, writefds, exceptfds, timeout)"; - - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER - "gettimeofday(tv, tz)"; - - PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; - - PROCEDURE -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - - PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - - PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - - PROCEDURE -Dup*(fd: INTEGER): INTEGER - "dup(fd)"; - - PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER - "dup(fd1, fd2)"; - - PROCEDURE -Pipe*(fds : LONGINT): INTEGER - "pipe(fds)"; - - PROCEDURE -Getpid*(): INTEGER - "getpid()"; - - PROCEDURE -Getuid*(): INTEGER - "getuid()"; - - PROCEDURE -Geteuid*(): INTEGER - "geteuid()"; - - PROCEDURE -Getgid*(): INTEGER - "getgid()"; - - PROCEDURE -Getegid*(): INTEGER - "getegid()"; - - PROCEDURE -Unlink*(name: Name): INTEGER - "unlink(name)"; - - PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER - "open(name, flag, mode)"; - - PROCEDURE -Close*(fd: INTEGER): INTEGER - "close(fd)"; - - PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER - "stat((const char*)name, (struct stat*)statbuf)"; - - PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER; VAR statbuf: Status): INTEGER - "fstat(fd, (struct stat*)statbuf)"; - - PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - 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: INTEGER): INTEGER - "fchmod(fd, mode)"; - - PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER - "chmod(path, mode)"; - - PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT - "lseek(fd, offset, origin)"; - - PROCEDURE -Fsync*(fd: INTEGER): INTEGER - "fsync(fd)"; - - PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER - "fcntl(fd, cmd, arg)"; - - PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER - "flock(fd, operation)"; - - PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER - "ftruncate(fd, length)"; - - PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - - PROCEDURE -Rename*(old, new: Name): INTEGER - "rename(old, new)"; - - PROCEDURE -Chdir*(path: Name): INTEGER - "chdir(path)"; - - PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): INTEGER - "ioctl(fd, request, arg)"; - - PROCEDURE -Kill*(pid, sig: INTEGER): INTEGER - "kill(pid, sig)"; - - PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER - "sigsetmask(mask)"; - - PROCEDURE -Sleep*(ms : INTEGER): INTEGER - "(INTEGER)sleep(ms)"; - - PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): INTEGER - "(INTEGER)nanosleep(req, rem)"; - - (* TCP/IP networking *) - - PROCEDURE -Gethostbyname*(name: Name): HostEntry - "(Unix_HostEntry)gethostbyname(name)"; - - PROCEDURE -Gethostname*(VAR name: Name): INTEGER - "gethostname(name, name__len)"; - - PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER - "socket(af, type, protocol)"; - - PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "connect(socket, &(name), namelen)"; - - PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER - "getsockname(socket, name, namelen)"; - - PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "bind(socket, &(name), namelen)"; - - PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER - "listen(socket, backlog)"; - - PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT - "accept(socket, addr, addrlen)"; - - PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "recv(socket, bufadr, buflen, flags)"; - - PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): 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. diff --git a/src/lib/ulm/armv6j_hardfp/ulmSysConversions.Mod b/src/lib/ulm/armv6j_hardfp/ulmSysConversions.Mod deleted file mode 100644 index f8ea3fbb..00000000 --- a/src/lib/ulm/armv6j_hardfp/ulmSysConversions.Mod +++ /dev/null @@ -1,574 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysConversi.om,v $ - Revision 1.2 1997/07/30 09:38:16 borchert - bug in ReadConv fixed: cv.flags was used but not set for - counts > 1 - - Revision 1.1 1994/02/23 07:58:28 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 8/90 - adapted to linux cae 02/01 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysConversions; - - (* convert Oberon records to/from C structures *) - - IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts; - - TYPE - Address* = SysTypes.Address; - Size* = Address; - - (* format: - - Format = Conversion { "/" Conversion } . - Conversion = [ Factors ] ConvChars [ Comment ] . - Factors = Array | Factor | Array Factor | Factor Array . - Array = Integer ":" . - Factor = Integer "*" . - ConvChars = OberonType CType | Skip CType | OberonType Skip . - OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" . - CType = "a" | "c" | "s" | "i" | "l" . - Integer = Digit { Digit } . - Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" . - Skip = "-" . - Comment = "=" { AnyChar } . - AnyChar = (* all characters except "/" *) . - - Oberon data types: - - a: Address - b: SYS.BYTE - B: BOOLEAN - c: CHAR - s: SHORTINT - i: INTEGER - l: LONGINT - S: SET - - C data types: - - a: char * - c: /* signed */ char - C: unsigned char - s: short int - S: unsigned short int - i: int - I: unsigned int - u: unsigned int - l: long int - L: unsigned long int - - example: - - conversion from - - Rec = - RECORD - a, b: INTEGER; - c: CHAR; - s: SET; - f: ARRAY 3 OF INTEGER; - END; - - to - - struct rec { - short a, b; - char c; - int xx; /* to be skipped on conversion */ - int s; - int f[3]; - }; - - or vice versa: - - "2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f" - - The comments allow to give the field names. - *) - - CONST - (* conversion flags *) - unsigned = 0; (* suppress sign extension *) - boolean = 1; (* convert anything # 0 to 1 *) - TYPE - Flags = SET; - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - format*: Events.Message; - END; - ConvStream = POINTER TO ConvStreamRec; - ConvStreamRec = - RECORD - fmt: Texts.Text; - char: CHAR; - eof: BOOLEAN; - (* 1: Oberon type - 2: C type - *) - type1, type2: CHAR; length: INTEGER; left: INTEGER; - offset1, offset2: Address; - size1, size2: Address; elementsleft: INTEGER; flags: Flags; - END; - - Format* = POINTER TO FormatRec; - FormatRec* = - RECORD - (Objects.ObjectRec) - offset1, offset2: Address; - size1, size2: Address; - flags: Flags; - next: Format; - END; - VAR - badformat*: Events.EventType; - - PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - Strings.Read(event.format, cv.fmt); - Events.Raise(event); - cv.eof := TRUE; - cv.char := 0X; - cv.left := 0; - cv.elementsleft := 0; - END Error; - - PROCEDURE SizeError(msg, format: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - COPY(format, event.format); - Events.Raise(event); - END SizeError; - - PROCEDURE NextCh(cv: ConvStream); - BEGIN - cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X); - IF cv.eof THEN - cv.char := 0X; - END; - END NextCh; - - PROCEDURE IsDigit(ch: CHAR) : BOOLEAN; - BEGIN - RETURN (ch >= "0") & (ch <= "9") - END IsDigit; - - PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER); - BEGIN - i := 0; - REPEAT - i := 10 * i + ORD(cv.char) - ORD("0"); - NextCh(cv); - UNTIL ~IsDigit(cv.char); - END ReadInt; - - PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR); - BEGIN - NEW(cv); - Texts.Open(SYS.VAL(Streams.Stream, cv.fmt)); - Strings.Write(cv.fmt, format); - cv.left := 0; cv.elementsleft := 0; - cv.offset1 := 0; cv.offset2 := 0; - cv.eof := FALSE; - NextCh(cv); - END Open; - - PROCEDURE Close(VAR cv: ConvStream); - BEGIN - IF ~Streams.Close(cv.fmt) THEN END; - END Close; - - PROCEDURE ScanConv(cv: ConvStream; - VAR type1, type2: CHAR; - VAR length: INTEGER) : BOOLEAN; - VAR - i: INTEGER; - factor: INTEGER; - BEGIN - IF cv.left > 0 THEN - type1 := cv.type1; - type2 := cv.type2; - length := cv.length; - DEC(cv.left); - RETURN TRUE - END; - IF cv.char = "/" THEN - NextCh(cv); - END; - IF cv.eof THEN - RETURN FALSE - END; - factor := 0; length := 0; - WHILE IsDigit(cv.char) DO - ReadInt(cv, i); - IF i <= 0 THEN - Error(cv, "integer must be positive"); RETURN FALSE - END; - IF cv.char = ":" THEN - IF length # 0 THEN - Error(cv, "multiple length specification"); RETURN FALSE - END; - length := i; - NextCh(cv); - ELSIF cv.char = "*" THEN - IF factor # 0 THEN - Error(cv, "multiple factor specification"); RETURN FALSE - END; - factor := i; cv.left := factor - 1; - NextCh(cv); - ELSE - Error(cv, "factor or length expected"); RETURN FALSE - END; - END; - type1 := cv.char; NextCh(cv); - type2 := cv.char; NextCh(cv); - IF cv.left > 0 THEN - cv.type1 := type1; cv.type2 := type2; cv.length := length; - END; - IF cv.char = "=" THEN (* comment *) - REPEAT - NextCh(cv); - UNTIL cv.eof OR (cv.char = "/"); - END; - RETURN TRUE - END ScanConv; - - PROCEDURE Align(VAR offset: Address; boundary: Address); - BEGIN - IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN - offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary)); - END; - END Align; - - PROCEDURE ReadConv(cv: ConvStream; - VAR offset1, offset2: Address; - VAR size1, size2: Address; - VAR flags: Flags) : BOOLEAN; - VAR - type1, type2: CHAR; - length: INTEGER; - align: BOOLEAN; - boundary: INTEGER; - BEGIN - IF cv.elementsleft > 0 THEN - DEC(cv.elementsleft); - - (* Oberon type *) - IF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - size1 := cv.size1; size2 := cv.size2; flags := cv.flags; - IF (size1 > 0) & (cv.elementsleft = 0) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - - (* C type *) - IF size2 > 1 THEN - Align(cv.offset2, 2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - RETURN TRUE - END; - IF ScanConv(cv, type1, type2, length) THEN - flags := {}; - (* Oberon type *) - CASE type1 OF - | "a": size1 := SIZE(Address); INCL(flags, unsigned); - | "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned); - | "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean); - | "c": size1 := SIZE(CHAR); INCL(flags, unsigned); - | "s": size1 := SIZE(SHORTINT); - | "i": size1 := SIZE(INTEGER); - | "l": size1 := SIZE(LONGINT); - | "S": size1 := SIZE(SET); INCL(flags, unsigned); - | "-": size1 := 0; - ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE - END; - IF size1 > 0 THEN - IF length > 0 THEN - Align(cv.offset1, SIZE(INTEGER)); - ELSIF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - - (* C type *) - CASE type2 OF - | "a": size2 := 4; INCL(flags, unsigned); (* char* *) - | "c": size2 := 1; (* /* signed */ char *) - | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) - | "s": size2 := 2; (* short int *) - | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) - | "i": size2 := 4; (* int *) - | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "l": size2 := 4; (* long int *) - | "L": size2 := 4; INCL(flags, unsigned); (* long int *) - | "-": size2 := 0; - ELSE Error(cv, "bad C type specifier"); RETURN FALSE - END; - IF size2 > 1 THEN - Align(cv.offset2, size2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - cv.size1 := size1; cv.size2 := size2; - IF length > 0 THEN - cv.elementsleft := length - 1; - cv.flags := flags; - END; - RETURN TRUE - ELSE - RETURN FALSE - END; - END ReadConv; - - PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags); - TYPE - Bytes = ARRAY 8 OF CHAR; - Pointer = POINTER TO Bytes; - VAR - dest, source: Pointer; - dindex, sindex: INTEGER; - nonzero: BOOLEAN; - fill : CHAR; - BEGIN - IF ssize > 0 THEN - dest := SYS.VAL(Pointer, to); - source := SYS.VAL(Pointer, from); - dindex := 0; sindex := 0; - IF boolean IN flags THEN - nonzero := FALSE; - WHILE ssize > 0 DO - nonzero := nonzero OR (source[sindex] # 0X); - INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1; - END; - IF dsize > 0 THEN - IF nonzero THEN - dest[dindex] := 1X; - ELSE - dest[dindex] := 0X; - END; - dsize := dsize - 1; INC (dindex); - END; - WHILE dsize > 0 DO - dest[dindex] := 0X; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - ELSE - WHILE (dsize > 0) & (ssize > 0) DO - dest[dindex] := source[sindex]; - ssize := SYS.VAL (INTEGER, ssize) - 1; - dsize := dsize - 1; - INC(dindex); INC(sindex); - END; - IF dsize > 0 THEN - (* sindex has been incremented at least once because - * ssize and dsize were greater than 0, i.e. sindex-1 - * is a valid inex. *) - fill := 0X; - IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN - fill := 0FFX; - END; - END; - WHILE dsize > 0 DO - dest[dindex] := fill; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - END; - END; - END Convert; - - PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset1, to + offset2, size1, size2, flags); - END; - Close(cv); - END ByAddrToC; - - PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset2, to + offset1, size2, size1, flags); - END; - Close(cv); - END ByAddrFromC; - - PROCEDURE CSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the C-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset2 + size2; - Align(size, 2); - RETURN size - END CSize; - - PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the Oberon-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset1 + size1; - Align(size, SIZE(INTEGER)); - RETURN size - END OberonSize; - - PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(from) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(to) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ToC; - - PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(to) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(from) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END FromC; - - PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR); - (* translate format into an internal representation - which is later referenced by fmt; - ByFmtToC and ByFmtFromC are faster than ToC and FromC - *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - element: Format; - head, tail: Format; - BEGIN - Open(cv, format); - head := NIL; tail := NIL; - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - NEW(element); - element.offset1 := offset1; - element.offset2 := offset2; - element.size1 := size1; - element.size2 := size2; - element.flags := flags; - element.next := NIL; - IF tail # NIL THEN - tail.next := element; - ELSE - head := element; - END; - tail := element; - END; - fmt := head; - Close(cv); - END Compile; - - PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset1, to + format.offset2, - format.size1, format.size2, format.flags); - format := format.next; - END; - END ByFmtAndAddrToC; - - PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset2, to + format.offset1, - format.size2, format.size1, format.flags); - format := format.next; - END; - END ByFmtAndAddrFromC; - - PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtToC; - - PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtFromC; - -BEGIN - Events.Define(badformat); - Events.SetPriority(badformat, Priorities.liberrors); -END ulmSysConversions. diff --git a/src/lib/ulm/armv6j_hardfp/ulmSysStat.Mod b/src/lib/ulm/armv6j_hardfp/ulmSysStat.Mod deleted file mode 100644 index c7f00f04..00000000 --- a/src/lib/ulm/armv6j_hardfp/ulmSysStat.Mod +++ /dev/null @@ -1,201 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysStat.om,v $ - Revision 1.3 2000/11/12 13:02:09 borchert - door file type added - - Revision 1.2 2000/11/12 12:48:07 borchert - - conversion adapted to Solaris 2.x - - Lstat added - - Revision 1.1 1994/02/23 08:00:48 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysStat; - - (* examine inode: stat(2) and fstat(2) *) - - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors, - SysTypes := ulmSysTypes; - - CONST - (* file mode: - bit 0 = 1<<0 bit 31 = 1<<31 - - user group other - 3 1 1111 11 - 1 ... 6 5432 109 876 543 210 - +--------+------+-----+-----+-----+-----+ - | unused | type | sst | rwx | rwx | rwx | - +--------+------+-----+-----+-----+-----+ - *) - - type* = {12..15}; - prot* = {0..8}; - - (* file types; example: (stat.mode * type = dir) *) - reg* = {15}; (* regular *) - dir* = {14}; (* directory *) - chr* = {13}; (* character special *) - fifo* = {12}; (* fifo *) - blk* = {13..14}; (* block special *) - symlink* = {13, 15}; (* symbolic link *) - socket* = {14, 15}; (* socket *) - - (* special *) - setuid* = 11; (* set user id on execution *) - setgid* = 10; (* set group id on execution *) - savetext* = 9; (* save swapped text even after use *) - - (* protection *) - uread* = 8; (* read permission owner *) - uwrite* = 7; (* write permission owner *) - uexec* = 6; (* execute/search permission owner *) - gread* = 5; (* read permission group *) - gwrite* = 4; (* write permission group *) - gexec* = 3; (* execute/search permission group *) - oread* = 2; (* read permission other *) - owrite* = 1; (* write permission other *) - oexec* = 0; (* execute/search permission other *) - - (* example for "r-xr-x---": (read + exec) * (owner + group) *) - owner* = {uread, uwrite, uexec}; - group* = {gread, gwrite, gexec}; - other* = {oread, owrite, oexec}; - read* = {uread, gread, oread}; - write* = {uwrite, gwrite, owrite}; - exec* = {uexec, gexec, oexec}; - rwx* = prot; - - TYPE - StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - mode*: SET; (* file mode; see mknod(2) *) - nlinks*: LONGINT; (* number of links *) - uid*: LONGINT; (* user id of the file's owner *) - gid*: LONGINT; (* group id of the file's group *) - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - mtime*: SysTypes.Time; (* time of last data modification *) - ctime*: SysTypes.Time; (* time of last file status change *) - END; - -(* Linux kernel struct stat (2.2.17) - struct stat { - unsigned short st_dev; - unsigned short __pad1; - unsigned long st_ino; - unsigned short st_mode; - unsigned short st_nlink; - unsigned short st_uid; - unsigned short st_gid; - unsigned short st_rdev; - unsigned short __pad2; - unsigned long st_size; - unsigned long st_blksize; - unsigned long st_blocks; - unsigned long st_atime; - unsigned long __unused1; - unsigned long st_mtime; - unsigned long __unused2; - unsigned long st_ctime; - unsigned long __unused3; - unsigned long __unused4; - unsigned long __unused5; - }; -*) - - CONST - statbufsize = 88(*64*); (* see *) (* sizeof struct stat gives us 144 on x86_64 and 88 on x86 *) - TYPE - UnixStatRec = ARRAY statbufsize OF SYS.BYTE; - CONST - statbufconv = - (*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*) - (*"ls=dev/-s=pad1/lL=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/lL=size/2*lL=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";*) - "ll=dev/-l=devx/-s=pad1/ll=ino/Sl=mode/ll=nlink/ll=uid/ll=gid/ll=rdev/-l=rdevx/-s=pad2/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; - VAR - statbuffmt: SysConversions.Format; - - PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newstat, path); - RETURN FALSE - END; - END Stat; -(* - PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: INTEGER; - origbuf: UnixStatRec; - BEGIN - IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newlstat, path); - RETURN FALSE - END; - END Lstat; -*) - PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newfstat, ""); - RETURN FALSE - END; - END Fstat; - -BEGIN - SysConversions.Compile(statbuffmt, statbufconv); -END ulmSysStat. diff --git a/src/lib/ulm/armv6j_hardfp/ulmSysTypes.Mod b/src/lib/ulm/armv6j_hardfp/ulmSysTypes.Mod deleted file mode 100644 index 174140e7..00000000 --- a/src/lib/ulm/armv6j_hardfp/ulmSysTypes.Mod +++ /dev/null @@ -1,70 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysTypes.om,v $ - Revision 1.1 1994/02/23 08:01:38 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysTypes; - - IMPORT Types := ulmTypes; - - TYPE - Address* = Types.Address; - UntracedAddress* = Types.UntracedAddress; - Count* = Types.Count; - Size* = Types.Size; - Byte* = Types.Byte; - - File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *) - Offset* = LONGINT; - Device* = LONGINT; - Inode* = LONGINT; - Time* = LONGINT; - - Word* = INTEGER; (* must have the size of C's int-type *) - - (* Note: linux supports wait4 but not waitid, i.e. these - * constants aren't needed. *) - (* - CONST - (* possible values of the idtype parameter (4 bytes), - see - *) - idPid = 0; (* a process identifier *) - idPpid = 1; (* a parent process identifier *) - idPgid = 2; (* a process group (job control group) identifier *) - idSid = 3; (* a session identifier *) - idCid = 4; (* a scheduling class identifier *) - idUid = 5; (* a user identifier *) - idGid = 6; (* a group identifier *) - idAll = 7; (* all processes *) - idLwpid = 8; (* an LWP identifier *) - TYPE - IdType = INTEGER; (* idPid .. idLwpid *) - *) - -END ulmSysTypes. diff --git a/src/lib/ulm/powerpc/ulmSYSTEM.Mod b/src/lib/ulm/powerpc/ulmSYSTEM.Mod deleted file mode 100644 index 814c0607..00000000 --- a/src/lib/ulm/powerpc/ulmSYSTEM.Mod +++ /dev/null @@ -1,137 +0,0 @@ -MODULE ulmSYSTEM; -IMPORT SYSTEM, Unix, Sys := ulmSys; - -TYPE pchar = POINTER TO ARRAY 1 OF CHAR; - pstring = POINTER TO ARRAY 1024 OF CHAR; - pstatus = POINTER TO Unix.Status; - - TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - pbytearray* = POINTER TO bytearray; - TYPE longrealarray* = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - plongrealarray* = POINTER TO bytearray; - - PROCEDURE LongToByteArr* ( l : LONGINT; VAR bar : bytearray); (* noch *) - VAR b : SYSTEM.BYTE; - p : pbytearray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(pbytearray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGINT) -1 DO - b := p^[i]; bar[i] := b; - END - END LongToByteArr; - - PROCEDURE LRealToByteArr* ( l : LONGREAL; VAR lar : longrealarray); (* noch *) - VAR b : SYSTEM.BYTE; - p : plongrealarray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(plongrealarray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGREAL) -1 DO - b := p^[i]; lar[i] := b; - END - END LRealToByteArr; - - -(* - PROCEDURE -Write(adr, n: LONGINT): LONGINT - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; -*) - - 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 UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *) - arg1, arg2, arg3: LONGINT) : BOOLEAN; - VAR - n : LONGINT; - ch : CHAR; - pch : pchar; - pstr : pstring; - pst : pstatus; - BEGIN - - IF syscall = Sys.read THEN - d0 := Unix.Read(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - ch := pch^[0]; - n := read(ch); - IF n # 1 THEN - ch := 0X; - RETURN FALSE - ELSE - pch^[0] := ch; - RETURN TRUE - END; - *) - ELSIF syscall = Sys.write THEN - d0 := Unix.Write(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - n := Write(SYSTEM.VAL(LONGINT, pch), 1); - IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END - *) - ELSIF syscall = Sys.open THEN - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Open(pstr^, SYSTEM.VAL(SET, arg3), SYSTEM.VAL(SET, arg2)); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.close THEN - d0 := Unix.Close(arg1); - IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.lseek THEN - d0 := Unix.Lseek(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.ioctl THEN - d0 := Unix.Ioctl(arg1, arg2, arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.fcntl THEN - d0 := Unix.Fcntl (arg1, arg2, arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.dup THEN - d0 := Unix.Dup(arg1); - RETURN d0 > 0; - ELSIF syscall = Sys.pipe THEN - d0 := Unix.Pipe(arg1); - RETURN d0 >= 0; - ELSIF syscall = Sys.newstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Stat(pstr^, pst^); - RETURN d0 >= 0 - ELSIF syscall = Sys.newfstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - d0 := Unix.Fstat(arg1, pst^); - RETURN d0 >= 0; - END - - END UNIXCALL; - - - PROCEDURE UNIXFORK(VAR pid: LONGINT) : BOOLEAN; - BEGIN - - END UNIXFORK; - - PROCEDURE UNIXSIGNAL(signo: INTEGER; p: PROCEDURE; - VAR old: PROCEDURE; VAR error: INTEGER) : BOOLEAN; - BEGIN - - END UNIXSIGNAL; - - PROCEDURE WMOVE*(from, to, n : LONGINT); - VAR l : LONGINT; - BEGIN - SYSTEM.MOVE(from, to, n); - END WMOVE; -END ulmSYSTEM. diff --git a/src/lib/ulm/powerpc/ulmSysConversions.Mod b/src/lib/ulm/powerpc/ulmSysConversions.Mod deleted file mode 100644 index f8ea3fbb..00000000 --- a/src/lib/ulm/powerpc/ulmSysConversions.Mod +++ /dev/null @@ -1,574 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysConversi.om,v $ - Revision 1.2 1997/07/30 09:38:16 borchert - bug in ReadConv fixed: cv.flags was used but not set for - counts > 1 - - Revision 1.1 1994/02/23 07:58:28 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 8/90 - adapted to linux cae 02/01 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysConversions; - - (* convert Oberon records to/from C structures *) - - IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts; - - TYPE - Address* = SysTypes.Address; - Size* = Address; - - (* format: - - Format = Conversion { "/" Conversion } . - Conversion = [ Factors ] ConvChars [ Comment ] . - Factors = Array | Factor | Array Factor | Factor Array . - Array = Integer ":" . - Factor = Integer "*" . - ConvChars = OberonType CType | Skip CType | OberonType Skip . - OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" . - CType = "a" | "c" | "s" | "i" | "l" . - Integer = Digit { Digit } . - Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" . - Skip = "-" . - Comment = "=" { AnyChar } . - AnyChar = (* all characters except "/" *) . - - Oberon data types: - - a: Address - b: SYS.BYTE - B: BOOLEAN - c: CHAR - s: SHORTINT - i: INTEGER - l: LONGINT - S: SET - - C data types: - - a: char * - c: /* signed */ char - C: unsigned char - s: short int - S: unsigned short int - i: int - I: unsigned int - u: unsigned int - l: long int - L: unsigned long int - - example: - - conversion from - - Rec = - RECORD - a, b: INTEGER; - c: CHAR; - s: SET; - f: ARRAY 3 OF INTEGER; - END; - - to - - struct rec { - short a, b; - char c; - int xx; /* to be skipped on conversion */ - int s; - int f[3]; - }; - - or vice versa: - - "2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f" - - The comments allow to give the field names. - *) - - CONST - (* conversion flags *) - unsigned = 0; (* suppress sign extension *) - boolean = 1; (* convert anything # 0 to 1 *) - TYPE - Flags = SET; - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - format*: Events.Message; - END; - ConvStream = POINTER TO ConvStreamRec; - ConvStreamRec = - RECORD - fmt: Texts.Text; - char: CHAR; - eof: BOOLEAN; - (* 1: Oberon type - 2: C type - *) - type1, type2: CHAR; length: INTEGER; left: INTEGER; - offset1, offset2: Address; - size1, size2: Address; elementsleft: INTEGER; flags: Flags; - END; - - Format* = POINTER TO FormatRec; - FormatRec* = - RECORD - (Objects.ObjectRec) - offset1, offset2: Address; - size1, size2: Address; - flags: Flags; - next: Format; - END; - VAR - badformat*: Events.EventType; - - PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - Strings.Read(event.format, cv.fmt); - Events.Raise(event); - cv.eof := TRUE; - cv.char := 0X; - cv.left := 0; - cv.elementsleft := 0; - END Error; - - PROCEDURE SizeError(msg, format: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - COPY(format, event.format); - Events.Raise(event); - END SizeError; - - PROCEDURE NextCh(cv: ConvStream); - BEGIN - cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X); - IF cv.eof THEN - cv.char := 0X; - END; - END NextCh; - - PROCEDURE IsDigit(ch: CHAR) : BOOLEAN; - BEGIN - RETURN (ch >= "0") & (ch <= "9") - END IsDigit; - - PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER); - BEGIN - i := 0; - REPEAT - i := 10 * i + ORD(cv.char) - ORD("0"); - NextCh(cv); - UNTIL ~IsDigit(cv.char); - END ReadInt; - - PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR); - BEGIN - NEW(cv); - Texts.Open(SYS.VAL(Streams.Stream, cv.fmt)); - Strings.Write(cv.fmt, format); - cv.left := 0; cv.elementsleft := 0; - cv.offset1 := 0; cv.offset2 := 0; - cv.eof := FALSE; - NextCh(cv); - END Open; - - PROCEDURE Close(VAR cv: ConvStream); - BEGIN - IF ~Streams.Close(cv.fmt) THEN END; - END Close; - - PROCEDURE ScanConv(cv: ConvStream; - VAR type1, type2: CHAR; - VAR length: INTEGER) : BOOLEAN; - VAR - i: INTEGER; - factor: INTEGER; - BEGIN - IF cv.left > 0 THEN - type1 := cv.type1; - type2 := cv.type2; - length := cv.length; - DEC(cv.left); - RETURN TRUE - END; - IF cv.char = "/" THEN - NextCh(cv); - END; - IF cv.eof THEN - RETURN FALSE - END; - factor := 0; length := 0; - WHILE IsDigit(cv.char) DO - ReadInt(cv, i); - IF i <= 0 THEN - Error(cv, "integer must be positive"); RETURN FALSE - END; - IF cv.char = ":" THEN - IF length # 0 THEN - Error(cv, "multiple length specification"); RETURN FALSE - END; - length := i; - NextCh(cv); - ELSIF cv.char = "*" THEN - IF factor # 0 THEN - Error(cv, "multiple factor specification"); RETURN FALSE - END; - factor := i; cv.left := factor - 1; - NextCh(cv); - ELSE - Error(cv, "factor or length expected"); RETURN FALSE - END; - END; - type1 := cv.char; NextCh(cv); - type2 := cv.char; NextCh(cv); - IF cv.left > 0 THEN - cv.type1 := type1; cv.type2 := type2; cv.length := length; - END; - IF cv.char = "=" THEN (* comment *) - REPEAT - NextCh(cv); - UNTIL cv.eof OR (cv.char = "/"); - END; - RETURN TRUE - END ScanConv; - - PROCEDURE Align(VAR offset: Address; boundary: Address); - BEGIN - IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN - offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary)); - END; - END Align; - - PROCEDURE ReadConv(cv: ConvStream; - VAR offset1, offset2: Address; - VAR size1, size2: Address; - VAR flags: Flags) : BOOLEAN; - VAR - type1, type2: CHAR; - length: INTEGER; - align: BOOLEAN; - boundary: INTEGER; - BEGIN - IF cv.elementsleft > 0 THEN - DEC(cv.elementsleft); - - (* Oberon type *) - IF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - size1 := cv.size1; size2 := cv.size2; flags := cv.flags; - IF (size1 > 0) & (cv.elementsleft = 0) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - - (* C type *) - IF size2 > 1 THEN - Align(cv.offset2, 2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - RETURN TRUE - END; - IF ScanConv(cv, type1, type2, length) THEN - flags := {}; - (* Oberon type *) - CASE type1 OF - | "a": size1 := SIZE(Address); INCL(flags, unsigned); - | "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned); - | "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean); - | "c": size1 := SIZE(CHAR); INCL(flags, unsigned); - | "s": size1 := SIZE(SHORTINT); - | "i": size1 := SIZE(INTEGER); - | "l": size1 := SIZE(LONGINT); - | "S": size1 := SIZE(SET); INCL(flags, unsigned); - | "-": size1 := 0; - ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE - END; - IF size1 > 0 THEN - IF length > 0 THEN - Align(cv.offset1, SIZE(INTEGER)); - ELSIF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - - (* C type *) - CASE type2 OF - | "a": size2 := 4; INCL(flags, unsigned); (* char* *) - | "c": size2 := 1; (* /* signed */ char *) - | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) - | "s": size2 := 2; (* short int *) - | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) - | "i": size2 := 4; (* int *) - | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "l": size2 := 4; (* long int *) - | "L": size2 := 4; INCL(flags, unsigned); (* long int *) - | "-": size2 := 0; - ELSE Error(cv, "bad C type specifier"); RETURN FALSE - END; - IF size2 > 1 THEN - Align(cv.offset2, size2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - cv.size1 := size1; cv.size2 := size2; - IF length > 0 THEN - cv.elementsleft := length - 1; - cv.flags := flags; - END; - RETURN TRUE - ELSE - RETURN FALSE - END; - END ReadConv; - - PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags); - TYPE - Bytes = ARRAY 8 OF CHAR; - Pointer = POINTER TO Bytes; - VAR - dest, source: Pointer; - dindex, sindex: INTEGER; - nonzero: BOOLEAN; - fill : CHAR; - BEGIN - IF ssize > 0 THEN - dest := SYS.VAL(Pointer, to); - source := SYS.VAL(Pointer, from); - dindex := 0; sindex := 0; - IF boolean IN flags THEN - nonzero := FALSE; - WHILE ssize > 0 DO - nonzero := nonzero OR (source[sindex] # 0X); - INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1; - END; - IF dsize > 0 THEN - IF nonzero THEN - dest[dindex] := 1X; - ELSE - dest[dindex] := 0X; - END; - dsize := dsize - 1; INC (dindex); - END; - WHILE dsize > 0 DO - dest[dindex] := 0X; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - ELSE - WHILE (dsize > 0) & (ssize > 0) DO - dest[dindex] := source[sindex]; - ssize := SYS.VAL (INTEGER, ssize) - 1; - dsize := dsize - 1; - INC(dindex); INC(sindex); - END; - IF dsize > 0 THEN - (* sindex has been incremented at least once because - * ssize and dsize were greater than 0, i.e. sindex-1 - * is a valid inex. *) - fill := 0X; - IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN - fill := 0FFX; - END; - END; - WHILE dsize > 0 DO - dest[dindex] := fill; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - END; - END; - END Convert; - - PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset1, to + offset2, size1, size2, flags); - END; - Close(cv); - END ByAddrToC; - - PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset2, to + offset1, size2, size1, flags); - END; - Close(cv); - END ByAddrFromC; - - PROCEDURE CSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the C-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset2 + size2; - Align(size, 2); - RETURN size - END CSize; - - PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the Oberon-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset1 + size1; - Align(size, SIZE(INTEGER)); - RETURN size - END OberonSize; - - PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(from) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(to) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ToC; - - PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(to) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(from) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END FromC; - - PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR); - (* translate format into an internal representation - which is later referenced by fmt; - ByFmtToC and ByFmtFromC are faster than ToC and FromC - *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - element: Format; - head, tail: Format; - BEGIN - Open(cv, format); - head := NIL; tail := NIL; - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - NEW(element); - element.offset1 := offset1; - element.offset2 := offset2; - element.size1 := size1; - element.size2 := size2; - element.flags := flags; - element.next := NIL; - IF tail # NIL THEN - tail.next := element; - ELSE - head := element; - END; - tail := element; - END; - fmt := head; - Close(cv); - END Compile; - - PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset1, to + format.offset2, - format.size1, format.size2, format.flags); - format := format.next; - END; - END ByFmtAndAddrToC; - - PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset2, to + format.offset1, - format.size2, format.size1, format.flags); - format := format.next; - END; - END ByFmtAndAddrFromC; - - PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtToC; - - PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtFromC; - -BEGIN - Events.Define(badformat); - Events.SetPriority(badformat, Priorities.liberrors); -END ulmSysConversions. diff --git a/src/lib/ulm/powerpc/ulmSysStat.Mod b/src/lib/ulm/powerpc/ulmSysStat.Mod deleted file mode 100644 index c7f00f04..00000000 --- a/src/lib/ulm/powerpc/ulmSysStat.Mod +++ /dev/null @@ -1,201 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysStat.om,v $ - Revision 1.3 2000/11/12 13:02:09 borchert - door file type added - - Revision 1.2 2000/11/12 12:48:07 borchert - - conversion adapted to Solaris 2.x - - Lstat added - - Revision 1.1 1994/02/23 08:00:48 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysStat; - - (* examine inode: stat(2) and fstat(2) *) - - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors, - SysTypes := ulmSysTypes; - - CONST - (* file mode: - bit 0 = 1<<0 bit 31 = 1<<31 - - user group other - 3 1 1111 11 - 1 ... 6 5432 109 876 543 210 - +--------+------+-----+-----+-----+-----+ - | unused | type | sst | rwx | rwx | rwx | - +--------+------+-----+-----+-----+-----+ - *) - - type* = {12..15}; - prot* = {0..8}; - - (* file types; example: (stat.mode * type = dir) *) - reg* = {15}; (* regular *) - dir* = {14}; (* directory *) - chr* = {13}; (* character special *) - fifo* = {12}; (* fifo *) - blk* = {13..14}; (* block special *) - symlink* = {13, 15}; (* symbolic link *) - socket* = {14, 15}; (* socket *) - - (* special *) - setuid* = 11; (* set user id on execution *) - setgid* = 10; (* set group id on execution *) - savetext* = 9; (* save swapped text even after use *) - - (* protection *) - uread* = 8; (* read permission owner *) - uwrite* = 7; (* write permission owner *) - uexec* = 6; (* execute/search permission owner *) - gread* = 5; (* read permission group *) - gwrite* = 4; (* write permission group *) - gexec* = 3; (* execute/search permission group *) - oread* = 2; (* read permission other *) - owrite* = 1; (* write permission other *) - oexec* = 0; (* execute/search permission other *) - - (* example for "r-xr-x---": (read + exec) * (owner + group) *) - owner* = {uread, uwrite, uexec}; - group* = {gread, gwrite, gexec}; - other* = {oread, owrite, oexec}; - read* = {uread, gread, oread}; - write* = {uwrite, gwrite, owrite}; - exec* = {uexec, gexec, oexec}; - rwx* = prot; - - TYPE - StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - mode*: SET; (* file mode; see mknod(2) *) - nlinks*: LONGINT; (* number of links *) - uid*: LONGINT; (* user id of the file's owner *) - gid*: LONGINT; (* group id of the file's group *) - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - mtime*: SysTypes.Time; (* time of last data modification *) - ctime*: SysTypes.Time; (* time of last file status change *) - END; - -(* Linux kernel struct stat (2.2.17) - struct stat { - unsigned short st_dev; - unsigned short __pad1; - unsigned long st_ino; - unsigned short st_mode; - unsigned short st_nlink; - unsigned short st_uid; - unsigned short st_gid; - unsigned short st_rdev; - unsigned short __pad2; - unsigned long st_size; - unsigned long st_blksize; - unsigned long st_blocks; - unsigned long st_atime; - unsigned long __unused1; - unsigned long st_mtime; - unsigned long __unused2; - unsigned long st_ctime; - unsigned long __unused3; - unsigned long __unused4; - unsigned long __unused5; - }; -*) - - CONST - statbufsize = 88(*64*); (* see *) (* sizeof struct stat gives us 144 on x86_64 and 88 on x86 *) - TYPE - UnixStatRec = ARRAY statbufsize OF SYS.BYTE; - CONST - statbufconv = - (*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*) - (*"ls=dev/-s=pad1/lL=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/lL=size/2*lL=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";*) - "ll=dev/-l=devx/-s=pad1/ll=ino/Sl=mode/ll=nlink/ll=uid/ll=gid/ll=rdev/-l=rdevx/-s=pad2/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; - VAR - statbuffmt: SysConversions.Format; - - PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newstat, path); - RETURN FALSE - END; - END Stat; -(* - PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: INTEGER; - origbuf: UnixStatRec; - BEGIN - IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newlstat, path); - RETURN FALSE - END; - END Lstat; -*) - PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newfstat, ""); - RETURN FALSE - END; - END Fstat; - -BEGIN - SysConversions.Compile(statbuffmt, statbufconv); -END ulmSysStat. diff --git a/src/lib/ulm/powerpc/ulmSysTypes.Mod b/src/lib/ulm/powerpc/ulmSysTypes.Mod deleted file mode 100644 index 174140e7..00000000 --- a/src/lib/ulm/powerpc/ulmSysTypes.Mod +++ /dev/null @@ -1,70 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysTypes.om,v $ - Revision 1.1 1994/02/23 08:01:38 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysTypes; - - IMPORT Types := ulmTypes; - - TYPE - Address* = Types.Address; - UntracedAddress* = Types.UntracedAddress; - Count* = Types.Count; - Size* = Types.Size; - Byte* = Types.Byte; - - File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *) - Offset* = LONGINT; - Device* = LONGINT; - Inode* = LONGINT; - Time* = LONGINT; - - Word* = INTEGER; (* must have the size of C's int-type *) - - (* Note: linux supports wait4 but not waitid, i.e. these - * constants aren't needed. *) - (* - CONST - (* possible values of the idtype parameter (4 bytes), - see - *) - idPid = 0; (* a process identifier *) - idPpid = 1; (* a parent process identifier *) - idPgid = 2; (* a process group (job control group) identifier *) - idSid = 3; (* a session identifier *) - idCid = 4; (* a scheduling class identifier *) - idUid = 5; (* a user identifier *) - idGid = 6; (* a group identifier *) - idAll = 7; (* all processes *) - idLwpid = 8; (* an LWP identifier *) - TYPE - IdType = INTEGER; (* idPid .. idLwpid *) - *) - -END ulmSysTypes. diff --git a/src/lib/ulm/powerpc/ulmTypes.Mod b/src/lib/ulm/powerpc/ulmTypes.Mod deleted file mode 100644 index 0d2db20e..00000000 --- a/src/lib/ulm/powerpc/ulmTypes.Mod +++ /dev/null @@ -1,133 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Types.om,v $ - Revision 1.5 2000/12/13 10:03:00 borchert - SetInt type used in msb constant - - Revision 1.4 2000/12/13 09:51:57 borchert - constants and types for the relationship of INTEGER and SET added - - Revision 1.3 1998/09/25 15:23:09 borchert - Real32..Real128 added - - Revision 1.2 1994/07/01 11:08:04 borchert - IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added - - Revision 1.1 1994/02/22 20:12:14 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/93 - ---------------------------------------------------------------------------- -*) - -MODULE ulmTypes; - - (* compiler-dependent type definitions; - this version works for Ulm's Oberon Compilers on - following architectures: m68k and sparc - *) - - IMPORT SYS := SYSTEM; - - TYPE - Address* = LONGINT (*SYS.ADDRESS*); - (* ulm compiler can accept - VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) - UntracedAddressDesc* = RECORD[1] END; - Count* = LONGINT; - Size* = Count; - Byte* = SYS.BYTE; - IntAddress* = LONGINT; - Int8* = SHORTINT; - Int16* = INTEGER; - Int32* = LONGINT; - Real32* = REAL; - Real64* = LONGREAL; - - CONST - bigEndian* = 0; (* SPARC, M68K etc *) - littleEndian* = 1; (* Intel 80x86, VAX etc *) - byteorder* = bigEndian; (* machine-dependent constant *) - TYPE - ByteOrder* = SHORTINT; (* bigEndian or littleEndian *) - - (* following constants and type definitions try to make - conversions from INTEGER to SET and vice versa more portable - to allow for bit operations on INTEGER values - *) - TYPE - SetInt* = LONGINT; (* INTEGER type that corresponds to SET *) - VAR msb* : SET; - msbIsMax*, msbIs0*: SHORTINT; - msbindex*, lsbindex*, nofbits*: LONGINT; - - PROCEDURE ToInt8*(int: LONGINT) : Int8; - BEGIN - RETURN SHORT(SHORT(int)) - END ToInt8; - - PROCEDURE ToInt16*(int: LONGINT) : Int16; - BEGIN - RETURN SYS.VAL(Int16, int) - END ToInt16; - - PROCEDURE ToInt32*(int: LONGINT) : Int32; - BEGIN - RETURN int - END ToInt32; - - PROCEDURE ToReal32*(real: LONGREAL) : Real32; - BEGIN - RETURN SHORT(real) - END ToReal32; - - PROCEDURE ToReal64*(real: LONGREAL) : Real64; - BEGIN - RETURN real - END ToReal64; - -BEGIN - msb := SYS.VAL(SET, MIN(SetInt)); - (* most significant bit, converted to a SET *) - (* we expect msbIsMax XOR msbIs0 to be 1; - this is checked for by an assertion - *) - msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)})); - (* is 1, if msb equals {MAX(SET)} *) - msbIs0 := SYS.VAL(SHORTINT, (msb = {0})); - (* is 0, if msb equals {0} *) - msbindex := msbIsMax * MAX(SET); - (* set element that corresponds to the most-significant-bit *) - lsbindex := MAX(SET) - msbindex; - (* set element that corresponds to the lowest-significant-bit *) - nofbits := MAX(SET) + 1; - (* number of elements in SETs *) - - ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1)); -END ulmTypes. diff --git a/src/lib/ulm/ulmCipherOps.Mod b/src/lib/ulm/ulmCipherOps.Mod deleted file mode 100644 index cf3318a7..00000000 --- a/src/lib/ulm/ulmCipherOps.Mod +++ /dev/null @@ -1,67 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: CipherOps.om,v 1.1 1997/04/02 11:53:20 borchert Exp borchert $ - ---------------------------------------------------------------------------- - $Log: CipherOps.om,v $ - Revision 1.1 1997/04/02 11:53:20 borchert - Initial revision - - ---------------------------------------------------------------------------- -*) - -MODULE ulmCipherOps; (* Michael Szczuka *) - - (* useful functions for stream ciphers *) - - IMPORT Streams := ulmStreams, SYS := SYSTEM, Write := ulmWrite; - - PROCEDURE XorByte* (b1, b2: SYS.BYTE) : SYS.BYTE; - (* adds two bytes bitwise modulo 2 *) - BEGIN - RETURN SYS.VAL(SYS.BYTE, SYS.VAL(SET, b1) / SYS.VAL(SET, b2)) - END XorByte; - - PROCEDURE XorStream* (in1, in2, out: Streams.Stream; - length: INTEGER) : BOOLEAN; - (* adds two streams bitwise modulo 2; restricted to length bytes *) - VAR - b1, b2, res : SYS.BYTE; - wholeStream : BOOLEAN; - BEGIN - IF length < 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE; - END; - WHILE wholeStream OR (length > 0) DO - IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN - res := XorByte(b1, b2); - IF ~Streams.WriteByte(out, res) THEN - RETURN FALSE - END; - ELSE - RETURN wholeStream - END; - DEC(length); - END; - RETURN TRUE - END XorStream; - -END ulmCipherOps. diff --git a/src/lib/ulm/ulmDisciplines.Mod b/src/lib/ulm/ulmDisciplines.Mod deleted file mode 100644 index 913f7c03..00000000 --- a/src/lib/ulm/ulmDisciplines.Mod +++ /dev/null @@ -1,140 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Disciplines.om,v $ - Revision 1.1 1994/02/22 20:07:03 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 5/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmDisciplines; - - (* Disciplines allows to attach additional data structures to - abstract datatypes like Streams; - these added data structures permit to parametrize operations - which are provided by other modules (e.g. Read or Write for Streams) - *) - - IMPORT Objects := ulmObjects; - - TYPE - Identifier* = LONGINT; - - Discipline* = POINTER TO DisciplineRec; - DisciplineRec* = - RECORD - (Objects.ObjectRec) - id*: Identifier; (* should be unique for all types of disciplines *) - END; - - DisciplineList = POINTER TO DisciplineListRec; - DisciplineListRec = - RECORD - discipline: Discipline; - id: Identifier; (* copied from discipline.id *) - next: DisciplineList; - END; - - Object* = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (Objects.ObjectRec) - (* private part *) - list: DisciplineList; (* set of disciplines *) - END; - - VAR - unique: Identifier; - - PROCEDURE Unique*() : Identifier; - (* returns a unique identifier; - this procedure should be called during initialization by - all modules defining a discipline type - *) - BEGIN - INC(unique); - RETURN unique - END Unique; - - PROCEDURE Remove*(object: Object; id: Identifier); - (* remove the discipline with the given id from object, if it exists *) - VAR - prev, dl: DisciplineList; - BEGIN - prev := NIL; - dl := object.list; - WHILE (dl # NIL) & (dl.id # id) DO - prev := dl; dl := dl.next; - END; - IF dl # NIL THEN - IF prev = NIL THEN - object.list := dl.next; - ELSE - prev.next := dl.next; - END; - END; - END Remove; - - PROCEDURE Add*(object: Object; discipline: Discipline); - (* adds a new discipline to the given object; - if already a discipline with the same identifier exist - it is deleted first - *) - VAR - dl: DisciplineList; - BEGIN - dl := object.list; - WHILE (dl # NIL) & (dl.id # discipline.id) DO - dl := dl.next; - END; - IF dl = NIL THEN - NEW(dl); - dl.id := discipline.id; - dl.next := object.list; - object.list := dl; - END; - dl.discipline := discipline; - END Add; - - PROCEDURE Seek*(object: Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - (* returns TRUE if a discipline with the given id is found *) - VAR - dl: DisciplineList; - BEGIN - dl := object.list; - WHILE (dl # NIL) & (dl.id # id) DO - dl := dl.next; - END; - IF dl # NIL THEN - discipline := dl.discipline; - ELSE - discipline := NIL; - END; - RETURN discipline # NIL - END Seek; - -BEGIN - unique := 0; -END ulmDisciplines. diff --git a/src/lib/ulm/ulmErrors.Mod b/src/lib/ulm/ulmErrors.Mod deleted file mode 100644 index edb1cb6f..00000000 --- a/src/lib/ulm/ulmErrors.Mod +++ /dev/null @@ -1,158 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Errors.om,v $ - Revision 1.2 1994/07/18 14:16:33 borchert - unused variables of Write (ch & index) removed - - Revision 1.1 1994/02/22 20:07:15 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 11/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmErrors; - - (* translate events to errors *) - - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM; - - CONST - (* Kind = (debug, message, warning, error, fatal, bug) *) - debug* = 0; - message* = 1; - warning* = 2; - error* = 3; - fatal* = 4; - bug* = 5; - nkinds* = 6; - TYPE - Kind* = SHORTINT; (* debug..bug *) - VAR - kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR; - - TYPE - Handler* = PROCEDURE (event: Events.Event; kind: Kind); - HandlerSet* = POINTER TO HandlerSetRec; - HandlerSetRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - handlerSet: SET; (* set of installed handlers *) - handler: ARRAY nkinds OF Handler; - END; - - (* ========== write discipline ========================================= *) - TYPE - WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event); - WriteDiscipline = POINTER TO WriteDisciplineRec; - WriteDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - write: WriteProcedure; - END; - VAR - writeDiscId: Disciplines.Identifier; - - (* ========== handler discipline ======================================= *) - TYPE - HandlerDiscipline = POINTER TO HandlerDisciplineRec; - HandlerDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - hs: HandlerSet; - kind: Kind; - END; - VAR - handlerDiscId: Disciplines.Identifier; - - VAR - null*: HandlerSet; (* empty handler set *) - - PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet); - BEGIN - NEW(hs); hs.handlerSet := {}; - END CreateHandlerSet; - - PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler); - BEGIN - hs.handler[kind] := handler; - INCL(hs.handlerSet, kind); - END InstallHandler; - - PROCEDURE AssignWriteProcedure*(eventType: Events.EventType; - write: WriteProcedure); - VAR - writeDiscipline: WriteDiscipline; - BEGIN - NEW(writeDiscipline); - writeDiscipline.id := writeDiscId; - writeDiscipline.write := write; - Disciplines.Add(eventType, writeDiscipline); - END AssignWriteProcedure; - - PROCEDURE Write*(s: Streams.Stream; event: Events.Event); - VAR - writeDiscipline: WriteDiscipline; - BEGIN - IF Disciplines.Seek(event.type, writeDiscId, SYS.VAL(Disciplines.Discipline, writeDiscipline)) THEN - writeDiscipline.write(s, event); - ELSE - IF ~Streams.WritePart(s, event.message, 0, - Strings.Len(event.message)) THEN - END; - END; - END Write; - - PROCEDURE GeneralEventHandler(event: Events.Event); - VAR - disc: HandlerDiscipline; - BEGIN - IF Disciplines.Seek(event.type, handlerDiscId, SYS.VAL(Disciplines.Discipline, disc)) & - (disc.kind IN disc.hs.handlerSet) THEN - disc.hs.handler[disc.kind](event, disc.kind); - END; - END GeneralEventHandler; - - PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType); - VAR - handlerDiscipline: HandlerDiscipline; - BEGIN - NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId; - handlerDiscipline.hs := hs; handlerDiscipline.kind := kind; - Disciplines.Add(type, handlerDiscipline); - Events.Handler(type, GeneralEventHandler); - END CatchEvent; - -BEGIN - writeDiscId := Disciplines.Unique(); - handlerDiscId := Disciplines.Unique(); - CreateHandlerSet(null); - kindText[debug] := "debug"; - kindText[message] := "message"; - kindText[warning] := "warning"; - kindText[error] := "error"; - kindText[fatal] := "fatal"; - kindText[bug] := "bug"; -END ulmErrors. diff --git a/src/lib/ulm/ulmForwarders.Mod b/src/lib/ulm/ulmForwarders.Mod deleted file mode 100644 index ac4fa0b8..00000000 --- a/src/lib/ulm/ulmForwarders.Mod +++ /dev/null @@ -1,244 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Forwarders.om,v $ - Revision 1.1 1996/01/04 16:40:57 borchert - Initial revision - - ---------------------------------------------------------------------------- -*) - -MODULE ulmForwarders; (* AFB 3/95 *) - - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM; - (* SYSTEM is necessary to cast to Disciplines.Discipline; noch *) - - TYPE - Object* = Services.Object; - ForwardProc* = PROCEDURE (from, to: Object); - - TYPE - ListOfForwarders = POINTER TO ListOfForwardersRec; - ListOfForwardersRec = - RECORD - forward: ForwardProc; - next: ListOfForwarders; - END; - ListOfDependants = POINTER TO ListOfDependantsRec; - ListOfDependantsRec = - RECORD - dependant: Object; - next: ListOfDependants; - END; - TypeDiscipline = POINTER TO TypeDisciplineRec; - TypeDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - list: ListOfForwarders; - END; - ObjectDiscipline = POINTER TO ObjectDisciplineRec; - ObjectDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - dependants: ListOfDependants; - forwarders: ListOfForwarders; - dependsOn: Object; - END; - VAR - genlist: ListOfForwarders; (* list which applies to all types *) - typeDiscID: Disciplines.Identifier; - objectDiscID: Disciplines.Identifier; - - (* === private procedures ============================================ *) - - PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object); - VAR - prev, p: ListOfDependants; - BEGIN - prev := NIL; p := list; - WHILE (p # NIL) & (p.dependant # dependant) DO - prev := p; p := p.next; - END; - IF p # NIL THEN - IF prev = NIL THEN - list := p.next; - ELSE - prev.next := p.next; - END; - END; - END RemoveDependant; - - PROCEDURE TerminationHandler(event: Events.Event); - (* remove list of dependants in case of termination and - remove event.resource from the list of dependants of that - object it depends on - *) - VAR - odisc: ObjectDiscipline; - dependsOn: Object; - BEGIN - WITH event: Resources.Event DO - IF event.change = Resources.terminated THEN - IF Disciplines.Seek(event.resource, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - Disciplines.Remove(event.resource, objectDiscID); - dependsOn := odisc.dependsOn; - IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) & - Disciplines.Seek(dependsOn, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - RemoveDependant(odisc.dependants, event.resource(Object)); - END; - END; - END; - END; - END TerminationHandler; - - PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc); - VAR - member: ListOfForwarders; - BEGIN - NEW(member); member.forward := forward; - member.next := list; list := member; - END Insert; - - PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline); - VAR - resourceNotification: Events.EventType; - BEGIN - IF ~Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL; - odisc.forwarders := NIL; odisc.dependsOn := NIL; - (* let's state our interest in termination of `object' if - we see this object the first time - *) - Resources.TakeInterest(object, resourceNotification); - Events.Handler(resourceNotification, TerminationHandler); - Disciplines.Add(object, odisc); - END; - END GetObjectDiscipline; - - (* === exported procedures =========================================== *) - - PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc); - (* register a forwarder which is to be called for all - forward operations which affects extensions of `for'; - "" may be given for Services.Object - *) - - VAR - type: Services.Type; - tdisc: TypeDiscipline; - - BEGIN (* Register *) - IF for = "" THEN - Insert(genlist, forward); - ELSE - Services.SeekType(for, type); - ASSERT(type # NIL); - IF ~Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) THEN - NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL; - END; - Insert(tdisc.list, forward); - Disciplines.Add(type, tdisc); - END; - END Register; - - PROCEDURE RegisterObject*(object: Object; forward: ForwardProc); - (* to be called instead of Register if specific objects - are supported only and not all extensions of a type - *) - VAR - odisc: ObjectDiscipline; - BEGIN - GetObjectDiscipline(object, odisc); - Insert(odisc.forwarders, forward); - END RegisterObject; - - PROCEDURE Update*(object: Object; forward: ForwardProc); - (* is to be called by one of the registered forwarders if - an interface for object has been newly installed or changed - in a way which needs forward to be called for each of - the filter objects which delegate to `object' - *) - VAR - odisc: ObjectDiscipline; - client: ListOfDependants; - BEGIN - IF Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - client := odisc.dependants; - WHILE client # NIL DO - forward(client.dependant, object); - client := client.next; - END; - END; - END Update; - - PROCEDURE Forward*(from, to: Object); - (* forward (as far as supported) all operations from `from' to `to' *) - VAR - type, otherType, baseType: Services.Type; - tdisc: TypeDiscipline; - odisc: ObjectDiscipline; - client: ListOfDependants; - forwarder: ListOfForwarders; - - PROCEDURE CallForwarders(list: ListOfForwarders); - BEGIN - WHILE list # NIL DO - list.forward(from, to); - list := list.next; - END; - END CallForwarders; - - BEGIN (* Forward *) - Services.GetType(from, type); - Services.GetType(to, otherType); - ASSERT((type # NIL) & (otherType # NIL)); - - IF Resources.Terminated(to) OR Resources.Terminated(from) THEN - (* forwarding operations is no longer useful *) - RETURN - END; - Resources.DependsOn(from, to); - - (* update the list of dependants for `to' *) - GetObjectDiscipline(to, odisc); - NEW(client); client.dependant := from; - client.next := odisc.dependants; odisc.dependants := client; - - (* call object-specific forwarders *) - CallForwarders(odisc.forwarders); - - LOOP (* go through the list of base types in descending order *) - IF Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) & (* noch *) - Services.IsExtensionOf(otherType, type) THEN - CallForwarders(tdisc.list); - END; - Services.GetBaseType(type, baseType); - IF baseType = NIL THEN EXIT END; - type := baseType; - END; - CallForwarders(genlist); - END Forward; - -BEGIN - genlist := NIL; - typeDiscID := Disciplines.Unique(); - objectDiscID := Disciplines.Unique(); -END ulmForwarders. diff --git a/src/lib/ulm/ulmIO.Mod b/src/lib/ulm/ulmIO.Mod deleted file mode 100644 index 2fa775e1..00000000 --- a/src/lib/ulm/ulmIO.Mod +++ /dev/null @@ -1,244 +0,0 @@ -MODULE ulmIO; - - IMPORT SYS := ulmSYSTEM, SYSTEM; - - CONST nl = 0AX; - - (* conversions *) - - CONST - oct = 0; - dec = 1; - hex = 2; - TYPE - Basetype = SHORTINT; (* oct..hex *) - - (* basic IO *) - - VAR - Done*: BOOLEAN; - oldch: CHAR; - readAgain: BOOLEAN; - - (* ==================== conversions ================================= *) - - PROCEDURE ConvertNumber(num, len: LONGINT; btyp: Basetype; neg: BOOLEAN; - VAR str: ARRAY OF CHAR); - - (* conversion of a number into a string of characters *) - (* num must get the absolute value of the number *) - (* len is the minimal length of the generated string *) - (* neg means: "the number is negative" for btyp = dec *) - - (*CONST - NumberLen = 11;*) - (* we need it as variable to change the value depending on architecture; -- noch *) - VAR - (*digits : ARRAY NumberLen+1 OF CHAR;*) - digits : POINTER TO ARRAY OF CHAR; - base : INTEGER; - cnt, ix : INTEGER; - maxlen : LONGINT; - dig : LONGINT; - NumberLen : SHORTINT; - BEGIN - - IF SIZE(LONGINT) = 4 THEN - NumberLen := 11 - ELSIF SIZE(LONGINT) = 8 THEN - NumberLen := 21 - ELSE - NumberLen := 11 (* default value, corresponds to 32 bit *) - END; - NEW(digits, NumberLen + 1 ); - ASSERT(num >= 0); - ix := 1; - WHILE ix <= NumberLen DO - digits[ix] := "0"; - INC(ix); - END; (* initialisation *) - IF btyp = oct THEN - base := 8; - ELSIF btyp = dec THEN - base := 10; - ELSIF btyp = hex THEN - base := 10H; - END; - cnt := 0; - REPEAT - INC(cnt); - dig := num MOD base; - num := num DIV base; - IF dig < 10 THEN - dig := dig + ORD("0"); - ELSE - dig := dig - 10 + ORD("A"); - END; - digits[cnt] := CHR(dig); - UNTIL num = 0; - (* (* i don't like this *) - IF btyp = oct THEN - cnt := 11; - ELSIF btyp = hex THEN - cnt := 8; - ELSIF neg THEN - *) - IF neg THEN - INC(cnt); - digits[cnt] := "-"; - END; - maxlen := LEN(str); (* get maximal length *) - IF len > maxlen THEN - len := SHORT(maxlen); - END; - IF cnt > maxlen THEN - cnt := SHORT(maxlen); - END; - ix := 0; - WHILE len > cnt DO - str[ix] := " "; - INC(ix); - DEC(len); - END; - WHILE cnt > 0 DO - str[ix] := digits[cnt]; - INC(ix); - DEC(cnt); - END; - IF ix < maxlen THEN - str[ix] := 0X; - END; - END ConvertNumber; - - PROCEDURE ConvertInteger(num: LONGINT; len: INTEGER; VAR str: ARRAY OF - CHAR); - (* conversion of an integer decimal number to a string *) - BEGIN - ConvertNumber(ABS(num),len,dec,num < 0,str); - END ConvertInteger; - - (* ========================= terminal ============================ *) - - PROCEDURE ReadChar(VAR ch: CHAR) : BOOLEAN; - CONST read = 3; - (*VAR r0, r1: INTEGER;*) - VAR r0, r1: LONGINT; (* in ulm system INTEGER and LONGINT have the same 4 byte size; -- noch *) - BEGIN - RETURN SYS.UNIXCALL(read, r0, r1, 0, SYSTEM.ADR(ch), 1) & (r0 > 0) - END ReadChar; - - PROCEDURE WriteChar(ch: CHAR) : BOOLEAN; - CONST write = 4; - (*VAR r0, r1: INTEGER;*) - VAR r0, r1: LONGINT; (* same here *) - BEGIN - RETURN SYS.UNIXCALL(write, r0, r1, 1, SYSTEM.ADR(ch), 1) - END WriteChar; - - PROCEDURE Read*(VAR ch: CHAR); - BEGIN - Done := TRUE; - IF readAgain THEN - ch := oldch; - readAgain := FALSE; - ELSIF ~ReadChar(ch) THEN - Done := FALSE; - ch := 0X; - ELSE - oldch := ch; - END; - END Read; - - PROCEDURE ReadAgain*; - BEGIN - IF readAgain THEN - Done := FALSE; - ELSE - Done := TRUE; - readAgain := TRUE; - END; - END ReadAgain; - - PROCEDURE Write*(ch: CHAR); - BEGIN - Done := WriteChar(ch); - END Write; - - PROCEDURE WriteLn*; - CONST nl = 0AX; - BEGIN - Write(nl); - END WriteLn; - - PROCEDURE WriteString*(s: ARRAY OF CHAR); - VAR i: INTEGER; - BEGIN - i := 0; - WHILE (i < LEN(s)) & (s[i] # 0X) DO - Write(s[i]); - INC(i); - END; - END WriteString; - - PROCEDURE InitIO; - BEGIN - readAgain := FALSE; - Done := TRUE; - END InitIO; - - PROCEDURE WriteInt*(arg: LONGINT); - VAR field: ARRAY 23 OF CHAR; - BEGIN (* the field size should be big enough to hold the long number. it was 12 to hold just 32 bit numbers, now it can hold 64 bit numbers; need to be more for 128bit numbers; -- noch *) - ConvertInteger(arg, 1, field); - WriteString(field); - END WriteInt; - - PROCEDURE ReadInt*(VAR arg: LONGINT); - VAR ch: CHAR; - minus: BOOLEAN; - BEGIN - minus := FALSE; - REPEAT - Read(ch); - IF ~Done THEN RETURN END; - IF ch = "-" THEN - minus := TRUE; - ELSIF (ch # " ") & (ch # nl) & ((ch < "0") OR (ch > "9")) THEN - WriteString("--- Integer expected on input"); WriteLn; - END; - UNTIL (ch >= "0") & (ch <= "9"); - arg := ORD(ch) - ORD("0"); - REPEAT - Read(ch); - IF ~Done THEN RETURN END; - IF (ch >= "0") & (ch <= "9") THEN - arg := arg*10 + (ORD(ch) - ORD("0")); - END; - UNTIL (ch < "0") OR (ch > "9"); - ReadAgain; - IF minus THEN arg := -arg; END; - END ReadInt; - - PROCEDURE ReadLine*(VAR string: ARRAY OF CHAR); - VAR - index: INTEGER; - ch: CHAR; - ok: BOOLEAN; - BEGIN - index := 0; ok := TRUE; - LOOP - IF ~ReadChar(ch) THEN ok := FALSE; EXIT END; - IF ch = nl THEN EXIT END; - IF index < LEN(string) THEN - string[index] := ch; INC(index); - END; - END; - IF index < LEN(string) THEN - string[index] := 0X; - END; - Done := ok OR (index > 0); - END ReadLine; - -BEGIN - InitIO; -END ulmIO. diff --git a/src/lib/ulm/ulmNetIO.Mod b/src/lib/ulm/ulmNetIO.Mod deleted file mode 100644 index 0d0d44a0..00000000 --- a/src/lib/ulm/ulmNetIO.Mod +++ /dev/null @@ -1,546 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: NetIO.om,v $ - Revision 1.4 2004/05/21 15:19:03 borchert - performance improvements: - - ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD, - if possible - (based on code by Christian Ehrhardt) - - WriteConstString uses Streams.Copy instead of a loop that uses - Streams.ReadByte and Streams.WriteByte - - Revision 1.3 1995/03/17 16:28:20 borchert - - SizeOf stuff removed - - support of const strings added - - support of Forwarders added - - Revision 1.2 1994/07/18 14:18:37 borchert - unused variables of WriteString (ch + index) removed - - Revision 1.1 1994/02/22 20:08:43 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 6/93 - ---------------------------------------------------------------------------- -*) - -MODULE ulmNetIO; - - (* abstraction for the exchange of Oberon base types which - are components of persistent data structures - *) - - IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, Types := ulmTypes; - - TYPE - Byte* = Types.Byte; - - TYPE - ReadByteProc* = - PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN; - ReadCharProc* = - PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN; - ReadBooleanProc* = - PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; - ReadShortIntProc* = - PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; - ReadIntegerProc* = - PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; - ReadLongIntProc* = - PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; - ReadRealProc* = - PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN; - ReadLongRealProc* = - PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; - ReadSetProc* = - PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN; - ReadStringProc* = - PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; - ReadConstStringProc* = - PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain; - VAR string: ConstStrings.String) : BOOLEAN; - - WriteByteProc* = - PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN; - WriteCharProc* = - PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN; - WriteBooleanProc* = - PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; - WriteShortIntProc* = - PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; - WriteIntegerProc* = - PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN; - WriteLongIntProc* = - PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN; - WriteRealProc* = - PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN; - WriteLongRealProc* = - PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; - WriteSetProc* = - PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN; - WriteStringProc* = - PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; - WriteConstStringProc* = - PROCEDURE (s: Streams.Stream; - string: ConstStrings.String) : BOOLEAN; - - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - readByte*: ReadByteProc; - readChar*: ReadCharProc; - readBoolean*: ReadBooleanProc; - readShortInt*: ReadShortIntProc; - readInteger*: ReadIntegerProc; - readLongInt*: ReadLongIntProc; - readReal*: ReadRealProc; - readLongReal*: ReadLongRealProc; - readSet*: ReadSetProc; - readString*: ReadStringProc; - readConstString*: ReadConstStringProc; - - writeByte*: WriteByteProc; - writeChar*: WriteCharProc; - writeBoolean*: WriteBooleanProc; - writeShortInt*: WriteShortIntProc; - writeInteger*: WriteIntegerProc; - writeLongInt*: WriteLongIntProc; - writeReal*: WriteRealProc; - writeLongReal*: WriteLongRealProc; - writeSet*: WriteSetProc; - writeString*: WriteStringProc; - writeConstString*: WriteConstStringProc; - END; - - (* private data structures *) - TYPE - Discipline = POINTER TO DisciplineRec; - DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - if: Interface; - END; - VAR - discID: Disciplines.Identifier; - - PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE); - VAR - i,j : LONGINT; - tmp : SYS.BYTE; - BEGIN - i := 0; j := LEN (a) - 1; - WHILE i < j DO - tmp := a[i]; a[i] := a[j]; a[j] := tmp; - INC (i); DEC (j); - END; - END Swap; - - PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE); - VAR - i,old, bit : LONGINT; - new : LONGINT; - - BEGIN - i := 0; - WHILE i < LEN (a) DO - old := ORD (SYS.VAL (CHAR, a[i])); - new := 0; bit := 080H; - WHILE old # 0 DO - IF ODD (old) THEN - INC (new, bit); - END; - bit := ASH (bit, -1);; - old := ASH (old, -1); - END; - a[i] := SYS.VAL (SYS.BYTE, new); - INC (i); - END; - END BitSwap; - - PROCEDURE ^ Forward(from, to: Forwarders.Object); - - PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface); - VAR - disc: Discipline; - BEGIN - IF if # NIL THEN - NEW(disc); disc.id := discID; disc.if := if; - Disciplines.Add(s, disc); - ELSE - Disciplines.Remove(s, discID); - END; - Forwarders.Update(s, Forward); - END AttachInterface; - - PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface); - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - if := disc.if; - ELSE - if := NIL; - END; - END GetInterface; - - PROCEDURE CopyInterface*(from, to: Streams.Stream); - VAR - if: Interface; - BEGIN - GetInterface(from, if); - AttachInterface(to, if); - END CopyInterface; - - PROCEDURE Forward(from, to: Forwarders.Object); - BEGIN - (* this check is necessary because of Forwarders.Update *) - IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN - RETURN - END; - - WITH from: Streams.Stream DO WITH to: Streams.Stream DO - (* be careful here, from & to must be reversed *) - CopyInterface(to, from); - END; END; - END Forward; - - PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readByte(s, byte) - ELSE - RETURN Streams.ReadByte(s, byte) - END; - END ReadByte; - - PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readChar(s, char) - ELSE - RETURN Streams.ReadByte(s, char) - END; - END ReadChar; - - PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readBoolean(s, boolean) - ELSE - RETURN Streams.Read(s, boolean) - END; - END ReadBoolean; - - PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readShortInt(s, shortint) - ELSE - RETURN Streams.ReadByte(s, shortint) - END; - END ReadShortInt; - - PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readInteger(s, integer) - ELSE - ret := Streams.Read(s, integer); - IF Types.byteorder = Types.littleEndian THEN - Swap (integer); - END; - RETURN ret; - END; - END ReadInteger; - - PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readLongInt(s, longint) - ELSE - ret := Streams.Read(s, longint); - IF Types.byteorder = Types.littleEndian THEN - Swap (longint); - END; - RETURN ret; - END; - END ReadLongInt; - - PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readReal(s, real) - ELSE - RETURN Streams.Read(s, real) - END; - END ReadReal; - - PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readLongReal(s, longreal) - ELSE - RETURN Streams.Read(s, longreal) - END; - END ReadLongReal; - - PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readSet(s, set) - ELSE - ret := Streams.Read(s, set); - IF Types.byteorder = Types.littleEndian THEN - BitSwap (set); - END; - RETURN ret; - END; - END ReadSet; - - PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; - VAR - disc: Discipline; - ch: CHAR; index: LONGINT; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readString(s, string) - ELSE - index := 0; - WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO - IF index + 1 < LEN(string) THEN - string[index] := ch; INC(index); - END; - END; - string[index] := 0X; - RETURN ~s.error - END; - END ReadString; - - PROCEDURE ReadConstStringD*(s: Streams.Stream; - domain: ConstStrings.Domain; - VAR string: ConstStrings.String) : BOOLEAN; - CONST - bufsize = 512; - VAR - length: LONGINT; - buf: Streams.Stream; - ch: CHAR; - disc: Discipline; - stringbuf: ARRAY bufsize OF CHAR; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readConstString(s, domain, string) - ELSE - IF ReadLongInt(s, length) THEN - IF length >= bufsize THEN - ConstStrings.Init(buf); - IF ~Streams.Copy(s, buf, length) THEN - RETURN FALSE - END; - ConstStrings.CloseD(buf, domain, string); - RETURN length = s.count; - ELSE - IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN - RETURN FALSE - END; - stringbuf[length] := 0X; - ConstStrings.CreateD(string, domain, stringbuf); - RETURN TRUE - END; - ELSE - RETURN FALSE - END; - END; - END ReadConstStringD; - - PROCEDURE ReadConstString*(s: Streams.Stream; - VAR string: ConstStrings.String) : BOOLEAN; - BEGIN - RETURN ReadConstStringD(s, ConstStrings.std, string) - END ReadConstString; - - PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeByte(s, byte) - ELSE - RETURN Streams.WriteByte(s, byte) - END; - END WriteByte; - - PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeChar(s, char) - ELSE - RETURN Streams.WriteByte(s, char) - END; - END WriteChar; - - PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeBoolean(s, boolean) - ELSE - RETURN Streams.Write(s, boolean) - END; - END WriteBoolean; - - PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeShortInt(s, shortint) - ELSE - RETURN Streams.WriteByte(s, shortint) - END; - END WriteShortInt; - - PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeInteger(s, integer) - ELSE - IF Types.byteorder = Types.littleEndian THEN - Swap (integer); - END; - RETURN Streams.Write(s, integer); - END; - END WriteInteger; - - PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeLongInt(s, longint) - ELSE - IF Types.byteorder = Types.littleEndian THEN - Swap (longint); - END; - RETURN Streams.Write(s, longint); - END; - END WriteLongInt; - - PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeReal(s, real) - ELSE - RETURN Streams.Write(s, real) - END; - END WriteReal; - - PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeLongReal(s, longreal) - ELSE - RETURN Streams.Write(s, longreal) - END; - END WriteLongReal; - - PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeSet(s, set) - ELSE - IF Types.byteorder = Types.littleEndian THEN - BitSwap (set); - END; - RETURN Streams.Write(s, set) - END; - END WriteSet; - - PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeString(s, string) - ELSE - RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) & - Streams.WriteByte(s, 0X) - END; - END WriteString; - - PROCEDURE WriteConstString*(s: Streams.Stream; - string: ConstStrings.String) : BOOLEAN; - VAR - ch: CHAR; - buf: Streams.Stream; - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeConstString(s, string) - ELSE - IF WriteLongInt(s, string.len) THEN - ConstStrings.Open(buf, string); - RETURN Streams.Copy(buf, s, string.len) - ELSE - RETURN FALSE - END; - END; - END WriteConstString; - -BEGIN - discID := Disciplines.Unique(); - Forwarders.Register("Streams.Stream", Forward); -END ulmNetIO. diff --git a/src/lib/ulm/ulmOperations.Mod b/src/lib/ulm/ulmOperations.Mod deleted file mode 100644 index 4f74cc61..00000000 --- a/src/lib/ulm/ulmOperations.Mod +++ /dev/null @@ -1,234 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Operations.om,v $ - Revision 1.4 2004/09/16 18:31:54 borchert - optimization for Assign added in case of a non-NIL target - and identical types for target and source - - Revision 1.3 1997/02/05 16:27:45 borchert - Init asserts now that Services.Init hat been called previously - for ``op'' - - Revision 1.2 1995/01/16 21:39:50 borchert - - assertions of Assertions have been converted into real assertions - - some fixes due to changes of PersistentObjects - - Revision 1.1 1994/02/22 20:09:03 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmOperations; - - (* generic support of arithmetic operations *) - - IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices; - - CONST - add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4; - TYPE - Operation* = SHORTINT; (* add..cmp *) - Operand* = POINTER TO OperandRec; - - TYPE - CapabilitySet* = SET; (* SET OF [add..cmp] *) - CreateProc* = PROCEDURE (VAR op: Operand); - (* should call Operations.Init for op *) - OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand; - VAR result: Operand); - AssignProc* = PROCEDURE (VAR target: Operand; source: Operand); - CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER; - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; - assign*: AssignProc; - op*: OperatorProc; - compare*: CompareProc; - END; - - TYPE - OperandRec* = - RECORD - (PersistentDisciplines.ObjectRec) - if: Interface; - caps: CapabilitySet; - END; - VAR - operandType: Services.Type; - - PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet); - VAR - type: Services.Type; - BEGIN - Services.GetType(op, type); ASSERT(type # NIL); - op.if := if; op.caps := caps; - END Init; - - PROCEDURE Capabilities*(op: Operand) : CapabilitySet; - BEGIN - RETURN op.caps - END Capabilities; - - PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN; - (* return TRUE if both operands have the same interface *) - BEGIN - RETURN op1.if = op2.if - END Compatible; - - (* the interface of the first operand must match the interface - of all other operands; - the result parameter must be either NIL or already initialized - with the same interface - *) - - PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand); - - VAR - tmpresult: Operand; - BEGIN - ASSERT(op1.if = op2.if); - ASSERT(op IN op1.caps); - (* we are very defensive here because the type of tmpresult - is perhaps not identical to result or an extension of it; - op1.if.create(result) will not work in all cases - because of type guard failures - *) - op1.if.create(tmpresult); - op1.if.op(op, op1, op2, tmpresult); - result := tmpresult; - END Op; - - PROCEDURE Add*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(add, op1, op2, result); - RETURN result - END Add; - - PROCEDURE Add2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(add, op1, op2, op1); - END Add2; - - PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(add, op1, op2, result); - END Add3; - - PROCEDURE Sub*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(sub, op1, op2, result); - RETURN result - END Sub; - - PROCEDURE Sub2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(sub, op1, op2, op1); - END Sub2; - - PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(sub, op1, op2, result); - END Sub3; - - PROCEDURE Mul*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(mul, op1, op2, result); - RETURN result - END Mul; - - PROCEDURE Mul2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(mul, op1, op2, op1); - END Mul2; - - PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(mul, op1, op2, result); - END Mul3; - - PROCEDURE Div*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(div, op1, op2, result); - RETURN result - END Div; - - PROCEDURE Div2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(div, op1, op2, op1); - END Div2; - - PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(div, op1, op2, result); - END Div3; - - PROCEDURE Compare*(op1, op2: Operand) : INTEGER; - BEGIN - ASSERT(op1.if = op2.if); - ASSERT(cmp IN op1.caps); - RETURN op1.if.compare(op1, op2) - END Compare; - - PROCEDURE Assign*(VAR target: Operand; source: Operand); - VAR - tmpTarget: Operand; - typesIdentical: BOOLEAN; - targetType, sourceType: Services.Type; - BEGIN - IF (target # NIL) & (target.if = source.if) THEN - Services.GetType(target, targetType); - Services.GetType(source, sourceType); - typesIdentical := targetType = sourceType; - ELSE - typesIdentical := FALSE; - END; - IF typesIdentical THEN - source.if.assign(target, source); - ELSE - source.if.create(tmpTarget); - source.if.assign(tmpTarget, source); - target := tmpTarget; - END; - END Assign; - - PROCEDURE Copy*(source, target: Operand); - BEGIN - source.if.assign(target, source); - END Copy; - -BEGIN - PersistentObjects.RegisterType(operandType, - "Operations.Operand", "PersistentDisciplines.Object", NIL); -END ulmOperations. diff --git a/src/lib/ulm/ulmPersistentDisciplines.Mod b/src/lib/ulm/ulmPersistentDisciplines.Mod deleted file mode 100644 index 8f37d4ce..00000000 --- a/src/lib/ulm/ulmPersistentDisciplines.Mod +++ /dev/null @@ -1,391 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: PersistentD.om,v $ - Revision 1.4 1998/02/22 10:25:22 borchert - bug fix in GetObject: Disciplines.Add was missing if the main object - is just an extension of Disciplines.Object and not of - PersistentDisciplines.Object - - Revision 1.3 1996/07/24 07:41:28 borchert - bug fix: count component was not initialized (with the - exception of CreateObject) -- detected by Martin Hasch - - Revision 1.2 1995/03/17 16:13:33 borchert - - persistent disciplines may now be attached to non-persistent objects - - some fixes due to changes of PersistentObjects - - Revision 1.1 1994/02/22 20:09:12 borchert - Initial revision - - ---------------------------------------------------------------------------- -*) - -MODULE ulmPersistentDisciplines; - - IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, - Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM; - - CONST - objectName = "PersistentDisciplines.Object"; - disciplineName = "PersistentDisciplines.Discipline"; - - TYPE - Identifier* = LONGINT; - - Discipline* = POINTER TO DisciplineRec; - DisciplineRec* = - RECORD - (PersistentObjects.ObjectRec) - id*: Identifier; (* should be unique for all types of disciplines *) - END; - - DisciplineList = POINTER TO DisciplineListRec; - DisciplineListRec = - RECORD - discipline: Discipline; - id: Identifier; (* copied from discipline.id *) - next: DisciplineList; - END; - - Interface = POINTER TO InterfaceRec; - Object = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (PersistentObjects.ObjectRec) - (* private part *) - count: LONGINT; (* number of attached disciplines *) - list: DisciplineList; (* set of disciplines *) - if: Interface; (* overrides builtins if # NIL *) - forwardTo: Object; - usedBy: Object; (* used as target of UseInterfaceOf *) - (* very restrictive way of avoiding reference cycles: - forwardTo references must be built from inner to - outer objects and not vice versa - *) - END; - - TYPE - VolatileDiscipline = POINTER TO VolatileDisciplineRec; - VolatileDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - object: Object; - END; - VAR - volDiscID: Disciplines.Identifier; - - TYPE - AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline); - RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier); - SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - add*: AddProc; - remove*: RemoveProc; - seek*: SeekProc; - END; - - VAR - unique: Identifier; - objIf: PersistentObjects.Interface; - objDatatype, discDatatype: Services.Type; - - CONST - hashtabsize = 32; - TYPE - Sample = POINTER TO SampleRec; - SampleRec = - RECORD - id: Identifier; - sample: Discipline; - next: Sample; - END; - BucketTable = ARRAY hashtabsize OF Sample; - VAR - samples: BucketTable; - - PROCEDURE CreateObject*(VAR object: Object); - (* creates a new object; this procedures should be called instead of - NEW for objects of type `Object' - *) - BEGIN - NEW(object); - object.count := 0; (* up to now, there are no attached disciplines *) - object.list := NIL; - object.if := NIL; - PersistentObjects.Init(object, objDatatype); - END CreateObject; - - PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object); - VAR - disc: VolatileDiscipline; - BEGIN - IF obj IS Object THEN - object := obj(Object); - (* initialize private components now if not done already; - we assume here that pointers which have not been - initialized yet are defined to be NIL - (because of the garbage collection); - a similar assumption does not necessarily hold for - other types (e.g. integers) - *) - IF object.list = NIL THEN - object.count := 0; - END; - ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN - object := disc.object; - ELSE - CreateObject(object); - NEW(disc); disc.id := volDiscID; disc.object := object; - Disciplines.Add(obj, disc); - END; - END GetObject; - - (* === normal stuff for disciplines ===================================== *) - - PROCEDURE Unique*(sample: Discipline) : Identifier; - (* returns a unique identifier; - this procedure should be called during initialization by - all modules defining a discipline type; - a sample of the associated discipline has to be provided - *) - VAR - hashval: Identifier; - entry: Sample; - BEGIN - INC(unique); - NEW(entry); entry.id := unique; entry.sample := sample; - hashval := unique MOD hashtabsize; - entry.next := samples[hashval]; samples[hashval] := entry; - RETURN unique - END Unique; - - PROCEDURE GetSample*(id: Identifier) : Discipline; - (* return sample for the given identifier; - NIL will be returned if id has not yet been returned by Unique - *) - VAR - hashval: Identifier; - ptr: Sample; - BEGIN - hashval := id MOD hashtabsize; - ptr := samples[hashval]; - WHILE (ptr # NIL) & (ptr.id # id) DO - ptr := ptr.next; - END; - IF ptr # NIL THEN - RETURN ptr.sample - ELSE - RETURN NIL - END; - END GetSample; - - PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface); - (* override the builtin implementations of Add, Remove and - Seek for `object' with the implementations given by `if' - *) - VAR - po: Object; - BEGIN - GetObject(object, po); - IF (po.list = NIL) & (po.forwardTo = NIL) THEN - po.if := if; - END; - END AttachInterface; - - PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object); - (* forward Add, Remove and Seek operations from object to host *) - VAR - po, phost: Object; - BEGIN - GetObject(object, po); GetObject(host, phost); - IF (po.list = NIL) & (po.forwardTo = NIL) & - (po.usedBy = NIL) THEN - po.forwardTo := phost; - phost.usedBy := po; (* avoid reference cycles *) - END; - END UseInterfaceOf; - - PROCEDURE Forward(from, to: Forwarders.Object); - BEGIN - UseInterfaceOf(from, to); - END Forward; - - PROCEDURE Remove*(object: Disciplines.Object; id: Identifier); - (* remove the discipline with the given id from object, if it exists *) - VAR - po: Object; - prev, dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - prev := NIL; - dl := po.list; - WHILE (dl # NIL) & (dl.id # id) DO - prev := dl; dl := dl.next; - END; - IF dl # NIL THEN - IF prev = NIL THEN - po.list := dl.next; - ELSE - prev.next := dl.next; - END; - DEC(po.count); (* discipline removed *) - END; - ELSE - po.if.remove(po, id); - END; - END Remove; - - PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline); - (* adds a new discipline to the given object; - if already a discipline with the same identifier exist - it is deleted first - *) - VAR - po: Object; - dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - dl := po.list; - WHILE (dl # NIL) & (dl.id # discipline.id) DO - dl := dl.next; - END; - IF dl = NIL THEN - NEW(dl); - dl.id := discipline.id; - dl.next := po.list; - po.list := dl; - INC(po.count); (* discipline added *) - END; - dl.discipline := discipline; - ELSE - po.if.add(po, discipline); - END; - END Add; - - PROCEDURE Seek*(object: Disciplines.Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - (* returns TRUE if a discipline with the given id is found *) - VAR - po: Object; - dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - dl := po.list; - WHILE (dl # NIL) & (dl.id # id) DO - dl := dl.next; - END; - IF dl # NIL THEN - discipline := dl.discipline; - ELSE - discipline := NIL; - END; - RETURN discipline # NIL - ELSE - RETURN po.if.seek(po, id, discipline) - END; - END Seek; - - (* === interface procedures for PersistentObjects for Object === *) - - PROCEDURE ReadObjectData(stream: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - (* read data and attached disciplines of given object from stream *) - VAR - discipline: Discipline; - count: LONGINT; - BEGIN - (* get number of attached disciplines *) - IF ~NetIO.ReadLongInt(stream, count) THEN - RETURN FALSE; - END; - (* read all disciplines from `stream' and attach them to `object' *) - WHILE count > 0 DO - IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN - RETURN FALSE; - END; - Add(object(Object), discipline); - DEC(count); - END; - RETURN TRUE; - END ReadObjectData; - - PROCEDURE WriteObjectData(stream: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - (* write data and attached disciplines of given object to stream *) - VAR - dl: DisciplineList; - BEGIN - WITH object: Object DO - (* write number of attached disciplines to `stream' *) - IF ~NetIO.WriteLongInt(stream, object.count) THEN - RETURN FALSE; - END; - (* write all attached disciplines to the stream *) - dl := object.list; - WHILE dl # NIL DO - IF ~PersistentObjects.Write(stream, dl.discipline) THEN - RETURN FALSE; - END; - dl := dl.next; - END; - END; - RETURN TRUE; - END WriteObjectData; - - PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object); - VAR - myObject: Object; - BEGIN - CreateObject(myObject); - obj := myObject; - END InternalCreate; - -BEGIN - unique := 0; - - NEW(objIf); - objIf.read := ReadObjectData; - objIf.write := WriteObjectData; - objIf.create := InternalCreate; - objIf.createAndRead := NIL; - PersistentObjects.RegisterType(objDatatype, objectName, "", objIf); - PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL); - - volDiscID := Disciplines.Unique(); - - Forwarders.Register("", Forward); -END ulmPersistentDisciplines. diff --git a/src/lib/ulm/ulmPersistentObjects.Mod b/src/lib/ulm/ulmPersistentObjects.Mod deleted file mode 100644 index 5e23487a..00000000 --- a/src/lib/ulm/ulmPersistentObjects.Mod +++ /dev/null @@ -1,1078 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: PersistentO.om,v 1.8 2004/03/30 13:14:16 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: PersistentO.om,v $ - Revision 1.8 2004/03/30 13:14:16 borchert - introduced more elaborate error events for cannotReadData - - Revision 1.7 1998/04/09 16:55:48 borchert - bug fix: ReadTypeInfo failed on hierarchical mode if none of the - types were known by returning TRUE with type set to NIL - - Revision 1.6 1998/03/24 22:42:28 borchert - improvements: - - it is now acceptable that read and write if procedures are given - but neither create nor createAndRead -- this is fine for - abstractions that maintain some components - - Read operates now immediately on the given object to support - LinearizedStructures -- otherwise it would be nearly impossible - to reconstruct self-referential data structures; - note that this is *not supported* by GuardedRead - - Revision 1.5 1995/04/04 12:36:39 borchert - major redesign of PersistentObjects: - - new type encoding schemes - - size if proc removed - - support for NIL and guards added - - Revision 1.4 1994/07/18 14:19:13 borchert - bug fix: SizeOf used uninitialized variable (name) and added the - length of all type names of the hierarchy to the sum - - Revision 1.3 1994/07/05 08:47:26 borchert - bug fix: modifications due to last bug fix didn't work correctly in - in all cases - code cleaned up at several locations - - Revision 1.2 1994/03/25 15:54:09 borchert - bug fix: the complete type hierarchy together with all abstract types - was written -- this caused a NIL-procedure to be called in - case of projections. Now, we write shorter type hierarchies and - GetCreate checks the create-procedure against NIL - - Revision 1.1 1994/02/22 20:09:21 borchert - Initial revision - - ---------------------------------------------------------------------------- - DB 7/93 - ---------------------------------------------------------------------------- -*) - -MODULE ulmPersistentObjects; - - (* handling of persistent objects *) - - IMPORT ASCII := ulmASCII, ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Errors := ulmErrors, Events := ulmEvents, Forwarders := ulmForwarders, - IndirectDisciplines := ulmIndirectDisciplines, Loader := ulmLoader, NetIO := ulmNetIO, Objects := ulmObjects, Priorities := ulmPriorities, - RelatedEvents := ulmRelatedEvents, Services := ulmServices, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, SYS := SYSTEM; - - CONST - maxNameLen = 128; (* max length of data type names *) - TYPE - TypeName = ARRAY maxNameLen OF CHAR; (* for temporary use only *) - ShortTypeName = ARRAY 32 OF CHAR; (* for error messages only *) - - CONST - cannotReadData* = 0; - cannotWriteData* = 1; - cannotReadType* = 2; - cannotWriteType* = 3; - invalidType* = 4; - unknownType* = 5; - otherTypeHier* = 6; - eofReached* = 7; - cannotSkip* = 8; - typeGuardFailure* = 9; (* GuardedRead failed to type guard failure *) - errorcodes* = 10; (* number of error codes *) - - (* how are types specified: fullTypeName, typeCode, incrTypeCode - with or without size info: withSize, withoutSize - with or without type hier: withHier, withoutHier - - combinations are given as additions, - e.g. typeCode + withSize + withHier - *) - fullTypeName* = 1; typeCode* = 2; incrTypeCode* = 3; - withSize* = 4; withoutSize* = 0; - withHier* = 8; withoutHier* = 0; - - defaultMode = fullTypeName + withSize + withHier; - (* provide all informations on default *) - - (* forms: - type spec: codeF | incrF | nameF | incrhierF | hierF - size spec: sizeF | noSizeF - add specs, eg. codeF + sizeF - *) - codeF = 1; (* just a type code *) - incrF = 2; (* type name + code given *) - nameF = 3; (* type name given *) - incrhierF = 4; (* type hierarchy with codes *) - hierF = 5; (* type hierarchy without codes *) - sizeF = 8; (* size information given *) - noSizeF = 0; (* no size information given *) - maskF = 8; - maxF = 13; (* maximal valid form code *) - - TYPE - Mode* = SHORTINT; - Form = SHORTINT; - - Object* = POINTER TO ObjectRec; - Type = POINTER TO TypeRec; - - ReadProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; - WriteProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; - CreateProc* = PROCEDURE (VAR o: Object); - CreateAndReadProc* = PROCEDURE (s: Streams.Stream; - create: BOOLEAN; - VAR o: Object) : BOOLEAN; - - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; (* create object *) - read*: ReadProc; (* read data from stream *) - write*: WriteProc; (* write data to stream *) - createAndRead*: CreateAndReadProc; (* replaces create & read *) - END; - - ObjectRec* = - RECORD - (Services.ObjectRec) - (* private data *) - type: Type; - projected: BOOLEAN; (* set after Read *) - END; - - CONST - ttlen = 16; - TYPE - TypeEntry = POINTER TO TypeEntryRec; - TypeEntryRec = - RECORD - code: LONGINT; - type: Type; - next: TypeEntry; - END; - TypeTable = ARRAY ttlen OF TypeEntry; - StreamDiscipline = POINTER TO StreamDisciplineRec; - StreamDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - mode: Mode; (* type encoding mode for the stream *) - rtypes, wtypes: TypeTable; - END; - - InterfaceList = POINTER TO InterfaceListRec; - InterfaceListRec = - RECORD - if: Interface; - next: InterfaceList; (* points to next extension *) - END; - TypeRec = - RECORD - (Services.TypeRec) - baseType: Type; (* the next non-abstract base type *) - if: Interface; (* may be = NIL for abstract types *) - ifs: InterfaceList; (* list of interfaces in reverse order *) - code: LONGINT; (* unique number *) - END; - - (* this list is used for storing the base type list of an object during - reading this object - *) - BaseTypeList = POINTER TO BaseTypeRec; - BaseTypeRec = - RECORD - name: ConstStrings.String; (* name of the base type *) - next: BaseTypeList; - END; - - (* each error causes an event; the error number is stored in - event.errorcode; the associated text can be taken from event.message - *) - ErrorCode = SHORTINT; - Event = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - stream*: Streams.Stream; - errorcode*: ErrorCode; - END; - UnknownTypeEvent = POINTER TO UnknownTypeEventRec; - UnknownTypeEventRec = - RECORD - (EventRec) - typeName: ARRAY 80 OF CHAR; - END; - DecodeFailureEvent = POINTER TO DecodeFailureEventRec; - DecodeFailureEventRec = - RECORD - (EventRec) - objectType: Services.Type; - END; - TypeGuardFailureEvent = POINTER TO TypeGuardFailureEventRec; - TypeGuardFailureEventRec = - RECORD - (EventRec) - found, expected: Services.Type; - END; - - VAR - id: Disciplines.Identifier; - nextTypeCode: LONGINT; (* for the generation of unique numbers *) - potype: Services.Type; - - errormsg*: ARRAY errorcodes OF Events.Message; - (* readable text for error codes *) - error*: Events.EventType; - (* raised on failed stream operations; ignored by default *) - - (* ===== for internal use only ========================================== *) - - PROCEDURE Error(stream: Streams.Stream; code: ErrorCode); - (* raise an error event with the error code `code' *) - VAR - event: Event; - BEGIN - stream.count := 0; - NEW(event); - event.type := error; - event.message := errormsg[code]; - event.stream := stream; - event.errorcode := code; - RelatedEvents.Raise(stream, event); - END Error; - - PROCEDURE UnknownType(stream: Streams.Stream; typeName: ARRAY OF CHAR); - VAR - event: UnknownTypeEvent; - BEGIN - stream.count := 0; - NEW(event); - event.type := error; - event.message := errormsg[unknownType]; - event.stream := stream; - event.errorcode := unknownType; - COPY(typeName, event.typeName); - RelatedEvents.Raise(stream, event); - END UnknownType; - - PROCEDURE TypeGuardFailure(stream: Streams.Stream; - found, expected: Services.Type); - VAR - event: TypeGuardFailureEvent; - BEGIN - stream.count := 0; - NEW(event); - event.type := error; - event.message := errormsg[typeGuardFailure]; - event.stream := stream; - event.errorcode := typeGuardFailure; - event.found := found; - event.expected := expected; - RelatedEvents.Raise(stream, event); - END TypeGuardFailure; - - PROCEDURE WriteEvent(s: Streams.Stream; event: Events.Event); - - VAR - typename: ARRAY 128 OF CHAR; - - PROCEDURE WriteString(s: Streams.Stream; - string: ARRAY OF CHAR) : BOOLEAN; - BEGIN - RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) - END WriteString; - - PROCEDURE WriteLn(s: Streams.Stream) : BOOLEAN; - VAR - lineterm: StreamDisciplines.LineTerminator; - width: INTEGER; - BEGIN - StreamDisciplines.GetLineTerm(s, lineterm); - IF ~WriteString(s, lineterm) THEN RETURN FALSE END; - StreamDisciplines.GetIndentationWidth(s, width); - WHILE width > 0 DO - IF ~Streams.WriteByte(s, " ") THEN RETURN FALSE END; - DEC(width); - END; - RETURN TRUE - END WriteLn; - - PROCEDURE WriteType(s: Streams.Stream; - type: Services.Type) : BOOLEAN; - VAR - name: TypeName; - BEGIN - Services.GetTypeName(type, name); - RETURN Streams.WriteByte(s, ASCII.quote) & - WriteString(s, name) & - Streams.WriteByte(s, ASCII.quote) - END WriteType; - - BEGIN - IF event IS UnknownTypeEvent THEN - WITH event: UnknownTypeEvent DO - IF WriteString(s, event.message) & - WriteString(s, ": ") & - Streams.WriteByte(s, ASCII.quote) & - WriteString(s, event.typeName) & - Streams.WriteByte(s, ASCII.quote) THEN - END; - END; - ELSIF event IS TypeGuardFailureEvent THEN - WITH event: TypeGuardFailureEvent DO - IF WriteString(s, event.message) & - WriteString(s, ":") & - WriteLn(s) & - WriteString(s, "expected extension of ") & - WriteType(s, event.expected) & - WriteString(s, " but got ") & - WriteType(s, event.found) THEN - END; - END; - ELSIF event IS DecodeFailureEvent THEN - WITH event: DecodeFailureEvent DO - Services.GetTypeName(event.objectType, typename); - IF WriteString(s, event.message) & - WriteString(s, ":") & - WriteLn(s) & - WriteString(s, "unable to parse object of type ") & - Streams.WriteByte(s, ASCII.quote) & - WriteString(s, typename) & - Streams.WriteByte(s, ASCII.quote) THEN - END; - END; - ELSE - IF WriteString(s, event.message) THEN END; - END; - END WriteEvent; - - PROCEDURE InitErrorHandling; - BEGIN - errormsg[cannotReadData] := "cannot read data part of persistent object"; - errormsg[cannotWriteData] := "cannot write data part of persistent object"; - errormsg[cannotReadType] := "cannot read type of persistent object"; - errormsg[cannotWriteType] := "cannot write type of persistent object"; - errormsg[invalidType] := "invalid type form read"; - errormsg[unknownType] := "unknown type information found"; - errormsg[otherTypeHier] := "different & nonconforming type hierarchy found"; - errormsg[eofReached] := "unexpected EOF encountered during reading"; - errormsg[cannotSkip] := "unable to skip unknown data parts"; - errormsg[typeGuardFailure] := "read object is of unexpected type"; - - Events.Define(error); - Events.SetPriority(error, Priorities.liberrors); - Events.Ignore(error); - Errors.AssignWriteProcedure(error, WriteEvent); - END InitErrorHandling; - - (* ==== marshalling procedures ======================================== *) - - (* encoding scheme: - - Object = Form Type Size ObjectInfo . - Form = SHORTINT; - Type = Code (* codeF *) | - Code TypeName (* incrF *) | - TypeName (* nameF *) | - Code TypeName { Code TypeName } 0 (* incrhierF *) | - TypeName { TypeName } 0X (* hierF *) . - Size = (* noSizeF *) | - Size (* sizeF *) . (* size of object info in bytes *) - ObjectInfo = { Byte } . - *) - - PROCEDURE DecodeForm(form: Form; - VAR nameGiven, codeGiven, hier, size: BOOLEAN); - VAR - typeform: SHORTINT; - sizeform: SHORTINT; - BEGIN - typeform := form MOD maskF; sizeform := form DIV maskF; - nameGiven := typeform IN {incrF, nameF, hierF, incrhierF}; - codeGiven := typeform IN {codeF, incrF, incrhierF}; - hier := (typeform = incrhierF) OR (typeform = hierF); - size := (sizeform = sizeF); - END DecodeForm; - - PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); - (* get the name of the module where 'name' was defined *) - VAR - index: INTEGER; - BEGIN - index := 0; - WHILE (name[index] # ".") & (name[index] # 0X) & - (index < LEN(module)-1) DO - module[index] := name[index]; INC(index); - END; - module[index] := 0X; - END GetModule; - - PROCEDURE Failure(s: Streams.Stream; code: ErrorCode); - BEGIN - IF s.eof THEN - Error(s, eofReached); - ELSE - Error(s, code); - END; - END Failure; - - PROCEDURE DecodeFailure(s: Streams.Stream; type: Services.Type); - VAR - event: DecodeFailureEvent; - BEGIN - IF s.eof THEN - Error(s, eofReached); - ELSE - NEW(event); - event.type := error; - event.message := errormsg[cannotReadData]; - event.stream := s; - event.errorcode := cannotReadData; - event.objectType := type; - RelatedEvents.Raise(s, event); - END; - END DecodeFailure; - - PROCEDURE GetStreamDisc(s: Streams.Stream; VAR disc: StreamDiscipline); - BEGIN - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - NEW(disc); disc.id := id; disc.mode := defaultMode; - IndirectDisciplines.Add(s, disc); - END; - END GetStreamDisc; - - PROCEDURE ReadTypeInfo(s: Streams.Stream; VAR type: Type; - VAR projection: BOOLEAN; - VAR size: Streams.Count) : BOOLEAN; - VAR - form: Form; - btype: Type; - nameGiven, codeGiven, hier, sizeGiven: BOOLEAN; - disc: StreamDiscipline; - sentinelFound, unknownTypeFound: BOOLEAN; - lastType: Type; - - PROCEDURE ReadType(s: Streams.Stream; VAR type: Type; - VAR sentinelFound, unknownTypeFound: BOOLEAN) : BOOLEAN; - VAR - code: LONGINT; - entry: TypeEntry; - typeName: TypeName; - btype: Type; - - PROCEDURE SeekType(typeName: ARRAY OF CHAR; - VAR type: Type) : BOOLEAN; - VAR - t: Services.Type; - module: TypeName; - BEGIN - Services.SeekType(typeName, t); - IF t = NIL THEN - GetModule(typeName, module); - IF Loader.Load(module, s) THEN - (* maybe the type is now registered *) - Services.SeekType(typeName, t); - END; - END; - IF (t # NIL) & (t IS Type) THEN - type := t(Type); RETURN TRUE - END; - RETURN FALSE - END SeekType; - - BEGIN (* ReadType *) - sentinelFound := FALSE; unknownTypeFound := FALSE; - type := NIL; - IF codeGiven THEN - IF ~NetIO.ReadLongInt(s, code) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF code = 0 THEN sentinelFound := TRUE; RETURN FALSE END; - entry := disc.rtypes[code MOD ttlen]; - WHILE (entry # NIL) & (entry.code # code) DO - entry := entry.next; - END; - IF entry # NIL THEN - type := entry.type; - END; - IF (entry = NIL) & ~nameGiven THEN - Failure(s, unknownType); unknownTypeFound := TRUE; RETURN FALSE - END; - END; - IF nameGiven THEN - IF ~NetIO.ReadString(s, typeName) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF typeName[0] = 0X THEN sentinelFound := TRUE; RETURN FALSE END; - IF (type = NIL) & ~SeekType(typeName, type) THEN - UnknownType(s, typeName); unknownTypeFound := TRUE; RETURN FALSE - END; - END; - IF codeGiven & (entry = NIL) THEN - NEW(entry); - entry.code := code; - entry.type := type; - entry.next := disc.rtypes[code MOD ttlen]; - disc.rtypes[code MOD ttlen] := entry; - END; - RETURN TRUE - END ReadType; - - BEGIN (* ReadTypeInfo *) - (* read & check form of type info *) - IF ~NetIO.ReadShortInt(s, form) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF (form <= 0) OR (form > maxF) THEN - Failure(s, invalidType); RETURN FALSE - END; - DecodeForm(form, nameGiven, codeGiven, hier, sizeGiven); - IF codeGiven THEN - GetStreamDisc(s, disc); - END; - - (* read first type information *) - IF ~ReadType(s, type, sentinelFound, unknownTypeFound) & ~hier THEN - RETURN FALSE - END; - - (* read type hierarchy, if any *) - projection := FALSE; - IF hier THEN - IF sentinelFound THEN - Failure(s, invalidType); RETURN FALSE - END; - lastType := type; - LOOP (* until type hierarchy is read *) - IF ReadType(s, btype, sentinelFound, unknownTypeFound) THEN - IF (lastType # NIL) & (lastType.baseType # btype) THEN - Failure(s, otherTypeHier); RETURN FALSE - END; - IF type = NIL THEN - projection := TRUE; - type := btype; - END; - lastType := btype; - ELSIF sentinelFound THEN - EXIT - ELSIF unknownTypeFound THEN - IF lastType # NIL THEN - Failure(s, otherTypeHier); RETURN FALSE - END; - ELSE - RETURN FALSE - END; - END; - IF type = NIL THEN - (* error events already generated by ReadType *) - RETURN FALSE - END; - END; - - (* read size information, if any *) - IF sizeGiven THEN - IF ~NetIO.ReadLongInt(s, size) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF size < 0 THEN - Failure(s, invalidType); RETURN FALSE - END; - ELSE - size := -1; - END; - RETURN TRUE - END ReadTypeInfo; - - PROCEDURE ReadData(s: Streams.Stream; VAR object: Object) : BOOLEAN; - (* use the interface list to read all data in the right order *) - VAR - ifList: InterfaceList; - BEGIN - ifList := object.type.ifs; - WHILE ifList # NIL DO - IF ~ifList.if.read(s, object) THEN - (* error handling is done by the calling procedure *) - RETURN FALSE - END; - ifList := ifList.next; - END; - RETURN (object.type.if.read = NIL) OR object.type.if.read(s, object) - END ReadData; - - PROCEDURE EncodeForm(s: Streams.Stream; type: Type; VAR form: Form); - VAR - mode: Mode; - disc: StreamDiscipline; - hier: BOOLEAN; - - PROCEDURE KnownType() : BOOLEAN; - VAR - p: TypeEntry; - BEGIN - p := disc.wtypes[type.code MOD ttlen]; - WHILE (p # NIL) & (p.type # type) DO - p := p.next; - END; - RETURN p # NIL - END KnownType; - - BEGIN - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - mode := defaultMode; disc := NIL; - ELSE - mode := disc.mode; - END; - form := 0; - hier := mode DIV 8 MOD 2 > 0; - CASE mode MOD 4 OF - | fullTypeName: IF hier THEN form := hierF ELSE form := nameF END; - | typeCode: form := codeF; ASSERT(~hier); - | incrTypeCode: IF KnownType() THEN - form := codeF; - ELSIF hier THEN - form := incrhierF; - ELSE - form := incrF; - END; - END; - IF mode DIV 4 MOD 2 > 0 THEN - INC(form, sizeF); - ELSE - INC(form, noSizeF); - END; - END EncodeForm; - - PROCEDURE WriteTypeInfo(s: Streams.Stream; type: Type; - VAR giveSize: BOOLEAN) : BOOLEAN; - (* write type information without size *) - VAR - form: Form; - giveName, giveCode, hier: BOOLEAN; - mode: Mode; incr: BOOLEAN; - disc: StreamDiscipline; - btype: Type; - - PROCEDURE WriteType(s: Streams.Stream; type: Type) : BOOLEAN; - VAR - typeName: TypeName; - entry: TypeEntry; - BEGIN - IF giveCode THEN - IF ~NetIO.WriteLongInt(s, type.code) THEN - Error(s, cannotWriteType); RETURN FALSE - END; - END; - IF giveName THEN - Services.GetTypeName(type, typeName); - IF ~NetIO.WriteString(s, typeName) THEN - Error(s, cannotWriteType); RETURN FALSE - END; - END; - IF incr THEN - NEW(entry); entry.type := type; entry.code := type.code; - entry.next := disc.wtypes[type.code MOD ttlen]; - disc.wtypes[type.code MOD ttlen] := entry; - END; - RETURN TRUE - END WriteType; - - BEGIN (* WriteTypeInfo *) - EncodeForm(s, type, form); - IF ~NetIO.WriteShortInt(s, form) THEN - Error(s, cannotWriteType); - END; - DecodeForm(form, giveName, giveCode, hier, giveSize); - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - mode := defaultMode; - END; - incr := giveName & giveCode; - - IF ~WriteType(s, type) THEN RETURN FALSE END; - - IF hier THEN - btype := type.baseType; - WHILE btype # NIL DO - IF ~WriteType(s, btype) THEN RETURN FALSE END; - btype := btype.baseType; - END; - (* write sentinel *) - IF giveCode THEN - IF ~NetIO.WriteLongInt(s, 0) THEN - Error(s, cannotWriteType); - RETURN FALSE - END; - ELSE - IF ~NetIO.WriteString(s, "") THEN - Error(s, cannotWriteType); - RETURN FALSE - END; - END; - END; - - RETURN TRUE - END WriteTypeInfo; - - PROCEDURE WriteData(s: Streams.Stream; object: Object) : BOOLEAN; - (* use the interface list to write all data in the right order *) - VAR - ifList: InterfaceList; - BEGIN - ifList := object.type.ifs; - WHILE ifList # NIL DO - IF ~ifList.if.write(s, object) THEN - (* error handling is done by the calling procedure *) - RETURN FALSE - END; - ifList := ifList.next; - END; - RETURN (object.type.if.write = NIL) OR object.type.if.write(s, object) - END WriteData; - - (* ===== exported procedures ============================================ *) - - PROCEDURE RegisterType*(VAR type: Services.Type; - name, baseName: ARRAY OF CHAR; - if: Interface); - VAR - newtype: Type; - baseType: Services.Type; - member: InterfaceList; - bt: Type; - ifval: INTEGER; - BEGIN - (* check the parameters *) - ASSERT(name[0] # 0X); - IF if # NIL THEN - ifval := 0; - IF if.create # NIL THEN INC(ifval, 1) END; - IF if.read # NIL THEN INC(ifval, 2) END; - IF if.write # NIL THEN INC(ifval, 4) END; - IF if.createAndRead # NIL THEN INC(ifval, 8) END; - (* legal variants: - - if = NIL abstract data type - - create read write createAndRead - #NIL NIL NIL NIL 1 empty data type - NIL #NIL #NIL NIL 6 abstract data type - #NIL #NIL #NIL NIL 7 normal case - NIL NIL #NIL #NIL 12 special case - - note that the special case must not be given as base type! - *) - ASSERT(ifval IN {1, 6, 7, 12}); - END; - - (* create type and determine next non-abstract base type *) - NEW(newtype); - newtype.code := nextTypeCode; INC(nextTypeCode); - newtype.if := if; - IF baseName = "" THEN - Services.InitType(newtype, name, "PersistentObjects.Object"); - ELSE - Services.InitType(newtype, name, baseName); - END; - IF baseName = "" THEN - newtype.baseType := NIL; - ELSE - Services.GetBaseType(newtype, baseType); - ASSERT((baseType # NIL) & (baseType IS Type)); - WHILE (baseType # NIL) & (baseType IS Type) & - (baseType(Type).if = NIL) DO - Services.GetBaseType(baseType, baseType); - END; - IF (baseType = NIL) OR ~(baseType IS Type) THEN - newtype.baseType := NIL; - ELSE - newtype.baseType := baseType(Type); - ASSERT(newtype.baseType.if.createAndRead = NIL); - END; - END; - - (* build up list of interfaces *) - newtype.ifs := NIL; bt := newtype.baseType; - WHILE bt # NIL DO - NEW(member); member.if := bt.if; - member.next := newtype.ifs; newtype.ifs := member; - bt := bt.baseType; - END; - - type := newtype; - END RegisterType; - - PROCEDURE Init*(object: Object; type: Services.Type); - BEGIN - ASSERT(type IS Type); - WITH type: Type DO - ASSERT((type.if.create # NIL) OR (type.if.createAndRead # NIL)); - object.type := type; - object.projected := FALSE; - Services.Init(object, type); - END; - END Init; - - PROCEDURE SetMode*(s: Streams.Stream; mode: Mode); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN - NEW(disc); disc.id := id; - END; - disc.mode := mode; - Disciplines.Add(s, disc); - END SetMode; - - PROCEDURE GetMode*(s: Streams.Stream; VAR mode: Mode); - (* return the current mode for the given stream *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN - mode := disc.mode; - ELSE - mode := defaultMode; - END; - END GetMode; - - PROCEDURE IsProjected*(object: Object) : BOOLEAN; - (* show whether the object was a victim of projection or not *) - BEGIN - RETURN object.projected - END IsProjected; - - PROCEDURE InternalRead(s: Streams.Stream; create: BOOLEAN; - VAR object: Object) : BOOLEAN; - (* read `object' from `s'; - note that we have to operate on `object' directly because - LinearizedStructures relies on this in case of cyclic - references - *) - VAR - streamCaps: Streams.CapabilitySet; - type, objectType: Type; - projection: BOOLEAN; (* necessary due to unknown types? *) - size: Streams.Count; (* size information, if unknown it equals -1 *) - skipUnknownParts: BOOLEAN; (* are we able to skip data if necessary? *) - - (* these vars are used for skipping unknown data areas *) - oldPos, newPos: Streams.Count; - textbuf: Texts.Text; - - BEGIN (* InternalRead *) - IF ~ReadTypeInfo(s, type, projection, size) THEN RETURN FALSE END; - IF ~create & (type.if.createAndRead = NIL) THEN - (* projection necessary due to target object? *) - Services.GetType(object, SYS.VAL(Services.Type, objectType)); - IF ~Services.IsExtensionOf(type, objectType) THEN - TypeGuardFailure(s, type, objectType); RETURN FALSE - END; - projection := projection OR (type # objectType); - END; - skipUnknownParts := projection & (size > 0); - streamCaps := Streams.Capabilities(s); - IF skipUnknownParts THEN - IF Streams.tell IN streamCaps THEN - Streams.GetPos(s, oldPos); - ELSE - Texts.Open(SYS.VAL(Streams.Stream, textbuf)); - IF ~Streams.Copy(s, textbuf, size) THEN - Failure(s, cannotReadData); RETURN FALSE - END; - Forwarders.Forward(textbuf, s); - RelatedEvents.Forward(textbuf, s); - s := textbuf; - skipUnknownParts := FALSE; - END; - END; - - IF type.if.createAndRead # NIL THEN - IF ~type.if.createAndRead(s, create, object) THEN - DecodeFailure(s, type); object := NIL; RETURN FALSE - END; - ELSE - IF create THEN - type.if.create(object); - END; - IF ~ReadData(s, object) THEN - DecodeFailure(s, type); - object := NIL; - RETURN FALSE - END; - END; - - (* store information about projection into object *) - object.projected := projection; - - IF skipUnknownParts THEN - IF Streams.seek IN streamCaps THEN - Streams.SetPos(s, oldPos + size); - ELSE - Streams.GetPos(s, newPos); - IF ~Streams.Copy(s, Streams.null, size - newPos + oldPos) THEN - Failure(s, cannotSkip); RETURN FALSE - END; - END; - ELSIF projection & (size < 0) THEN - Error(s, cannotSkip); RETURN FALSE - END; - - s.count := 1; (* show success *) - RETURN TRUE - END InternalRead; - - PROCEDURE Read*(s: Streams.Stream; VAR object: Object) : BOOLEAN; - (* read `object' from `s'; object # NIL on success *) - BEGIN - RETURN InternalRead(s, (* create = *) TRUE, object) - END Read; - - PROCEDURE ReadInto*(s: Streams.Stream; object: Object) : BOOLEAN; - (* read an object from `s' and assign it to `object'; - this fails if `object' doesn't has the IDENTICAL type - (thus projections are not supported here) - *) - BEGIN - RETURN InternalRead(s, (* create = *) FALSE, object) - END ReadInto; - - PROCEDURE GuardedRead*(s: Streams.Stream; guard: Services.Type; - VAR object: Object) : BOOLEAN; - (* read an object from `s' and return it, provided - the type of the read object is an extension of `guard' - *) - VAR - testObject: Object; - type: Services.Type; - BEGIN - IF ~Read(s, testObject) THEN RETURN FALSE END; - Services.GetType(testObject, type); - IF Services.IsExtensionOf(type, guard) THEN - object := testObject; RETURN TRUE - ELSE - TypeGuardFailure(s, type, guard); - RETURN FALSE - END; - END GuardedRead; - - PROCEDURE Write*(s: Streams.Stream; object: Object) : BOOLEAN; - (* write `obj' to `s' *) - VAR - giveSize: BOOLEAN; - streamCaps: Streams.CapabilitySet; - patchSize: BOOLEAN; - sizePos, beginPos, endPos: Streams.Count; - textbuf, origStream: Streams.Stream; - mode: Mode; - BEGIN - IF ~WriteTypeInfo(s, object.type, giveSize) THEN RETURN FALSE END; - IF giveSize THEN - streamCaps := Streams.Capabilities(s); - patchSize := ({Streams.tell, Streams.seek} - streamCaps = {}) & - Streams.Tell(s, sizePos); - IF patchSize THEN - IF ~NetIO.WriteLongInt(s, 0) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - Streams.GetPos(s, beginPos); - ELSE - Texts.Open(textbuf); - Forwarders.Forward(textbuf, s); - RelatedEvents.Forward(textbuf, s); - GetMode(s, mode); SetMode(textbuf, mode); - origStream := s; s := textbuf; - END; - END; - - IF object.type.if.createAndRead # NIL THEN - IF ~object.type.if.write(s, object) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - ELSE - IF ~WriteData(s, object) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - END; - - IF giveSize THEN - IF patchSize THEN - Streams.GetPos(s, endPos); - Streams.SetPos(s, sizePos); - IF ~NetIO.WriteLongInt(s, endPos - beginPos) THEN - Streams.SetPos(s, endPos); - Error(s, cannotWriteData); - RETURN FALSE - END; - Streams.SetPos(s, endPos); - ELSE - Streams.GetPos(textbuf, endPos); - Streams.SetPos(textbuf, 0); - s := origStream; - IF ~NetIO.WriteLongInt(s, endPos) OR - ~Streams.Copy(textbuf, s, endPos) THEN - Error(s, cannotWriteData); - END; - END; - END; - s.count := 1; - RETURN TRUE - END Write; - - PROCEDURE ReadObjectOrNIL*(s: Streams.Stream; VAR object: Object) : BOOLEAN; - VAR - nil: BOOLEAN; - BEGIN - object := NIL; - RETURN NetIO.ReadBoolean(s, nil) & (nil OR Read(s, object)) - END ReadObjectOrNIL; - - PROCEDURE GuardedReadObjectOrNIL*(s: Streams.Stream; guard: Services.Type; - VAR object: Object) : BOOLEAN; - (* may be used instead of ReadObjectOrNIL *) - VAR - testObject: Object; - type: Services.Type; - nil: BOOLEAN; - BEGIN - IF ~NetIO.ReadBoolean(s, nil) THEN RETURN FALSE END; - IF nil THEN - object := NIL; - RETURN TRUE - END; - IF ~Read(s, testObject) THEN RETURN FALSE END; - IF testObject = NIL THEN RETURN TRUE END; - Services.GetType(testObject, type); - IF Services.IsExtensionOf(type, guard) THEN - object := testObject; RETURN TRUE - ELSE - TypeGuardFailure(s, type, guard); - RETURN FALSE - END; - END GuardedReadObjectOrNIL; - - PROCEDURE WriteObjectOrNIL*(s: Streams.Stream; object: Object) : BOOLEAN; - VAR - nil: BOOLEAN; - BEGIN - nil := object = NIL; - RETURN NetIO.WriteBoolean(s, nil) & (nil OR Write(s, object)) - END WriteObjectOrNIL; - -BEGIN - id := Disciplines.Unique(); - nextTypeCode := 1; - InitErrorHandling; - Services.CreateType(potype, "PersistentObjects.Object", ""); -END ulmPersistentObjects. diff --git a/src/lib/ulm/ulmRandomGenerators.Mod b/src/lib/ulm/ulmRandomGenerators.Mod deleted file mode 100644 index cb63a9a5..00000000 --- a/src/lib/ulm/ulmRandomGenerators.Mod +++ /dev/null @@ -1,419 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: RandomGener.om,v $ - Revision 1.9 2004/03/09 21:44:12 borchert - unpredictable added to the standard set of PRNGs - - Revision 1.8 2004/03/06 07:22:09 borchert - Init asserts that the sequence has been registered at Services - - Revision 1.7 1998/02/14 22:04:09 martin - Missing calls of Services.Init and Services.CreateType added. - - Revision 1.6 1997/10/11 21:22:03 martin - assertion in ValS added, obsolete variable removed - - Revision 1.5 1997/10/10 16:26:49 martin - RestartSequence added, range conversions improved, - default implementation replaced. - - Revision 1.4 1997/04/01 16:33:41 borchert - major revision of Random: - - module renamed to RandomGenerators - - abstraction instead of simple implementation (work by Frank Fischer) - - Revision 1.3 1994/09/01 18:15:41 borchert - bug fix: avoid arithmetic overflow in ValS - - Revision 1.2 1994/08/30 09:48:00 borchert - sequences added - - Revision 1.1 1994/02/23 07:25:30 borchert - Initial revision - - ---------------------------------------------------------------------------- - original implementation by AFB 2/90 - conversion to abstraction by Frank B.J. Fischer 3/97 - ---------------------------------------------------------------------------- -*) - -MODULE ulmRandomGenerators; - - (* Anyone who considers arithmetical - methods of producing random digits - is, of course, in a state of sin. - - John von Neumann (1951) - *) - - IMPORT - Clocks := ulmClocks, Disciplines := ulmDisciplines, Objects := ulmObjects, Operations := ulmOperations, Process := ulmProcess, Services := ulmServices, Times := ulmTimes, - Types := ulmTypes, S := SYSTEM; - - TYPE - Sequence* = POINTER TO SequenceRec; - - Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32; - LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL; - RewindSequenceProc* = PROCEDURE (sequence: Sequence); - RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence); - SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand); - - CONST - int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3; - - TYPE - CapabilitySet* = SET; (* of [int32ValS..restartSequence] *) - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - int32ValS* : Int32ValSProc; (* at least one of ... *) - longRealValS* : LongRealValSProc; (* ... these required *) - rewindSequence* : RewindSequenceProc; (* optional *) - restartSequence*: RestartSequenceProc; (* optional *) - END; - - SequenceRec* = - RECORD - (Services.ObjectRec) - (* private components *) - if : Interface; - caps: CapabilitySet; - END; - - VAR - std* : Sequence; (* default sequence *) - seed*: Sequence; (* sequence of seed values *) - unpredictable*: Sequence; - (* reasonably fast sequence of unpredictable values; - is initially NIL - *) - - (* ----- private definitions ----- *) - - CONST - modulus1 = 2147483647; (* a Mersenne prime *) - factor1 = 48271; (* passes spectral test *) - quotient1 = modulus1 DIV factor1; (* 44488 *) - remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *) - modulus2 = 2147483399; (* a non-Mersenne prime *) - factor2 = 40692; (* also passes spectral test *) - quotient2 = modulus2 DIV factor2; (* 52774 *) - remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *) - - TYPE - DefaultSequence = POINTER TO DefaultSequenceRec; - DefaultSequenceRec = - RECORD - (SequenceRec) - seed1, seed2: LONGINT; - value1, value2: LONGINT; - END; - - ServiceDiscipline = POINTER TO ServiceDisciplineRec; - ServiceDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - setValS: SetValSProc; - END; - - VAR - service : Services.Service; - serviceDiscID: Disciplines.Identifier; - sequenceType, - defaultSequenceType: Services.Type; - - (* ----- bug workaround ----- *) - - PROCEDURE Entier(value: LONGREAL): LONGINT; - VAR - result: LONGINT; - BEGIN - result := ENTIER(value); - IF result > value THEN - DEC(result); - END; - RETURN result - END Entier; - - (* ----- exported procedures ----- *) - - PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet); - (* initialize sequence *) - VAR - type: Services.Type; - BEGIN - ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL)); - ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL)); - ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL)); - ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL)); - Services.GetType(sequence, type); ASSERT(type # NIL); - sequence.if := if; - sequence.caps := caps; - END Init; - - PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet; - (* tell which procedures are implemented *) - BEGIN - RETURN sequence.caps - END Capabilities; - - PROCEDURE RewindSequence*(sequence: Sequence); - (* re-examine sequence *) - BEGIN - ASSERT(rewindSequence IN sequence.caps); - sequence.if.rewindSequence(sequence); - END RewindSequence; - - PROCEDURE RestartSequence*(sequence, seed: Sequence); - (* restart sequence with new seed values *) - BEGIN - ASSERT(restartSequence IN sequence.caps); - sequence.if.restartSequence(sequence, seed); - END RestartSequence; - - PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL; - - PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32; - (* get random 32-bit value from sequence *) - VAR - real: LONGREAL; - BEGIN - IF int32ValS IN sequence.caps THEN - RETURN sequence.if.int32ValS(sequence) - ELSE - real := LongRealValS(sequence); - RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) )) - END; - END Int32ValS; - - PROCEDURE Int32Val*(): Types.Int32; - (* get random 32-bit value from std sequence *) - BEGIN - RETURN Int32ValS(std); - END Int32Val; - - PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL; - (* get a uniformly distributed longreal value in [0..1) *) - BEGIN - IF longRealValS IN sequence.caps THEN - RETURN sequence.if.longRealValS(sequence) - ELSE - RETURN 0.5 + - Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32)) - END; - END LongRealValS; - - PROCEDURE LongRealVal*(): LONGREAL; - (* get a uniformly distributed longreal value in [0..1) *) - BEGIN - RETURN LongRealValS(std) - END LongRealVal; - - PROCEDURE RealValS*(sequence: Sequence): REAL; - (* get a uniformly distributed real value in [0..1) *) - BEGIN - RETURN SHORT(LongRealValS(sequence)) - END RealValS; - - PROCEDURE RealVal*(): REAL; - (* get a uniformly distributed real value in [0..1) *) - BEGIN - RETURN SHORT(LongRealValS(std)) - END RealVal; - - PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT; - (* get a uniformly distributed integer in [low..high] *) - BEGIN - ASSERT(low <= high); - RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) ) - END ValS; - - PROCEDURE Val*(low, high: LONGINT): LONGINT; - (* get a uniformly distributed integer in [low..high] *) - BEGIN - RETURN ValS(std, low, high) - END Val; - - PROCEDURE FlipS*(sequence: Sequence): BOOLEAN; - (* return TRUE or FALSE *) - BEGIN - IF int32ValS IN sequence.caps THEN - RETURN sequence.if.int32ValS(sequence) >= 0 - ELSE - RETURN sequence.if.longRealValS(sequence) >= 0.5 - END; - END FlipS; - - PROCEDURE Flip*(): BOOLEAN; - (* return TRUE or FALSE *) - BEGIN - RETURN FlipS(std) - END Flip; - - PROCEDURE Support*(type: Services.Type; setValS: SetValSProc); - (* support service for type *) - VAR - serviceDisc: ServiceDiscipline; - BEGIN - NEW(serviceDisc); - serviceDisc.id := serviceDiscID; - serviceDisc.setValS := setValS; - Disciplines.Add(type, serviceDisc); - Services.Define(type, service, NIL); - END Support; - - PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand); - (* store random value from sequence into already initialized value *) - VAR - baseType : Services.Type; - serviceDisc: ServiceDiscipline; - ok : BOOLEAN; - BEGIN - Services.GetSupportedBaseType(value, service, baseType); - ok := Disciplines.Seek(baseType, serviceDiscID, S.VAL(Disciplines.Discipline, serviceDisc)); - ASSERT(ok); - serviceDisc.setValS(sequence, value); - END SetValS; - - PROCEDURE SetVal*(value: Operations.Operand); - (* store random value from std sequence into already initialized value *) - BEGIN - SetValS(std, value); - END SetVal; - - (* ----- DefaultSequence ----- *) - - PROCEDURE CongruentialStep(VAR value1, value2: LONGINT); - BEGIN - value1 := - factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1); - IF value1 < 0 THEN - INC(value1, modulus1); - END; - value2 := - factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2); - IF value2 < 0 THEN - INC(value2, modulus2); - END; - END CongruentialStep; - - PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL; - VAR - value: LONGINT; - BEGIN - WITH sequence: DefaultSequence DO - CongruentialStep(sequence.value1, sequence.value2); - value := sequence.value1 - sequence.value2; - IF value <= 0 THEN - INC(value, modulus1); - END; - RETURN (value - 1.) / (modulus1 - 1.) - END; - END DefaultSequenceValue; - - PROCEDURE DefaultSequenceRewind(sequence: Sequence); - BEGIN - WITH sequence: DefaultSequence DO - sequence.value1 := sequence.seed1; - sequence.value2 := sequence.seed2; - END; - END DefaultSequenceRewind; - - PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence); - BEGIN - WITH sequence: DefaultSequence DO - sequence.seed1 := ValS(seed, 1, modulus1-1); - sequence.seed2 := ValS(seed, 1, modulus2-1); - sequence.value1 := sequence.seed1; - sequence.value2 := sequence.seed2; - END; - END DefaultSequenceRestart; - - PROCEDURE CreateDefaultSequences; - VAR - mySeed, myStd: DefaultSequence; - if: Interface; - daytime: Times.Time; - timeval: Times.TimeValueRec; - count: LONGINT; - - PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT; - VAR - index, - val: LONGINT; - BEGIN - val := 27567352; - index := 0; - WHILE str[index] # 0X DO - val := (val MOD 16777216) * 128 + - (val DIV 16777216 + ORD(str[index])) MOD 128; - INC(index); - END; (*WHILE*) - RETURN val - END Hash; - - BEGIN - (* define interface for all default sequences *) - NEW(if); - if.longRealValS := DefaultSequenceValue; - if.rewindSequence := DefaultSequenceRewind; - if.restartSequence := DefaultSequenceRestart; - - (* fake initial randomness using some portably accessible sources *) - NEW(mySeed); - Services.Init(mySeed, defaultSequenceType); - Init(mySeed, if, {longRealValS}); - Clocks.GetTime(Clocks.system, daytime); - Times.GetValue(daytime, timeval); - (* extract those 31 bits from daytime that are most likely to vary *) - mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1; - (* generate 31 more bits from the process name *) - mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1; - (* scramble these values *) - count := 0; - WHILE count < 4 DO - CongruentialStep(mySeed.value1, mySeed.value2); - INC(count); - END; - (* mix them together *) - DefaultSequenceRestart(mySeed, mySeed); - seed := mySeed; - - (* now use our seed to initialize std sequence *) - NEW(myStd); - Services.Init(myStd, defaultSequenceType); - Init(myStd, if, {longRealValS, rewindSequence, restartSequence}); - DefaultSequenceRestart(myStd, mySeed); - std := myStd; - - unpredictable := NIL; - END CreateDefaultSequences; - -BEGIN - serviceDiscID := Disciplines.Unique(); - Services.Create(service, "RandomGenerators"); - Services.CreateType(sequenceType, "RandomGenerators.Sequence", ""); - Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence", - "RandomGenerators.Sequence"); - CreateDefaultSequences; -END ulmRandomGenerators. diff --git a/src/lib/ulm/ulmRelatedEvents.Mod b/src/lib/ulm/ulmRelatedEvents.Mod deleted file mode 100644 index 6f9a0c32..00000000 --- a/src/lib/ulm/ulmRelatedEvents.Mod +++ /dev/null @@ -1,422 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: RelatedEven.om,v $ - Revision 1.8 2005/04/28 08:30:09 borchert - added assertion to Forward that takes care that from # to - (otherwise we get a nasty infinite loop) - - Revision 1.7 2004/09/09 21:04:24 borchert - undoing change of Revision 1.5: - fields dependants and dependson must not be subject of - Save/Restore as this makes it impossible to undo the - dependencies within the TerminationHandler - we no longer remove the discipline in case of terminated - objects as this causes a list of error events to be lost - - Revision 1.6 2004/02/18 17:01:59 borchert - Raise asserts now that event.type # NIL - - Revision 1.5 2004/02/18 16:53:48 borchert - fields dependants and dependson moved from discipline to state - object to support them for Save/Restore - - Revision 1.4 1998/01/12 14:39:18 borchert - some bug fixes around RelatedEvents.null - - Revision 1.3 1995/03/20 17:05:13 borchert - - Save & Restore added - - support for Forwarders & Resources added - - Revision 1.2 1994/08/27 14:49:44 borchert - null object added - - Revision 1.1 1994/02/22 20:09:53 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 11/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmRelatedEvents; - - (* relate events to objects *) - - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM; - - CONST - (* possible directions of propagated events *) - forward = 0; (* forward along the forwardTo chain, if given *) - backward = 1; (* forward event to all dependants, if present *) - both = 2; (* forward event to both directions *) - TYPE - Direction = SHORTINT; (* forward, backward, both *) - - TYPE - Object* = Disciplines.Object; - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - object*: Object; - event*: Events.Event; - END; - Queue* = POINTER TO QueueRec; - QueueRec* = - RECORD - (Objects.ObjectRec) - event*: Events.Event; - next*: Queue; - END; - ObjectList = POINTER TO ObjectListRec; - ObjectListRec = - RECORD - object: Object; - next: ObjectList; - END; - - TYPE - State = POINTER TO StateRec; - StateRec = - RECORD - default: BOOLEAN; (* default reaction? *) - eventType: Events.EventType; (* may be NIL *) - queue: BOOLEAN; (* are events to be queued? *) - forwardto: Object; - head, tail: Queue; - saved: State; - END; - Discipline = POINTER TO DisciplineRec; - DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - state: State; - dependants: ObjectList; - dependsOn: Object; - END; - VAR - id: Disciplines.Identifier; - VAR - null*: Object; (* object which ignores all related events *) - nullevent: Events.EventType; - - PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object); - VAR - prev, p: ObjectList; - BEGIN - prev := NIL; p := list; - WHILE (p # NIL) & (p.object # dependant) DO - prev := p; p := p.next; - END; - IF p # NIL THEN - IF prev = NIL THEN - list := p.next; - ELSE - prev.next := p.next; - END; - END; - END RemoveDependant; - - PROCEDURE TerminationHandler(event: Events.Event); - VAR - disc: Discipline; - BEGIN - WITH event: Resources.Event DO - IF (event.change = Resources.terminated) & - Disciplines.Seek(event.resource, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - IF (disc.dependsOn # NIL) & - Disciplines.Seek(disc.dependsOn, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - RemoveDependant(disc.dependants, event.resource); - disc.dependsOn := NIL; - END; - (* - afb 9/2004: - do not remove this discipline for dead objects - as this makes it impossible to retrieve the final - list of error events - Disciplines.Remove(event.resource, id); - *) - END; - END; - END TerminationHandler; - - PROCEDURE CreateState(VAR state: State); - BEGIN - NEW(state); - state.eventType := NIL; - state.queue := FALSE; state.head := NIL; state.tail := NIL; - state.forwardto := NIL; - state.default := TRUE; - state.saved := NIL; - END CreateState; - - PROCEDURE CreateDiscipline(VAR disc: Discipline); - BEGIN - NEW(disc); disc.id := id; CreateState(disc.state); - END CreateDiscipline; - - PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType); - (* returns an event type for the given object; - all events related to the object are also handled by this event type - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object = null THEN - eventType := nullevent; - ELSE - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - state := disc.state; - state.default := FALSE; - IF state.eventType = NIL THEN - Events.Define(state.eventType); - Events.SetPriority(state.eventType, Priorities.liberrors + 1); - Events.Ignore(state.eventType); - END; - eventType := state.eventType; - END; - END GetEventType; - - PROCEDURE Forward*(from, to: Object); - (* causes all events related to `from' to be forwarded to `to' *) - VAR - disc: Discipline; - BEGIN - IF (from # NIL) & (from # null) THEN - ASSERT(from # to); - IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(from, disc); - END; - IF to = null THEN - to := NIL; - END; - disc.state.forwardto := to; - disc.state.default := FALSE; - END; - END Forward; - - PROCEDURE ForwardToDependants(from, to: Forwarders.Object); - (* is called by Forwarders.Forward: - build a backward chain from `to' to `from' - *) - VAR - fromDisc, toDisc: Discipline; - member: ObjectList; - eventType: Events.EventType; - BEGIN - IF (from = null) OR (to = null) THEN RETURN END; - IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, fromDisc)) THEN (* noch *) - CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc); - END; - IF fromDisc.dependsOn # NIL THEN RETURN END; - fromDisc.dependsOn := to; - Resources.TakeInterest(from, eventType); - Events.Handler(eventType, TerminationHandler); - - IF ~Disciplines.Seek(to, id, SYSTEM.VAL(Disciplines.Discipline, toDisc)) THEN (* noch *) - CreateDiscipline(toDisc); Disciplines.Add(to, toDisc); - END; - NEW(member); member.object := from; - member.next := toDisc.dependants; toDisc.dependants := member; - END ForwardToDependants; - - PROCEDURE QueueEvents*(object: Object); - (* put all incoming events into a queue *) - VAR - disc: Discipline; - state: State; - BEGIN - IF (object # NIL) & (object # null) THEN - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - state := disc.state; - state.default := FALSE; - IF ~state.queue THEN - state.queue := TRUE; state.head := NIL; state.tail := NIL; - END; - END; - END QueueEvents; - - PROCEDURE GetQueue*(object: Object; VAR queue: Queue); - (* return queue of related events which is removed - from the object; - object must have been prepared by QueueEvents - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF (object # NIL) & (object # null) & - Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *) - state := disc.state; - queue := state.head; state.head := NIL; state.tail := NIL; - ELSE - queue := NIL; - END; - END GetQueue; - - PROCEDURE EventsPending*(object: Object) : BOOLEAN; - (* return TRUE if GetQueue will return a queue # NIL *) - VAR - disc: Discipline; - BEGIN - IF (object # NIL) & (object # null) & - Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *) - RETURN disc.state.head # NIL - ELSE - RETURN FALSE - END; - END EventsPending; - - PROCEDURE Reset*(object: Object); - (* return to default behaviour *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object # null THEN - IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - IF (disc.state.saved = NIL) & - (disc.dependsOn = NIL) & - (disc.dependants = NIL) THEN - Disciplines.Remove(object, id); - ELSE - state := disc.state; - state.queue := FALSE; state.head := NIL; state.tail := NIL; - state.eventType := NIL; state.forwardto := NIL; - state.default := TRUE; - END; - END; - END; - END Reset; - - PROCEDURE Save*(object: Object); - (* save current status of the given object and reset to - default behaviour; - the status includes the reaction types and event queues; - Save operations may be nested - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object # null THEN - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - CreateState(state); - state.saved := disc.state; disc.state := state; - END; - END Save; - - PROCEDURE Restore*(object: Object); - (* restore status saved earlier by Save *) - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & (disc.state.saved # NIL) THEN (* noch *) - disc.state := disc.state.saved; - END; - END Restore; - - PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event); - VAR - disc: Discipline; - state: State; - relEvent: Event; - element: Queue; (* new element of queue *) - dependant: ObjectList; - BEGIN - IF (object = null) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN RETURN END; - - (* backward chaining *) - IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN - dependant := disc.dependants; - WHILE dependant # NIL DO - InternalRaise(dependant.object, backward, event); - dependant := dependant.next; - END; - END; - - (* local handling & forward chaining *) - IF ~disc.state.default THEN - state := disc.state; - IF state.queue THEN - NEW(element); element.next := NIL; element.event := event; - IF state.tail # NIL THEN - state.tail.next := element; - ELSE - state.head := element; - END; - state.tail := element; - END; - IF state.eventType # NIL THEN - NEW(relEvent); - relEvent.message := event.message; - relEvent.type := state.eventType; - relEvent.object := object; - relEvent.event := event; - Events.Raise(relEvent); - END; - IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN - InternalRaise(state.forwardto, forward, event); - END; - END; - END InternalRaise; - - PROCEDURE Raise*(object: Object; event: Events.Event); - VAR - disc: Discipline; - BEGIN - ASSERT(event.type # NIL); - IF object # null THEN - IF (object = NIL) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - Events.Raise(event); - ELSE - InternalRaise(object, both, event); - END; - END; - END Raise; - - PROCEDURE AppendQueue*(object: Object; queue: Queue); - (* Raise(object, event) for all events of the queue *) - BEGIN - WHILE queue # NIL DO - Raise(object, queue.event); - queue := queue.next; - END; - END AppendQueue; - -BEGIN - id := Disciplines.Unique(); - NEW(null); - Events.Define(nullevent); - Forwarders.Register("", ForwardToDependants); -END ulmRelatedEvents. diff --git a/src/lib/ulm/ulmScales.Mod b/src/lib/ulm/ulmScales.Mod deleted file mode 100644 index 8b60d48a..00000000 --- a/src/lib/ulm/ulmScales.Mod +++ /dev/null @@ -1,445 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Scales.om,v $ - Revision 1.3 2004/09/03 09:31:53 borchert - bug fixes: Services.Init added in CreateOperand - Scales.Measure changed to Measure - - Revision 1.2 1995/01/16 21:40:39 borchert - - assertions of Assertions converted into real assertions - - fixes due to changed if of PersistentObjects - - Revision 1.1 1994/02/22 20:10:03 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmScales; - - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, - RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM; - - TYPE - Scale* = POINTER TO ScaleRec; - Family* = POINTER TO FamilyRec; - FamilyRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - reference: Scale; - END; - - TYPE - Unit* = POINTER TO UnitRec; - UnitList = POINTER TO UnitListRec; - UnitListRec = - RECORD - unit: Unit; - next: UnitList; - END; - Interface* = POINTER TO InterfaceRec; - ScaleRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - if: Interface; - family: Family; - head, tail: UnitList; - nextUnit: UnitList; - END; - - CONST - unitNameLength* = 32; - TYPE - UnitName* = ARRAY unitNameLength OF CHAR; - UnitRec* = RECORD - (Disciplines.ObjectRec) - name: UnitName; - scale: Scale; - END; - - CONST - undefined = 0; absolute* = 1; relative* = 2; - TYPE - Measure* = POINTER TO MeasureRec; - MeasureRec* = - RECORD - (Operations.OperandRec) - scale: Scale; - type: SHORTINT; (* absolute or relative? *) - END; - VAR - measureType: Services.Type; - - TYPE - Value* = LONGINT; - - CONST - add* = Operations.add; sub* = Operations.sub; - TYPE - Operation* = SHORTINT; (* add or sub *) - TYPE - CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN); - GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value); - SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value); - AssignProc* = PROCEDURE (target: Measure; source: Measure); - OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure); - CompareProc* = PROCEDURE (op1, op2: Measure) : INTEGER; - ConvertProc* = PROCEDURE (from, to: Measure); - - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; - getvalue*: GetValueProc; - setvalue*: SetValueProc; - assign*: AssignProc; - op*: OperatorProc; - compare*: CompareProc; - (* the conversion routines are only to be provided - if the scaling system belongs to a family - *) - scaleToReference*: ConvertProc; - referenceToScale*: ConvertProc; - END; - - VAR - invalidOperation*: Events.EventType; - (* operation cannot be performed for the given combination - of types (absolute or relative) - *) - incompatibleScales*: Events.EventType; - (* the scales of the operands do not belong to the same family *) - badCombination*: Events.EventType; - (* SetValue or GetValue: - given measure and unit do not belong to the same scaling system - *) - - (* our interface to Operations *) - opif: Operations.Interface; - opcaps: Operations.CapabilitySet; - - (* ======= private procedures ===================================== *) - - PROCEDURE DummyConversion(from, to: Measure); - BEGIN - from.scale.if.assign(to, from); - END DummyConversion; - - (* ======== exported procedures ==================================== *) - - PROCEDURE InitFamily*(family: Family; reference: Scale); - BEGIN - family.reference := reference; - (* the reference scale becomes now a member of the family *) - reference.family := family; - reference.if.scaleToReference := DummyConversion; - reference.if.referenceToScale := DummyConversion; - END InitFamily; - - PROCEDURE Init*(scale: Scale; family: Family; if: Interface); - (* reference scales are to be initialized with family = NIL *) - BEGIN - scale.if := if; - scale.family := family; - scale.head := NIL; scale.tail := NIL; - scale.nextUnit := NIL; - END Init; - - PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName); - VAR - listp: UnitList; - BEGIN - unit.name := name; - unit.scale := scale; - NEW(listp); listp.unit := unit; listp.next := NIL; - IF scale.head # NIL THEN - scale.tail.next := listp; - ELSE - scale.head := listp; - END; - scale.tail := listp; - END InitUnit; - - PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: SHORTINT); - BEGIN - scale.if.create(scale, measure, type = absolute); - Operations.Init(measure, opif, opcaps); - measure.scale := scale; - measure.type := type; - END CreateMeasure; - - PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure); - (* init measure to the origin of the given system *) - BEGIN - CreateMeasure(scale, measure, absolute); - END CreateAbsMeasure; - - PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure); - (* init relative measure to 0 *) - BEGIN - CreateMeasure(scale, measure, relative); - END CreateRelMeasure; - - PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure); - (* convert measure to the given scale which must belong - to the same family as the original scale of measure - *) - VAR - newMeasure: Measure; - refMeasure: Measure; - reference: Scale; - BEGIN - IF scale = measure.scale THEN - (* trivial case -- nothing is to be done *) - RETURN - END; - (* check that both scales belong to the same family *) - ASSERT((scale.family # NIL) & (scale.family = measure.scale.family)); - CreateMeasure(scale, newMeasure, measure.type); - reference := scale.family.reference; - CreateMeasure(reference, refMeasure, measure.type); - measure.scale.if.scaleToReference(measure, refMeasure); - scale.if.referenceToScale(refMeasure, newMeasure); - measure := newMeasure; - END ConvertMeasure; - - PROCEDURE GetReference*(family: Family; VAR reference: Scale); - BEGIN - reference := family.reference; - END GetReference; - - PROCEDURE GetFamily*(scale: Scale; VAR family: Family); - BEGIN - family := scale.family; - END GetFamily; - - PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale); - BEGIN - scale := unit.scale; - END GetScaleOfUnit; - - PROCEDURE GetScale*(measure: Measure; VAR scale: Scale); - BEGIN - scale := measure.scale; - END GetScale; - - PROCEDURE TraverseUnits*(scale: Scale); - BEGIN - scale.nextUnit := scale.head; - END TraverseUnits; - - PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN; - BEGIN - IF scale.nextUnit # NIL THEN - unit := scale.nextUnit.unit; - scale.nextUnit := scale.nextUnit.next; - RETURN TRUE - ELSE - RETURN FALSE - END; - END NextUnit; - - PROCEDURE GetName*(unit: Unit; VAR name: UnitName); - BEGIN - name := unit.name; - END GetName; - - PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value); - VAR - scale: Scale; - BEGIN - scale := measure.scale; - ASSERT(unit.scale = scale); - scale.if.getvalue(measure, unit, value); - END GetValue; - - PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value); - VAR - scale: Scale; - BEGIN - scale := measure.scale; - ASSERT(unit.scale = scale); - scale.if.setvalue(measure, unit, value); - END SetValue; - - PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN; - BEGIN - RETURN measure.type = absolute - END IsAbsolute; - - PROCEDURE IsRelative*(measure: Measure) : BOOLEAN; - BEGIN - RETURN measure.type = relative - END IsRelative; - - PROCEDURE MeasureType*(measure: Measure) : SHORTINT; - BEGIN - RETURN measure.type - END MeasureType; - - (* ======== interface procedures for Operations ================= *) - - PROCEDURE CreateOperand(VAR op: Operations.Operand); - (* at this time we don't know anything about the - associated scale -- so we've have to delay this decision - *) - VAR - measure: Measure; - BEGIN - NEW(measure); - measure.type := undefined; - measure.scale := NIL; - Services.Init(measure, measureType); - op := measure; - Operations.Init(op, opif, {Operations.add..Operations.cmp}); - END CreateOperand; - - PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand); - BEGIN - (*WITH source: Measure DO WITH target: Measure DO*) - WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *) - (* target is already initialized but possibly to a dummy operand - by CreateOperand - *) - IF target(Measure).type = undefined THEN (* type guard introduced *) - (* init target with the scale of source *) - CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *) - END; - IF target(Measure).scale # source.scale THEN - (* adapt scale type from source -- - this could lead to a type guard failure if - target is not of the appropiate type - *) - CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); - END; - IF target(Measure).type # source.type THEN - (* adapt measure type from source *) - CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type); - END; - source.scale.if.assign(SYS.VAL(Measure, target), source); - END; END; - END Assign; - - PROCEDURE CheckCompatibility(op1, op2: Operations.Operand; - VAR m1, m2: Measure); - (* is needed by Op and Compare: - both operands are checked to be members of the same family; - if they have different scales of the same family a - conversion is done; - *) - VAR - scale1, scale2: Scale; - BEGIN - WITH op1: Measure DO WITH op2: Measure DO - scale1 := op1.scale; scale2 := op2.scale; - IF scale1 # scale2 THEN - ASSERT((scale1.family # NIL) & (scale1.family = scale2.family)); - (* convert both operands to the reference scale *) - CreateMeasure(scale1.family.reference, m1, op1.type); - scale1.if.scaleToReference(op1, m1); - CreateMeasure(scale2.family.reference, m2, op2.type); - scale2.if.scaleToReference(op2, m2); - ELSE - m1 := op1; - m2 := op2; - END; - END; END; - END CheckCompatibility; - - PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand; - VAR result: Operations.Operand); - VAR - restype: SHORTINT; (* type of result -- set by CheckTypes *) - m1, m2: Measure; - - PROCEDURE CheckTypes(VAR restype: SHORTINT); - (* check operands for correct typing; - sets restype to the correct result type; - *) - VAR ok: BOOLEAN; - BEGIN - (*WITH op1: Measure DO WITH op2: Measure DO*) - IF op1 IS Measure THEN IF op2 IS Measure THEN - CASE op OF - | Operations.add: (* only abs + abs is invalid *) - ok := (op1(Measure).type = relative) OR - (op2(Measure).type = relative); - IF op1(Measure).type = op2(Measure).type THEN - (* both are relative *) - restype := relative; - ELSE - (* exactly one absolute type is involved *) - restype := absolute; - END; - | Operations.sub: (* only rel - abs is invalid *) - ok := op1(Measure).type <= op2(Measure).type; - IF op1(Measure).type # op2(Measure).type THEN - (* abs - rel *) - restype := absolute; - ELSE - (* abs - abs or rel - rel *) - restype := relative; - END; - END; - ASSERT(ok); (* invalid operation *) - END; END; - END CheckTypes; - - BEGIN (* Op *) - (* result is already of type Measure; this is guaranteed by Operations *) - IF result IS Measure THEN - CheckTypes(restype); - CheckCompatibility(op1, op2, m1, m2); - CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype); - m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result)); - END; - END Op; - - PROCEDURE Compare(op1, op2: Operations.Operand) : INTEGER; - VAR - m1, m2: Measure; - BEGIN - CheckCompatibility(op1, op2, m1, m2); - ASSERT(m1.type = m2.type); - CheckCompatibility(op1, op2, m1, m2); - RETURN m1.scale.if.compare(m1, m2) - END Compare; - - PROCEDURE InitInterface; - BEGIN - NEW(opif); - opif.create := CreateOperand; - opif.assign := Assign; - opif.op := Op; - opif.compare := Compare; - opcaps := {Operations.add, Operations.sub, Operations.cmp}; - END InitInterface; - -BEGIN - InitInterface; - PersistentObjects.RegisterType(measureType, - "Scales.Measure", "Operations.Operand", NIL); -END ulmScales. diff --git a/src/lib/ulm/ulmServices.Mod b/src/lib/ulm/ulmServices.Mod deleted file mode 100644 index 3b804e4f..00000000 --- a/src/lib/ulm/ulmServices.Mod +++ /dev/null @@ -1,520 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Services.om,v $ - Revision 1.2 2004/09/03 09:34:24 borchert - cache results of LoadService to avoid further attempts - - Revision 1.1 1995/03/03 09:32:15 borchert - Initial revision - - ---------------------------------------------------------------------------- -*) - -MODULE ulmServices; - - IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects; - - TYPE - Type* = POINTER TO TypeRec; - ServiceList = POINTER TO ServiceListRec; - Service* = POINTER TO ServiceRec; - Object* = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (Disciplines.ObjectRec) - type: Type; - installed: ServiceList; (* set of installed services *) - END; - - InstallProc = PROCEDURE (object: Object; service: Service); - - ServiceRec* = - RECORD - (Disciplines.ObjectRec) - name: ARRAY 64 OF CHAR; - next: Service; - END; - - ServiceListRec = - RECORD - service: Service; - type: Type; - install: InstallProc; - next: ServiceList; - END; - - VAR - services: Service; - (* list of services -- needed to support Seek *) - - TYPE - LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN; - LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN; - LoaderInterface* = POINTER TO LoaderInterfaceRec; - LoaderInterfaceRec* = - RECORD - loadModule*: LoadModuleProc; - loadService*: LoadServiceProc; - END; - VAR - loaderIF: LoaderInterface; - - (* ==== name tables ================================================== *) - - CONST - bufsize = 512; (* length of a name buffer in bytes *) - tabsize = 1171; - TYPE - BufferPosition = INTEGER; - Length = LONGINT; - HashValue = INTEGER; - Buffer = ARRAY bufsize OF CHAR; - NameList = POINTER TO NameListRec; - NameListRec = - RECORD - buffer: Buffer; - next: NameList; - END; - VAR - currentBuf: NameList; currentPos: BufferPosition; - TYPE - TypeRec* = - RECORD - (Disciplines.ObjectRec) - baseType: Type; - services: ServiceList; - cachedservices: ServiceList; (* of base types *) - (* table management *) - hashval: HashValue; - length: Length; - begin: NameList; - pos: BufferPosition; - next: Type; (* next type with same hash value *) - END; - BucketTable = ARRAY tabsize OF Type; - VAR - bucket: BucketTable; - - (* ==== name table management ======================================== *) - - PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue; - CONST - shift = 4; - VAR - index: LONGINT; - val: LONGINT; - ch: CHAR; - ordval: INTEGER; - BEGIN - index := 0; val := length; - WHILE index < length DO - ch := name[index]; - IF ch >= " " THEN - ordval := ORD(ch) - ORD(" "); - ELSE - ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch); - END; - val := ASH(val, shift) + ordval; - INC(index); - END; - val := val MOD tabsize; - RETURN SHORT(val) - END Hash; - - PROCEDURE CreateBuf(VAR buf: NameList); - BEGIN - NEW(buf); buf.next := NIL; - IF currentBuf # NIL THEN - currentBuf.next := buf; - END; - currentBuf := buf; - currentPos := 0; - END CreateBuf; - - PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT; - VAR - index: LONGINT; - BEGIN - index := 0; - WHILE (index < LEN(string)) & (string[index] # 0X) DO - INC(index); - END; - RETURN index - END StringLength; - - PROCEDURE InitName(name: Type; string: ARRAY OF CHAR); - VAR - index, length: LONGINT; - firstbuf, buf: NameList; - startpos: BufferPosition; - BEGIN - IF currentBuf = NIL THEN - CreateBuf(buf); - ELSE - buf := currentBuf; - END; - - firstbuf := buf; startpos := currentPos; - index := 0; - WHILE (index < LEN(string)) & (string[index] # 0X) DO - IF currentPos = bufsize THEN - CreateBuf(buf); - END; - buf.buffer[currentPos] := string[index]; INC(currentPos); - INC(index); - END; - length := index; - - name.hashval := Hash(string, length); - name.length := length; - name.begin := firstbuf; - name.pos := startpos; - name.next := bucket[name.hashval]; - bucket[name.hashval] := name; - END InitName; - - PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN; - (* precondition: both have the same length *) - VAR - index: LONGINT; - buf: NameList; - pos: INTEGER; - BEGIN - buf := name.begin; pos := name.pos; - index := 0; - WHILE index < name.length DO - IF pos = bufsize THEN - buf := buf.next; pos := 0; - END; - IF string[index] # buf.buffer[pos] THEN - RETURN FALSE - END; - INC(pos); - INC(index); - END; - RETURN TRUE - END EqualName; - - PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN; - VAR - length: LONGINT; - hashval: HashValue; - p: Type; - BEGIN - length := StringLength(string); - hashval := Hash(string, length); - p := bucket[hashval]; - WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO - p := p.next; - END; - name := p; - RETURN p # NIL - END SeekName; - - PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR); - VAR - index: LONGINT; - buf: NameList; - pos: INTEGER; - BEGIN - buf := name.begin; pos := name.pos; - index := 0; - WHILE (index + 1 < LEN(string)) & (index < name.length) DO - IF pos = bufsize THEN - buf := buf.next; pos := 0; - END; - string[index] := buf.buffer[pos]; - INC(pos); - INC(index); - END; - string[index] := 0X; - END ExtractName; - - PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN; - BEGIN - IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN - RETURN loaderIF.loadModule(module) - ELSE - RETURN FALSE - END; - END LoadModule; - - PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN; - BEGIN - IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN - RETURN loaderIF.loadService(service, for) - ELSE - RETURN FALSE - END; - END LoadService; - - PROCEDURE MemberOf(list: ServiceList; service: Service; - VAR member: ServiceList) : BOOLEAN; - VAR - p: ServiceList; - BEGIN - p := list; - WHILE (p # NIL) & (p.service # service) DO - p := p.next; - END; - member := p; - RETURN p # NIL - END MemberOf; - - PROCEDURE SeekService(type: Type; service: Service; - VAR member: ServiceList; - VAR baseType: Type) : BOOLEAN; - - VAR - btype: Type; - cachedservice: ServiceList; - - PROCEDURE Seek(type: Type; service: Service; - VAR member: ServiceList) : BOOLEAN; - VAR - typeName: ARRAY 512 OF CHAR; - BEGIN - IF MemberOf(type.services, service, member) OR - MemberOf(type.cachedservices, service, member) THEN - RETURN TRUE - END; - ExtractName(type, typeName); - RETURN LoadService(service.name, typeName) & - MemberOf(type.services, service, member) - END Seek; - - BEGIN (* SeekService *) - btype := type; - WHILE (btype # NIL) & ~Seek(btype, service, member) DO - btype := btype.baseType; - END; - IF (member # NIL) & (btype # type) THEN - (* cache result to avoid further tries to load - a more fitting variant dynamically - *) - NEW(cachedservice); - cachedservice.service := service; - cachedservice.type := member.type; - cachedservice.install := member.install; - cachedservice.next := type.cachedservices; - type.cachedservices := cachedservice; - baseType := member.type; - RETURN TRUE - END; - IF member = NIL THEN - RETURN FALSE - ELSE - baseType := member.type; - RETURN TRUE - END; - END SeekService; - - PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); - (* get the name of the module where 'name' was defined *) - VAR - index: INTEGER; - BEGIN - index := 0; - WHILE (name[index] # ".") & (name[index] # 0X) & - (index < LEN(module)-1) DO - module[index] := name[index]; INC(index); - END; - module[index] := 0X; - END GetModule; - - (* ==== exported procedures ========================================== *) - - PROCEDURE InitLoader*(if: LoaderInterface); - BEGIN - ASSERT((loaderIF = NIL) & (if # NIL)); - loaderIF := if; - END InitLoader; - - PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR); - VAR - baseType: Type; - otherType: Type; - ok: BOOLEAN; - BEGIN - IF baseName = "" THEN - baseType := NIL; - ELSE - ok := SeekName(baseName, baseType); ASSERT(ok); - END; - ASSERT(~SeekName(name, otherType)); - InitName(type, name); - type.baseType := baseType; - type.services := NIL; - type.cachedservices := NIL; - END InitType; - - PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR); - BEGIN - NEW(type); InitType(type, name, baseName); - END CreateType; - - PROCEDURE Init*(object: Object; type: Type); - BEGIN - ASSERT(type # NIL); - ASSERT(object.type = NIL); - object.type := type; - object.installed := NIL; - END Init; - - PROCEDURE GetType*(object: Object; VAR type: Type); - BEGIN - type := object.type; - END GetType; - - PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR); - BEGIN - ExtractName(type, name); - END GetTypeName; - - PROCEDURE GetBaseType*(type: Type; VAR baseType: Type); - BEGIN - baseType := type.baseType; - END GetBaseType; - - PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN; - BEGIN - ASSERT(baseType # NIL); - WHILE (type # NIL) & (type # baseType) DO - type := type.baseType; - END; - RETURN type = baseType - END IsExtensionOf; - - PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type); - VAR - module: ARRAY 64 OF CHAR; - BEGIN - IF ~SeekName(name, type) THEN - (* try to load the associated module *) - GetModule(name, module); - IF ~LoadModule(module) OR ~SeekName(name, type) THEN - type := NIL; - END; - END; - END SeekType; - - PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service); - BEGIN - service := services; - WHILE (service # NIL) & (service.name # name) DO - service := service.next; - END; - - (* try to load a module named after `name', if not successful *) - IF (service = NIL) & LoadModule(name) THEN - service := services; - WHILE (service # NIL) & (service.name # name) DO - service := service.next; - END; - END; - END Seek; - - PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR); - - PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN; - VAR - service: Service; - BEGIN - service := services; - WHILE (service # NIL) & (service.name # name) DO - service := service.next; - END; - RETURN service # NIL - END Created; - - BEGIN - ASSERT(~Created(name)); - NEW(service); - COPY(name, service.name); - service.next := services; services := service; - END Create; - - PROCEDURE Define*(type: Type; service: Service; install: InstallProc); - VAR - member: ServiceList; - BEGIN - ASSERT(service # NIL); - (* protect against multiple definitions: *) - ASSERT(~MemberOf(type.services, service, member)); - - NEW(member); member.service := service; - member.install := install; member.type := type; - member.next := type.services; type.services := member; - END Define; - - PROCEDURE Install*(object: Object; service: Service) : BOOLEAN; - VAR - member, installed: ServiceList; - baseType: Type; - BEGIN - IF object.type = NIL THEN RETURN FALSE END; - IF ~SeekService(object.type, service, member, baseType) THEN - (* service not supported for this object type *) - RETURN FALSE - END; - IF ~MemberOf(object.installed, service, installed) THEN - (* install services only once *) - IF member.install # NIL THEN - member.install(object, service); - END; - NEW(installed); - installed.service := service; - installed.next := object.installed; - object.installed := installed; - END; - RETURN TRUE - END Install; - - PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN; - VAR - member: ServiceList; - baseType: Type; - BEGIN - RETURN (object.type # NIL) & - SeekService(object.type, service, member, baseType) - END Supported; - - PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN; - VAR - member: ServiceList; - BEGIN - RETURN MemberOf(object.installed, service, member) - END Installed; - - PROCEDURE GetSupportedBaseType*(object: Object; service: Service; - VAR baseType: Type); - VAR - member: ServiceList; - BEGIN - IF ~SeekService(object.type, service, member, baseType) THEN - baseType := NIL; - END; - END GetSupportedBaseType; - -BEGIN - currentBuf := NIL; currentPos := 0; loaderIF := NIL; -END ulmServices. diff --git a/src/lib/ulm/ulmStreamDisciplines.Mod b/src/lib/ulm/ulmStreamDisciplines.Mod deleted file mode 100644 index 686214c9..00000000 --- a/src/lib/ulm/ulmStreamDisciplines.Mod +++ /dev/null @@ -1,246 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: StreamDisci.om,v $ - Revision 1.2 1994/07/04 14:53:25 borchert - parameter for indentation width added - - Revision 1.1 1994/02/22 20:10:34 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 10/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmStreamDisciplines; - - (* definition of general-purpose disciplines for streams *) - - IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM; - - TYPE - LineTerminator* = ARRAY 4 OF CHAR; - VAR - badfieldsepset*: Events.EventType; - - TYPE - StreamDiscipline = POINTER TO StreamDisciplineRec; - StreamDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - lineterm: LineTerminator; - fieldseps: Sets.CharSet; - fieldsep: CHAR; (* one of them *) - whitespace: Sets.CharSet; - indentwidth: INTEGER; - END; - - VAR - id: Disciplines.Identifier; - (* default values *) - defaultFieldSeps: Sets.CharSet; - defaultFieldSep: CHAR; - defaultLineTerm: LineTerminator; - defaultWhiteSpace: Sets.CharSet; - defaultIndentWidth: INTEGER; - - PROCEDURE InitDiscipline(VAR disc: StreamDiscipline); - BEGIN - NEW(disc); disc.id := id; - disc.fieldseps := defaultFieldSeps; - disc.fieldsep := defaultFieldSep; - disc.lineterm := defaultLineTerm; - disc.whitespace := defaultWhiteSpace; - disc.indentwidth := defaultIndentWidth; - END InitDiscipline; - - PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.lineterm := lineterm; - Disciplines.Add(s, disc); - END SetLineTerm; - - PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator); - (* default line terminator is ASCII.nl *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - lineterm := disc.lineterm; - ELSE - lineterm := defaultLineTerm; - END; - END GetLineTerm; - - PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet); - (* cardinality of fieldsepset must be >= 1 *) - VAR - disc: StreamDiscipline; - ch: CHAR; found: BOOLEAN; - fieldsep: CHAR; - event: Events.Event; - BEGIN - ch := 0X; - LOOP (* seek for the first element inside fieldsepset *) - IF Sets.CharIn(fieldsepset, ch) THEN - found := TRUE; fieldsep := ch; EXIT - END; - IF ch = MAX(CHAR) THEN - found := FALSE; EXIT - END; - ch := CHR(ORD(ch) + 1); - END; - IF ~found THEN - NEW(event); - event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset"; - event.type := badfieldsepset; - Events.Raise(event); - RETURN - END; - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.fieldseps := fieldsepset; - disc.fieldsep := fieldsep; - Disciplines.Add(s, disc); - END SetFieldSepSet; - - PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet); - (* default field separators are ASCII.tab and ASCII.sp *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - fieldsepset := disc.fieldseps; - ELSE - fieldsepset := defaultFieldSeps; - END; - END GetFieldSepSet; - - PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - Sets.InclChar(disc.fieldseps, fieldsep); - disc.fieldsep := fieldsep; - Disciplines.Add(s, disc); - END SetFieldSep; - - PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR); - (* default field separator is ASCII.tab; - if a set of field separators has been given via SetFieldSepSet, - one of them is returned - *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - fieldsep := disc.fieldsep; - ELSE - fieldsep := defaultFieldSep; - END; - END GetFieldSep; - - PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet); - (* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - whitespace := disc.whitespace; - ELSE - whitespace := defaultWhiteSpace; - END; - END GetWhiteSpace; - - PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.whitespace := whitespace; - Disciplines.Add(s, disc); - END SetWhiteSpace; - - PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF indentwidth >= 0 THEN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.indentwidth := indentwidth; - Disciplines.Add(s, disc); - END; - END SetIndentationWidth; - - PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - indentwidth := disc.indentwidth; - ELSE - indentwidth := defaultIndentWidth; - END; - END GetIndentationWidth; - - PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - IF disc.indentwidth + incr >= 0 THEN - INC(disc.indentwidth, incr);; - END; - Disciplines.Add(s, disc); - END IncrIndentationWidth; - -BEGIN - Events.Define(badfieldsepset); - - id := Disciplines.Unique(); - Sets.InitSet(defaultFieldSeps); - Sets.InclChar(defaultFieldSeps, ASCII.tab); - Sets.InclChar(defaultFieldSeps, ASCII.sp); - defaultFieldSep := ASCII.tab; - defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X; - Sets.InitSet(defaultWhiteSpace); - Sets.InclChar(defaultWhiteSpace, ASCII.tab); - Sets.InclChar(defaultWhiteSpace, ASCII.sp); - Sets.InclChar(defaultWhiteSpace, ASCII.np); - Sets.InclChar(defaultWhiteSpace, ASCII.nl); - defaultIndentWidth := 0; -END ulmStreamDisciplines. diff --git a/src/lib/ulm/ulmStreams.Mod b/src/lib/ulm/ulmStreams.Mod deleted file mode 100644 index 8e54ed95..00000000 --- a/src/lib/ulm/ulmStreams.Mod +++ /dev/null @@ -1,2149 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-2001 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Streams.om,v 1.13 2005/02/14 23:36:35 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Streams.om,v $ - Revision 1.13 2005/02/14 23:36:35 borchert - bug fix: WritePart called InternalFlush without considering - that s.pos may be implicitly changed - (this assumption was wrong since revision 1.11) - - Revision 1.12 2004/05/20 09:52:43 borchert - performance improvements: - - WritePart and Write take now the buffer by reference - - ReadByteFromBuf replaced by ReadBytesFromBuf - (contributed by Christian Ehrhardt) - - Revision 1.11 2001/05/03 15:17:58 borchert - InternalFlush adapted for unidirectional pipelines to avoid - unintentional flushes due to buffer boundaries - - Revision 1.10 2000/04/25 21:41:47 borchert - Streams.ReadPart loops now for unbuffered streams to collect input - until cnt is reached - - Revision 1.9 1998/03/31 11:13:05 borchert - bug fix: NotificationHandler just reacted on Resources.unreferenced - but not on Resources.terminated - - Revision 1.8 1998/03/24 22:58:28 borchert - bug fix in Copy: left was computed incorrectly in case of - copies with fixed length (# -1) - - Revision 1.7 1997/04/02 07:50:05 borchert - Copy replaced by a slightly more efficient variant - - Revision 1.6 1996/09/18 07:43:51 borchert - qualified references to own module (i.e. Streams.XXX) removed - - Revision 1.5 1996/01/04 16:43:57 borchert - some bug fixes in the updates of read and write regions - - Revision 1.4 1995/10/11 09:46:41 borchert - - closeEvent re-introduced (because it gets raised *before* - the actual close) - - bug fix: s.write was diminished in ReadPart but the write region - not properly adjusted - - bug fix: InternalSeek was setting s.left to negative values in - a special case - - Revision 1.3 1995/04/18 12:17:12 borchert - - Streams.Stream is now an extension of Services.Object - - Library variant of assertions replaced by ASSERT - - support of Resources added - - EnableClose, PreventClose & closeEvent removed - - Revision 1.2 1994/07/05 12:45:57 borchert - some minor bug fixes & enhancements: - - ReadPacket added - - streams which don't require cleanup are now subject to the GC - even if Close will never be called for them - - line buffered streams w/o bufio/addrio capability fill now buffer - up to the next line terminator only instead of trying to fill the - whole buffer - - ReadPart didn't set count correctly in all cases - - Touch calls now the flush interface procedure - - Revision 1.1 1994/02/22 20:10:45 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 6/89 - Major Revision: AFB 1/92: bufpool - ---------------------------------------------------------------------------- -*) - -MODULE ulmStreams; - - IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Resources := ulmResources, - Services := ulmServices, SYS := ulmSYSTEM, SYSTEM, Types := ulmTypes; - - CONST - (* 3rd parameter of Seek *) - (* Whence = (fromStart, fromPos, fromEnd); *) - fromStart* = 0; fromPos* = 1; fromEnd* = 2; - - (* capabilities of a stream *) - (* Capability = (read, write, addrio, bufio, seek, tell, trunc, close, - holes, handler); - *) - read* = 0; write* = 1; addrio* = 2; bufio* = 3; seek* = 4; tell* = 5; - trunc* = 6; flush* = 7; close* = 8; holes* = 9; handler* = 10; - - (* BufMode = (nobuf, linebuf, onebuf, bufpool); *) - nobuf* = 0; linebuf* = 1; onebuf* = 2; bufpool* = 3; - - (* ErrorCode = (NoHandlerDefined, CannotRead, CannotSeek, CloseFailed, - NotLineBuffered, SeekFailed, TellFailed, BadWhence, - CannotTell, WriteFailed, CannotWrite, ReadFailed, - Unbuffered, BadParameters, CannotTrunc, TruncFailed, - NestedCall, FlushFailed); - *) - NoHandlerDefined* = 0; (* no handler defined *) - CannotRead* = 1; (* stream is write only *) - CannotSeek* = 2; (* stream is not capable of seeking *) - CloseFailed* = 3; (* Flush or Close failed *) - NotLineBuffered* = 4; (* LineTerm must not be called *) - SeekFailed* = 5; (* seek operation failed *) - TellFailed* = 6; (* tell operation failed *) - BadWhence* = 7; (* whence value out of [fromStart..fromEnd] *) - CannotTell* = 8; (* stream does not have a current position *) - WriteFailed* = 9; (* write error *) - CannotWrite* = 10; (* stream is read only *) - ReadFailed* = 11; (* read error *) - Unbuffered* = 12; (* operation isn't valid for unbuff'd streams *) - BadParameters* = 13; (* e.g. wrong count or offset values *) - CannotTrunc* = 14; (* stream is not capable of truncating *) - TruncFailed* = 15; (* trunc operation failed *) - NestedCall* = 16; (* nested stream operation *) - FlushFailed* = 17; (* flush operation failed *) - errorcodes* = 18; (* number of error codes *) - - (* === private constants ======================================= *) - bufsize = 8192; (* should be the file system block size *) - defaulttermch = 0AX; (* default line terminator (for linebuf) *) - - TYPE - Address* = Types.Address; - Count* = Types.Count; - Byte* = Types.Byte; - Whence* = SHORTINT; (* Whence = (fromStart, fromPos, fromEnd); *) - CapabilitySet* = SET; (* OF Capability; *) - BufMode* = SHORTINT; - ErrorCode* = SHORTINT; - Stream* = POINTER TO StreamRec; - Message* = RECORD (Objects.ObjectRec) END; - - (* the buffering system: - - buffers are always on bufsize-boundaries - - ok: the other components are defined - pos: file position of cont[0] (pos MOD bufsize = 0) - cont: valid data: cont[rbegin]..cont[rend-1] (read-region) - written data: cont[wbegin]..cont[wend-1] (write-region) - - both regions are maintained (even for non-rw streams) - *) - Buffer = POINTER TO BufferRec; - BufferRec = - RECORD - ok: BOOLEAN; (* TRUE if other components are valid *) - pos: Count; (* file position which corresponds to cont[0] *) - rbegin: Count; (* read-region: starting index *) - rend: Count; (* read-region: ending index *) - wbegin: Count; (* write-region: starting index of dirty region *) - wend: Count; (* write-region: ending index *) - cont: ARRAY bufsize OF Byte; (* buffer contents *) - nextfree: Buffer; (* only needed for released buffers *) - (* components for buffers which are members of a buffer pool *) - prevh, nexth: Buffer; (* next buffer with same the hash value *) - preva, nexta: Buffer; (* sorted list of buffers (access time) *) - END; - - CONST - hashtabsize = 128; (* size of bucket table *) - TYPE - BucketTable = ARRAY hashtabsize OF Buffer; - BufferPool = POINTER TO BufferPoolRec; - BufferPoolRec = - RECORD - maxbuf: INTEGER; (* maximal number of buffers to be used *) - nbuf: INTEGER; (* number of buffers in use *) - bucket: BucketTable; - (* list of all buffers sorted after the last access time; - tail points to the buffer most recently accessed - *) - head, tail: Buffer; - END; - - TYPE - AddrIOProc* = PROCEDURE (s: Stream; ptr: Address; cnt: Count) : Count; - BufIOProc* = PROCEDURE (s: Stream; VAR buf: ARRAY OF Byte; - off, cnt: Count) : Count; - SeekProc* = PROCEDURE (s: Stream; cnt: Count; whence: Whence) : BOOLEAN; - TellProc* = PROCEDURE (s: Stream; VAR cnt: Count) : BOOLEAN; - ReadProc* = PROCEDURE (s: Stream; VAR byte: Byte) : BOOLEAN; - WriteProc* = PROCEDURE (s: Stream; byte: Byte) : BOOLEAN; - TruncProc* = PROCEDURE (s: Stream; cnt: Count) : BOOLEAN; - FlushProc* = PROCEDURE (s: Stream) : BOOLEAN; - CloseProc* = PROCEDURE (s: Stream) : BOOLEAN; - HandlerProc* = PROCEDURE (s: Stream; VAR msg: Message); - - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - addrread*: AddrIOProc; (* read, addrio *) - addrwrite*: AddrIOProc; (* write, addrio *) - bufread*: BufIOProc; (* read, bufio *) - bufwrite*: BufIOProc; (* write, bufio *) - read*: ReadProc; (* read *) - write*: WriteProc; (* write *) - seek*: SeekProc; (* seek *) - tell*: TellProc; (* tell *) - trunc*: TruncProc; (* trunc *) - flush*: FlushProc; (* flush *) - close*: CloseProc; (* close *) - handler*: HandlerProc; (* handler *) - END; - - StreamRec* = - RECORD - (Services.ObjectRec) - (* following components are set after i/o-operations *) - count*: Count; (* resulting count of last operation *) - errors*: INTEGER; (* incremented for each error; may be set to 0 *) - error*: BOOLEAN; (* last operation successful? *) - lasterror*: ErrorCode; (* error code of last error *) - eof*: BOOLEAN; (* last read-operation with count=0 returned *) - (* === private part ============================================ *) - prev, next: Stream; (* list of open streams *) - if: Interface; caps: CapabilitySet; - bufmode: BufMode; (* buffering mode *) - bidirect: BOOLEAN; (* bidirectional buffering? *) - termch: Byte; (* flush on termch (linebuf only) *) - inlist: BOOLEAN; (* member of the list of opened streams? *) - tiedStream: Stream; (* to be flushed before read operations *) - buf: Buffer; (* current buffer; = NIL for unbuffered streams *) - wbuf: Buffer; (* buffer for writing (only if bidirect = TRUE) *) - bufpool: BufferPool; (* only if bufmode = bufpool *) - validpos: BOOLEAN; (* pos valid? *) - pos: Count; (* current position in stream *) - maxpos: Count; (* maximal position until now (only if buf # NIL) *) - left: Count; (* number of bytes left in buf (after pos) *) - write: Count; (* number of bytes which can be written in buf *) - rpos: Count; (* current position of if.tell *) - wextensible: BOOLEAN; (* write region extensible? *) - eofFound: BOOLEAN; (* eof seen yet? temporary use only *) - lock: BOOLEAN; (* avoid recursive operations *) - flushEvent: Events.EventType; (* valid if # NIL *) - closeEvent: Events.EventType; (* valid if # NIL *) - END; - VAR - type: Services.Type; - - TYPE - (* each error causes an event; - the error number is stored in event.errorcode; - the associated text can be taken from event.message - *) - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - stream*: Stream; - errorcode*: ErrorCode; - END; - - VAR - null*: Stream; (* accepts any output; does not return input *) - (* these streams are set by other modules; - after initialization of Streams they equal `null'; - so, connections with the standard UNIX streams must be - done by other modules - *) - stdin*, stdout*, stderr*: Stream; - errormsg*: ARRAY errorcodes OF Events.Message; - error*: Events.EventType; - - (* === private variables ========================================== *) - - opened: Stream; (* list of opened streams *) - (* this list has been reduced to the set of streams which - need to be cleaned up explicitly; - all other streams are subject to the garbage collection - even if Close has never been called for them - *) - freelist: Buffer; (* list of free buffers *) - nullif: Interface; (* interface of null-devices *) - - (* === private procedures ========================================= *) - - PROCEDURE NewStream(s: Stream); - BEGIN - IF s.inlist THEN - s.prev := NIL; - s.next := opened; - IF opened # NIL THEN - opened.prev := s; - END; - opened := s; - END; - END NewStream; - - PROCEDURE OldStream(s: Stream); - BEGIN - IF s.inlist THEN - IF s.prev # NIL THEN - s.prev.next := s.next; - ELSE - opened := s.next; - END; - IF s.next # NIL THEN - s.next.prev := s.prev; - END; - END; - END OldStream; - - PROCEDURE NewBuffer(VAR b: Buffer); - BEGIN - IF freelist # NIL THEN - b := freelist; - freelist := freelist.nextfree; - ELSE - NEW(b); - END; - b.nextfree := NIL; - b.ok := FALSE; - END NewBuffer; - - PROCEDURE OldBuffer(VAR b: Buffer); - BEGIN - b.nextfree := freelist; - freelist := b; - b := NIL; - END OldBuffer; - - PROCEDURE Error(s: Stream; code: ErrorCode); - VAR - event: Event; - BEGIN - IF s # NIL THEN - INC(s.errors); - s.error := TRUE; - s.lasterror := code; - - (* generate error event *) - NEW(event); - event.type := error; - event.message := errormsg[code]; - event.stream := s; - event.errorcode := code; - RelatedEvents.Raise(s, event); - END; - END Error; - - PROCEDURE ^ InternalFlush(s: Stream) : BOOLEAN; - - (* ===== management of buffer pool ================================== *) - - PROCEDURE InitBufPool(s: Stream); - VAR - index: INTEGER; - BEGIN - s.bufpool.maxbuf := 16; (* default size *) - s.bufpool.nbuf := 0; (* currently, no buffers are allocated *) - s.bufpool.head := NIL; s.bufpool.tail := NIL; - index := 0; - WHILE index < hashtabsize DO - s.bufpool.bucket[index] := NIL; - INC(index); - END; - END InitBufPool; - - PROCEDURE HashValue(pos: Count) : INTEGER; - (* HashValue returns a hash value for pos *) - BEGIN - RETURN SHORT(pos DIV bufsize) MOD hashtabsize - END HashValue; - - PROCEDURE FindBuffer(s: Stream; pos: Count; VAR buf: Buffer) : BOOLEAN; - VAR - index: INTEGER; - bp: Buffer; - BEGIN - index := HashValue(pos); - bp := s.bufpool.bucket[index]; - WHILE bp # NIL DO - IF bp.pos = pos THEN - buf := bp; RETURN TRUE - END; - bp := bp.nexth; (* next buffer with same hash value *) - END; - buf := NIL; - RETURN FALSE - END FindBuffer; - - PROCEDURE GetBuffer(s: Stream); - (* look for buffer for s.pos and make it to the current buffer; - set s.left and s.write in dependance of s.pos - *) - VAR - buf: Buffer; - pos: Count; (* buffer boundary for s.pos *) - posindex: Count; (* buf[posindex] corresponds to s.pos *) - index: INTEGER; (* index into bucket table of the buffer pool *) - - PROCEDURE InitBuf(buf: Buffer); - VAR - index: INTEGER; (* of bucket table *) - BEGIN - buf.ok := TRUE; - buf.pos := pos; - buf.rbegin := posindex; buf.rend := posindex; s.left := 0; - buf.wbegin := posindex; buf.wend := posindex; - s.write := bufsize - posindex; - buf.nextfree := NIL; - - (* insert buf into hash list *) - index := HashValue(pos); - buf.prevh := NIL; - buf.nexth := s.bufpool.bucket[index]; - IF buf.nexth # NIL THEN - buf.nexth.prevh := buf; - END; - s.bufpool.bucket[index] := buf; - - (* buf is already at the end of the sorted list if we - re-use an old buffer - *) - IF s.bufpool.tail # buf THEN - (* append buf to the sorted list *) - buf.nexta := NIL; - IF s.bufpool.tail = NIL THEN - s.bufpool.head := buf; - buf.preva := NIL; - ELSE - s.bufpool.tail.nexta := buf; - buf.preva := s.bufpool.tail; - END; - s.bufpool.tail := buf; - END; - END InitBuf; - - PROCEDURE UseBuffer(s: Stream; buf: Buffer); - (* make buf to the current buffer of s *) - BEGIN - IF s.buf # buf THEN - (* remove buf from sorted list *) - IF buf.preva # NIL THEN - buf.preva.nexta := buf.nexta; - ELSE - s.bufpool.head := buf.nexta; - END; - IF buf.nexta # NIL THEN - buf.nexta.preva := buf.preva; - ELSE - s.bufpool.tail := buf.preva; - END; - - (* append buf to sorted list *) - buf.nexta := NIL; - IF s.bufpool.tail = NIL THEN - s.bufpool.head := buf; - buf.preva := NIL; - ELSE - s.bufpool.tail.nexta := buf; - buf.preva := s.bufpool.tail; - END; - s.bufpool.tail := buf; - - (* set current buf of s to buf *) - s.buf := buf; - - (* update s.left and s.write *) - IF buf.rbegin = buf.rend THEN - buf.rbegin := posindex; buf.rend := posindex; s.left := 0; - ELSIF (posindex >= buf.rbegin) & (posindex < buf.rend) THEN - s.left := buf.rend - posindex; - ELSE - s.left := 0; - END; - IF buf.wbegin = buf.wend THEN - buf.wbegin := posindex; buf.wend := posindex; - s.write := bufsize - posindex; - ELSIF (posindex >= buf.wbegin) & (posindex < buf.wend) THEN - s.write := bufsize - posindex; - ELSE - s.write := 0; - END; - END; - END UseBuffer; - - BEGIN (* GetBuffer *) - posindex := s.pos MOD bufsize; - pos := s.pos - posindex; - - IF ~s.buf.ok THEN - (* init first allocated buffer which has not been used until now *) - InitBuf(s.buf); - INC(s.bufpool.nbuf); - ELSIF s.buf.pos # pos THEN - IF FindBuffer(s, pos, buf) THEN - UseBuffer(s, buf); - ELSE - IF s.bufpool.nbuf >= s.bufpool.maxbuf THEN - (* re-use already allocated buffer *) - buf := s.bufpool.head; - UseBuffer(s, buf); - IF buf.wbegin # buf.wend THEN - IF ~InternalFlush(s) THEN END; - END; - - (* remove buf from hash list *) - IF buf.prevh # NIL THEN - buf.prevh.nexth := buf.nexth; - ELSE - index := HashValue(buf.pos); - s.bufpool.bucket[index] := buf.nexth; - END; - IF buf.nexth # NIL THEN - buf.nexth.prevh := buf.prevh; - END; - - InitBuf(buf); - ELSE - (* allocate and initialize new buffer *) - NewBuffer(buf); - InitBuf(buf); - INC(s.bufpool.nbuf); - END; - s.buf := buf; - END; - END; - END GetBuffer; - - PROCEDURE FlushBufPool(s: Stream) : BOOLEAN; - VAR - buf: Buffer; - ok: BOOLEAN; - BEGIN - ok := TRUE; - IF s.bufpool.nbuf > 0 THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - s.buf := buf; - ok := InternalFlush(s) & ok; - buf := buf.nexta; - END; - END; - RETURN ok - END FlushBufPool; - - PROCEDURE ReleaseBufPool(s: Stream); - (* precondition: all buffers are flushed *) - VAR - buf: Buffer; - BEGIN - IF s.bufpool.nbuf > 0 THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - s.buf := buf; - OldBuffer(s.buf); - buf := buf.nexta; - END; - END; - NewBuffer(s.buf); - InitBufPool(s); - END ReleaseBufPool; - - (* ================================================================== *) - - PROCEDURE GetBufMode*(s: Stream) : BufMode; - BEGIN - RETURN s.bufmode - END GetBufMode; - - PROCEDURE LineTerm*(s: Stream; termch: Byte); - (* set line terminator of `s' (linebuf) to `termch' *) - BEGIN - s.error := FALSE; - IF s.bufmode = linebuf THEN - s.termch := termch; - ELSE - Error(s, NotLineBuffered); - END; - END LineTerm; - - PROCEDURE Tie*(in, out: Stream); - (* PRE: `in' is an line buffered input stream, - `out' an output stream, - and `in' # `out'; - causes `out' to be flushed before reading from `in'; - `out' may be NIL to undo the effect - *) - BEGIN - in.error := FALSE; - IF in.bufmode # linebuf THEN - Error(in, NotLineBuffered); RETURN - END; - IF (in = out) OR ~(read IN in.caps) OR - (out # NIL) & ~(write IN out.caps) THEN - Error(in, BadParameters); RETURN - END; - in.tiedStream := out; - END Tie; - - PROCEDURE SetBufferPoolSize*(s: Stream; nbuf: INTEGER); - BEGIN - s.error := FALSE; - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN - END; - IF (s.bufmode = bufpool) & (nbuf >= 1) THEN - s.bufpool.maxbuf := nbuf; - END; - s.lock := FALSE; - END SetBufferPoolSize; - - PROCEDURE GetBufferPoolSize*(s: Stream; VAR nbuf: INTEGER); - BEGIN - s.error := FALSE; - CASE s.bufmode OF - | nobuf: nbuf := 0; - | linebuf: nbuf := 1; - | onebuf: nbuf := 1; - | bufpool: nbuf := s.bufpool.maxbuf; - END; - END GetBufferPoolSize; - - PROCEDURE Capabilities*(s: Stream) : CapabilitySet; - BEGIN - s.error := FALSE; - RETURN s.caps - END Capabilities; - - PROCEDURE GetFlushEvent*(s: Stream; VAR type: Events.EventType); - (* `type' will be raised BEFORE every flush operation *) - BEGIN - s.error := FALSE; - IF s.flushEvent = NIL THEN - Events.Define(s.flushEvent); - END; - type := s.flushEvent; - END GetFlushEvent; - - PROCEDURE GetCloseEvent*(s: Stream; VAR type: Events.EventType); - (* `type' will be raised BEFORE the stream gets closed; - that means write operations etc. are legal - *) - BEGIN - s.error := FALSE; - IF s.closeEvent = NIL THEN - Events.Define(s.closeEvent); - END; - type := s.closeEvent; - END GetCloseEvent; - - PROCEDURE Close*(s: Stream) : BOOLEAN; - VAR - event: Event; - type: Events.EventType; - otherStream: Stream; - BEGIN - s.error := FALSE; - - IF (s.closeEvent # NIL) & ~SYS.TAS(s.lock) THEN - type := s.closeEvent; s.closeEvent := NIL; - s.lock := FALSE; - Events.SetPriority(type, Events.GetPriority() + 1); - NEW(event); - event.type := type; - event.message := "close event of Streams"; - event.stream := s; - Events.Raise(event); - END; - - IF ~SYS.TAS(s.lock) THEN - IF write IN s.caps THEN - IF s.bufmode = bufpool THEN - IF ~FlushBufPool(s) THEN END; - ELSE - IF ~InternalFlush(s) THEN END; - END; - END; - IF close IN s.caps THEN - IF ~s.if.close(s) THEN - Error(s, CloseFailed); - END; - END; - IF s.buf # NIL THEN - IF s.bufmode = bufpool THEN - ReleaseBufPool(s); - END; - OldBuffer(s.buf); - END; - OldStream(s); - - (* check if this stream has been tied to another stream *) - otherStream := opened; - WHILE otherStream # NIL DO - IF otherStream.tiedStream = s THEN - otherStream.tiedStream := NIL; (* undo tie operation *) - END; - otherStream := otherStream.next; - END; - (* s.lock remains TRUE to prevent further operations *) - Resources.Notify(s, Resources.terminated); - RETURN ~s.error - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Close; - - PROCEDURE Release*(s: Stream); - BEGIN - IF ~Close(s) THEN END; - END Release; - - PROCEDURE CloseAll*; - BEGIN - WHILE opened # NIL DO - (* that's no endless loop; see Close/OldStream *) - Release(opened); - END; - END CloseAll; - - PROCEDURE NotificationHandler(event: Events.Event); - VAR - s: Stream; - BEGIN - IF ~(event IS Resources.Event) THEN RETURN END; - WITH event: Resources.Event DO - IF ~(event.resource IS Stream) THEN RETURN END; - s := event.resource(Stream); - IF event.change IN {Resources.unreferenced, Resources.terminated} THEN - IF ~s.lock THEN - Release(s); - END; - END; - END; - END NotificationHandler; - - PROCEDURE Init*(s: Stream; if: Interface; caps: CapabilitySet; - bufmode: BufMode); - - VAR - eventType: Events.EventType; - type: Services.Type; - - PROCEDURE InitBidirectionalBuffering(s: Stream); - BEGIN - s.validpos := TRUE; - s.pos := 0; - NewBuffer(s.wbuf); - s.buf.ok := TRUE; s.buf.rbegin := 0; s.buf.rend := 0; s.buf.pos := 0; - s.wbuf.ok := TRUE; s.wbuf.wbegin := 0; s.wbuf.wend := 0; - s.wbuf.pos := 0; - s.left := 0; s.write := bufsize; - END InitBidirectionalBuffering; - - BEGIN - ASSERT((s # NIL) & (if # NIL) & ({read, write} * caps # {})); - Services.GetType(s, type); ASSERT(type # NIL); - s.inlist := (close IN caps) OR (bufmode # nobuf) & (write IN caps); - NewStream(s); - (* initialize public part *) - s.count := 0; - s.errors := 0; - s.error := FALSE; - s.lasterror := 0; - s.eof := FALSE; - (* private part *) - s.if := if; s.caps := caps; - s.bufmode := bufmode; - s.validpos := FALSE; - s.left := 0; s.write := 0; - s.tiedStream := NIL; - IF bufmode IN {linebuf, onebuf, bufpool} THEN - NewBuffer(s.buf); - IF (bufmode = bufpool) & ~(seek IN caps) THEN - bufmode := onebuf; - END; - CASE bufmode OF - | linebuf: s.termch := defaulttermch; - | bufpool: NEW(s.bufpool); InitBufPool(s); - ELSE - END; - s.maxpos := 0; - s.wextensible := {read, write, seek, tell, holes} * caps = - {read, write, seek, tell}; - s.bidirect := {read, write, seek, tell, trunc} * caps = {read, write}; - IF s.bidirect THEN - InitBidirectionalBuffering(s); - ELSE - s.wbuf := NIL; - END; - ELSE - s.buf := NIL; - s.wbuf := NIL; - s.wextensible := FALSE; - s.bidirect := FALSE; - END; - s.flushEvent := NIL; - s.closeEvent := NIL; - Resources.TakeInterest(s, eventType); - Events.Handler(eventType, NotificationHandler); - s.lock := FALSE; - END Init; - - PROCEDURE Send*(s: Stream; VAR message: Message); - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF handler IN s.caps THEN - s.if.handler(s, message); - ELSE - Error(s, NoHandlerDefined); - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - END Send; - - (* === private i/o procedures ================================= *) - - PROCEDURE ValidPos(s: Stream); - BEGIN - IF ~s.validpos THEN - IF tell IN s.caps THEN - IF ~s.if.tell(s, s.pos) OR (s.pos < 0) THEN - Error(s, TellFailed); - s.pos := 0; - END; - ELSE - s.pos := 0; - END; - s.rpos := s.pos; - s.validpos := TRUE; - s.left := 0; - s.write := 0; - END; - END ValidPos; - - PROCEDURE InitBuf(s: Stream); - BEGIN - IF s.bufmode = bufpool THEN - GetBuffer(s); - ELSE - s.buf.pos := s.pos - s.pos MOD bufsize; - s.buf.wbegin := s.pos MOD bufsize; - s.write := bufsize - s.buf.wbegin; - s.buf.wend := s.buf.wbegin; - s.buf.rbegin := s.buf.wbegin; - s.buf.rend := s.buf.wbegin; - s.left := 0; - s.buf.ok := TRUE; - END; - END InitBuf; - - PROCEDURE FillBuf(s: Stream) : BOOLEAN; - (* return FALSE on EOF or errors *) - VAR - offset, count: Count; - posindex: Count; (* s.pos MOD bufsize *) - - PROCEDURE Fill(s: Stream; VAR offset, count: Count) : BOOLEAN; - (* try to fill buf.cont[offset]..buf.cont[offset+count-1]; - return FALSE on EOF; - Fill always extends a read region: - s.buf.rend is set to offset + the number of bytes read - *) - VAR - linetermseen: BOOLEAN; - byte: Byte; - BEGIN - IF s.eofFound THEN - RETURN FALSE - END; - IF addrio IN s.caps THEN - s.buf.rend := s.if.addrread(s, SYSTEM.ADR(s.buf.cont[offset]), count) + - offset; - ELSIF bufio IN s.caps THEN - s.buf.rend := s.if.bufread(s, s.buf.cont, offset, count) + offset; - ELSIF s.bufmode = linebuf THEN - s.buf.rend := offset; linetermseen := FALSE; - WHILE ~linetermseen & (s.buf.rend < offset+count) & - s.if.read(s, byte) DO - s.buf.cont[s.buf.rend] := byte; INC(s.buf.rend); - linetermseen := byte = s.termch; - END; - s.eofFound := ~linetermseen & - (s.buf.rend < offset+count); (* s.if.read failed? *) - ELSE - s.buf.rend := offset; - WHILE (s.buf.rend < offset+count) & - s.if.read(s, s.buf.cont[s.buf.rend]) DO - INC(s.buf.rend); - END; - s.eofFound := s.buf.rend < offset+count; (* s.if.read failed? *) - END; - (* negative counts of addrread or bufread indicate read errors *) - IF s.buf.rend < offset THEN - (* note error and recover s.buf.rend *) - Error(s, ReadFailed); - s.buf.rend := offset; - END; - INC(s.rpos, s.buf.rend - offset); - IF s.buf.rend > offset THEN - DEC(count, s.buf.rend - offset); - offset := s.buf.rend; - RETURN TRUE - ELSE - s.eofFound := TRUE; - RETURN FALSE - END; - END Fill; - - BEGIN (* FillBuf *) - ValidPos(s); - posindex := s.pos MOD bufsize; - s.eofFound := FALSE; - - (* flush associated output streams (line buffered streams only) *) - IF s.bufmode = linebuf THEN - IF write IN s.caps THEN - IF ~InternalFlush(s) THEN END; - END; - IF (s.tiedStream # NIL) & ~SYS.TAS(s.tiedStream.lock) THEN - IF ~InternalFlush(s.tiedStream) THEN END; - s.tiedStream.lock := FALSE; - END; - END; - - (* get a valid buffer and set - offset and count to the buffer range which is to be filled; - on default, we want to fill the whole buffer - *) - offset := 0; count := bufsize; (* default *) - IF ~s.buf.ok THEN - InitBuf(s); - ELSIF s.bidirect THEN - s.buf.rbegin := 0; s.buf.rend := 0; s.pos := 0; posindex := 0; - ELSE - IF s.bufmode = bufpool THEN - GetBuffer(s); - IF s.left > 0 THEN - (* buffer is already filled *) - s.eof := FALSE; RETURN TRUE - END; - ELSIF s.buf.pos # s.pos - posindex THEN - (* reuse filled buffer *) - IF write IN s.caps THEN - IF ~InternalFlush(s) THEN END; - END; - InitBuf(s); - END; - IF s.buf.rbegin # s.buf.rend THEN - IF (write IN s.caps) & - (s.buf.wbegin <= posindex) & (s.buf.wend > posindex) THEN - (* set read region to write region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.wend - posindex; - s.eof := FALSE; RETURN TRUE - ELSIF s.buf.rend = posindex THEN - (* stream position equals end of read region *) - offset := s.buf.rend; count := bufsize - offset; - END; - END; - - (* take care of the write region by limiting count; - note that s.pos does *not* point into the write region; - this is guaranteed by WritePart and other operations - which would have extended the read region in such a case - *) - IF (write IN s.caps) & (s.buf.wbegin # s.buf.wend) THEN - IF s.buf.wbegin >= offset THEN - IF s.buf.wbegin > posindex THEN - (* write-region behind current position *) - count := s.buf.wbegin - offset; - ELSE - (* write-region before current position *) - offset := s.buf.wend; count := bufsize - offset; - END; - END; - IF (s.buf.pos + s.buf.wbegin = s.rpos) & ~(seek IN s.caps) THEN - (* flush if the start of write region corresponds to real - file position and we are not able to change the position - *) - IF ~InternalFlush(s) THEN END; - END; - END; - END; - - (* set the real position to the position we want to read from *) - IF ~s.bidirect & (s.buf.pos + offset # s.rpos) THEN - IF (seek IN s.caps) & s.if.seek(s, s.buf.pos+offset, fromStart) THEN - s.rpos := s.buf.pos + offset; - ELSIF s.pos = s.rpos THEN - DEC(count, posindex - offset); - offset := posindex; - ELSIF seek IN s.caps THEN - Error(s, SeekFailed); RETURN FALSE - ELSE - Error(s, CannotSeek); RETURN FALSE - END; - END; - - (* try to fill buf[offset..offset+count-1]; - and set s.buf.rbegin & s.buf.rend to the new read region - *) - IF s.buf.rend # offset THEN - (* forget old read region if we cannot extend it *) - s.buf.rbegin := offset; s.buf.rend := offset; - END; - WHILE Fill(s, offset, count) & (posindex >= s.buf.rend) DO END; - - IF posindex >= s.buf.rend THEN - (* read operation failed *) - IF (s.pos > s.rpos) & - (seek IN s.caps) & s.if.seek(s, s.pos, fromStart) THEN - s.rpos := s.pos; - (* second try: we were not able to fill the whole buffer - but perhaps we are able to read what we were requested for - *) - DEC(count, posindex - offset); - offset := posindex; - s.buf.rbegin := offset; s.buf.rend := offset; - s.eofFound := FALSE; (* retry it *) - s.eof := ~Fill(s, offset, count); - ELSE - s.eof := TRUE; - END; - ELSE - s.eof := FALSE; - END; - - IF s.eof THEN - s.left := 0; - ELSE - s.left := s.buf.rend - posindex; - END; - - RETURN ~s.eof - END FillBuf; - - - (* ==== i/o operations ============================================== *) - - PROCEDURE ReadPart*(s: Stream; VAR buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* fill buf[off..off+cnt-1] *) - - VAR - pos: Count; - partcnt: Count; - - PROCEDURE ReadBytesFromBuf(s: Stream; - VAR to: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - VAR - bytes, max, spos: Count; - BEGIN - IF s.left = 0 THEN - IF s.eofFound OR ~FillBuf(s) THEN RETURN FALSE END; - END; - spos := s.pos MOD bufsize; - max := s.left; - IF max > cnt THEN - max := cnt; - END; - bytes := 0; - WHILE bytes < max DO - to[off] := s.buf.cont[spos]; - INC(off); INC(spos); INC(bytes); - END; - INC(s.pos, bytes); DEC(s.left, bytes); INC(s.count, bytes); - IF ~s.bidirect THEN - IF s.write >= bytes THEN - DEC(s.write, bytes); - ELSE - s.write := 0; - END; - END; - RETURN TRUE - END ReadBytesFromBuf; - - BEGIN (* ReadPart *) - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - RETURN FALSE - END; - s.error := FALSE; s.count := 0; - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); RETURN FALSE - ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); RETURN FALSE - END; - IF cnt = 0 THEN s.lock := FALSE; RETURN TRUE END; - IF s.buf # NIL THEN - s.eofFound := FALSE; - WHILE (s.count < cnt) & - ReadBytesFromBuf(s, buf, s.count + off, cnt - s.count) DO - (* s.count is already incremented by ReadBytesFromBuf *) - END; - (* extend write region, if necessary *) - IF ~s.bidirect THEN - pos := s.pos MOD bufsize; - IF (s.write > 0) & (s.buf.wend < pos) THEN - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; - END; - s.buf.wend := pos; - END; - END; - ELSE - IF addrio IN s.caps THEN - s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), cnt); - IF (s.count > 0) & (s.count < cnt) THEN - LOOP - partcnt := s.if.addrread(s, - SYSTEM.ADR(buf[off + s.count]), cnt - s.count); - IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; - ASSERT(partcnt <= cnt - s.count); - INC(s.count, partcnt); - IF s.count = cnt THEN EXIT END; - END; - END; - ELSIF bufio IN s.caps THEN - s.count := s.if.bufread(s, buf, off, cnt); - IF (s.count > 0) & (s.count < cnt) THEN - LOOP - partcnt := s.if.bufread(s, buf, off + s.count, cnt - s.count); - IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; - ASSERT(partcnt <= cnt - s.count); - INC(s.count, partcnt); - IF s.count = cnt THEN EXIT END; - END; - END; - ELSE - s.count := 0; - WHILE (s.count < cnt) & s.if.read(s, buf[s.count+off]) DO - INC(s.count); - END; - END; - IF s.count < 0 THEN - s.count := 0; - Error(s, ReadFailed); - ELSE - s.eof := s.count = 0; - END; - END; - s.lock := FALSE; - RETURN s.count = cnt - END ReadPart; - - PROCEDURE Read*(s: Stream; VAR buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN ReadPart(s, buf, 0, LEN(buf)) - END Read; - - PROCEDURE ReadByte*(s: Stream; VAR byte: Byte) : BOOLEAN; - VAR - ok: BOOLEAN; - pos: Count; - BEGIN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN FALSE - END; - s.error := FALSE; - IF s.left = 0 THEN - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN FALSE - END; - IF s.buf # NIL THEN - IF ~FillBuf(s) THEN - (* FillBuf sets s.eof *) - s.lock := FALSE; - s.count := 0; - RETURN FALSE - END; - ELSE - ok := s.if.read(s, byte); - IF ok THEN - s.count := 1; - ELSE - s.count := 0; - END; - s.eof := ~ok; - s.lock := FALSE; - RETURN ok - END; - END; - (* s.left > 0 *) - s.count := 1; - byte := s.buf.cont[s.pos MOD bufsize]; - INC(s.pos); DEC(s.left); - IF ~s.bidirect & (s.write # 0) THEN - DEC(s.write); - pos := s.pos MOD bufsize; - IF s.buf.wend < pos THEN - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; - END; - s.buf.wend := pos; - END; - END; - (* s.eof has been set by FillBuf *) - s.lock := FALSE; - RETURN TRUE - END ReadByte; - - PROCEDURE ReadPacket*(s: Stream; VAR buf: ARRAY OF Byte; - off, maxcnt: Count) : Count; - (* fill buf[off..] with next packet *) - BEGIN - IF s.left > 0 THEN - IF maxcnt > s.left THEN - maxcnt := s.left; - END; - IF ReadPart(s, buf, off, maxcnt) THEN END; - RETURN s.count - END; - - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - s.count := 0; - RETURN 0 - END; - s.error := FALSE; s.count := 0; - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN 0 - ELSIF (off < 0) OR (off+maxcnt > LEN(buf)) OR (maxcnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); s.count := 0; RETURN 0 - END; - IF maxcnt = 0 THEN s.lock := FALSE; RETURN 0 END; - - IF s.buf # NIL THEN - (* s.left = 0 *) - IF ~FillBuf(s) THEN - (* FillBuf sets s.eof *) - s.lock := FALSE; - RETURN 0 - END; - s.lock := FALSE; - IF maxcnt > s.left THEN - maxcnt := s.left; - END; - IF ReadPart(s, buf, off, maxcnt) THEN END; - RETURN s.count - END; - - (* s.buf = NIL *) - IF addrio IN s.caps THEN - s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), maxcnt); - ELSIF bufio IN s.caps THEN - s.count := s.if.bufread(s, buf, off, maxcnt); - ELSE - s.count := 0; - WHILE (s.count < maxcnt) & s.if.read(s, buf[s.count+off]) DO - INC(s.count); - END; - END; - IF s.count < 0 THEN - s.count := 0; - Error(s, ReadFailed); - ELSE - s.eof := s.count = 0; - END; - s.lock := FALSE; - RETURN s.count - END ReadPacket; - - PROCEDURE WritePart*(s: Stream; - (* read-only *) VAR buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* write buf[off..off+cnt-1] to s *) - VAR - posindex: Count; - - PROCEDURE NewBuffer(s: Stream) : BOOLEAN; - (* flush and get new buffer *) - BEGIN - IF s.pos - posindex # s.buf.pos THEN - IF s.bufmode # bufpool THEN - IF ~InternalFlush(s) THEN RETURN FALSE END; - END; - InitBuf(s); - IF s.write # 0 THEN RETURN TRUE END; - END; - IF s.buf.wbegin = s.buf.wend THEN - (* nothing written into this buffer until now *) - s.buf.wbegin := posindex; s.buf.wend := posindex; - s.write := bufsize - posindex; - ELSIF s.wextensible & (s.buf.rbegin # s.buf.rend) THEN - (* check if the write region may be extended - over parts of the read region - *) - IF s.buf.wend < posindex THEN - (* write region before current position *) - IF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend >= posindex) THEN - s.buf.wend := posindex; - s.write := bufsize - posindex; - END; - ELSE (* s.wbegin > posindex *) - (* write region after current position *) - IF (s.buf.rbegin <= posindex) & (s.buf.rend >= s.buf.wbegin) THEN - s.buf.wbegin := posindex; - s.write := bufsize - posindex; - END; - END; - END; - IF (* still *) s.write = 0 THEN - (* Flush necessary *) - IF ~InternalFlush(s) THEN RETURN FALSE END; - s.buf.wbegin := posindex; s.buf.wend := posindex; - s.write := bufsize - posindex; - END; - RETURN TRUE - END NewBuffer; - - PROCEDURE UpdateReadRegion(s: Stream); - BEGIN - (* update s.left and extend read region, if possible *) - IF s.buf.rbegin = s.buf.rend THEN - (* set read region to write region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.rend - posindex; - ELSIF (s.buf.rbegin < s.buf.wbegin) & (s.buf.rend >= s.buf.wbegin) THEN - (* forward extension of read region possible *) - IF s.buf.rend < s.buf.wend THEN - s.buf.rend := s.buf.wend; - END; - s.left := s.buf.rend - posindex; - ELSIF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend > s.buf.wend) THEN - (* backward extension of read region possible *) - IF s.buf.rbegin > s.buf.wbegin THEN - s.buf.rbegin := s.buf.wend; - END; - s.left := s.buf.rend - posindex; - ELSE - (* posindex does not fall into [s.buf.rbegin..s.buf.rend-1] *) - s.left := 0; - END; - IF s.pos = s.buf.pos + bufsize THEN - s.left := 0; - END; - END UpdateReadRegion; - - BEGIN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN FALSE - END; - s.error := FALSE; s.count := 0; - IF ~(write IN s.caps) THEN - s.lock := FALSE; Error(s, CannotWrite); RETURN FALSE - ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); RETURN FALSE - ELSIF cnt = 0 THEN - s.lock := FALSE; RETURN TRUE - END; - - IF s.buf # NIL THEN - IF s.bidirect THEN - WHILE s.count < cnt DO - IF (s.write = 0) & ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - s.wbuf.cont[s.wbuf.wend] := buf[off + s.count]; - INC(s.wbuf.wend); INC(s.count); DEC(s.write); - IF (s.bufmode = linebuf) & - (buf[s.count+off-1] = s.termch) THEN - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - END; - END; - ELSE - ValidPos(s); - posindex := s.pos MOD bufsize; - IF ~s.buf.ok THEN - InitBuf(s); - END; - - (* copy from buf to s.buf *) - WHILE s.count < cnt DO - IF s.write = 0 THEN - posindex := s.pos MOD bufsize; - IF s.count > 0 THEN - UpdateReadRegion(s); - END; - IF ~NewBuffer(s) THEN - s.lock := FALSE; RETURN FALSE - END; - END; - s.buf.cont[posindex] := buf[off + s.count]; - IF s.buf.wend = posindex THEN - INC(s.buf.wend); - END; - INC(s.count); INC(s.pos); DEC(s.write); INC(posindex); - IF (s.bufmode = linebuf) & - (buf[s.count+off-1] = s.termch) THEN - UpdateReadRegion(s); - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - (* s.pos can be changed by InternalFlush *) - posindex := s.pos MOD bufsize; - END; - END; - UpdateReadRegion(s); - END; - ELSE (* unbuffered stream *) - IF addrio IN s.caps THEN - s.count := s.if.addrwrite(s, SYSTEM.ADR(buf[off]), cnt); - ELSIF bufio IN s.caps THEN - s.count := s.if.bufwrite(s, buf, off, cnt); - ELSE - s.count := 0; - WHILE (s.count < cnt) & s.if.write(s, buf[off+s.count]) DO - INC(s.count); - END; - END; - IF s.count # cnt THEN - Error(s, WriteFailed); - END; - END; - s.lock := FALSE; - RETURN s.count = cnt - END WritePart; - - PROCEDURE Write*(s: Stream; - (* read-only *) VAR buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN WritePart(s, buf, 0, LEN(buf)) - END Write; - - PROCEDURE WritePartC*(s: Stream; buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* write buf[off..off+cnt-1] to s *) - BEGIN - RETURN WritePart(s, buf, off, cnt) - END WritePartC; - - PROCEDURE WriteC*(s: Stream; buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN WritePart(s, buf, 0, LEN(buf)) - END WriteC; - - PROCEDURE WriteByte*(s: Stream; byte: Byte) : BOOLEAN; - VAR - posindex: Count; - BEGIN - IF (s.write > 0) & ~SYS.TAS(s.lock) THEN - s.error := FALSE; s.count := 1; - - IF s.bidirect THEN - s.wbuf.cont[s.wbuf.wend] := byte; INC(s.wbuf.wend); DEC(s.write); - ELSE - (* put byte into s.buf *) - posindex := s.pos MOD bufsize; - s.buf.cont[posindex] := byte; - IF s.buf.wend = posindex THEN - INC(s.buf.wend); - END; - DEC(s.write); - - (* update s.buf.rend and s.left, if necessary *) - IF s.buf.rend = posindex THEN - INC(s.buf.rend); - END; - IF s.left # 0 THEN - DEC(s.left); - ELSIF s.buf.rbegin = s.buf.rend THEN - (* set read-region to write-region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.wend - posindex; - END; - - INC(s.pos); - END; - - IF (s.bufmode = linebuf) & (byte = s.termch) THEN - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - IF ~s.bidirect THEN - s.buf.wbegin := s.pos MOD bufsize; - END; - END; - - s.lock := FALSE; RETURN TRUE - ELSE - RETURN WritePart(s, byte, 0, 1) - END; - END WriteByte; - - PROCEDURE InternalSeek(s: Stream; offset: Count; whence: Whence) : BOOLEAN; - VAR - oldpos: Count; pos: Count; - BEGIN - s.error := FALSE; - IF s.bidirect THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF s.buf = NIL THEN - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; - ELSE - IF ~s.validpos & (seek IN s.caps) THEN - IF (write IN s.caps) & ~InternalFlush(s) THEN END; - IF ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; - IF whence = fromStart THEN - s.validpos := TRUE; - s.pos := offset; s.rpos := offset; - END; - ELSE - ValidPos(s); oldpos := s.pos; - IF s.pos > s.maxpos THEN - s.maxpos := s.pos; - END; - CASE whence OF - | fromStart: IF offset < 0 THEN - Error(s, SeekFailed); RETURN FALSE - END; - s.pos := offset; - | fromPos: IF s.pos + offset < 0 THEN - Error(s, SeekFailed); RETURN FALSE - END; - INC(s.pos, offset); - | fromEnd: IF (write IN s.caps) & ~InternalFlush(s) THEN END; - IF ~(seek IN s.caps) OR - ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; - s.validpos := FALSE; ValidPos(s); - ELSE - Error(s, BadWhence); RETURN FALSE - END; - IF ~(holes IN s.caps) & (s.pos > s.maxpos) THEN - (* if holes are not permitted - we need to check the new position - *) - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF s.if.seek(s, s.pos, fromStart) THEN - s.rpos := s.pos; s.maxpos := s.pos; - ELSE - Error(s, SeekFailed); RETURN FALSE - END; - END; - IF s.buf.ok & (s.pos # oldpos) THEN - (* set s.left and s.write *) - IF (s.pos < s.buf.pos) OR (s.pos >= s.buf.pos + bufsize) THEN - s.left := 0; s.write := 0; - ELSE - pos := s.pos MOD bufsize; - IF s.buf.rbegin = s.buf.rend THEN - s.buf.rbegin := pos; s.buf.rend := pos; - END; - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; s.buf.wend := pos; - END; - IF s.pos > oldpos THEN - IF (pos >= s.buf.rbegin) & (pos < s.buf.rend) THEN - s.left := s.buf.rend - pos; - ELSE - s.left := 0; - END; - IF (pos >= s.buf.wbegin) & (pos <= s.buf.wend) THEN - s.write := bufsize - pos; - ELSE - s.write := 0; - END; - IF s.wextensible & - (s.write < s.left) & (s.buf.wbegin # s.buf.wend) THEN - (* s.write = 0 (else s.write >= s.left); - try to extend write-region to avoid - an unnecessary flush operation - *) - IF (s.buf.wbegin < pos) & - (s.buf.wend >= s.buf.rbegin) THEN - (* write-region is followed by read-region *) - s.buf.wend := pos; s.write := bufsize - pos; - ELSIF (pos < s.buf.wbegin) & - (s.buf.wbegin >= s.buf.rend) THEN - (* read-region is followed by write-region *) - s.buf.wbegin := pos; s.write := bufsize - pos; - END; - END; - ELSE (* s.pos < oldpos *) - IF (pos < s.buf.rbegin) OR (pos > s.buf.rend) THEN - s.left := 0; - ELSE - s.left := s.buf.rend - pos; - END; - IF (pos < s.buf.wbegin) OR (pos > s.buf.wend) THEN - s.write := 0; - ELSE - s.write := bufsize - pos; - END; - END; - END; - END; - END; - END; - IF s.left > 0 THEN - s.eof := FALSE; - END; - RETURN TRUE - END InternalSeek; - - PROCEDURE Seek*(s: Stream; offset: Count; whence: Whence) : BOOLEAN; - VAR - rval: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - rval := InternalSeek(s, offset, whence); - s.lock := FALSE; - RETURN rval - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Seek; - - PROCEDURE Tell*(s: Stream; VAR offset: Count) : BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF tell IN s.caps THEN - IF s.buf # NIL THEN - IF s.validpos THEN - offset := s.pos; - ELSIF s.if.tell(s, s.rpos) THEN - s.validpos := TRUE; - s.pos := s.rpos; - offset := s.pos; - ELSE - s.lock := FALSE; - Error(s, TellFailed); - END; - ELSIF ~s.if.tell(s, offset) THEN - s.lock := FALSE; - Error(s, TellFailed); - END; - ELSE - s.lock := FALSE; - Error(s, CannotTell); - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - RETURN ~s.error - END Tell; - - PROCEDURE GetPos*(s: Stream; VAR offset: Count); - (* IF ~Tell(s, offset) THEN offset := internal position END; *) - BEGIN - IF ~Tell(s, offset) THEN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - ELSE - ValidPos(s); - offset := s.pos; - s.lock := FALSE; - END; - END; - END GetPos; - - PROCEDURE SetPos*(s: Stream; offset: Count); - (* IF ~Seek(s, offset, fromStart) THEN END; *) - BEGIN - IF ~Seek(s, offset, fromStart) THEN END; - END SetPos; - - PROCEDURE ^ Touch*(s: Stream); - - PROCEDURE Trunc*(s: Stream; length: Count) : BOOLEAN; - (* truncate `s' to a total length of `length'; - following holds if holes are permitted: - (1) the current position remains unchanged - (2) the contents between `length' and - the current position is undefined - this call fails if holes are not permitted and the - current position is beyond `length' - *) - VAR - ok: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF (trunc IN s.caps) & (length >= 0) THEN - s.error := FALSE; ok := TRUE; - IF s.buf # NIL THEN - ValidPos(s); - IF ~(holes IN s.caps) & (s.pos > length) THEN - ok := FALSE; - ELSIF (s.bufmode = bufpool) OR s.buf.ok & - (s.buf.pos DIV bufsize >= length DIV bufsize) THEN - Touch(s); - END; - END; - IF ~ok OR ~s.if.trunc(s, length) THEN - s.lock := FALSE; Error(s, TruncFailed); - END; - ELSE - s.lock := FALSE; Error(s, CannotTrunc); - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - RETURN ~s.error - END Trunc; - - PROCEDURE Back*(s: Stream) : BOOLEAN; - (* undo last read operation (one byte); - because of the delayed buffer filling - Back is always successful for buffered streams - immediately after read-operations - *) - VAR - rval: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF read IN s.caps THEN - IF seek IN s.caps THEN - (* fails if s.pos = 0 *) - rval := InternalSeek(s, -1, 1) - ELSIF s.bidirect & s.buf.ok THEN - IF s.pos > 0 THEN - DEC(s.pos); INC(s.left); - rval := TRUE; - ELSE - rval := FALSE; - END; - ELSIF (s.buf # NIL) & s.buf.ok THEN - rval := InternalSeek(s, -1, 1) & (s.left > 0) - ELSE - rval := FALSE - END; - ELSE - s.lock := FALSE; Error(s, CannotRead); - rval := FALSE - END; - s.lock := FALSE; - RETURN rval - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Back; - - PROCEDURE Insert*(s: Stream; byte: Byte) : BOOLEAN; - (* return `byte' on next read-operation *) - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF read IN s.caps THEN - IF s.buf # NIL THEN - (* seek in buffer possible? *) - IF s.bidirect THEN - IF s.pos > 0 THEN - DEC(s.pos); s.buf.cont[s.pos] := byte; - RETURN TRUE - ELSE - RETURN FALSE - END; - ELSIF s.buf.ok & - (s.pos > s.buf.pos+s.buf.rbegin) & - (s.pos < s.buf.pos+s.buf.rend) & - InternalSeek(s, -1, 1) THEN - s.buf.cont[s.pos MOD bufsize] := byte; - s.lock := FALSE; - RETURN TRUE - ELSE - s.lock := FALSE; - RETURN FALSE - END; - ELSE - s.lock := FALSE; Error(s, Unbuffered); RETURN FALSE - END; - ELSE - s.lock := FALSE; Error(s, CannotRead); RETURN FALSE - END; - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Insert; - - PROCEDURE InternalFlush(s: Stream) : BOOLEAN; - - PROCEDURE Write(s: Stream; buf: Buffer) : BOOLEAN; - - VAR - count: Count; - BEGIN - IF addrio IN s.caps THEN - count := s.if.addrwrite(s, SYSTEM.ADR(buf.cont[buf.wbegin]), - buf.wend-buf.wbegin); - ELSIF bufio IN s.caps THEN - count := s.if.bufwrite(s, buf.cont, - buf.wbegin, buf.wend-buf.wbegin); - ELSIF s.if.write(s, buf.cont[buf.wbegin]) THEN - count := 1; - ELSE - count := 0; - END; - IF count < 0 THEN - count := 0; - END; - INC(buf.wbegin, count); INC(s.rpos, count); - RETURN count > 0 - END Write; - - PROCEDURE FlushEvent; - VAR - event: Event; - BEGIN - IF s.flushEvent # NIL THEN - NEW(event); - event.type := s.flushEvent; - event.message := "flush event of Streams"; - event.stream := s; - Events.Raise(event); - END; - END FlushEvent; - - BEGIN - s.error := FALSE; - IF (write IN s.caps) & (s.buf # NIL) & s.buf.ok THEN - IF s.bidirect & (s.wbuf.wend > s.wbuf.wbegin) THEN - FlushEvent; - WHILE (s.wbuf.wend > s.wbuf.wbegin) & Write(s, s.wbuf) DO END; - IF s.wbuf.wend > s.wbuf.wbegin THEN - s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; - Error(s, WriteFailed); RETURN FALSE - END; - s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; - ELSIF ~s.bidirect & (s.buf.wend > s.buf.wbegin) THEN - FlushEvent; - ValidPos(s); - IF s.buf.pos + s.buf.wbegin # s.rpos THEN - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); - (* write in this case at the current position - else there is no easy way to write anyhow - *) - ELSIF ~s.if.seek(s, s.buf.pos + s.buf.wbegin, fromStart) THEN - s.buf.wend := s.buf.wbegin; s.write := 0; - Error(s, SeekFailed); RETURN FALSE - END; - s.rpos := s.buf.pos + s.buf.wbegin; - END; - WHILE (s.buf.wend > s.buf.wbegin) & Write(s, s.buf) DO END; - IF s.buf.wend > s.buf.wbegin THEN - s.buf.wend := s.buf.wbegin; s.write := bufsize - s.buf.wbegin; - Error(s, WriteFailed); RETURN FALSE - END; - IF {seek, tell, trunc} * s.caps = {} THEN - (* unidirectional pipeline; reset s.pos to avoid - unintentional flushes due to buffer boundaries - *) - s.pos := 0; s.rpos := 0; s.buf.pos := 0; - s.buf.wbegin := 0; s.buf.wend := 0; s.write := bufsize; - ELSE - IF (s.pos >= s.buf.pos) & (s.pos < s.buf.pos + bufsize) THEN - s.buf.wbegin := s.pos MOD bufsize; - s.buf.wend := s.buf.wbegin; - s.write := bufsize - s.buf.wbegin; - ELSE - s.write := 0; - END; - END; - END; - END; - RETURN TRUE - END InternalFlush; - - PROCEDURE Flush*(s: Stream) : BOOLEAN; - VAR - ok: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF s.bufmode = bufpool THEN - ok := FlushBufPool(s); - ELSE - ok := InternalFlush(s); - END; - IF ok & (flush IN s.caps) THEN - ok := s.if.flush(s); - IF ~ok THEN - Error(s, FlushFailed); - END; - END; - s.lock := FALSE; - RETURN ok - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Flush; - - PROCEDURE InputInBuffer*(s: Stream) : BOOLEAN; - (* returns TRUE if the next byte to be read is buffered *) - VAR - buf: Buffer; - pos: Count; - BEGIN - IF s.bufmode = bufpool THEN - IF ~s.buf.ok THEN RETURN FALSE END; - pos := s.pos - s.pos MOD bufsize; - IF s.buf.pos # pos THEN - IF ~FindBuffer(s, pos, buf) THEN - RETURN FALSE - END; - pos := s.pos - buf.pos; - RETURN (pos >= buf.rbegin) & (pos < buf.rend) - END; - ELSIF s.bidirect THEN - RETURN s.left > 0 - END; - pos := s.pos MOD bufsize; - RETURN (read IN s.caps) & (s.buf # NIL) & s.buf.ok & - ((s.left > 0) OR - (write IN s.caps) & (s.buf.wbegin <= pos) & (s.buf.wend > pos)) - END InputInBuffer; - - PROCEDURE OutputInBuffer*(s: Stream) : BOOLEAN; - (* returns TRUE if Flush would lead to a write-operation *) - VAR - buf: Buffer; - BEGIN - IF s.bufmode = bufpool THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - IF buf.wbegin # buf.wend THEN RETURN TRUE END; - buf := buf.nexta; - END; - RETURN FALSE - ELSIF s.bidirect THEN - RETURN s.wbuf.wend > s.wbuf.wbegin - ELSE - RETURN (write IN s.caps) & (s.buf # NIL) & s.buf.ok & - (s.buf.wend > s.buf.wbegin) - END; - END OutputInBuffer; - - PROCEDURE OutputWillBeBuffered*(s: Stream) : BOOLEAN; - (* returns TRUE if the next written byte will be buffered *) - VAR - buf: Buffer; - pos: Count; - BEGIN - IF s.bufmode = bufpool THEN - IF s.bufpool.nbuf < s.bufpool.maxbuf THEN RETURN TRUE END; - pos := s.pos - s.pos MOD bufsize; - IF s.buf.pos # pos THEN - IF ~FindBuffer(s, pos, buf) THEN RETURN FALSE END; - IF s.buf.wbegin = s.buf.wend THEN RETURN TRUE END; - pos := s.pos - buf.pos; - RETURN (pos >= buf.wbegin) & (pos <= buf.wend) OR - (buf.wbegin > 0) & (pos + 1 = buf.wbegin) - END; - ELSIF s.bidirect THEN - RETURN s.write > 0 - END; - RETURN (write IN s.caps) & (s.buf # NIL) & - ((s.write > 0) OR ~s.buf.ok) - END OutputWillBeBuffered; - - PROCEDURE Touch*(s: Stream); - (* forget any buffer contents *) - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF write IN s.caps THEN - IF s.bufmode = bufpool THEN - IF ~FlushBufPool(s) THEN END; - ReleaseBufPool(s); - ELSE - IF ~InternalFlush(s) THEN END; - END; - END; - IF flush IN s.caps THEN - IF ~s.if.flush(s) THEN - Error(s, FlushFailed); - END; - END; - IF s.bidirect THEN - s.buf.rbegin := 0; s.buf.rend := 0; s.left := 0; - ELSE - s.validpos := FALSE; - IF s.buf # NIL THEN - s.buf.ok := FALSE; - s.left := 0; - s.write := 0; - s.eofFound := FALSE; - END; - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - END Touch; - - PROCEDURE Copy*(source, dest: Stream; maxcnt: Count) : BOOLEAN; - (* more efficient variants are possible *) - VAR - left, count, copied, read, written: Count; - buffer: ARRAY bufsize OF Byte; - ok: BOOLEAN; - BEGIN - IF maxcnt >= 0 THEN - read := 0; written := 0; ok := TRUE; - left := maxcnt; - LOOP - IF left = 0 THEN - EXIT - END; - ASSERT(left > 0); - IF left > bufsize THEN - count := bufsize; - ELSE - count := left; - END; - - ok := ReadPacket(source, buffer, 0, count) > 0; - ASSERT(source.count <= count); - INC(read, source.count); - IF ~ok THEN EXIT END; - - ok := WritePart(dest, buffer, 0, source.count); - ASSERT(dest.count <= source.count); - INC(written, dest.count); - IF ~ok THEN EXIT END; - - DEC(left, dest.count); - END; - source.count := read; dest.count := written; - RETURN ok - ELSE - copied := 0; - WHILE (ReadPacket(source, buffer, 0, bufsize) > 0) & - WritePart(dest, buffer, 0, source.count) DO - INC(copied, source.count); - END; - source.count := copied; dest.count := copied; - RETURN ~source.error & ~dest.error - END; - END Copy; - - (* === nulldev procedures ========================================== *) - - PROCEDURE NulldevRead(s: Stream; VAR byte: Byte) : BOOLEAN; - BEGIN - byte := 0X; - RETURN FALSE - END NulldevRead; - - PROCEDURE NulldevWrite(s: Stream; byte: Byte) : BOOLEAN; - BEGIN - RETURN TRUE - END NulldevWrite; - - PROCEDURE InitNullIf(VAR nullif: Interface); - BEGIN - NEW(nullif); - nullif.read := NulldevRead; - nullif.write := NulldevWrite; - END InitNullIf; - - PROCEDURE OpenNulldev(VAR s: Stream); - BEGIN - NEW(s); - Services.Init(s, type); - Init(s, nullif, {read, write}, nobuf); - END OpenNulldev; - - PROCEDURE ExitHandler(event: Events.Event); - (* flush all streams on exit; - we do not close them to allow output by other exit event handlers - *) - VAR s: Stream; - BEGIN - s := opened; - WHILE s # NIL DO - IF (s.bufmode # nobuf) & (write IN s.caps) THEN - IF ~Flush(s) THEN END; - END; - s := s.next; - END; - END ExitHandler; - - PROCEDURE FreeHandler(event: Events.Event); - (* set all free lists to NIL to return the associated storage - to the garbage collector - *) - BEGIN - freelist := NIL; - END FreeHandler; - -BEGIN - Services.CreateType(type, "Streams.Stream", ""); - - errormsg[NoHandlerDefined] := "no handler defined"; - errormsg[CannotRead] := "not opened for reading"; - errormsg[CannotSeek] := "not capable of seeking"; - errormsg[CloseFailed] := "close operation failed"; - errormsg[NotLineBuffered] := "stream is not line buffered"; - errormsg[SeekFailed] := "seek operation failed"; - errormsg[TellFailed] := "tell operation failed"; - errormsg[BadWhence] := "bad value of whence parameter"; - errormsg[CannotTell] := "not capable of telling current position"; - errormsg[WriteFailed] := "write operation failed"; - errormsg[CannotWrite] := "not opened for writing"; - errormsg[ReadFailed] := "read operation failed"; - errormsg[Unbuffered] := "operation is not valid for unbuffered streams"; - errormsg[BadParameters] := "bad parameter values"; - errormsg[CannotTrunc] := "not capable of truncating"; - errormsg[TruncFailed] := "trunc operation failed"; - errormsg[NestedCall] := "nested stream operation"; - errormsg[FlushFailed] := "flush operation failed"; - - Events.Define(error); Events.SetPriority(error, Priorities.liberrors); - Events.Ignore(error); - - opened := NIL; - InitNullIf(nullif); - OpenNulldev(null); stdin := null; stdout := null; stderr := null; - - Events.Handler(Process.termination, ExitHandler); - Events.Handler(Process.startOfGarbageCollection, FreeHandler); -END ulmStreams. diff --git a/src/lib/ulm/ulmSysIO.Mod b/src/lib/ulm/ulmSysIO.Mod deleted file mode 100644 index 33959006..00000000 --- a/src/lib/ulm/ulmSysIO.Mod +++ /dev/null @@ -1,343 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysIO.om,v 1.1 1994/02/23 07:59:15 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysIO.om,v $ - Revision 1.1 1994/02/23 07:59:15 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 6/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysIO; - - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, SysErrors := ulmSysErrors, SysTypes := ulmSysTypes; - - CONST - (* file control options: arguments of Fcntl and Open *) - rdonly* = {}; - wronly* = { 0 }; - rdwr* = { 1 }; - append* = { 10 }; - ndelay* = { 11 }; (* O_NONBLOCK that works like former O_NDELAY *) - creat* = { 6 }; - trunc* = { 9 }; - excl* = { 7 }; - noctty* = { 8 }; - sync* = { 12 }; - fasync* = { 13 }; - direct* = { 14 }; - largefile* = { 15 }; - directory* = { 16 }; - nofollow* = { 17 }; - - (* Whence = (fromStart, fromPos, fromEnd); *) - fromStart* = 0; - fromPos* = 1; - fromEnd* = 2; - - (* file descriptor flags *) - closeonexec* = { 0 }; - - (* Fcntl requests *) - dupfd* = 0; (* duplicate file descriptor *) - getfd* = 1; (* get file desc flags (close-on-exec) *) - setfd* = 2; (* set file desc flags (close-on-exec) *) - getfl* = 3; (* get file flags *) - setfl* = 4; (* set file flags (ndelay, append) *) - getlk* = 5; (* get file lock *) - setlk* = 6; (* set file lock *) - setlkw* = 7; (* set file lock and wait *) - setown* = 8; (* set owner (async IO) *) - getown* = 9; (* get owner (async IO) *) - setsig* = 10; (* set SIGIO replacement *) - getsig* = 11; (* get SIGIO replacement *) - - TYPE - File* = SysTypes.File; (* file descriptor *) - Address* = SysTypes.Address; - Count* = SysTypes.Count; - Protection* = LONGINT; - Whence* = LONGINT; - - PROCEDURE OpenCreat*(VAR fd: File; - filename: ARRAY OF CHAR; options: SET; - protection: Protection; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; - (* the filename must be 0X-terminated *) - VAR - d0, d1: (*INTEGER*)LONGINT; - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1, - SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN - fd := d0; - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.open, filename); - RETURN FALSE - END; - END; - END; - END OpenCreat; - - PROCEDURE Open*(VAR fd: File; - filename: ARRAY OF CHAR; options: SET; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; - (* the filename must be 0X-terminated *) - BEGIN - RETURN OpenCreat(fd, filename, options, 0, errors, retry, interrupted) - END Open; - - PROCEDURE Close*(fd: File; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; - VAR - d0, d1: LONGINT; - a0, a1 : LONGINT; (* just to match UNIXCALL interface *) - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN - (*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*) - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.close, ""); - RETURN FALSE - END; - END; - END; - END Close; - - PROCEDURE Read*(fd: File; buf: Address; cnt: Count; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; - (* return value of 0: EOF - -1: I/O error - >0: number of bytes read - *) - VAR - d0, d1: LONGINT; - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN - RETURN d0 - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.read, ""); - RETURN -1 - END; - END; - END; - END Read; - - PROCEDURE Write*(fd: File; buf: Address; cnt: Count; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; - (* return value of -1: I/O error - >=0: number of bytes written - *) - VAR - d0, d1: LONGINT; - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN - RETURN d0 - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.write, ""); - RETURN -1 - END; - END; - END; - END Write; - - PROCEDURE Seek*(fd: File; offset: Count; whence: Whence; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, offset, whence) THEN - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.lseek, ""); - RETURN FALSE - END; - END Seek; - - PROCEDURE Tell*(fd: File; VAR offset: Count; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, 0, fromPos) THEN - offset := d0; - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.lseek, ""); - RETURN FALSE - END; - END Tell; - - PROCEDURE Isatty*(fd: File) : BOOLEAN; - CONST - sizeofStructTermIO = 18; - tcgeta = 00005405H; - VAR - d0, d1: LONGINT; - buf: ARRAY 32 OF SYS.BYTE; (* Should be more than sufficient *) - BEGIN - (* following system call fails for non-tty's *) - RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf)) - END Isatty; - - PROCEDURE Fcntl*(fd: File; request: INTEGER; VAR arg: LONGINT; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; - VAR - d0, d1: LONGINT; - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, arg) THEN - arg := d0; - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE - END; - END; - END; - END Fcntl; - - PROCEDURE FcntlSet*(fd: File; request: INTEGER; flags: SET; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; - VAR - d0, d1: LONGINT; - BEGIN - interrupted := FALSE; - LOOP - IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, SYS.VAL(LONGINT, flags)) THEN - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE - END; - END; - END; - END FcntlSet; - - PROCEDURE FcntlGet*(fd: File; request: INTEGER; VAR flags: SET; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, 0) THEN - ulmSYSTEM.WMOVE(SYS.ADR(d0), SYS.ADR(flags), 1); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE - END; - END FcntlGet; - - PROCEDURE Dup*(fd: File; VAR newfd: File; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - a0, a1: LONGINT; - BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.dup, d0, d1, fd, a0, a1) THEN - newfd := d0; - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.dup, ""); - RETURN FALSE - END; - END Dup; - - PROCEDURE Dup2*(fd, newfd: File; errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - a0, a1: LONGINT; - fd2: File; - interrupted: BOOLEAN; - BEGIN - fd2 := newfd; - (* handmade close to avoid unnecessary events *) - IF ~ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, newfd, a0, a1) THEN END; - IF Fcntl(fd, dupfd, fd2, errors, TRUE, interrupted) THEN - IF fd2 = newfd THEN - RETURN TRUE - ELSE - RETURN Close(fd2, errors, TRUE, interrupted) & FALSE - END; - ELSE - RETURN FALSE - END; - END Dup2; - - PROCEDURE Pipe*(VAR readfd, writefd: File; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: LONGINT; - a0, a1: LONGINT; - fds : ARRAY 2 OF (*File*)INTEGER; (* it needs int pipefd[2], and int is 4 bytes long on x86_64 -- noch *) - BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.pipe, d0, d1, SYS.ADR (fds), a0, a1) THEN - readfd := fds[0]; writefd := fds[1]; - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.pipe, ""); - RETURN FALSE - END; - END Pipe; - -END ulmSysIO. diff --git a/src/lib/ulm/ulmTCrypt.Mod b/src/lib/ulm/ulmTCrypt.Mod deleted file mode 100644 index e1909085..00000000 --- a/src/lib/ulm/ulmTCrypt.Mod +++ /dev/null @@ -1,1762 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: TCrypt.om,v 1.1 1997/04/02 11:54:02 borchert Exp borchert $ - ---------------------------------------------------------------------------- - $Log: TCrypt.om,v $ - Revision 1.1 1997/04/02 11:54:02 borchert - Initial revision - - ---------------------------------------------------------------------------- -*) - -MODULE ulmTCrypt; (* Michael Szczuka *) - - (* Trautner's association method for key exchange *) - - IMPORT AsymmetricCiphers := ulmAsymmetricCiphers, BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, Conclusions := ulmConclusions, Events := ulmEvents, - NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Random := ulmRandomGenerators, RelatedEvents := ulmRelatedEvents, - Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM; - - CONST - M = 16; (* size of an element of CC(M) [ring of Circular Convolution] *) - MaxVar = 8; (* number of variables of a polynomial *) - MaxNrExp = 4; (* maxiumum number of different exponts used during - initialisaton *) - Dim = 2; (* dimension of the linear recursion *) - Rounds = 16; (* length of the linear recursion in rounds *) - LastRounds = 4; (* use the last LastRounds polynomial vectors as - the composed function eta *) - reg = 1; sing = 2; random = 3; - LIST = TRUE; NOLIST = FALSE; - MaxTerms = 1000; - - CONST - writeSetFailed = 0; - readSetFailed = 1; - notRegular = 2; - errorcodes = 3; - - TYPE - (* an element out of CC(M) *) - CCMElement = SET; - Exponent = ARRAY MaxVar OF SHORTINT; - - TYPE - (* a polynomial with coefficients out of CC(M) *) - Polynom = POINTER TO PolynomRec; - PolynomRec = RECORD - koeff : CCMElement; - exp : Exponent; - next : Polynom; - END; - - TYPE - VektorCCM = ARRAY Dim OF CCMElement; - VektorPolynom = ARRAY Dim OF Polynom; - MatCCM = ARRAY Dim, Dim OF CCMElement; - MatPolynom = ARRAY Dim, Dim OF Polynom; - ListCCM = ARRAY Rounds OF CCMElement; - ListPolynom = ARRAY Rounds OF Polynom; - ChainCCM = ARRAY Rounds OF VektorCCM; - ChainPolynom = ARRAY Rounds OF VektorPolynom; - (* to increase the performance of the algorithm there shouldn't be too - many different exponents to start with *) - ListExp = ARRAY MaxNrExp OF Exponent; - - TYPE - (* this type is the input of the TCrypt method *) - TCryptInput = POINTER TO TCryptInputRec; - TCryptInputRec = RECORD - arg : ARRAY MaxVar OF CCMElement; - END; - - TYPE - (* result type after encryption with the public key *) - TCryptTmp = POINTER TO TCryptTmpRec; - TCryptTmpRec = RECORD - numerator : ChainCCM; - denominator : ListCCM; - END; - - TYPE - (* result type of the algorithm *) - TCryptRes = POINTER TO TCryptResRec; - TCryptResRec = RECORD - arg : ARRAY LastRounds OF VektorCCM; - END; - - TYPE - (* this type represents the public function f resp. phi *) - Phi = POINTER TO PhiRec; - PhiRec = RECORD - num : ChainPolynom; - denom : ListPolynom; - END; - - TYPE - (* the private/secret function g resp. psi consisting of an inital matrix - and a permutation *) - Psi = POINTER TO PsiRec; - PsiRec = RECORD - (* although the inital matrix consists only of elements out of CC(M) - this generalization is useful since all other matrces consist of - polynomials *) - initialmatrix : MatCCM; - (* correcting factors *) - korrNum : ChainCCM; - korrDenom : ListCCM; - END; - - (* the public function h resp. eta being the composition of f/phi - and g/psi *) - TYPE - Eta = POINTER TO EtaRec; - EtaRec = RECORD - p : ARRAY LastRounds OF VektorPolynom; - END; - - TYPE - (* the declaration of a basic type which PublicCipher and PrivateCipher - are descendents from seems a good idea ... at least to me :) *) - Cipher* = POINTER TO CipherRec; - CipherRec* = RECORD (AsymmetricCiphers.CipherRec) END; - (* the specific format of a public key for Trautner's technique *) - PublicCipher = POINTER TO PublicCipherRec; - PublicCipherRec = RECORD - (CipherRec) - phi : Phi; - eta : Eta; - END; - (* the specific format of a key for Trautner's technique *) - PrivateCipher = POINTER TO PrivateCipherRec; - PrivateCipherRec = RECORD - (CipherRec) - phi : Phi; - psi : Psi; - eta : Eta; - END; - - TYPE - ErrorEvent = POINTER TO ErrorEventRec; - ErrorEventRec = RECORD - (Events.EventRec) - errorcode : SHORTINT; - END; - - VAR - pubType, privType, cipherType : Services.Type; - pubIf, privIf, cipherIf : PersistentObjects.Interface; - NullCCM, EinsCCM : CCMElement; (* the zero and unit of CC(M) *) - NullExp : Exponent; (* consists of zero exponents *) - NullExpList : ListExp; (* a pseudo list for CreatePolynom *) - GlobalExpList : ListExp; (* contains the exponents which should be used - when calling CreatePolynom *) - NullPolynom : Polynom; (* the zero polynomial *) - PolFeld : ARRAY MaxTerms OF Polynom; (* used for sorting purposes *) - PreEvalArg : ARRAY M OF TCryptInput; (* precomputed values to speed - up evaluation of a polynomial *) - k : SHORTINT; (* simple counter during initialisation *) - error : Events.EventType; - errormsg : ARRAY errorcodes OF Events.Message; - - - (* ***** error handling ***** *) - - PROCEDURE InitErrorHandling; - BEGIN - Events.Define(error); - errormsg[writeSetFailed] := "couldn't write set"; - errormsg[readSetFailed] := "couldn't read set"; - errormsg[notRegular] := "element isn't regular"; - END InitErrorHandling; - - PROCEDURE Error(s: Streams.Stream; errorcode: SHORTINT); - VAR - event: ErrorEvent; - BEGIN - NEW(event); - event.message := errormsg[errorcode]; - event.type := error; - event.errorcode := errorcode; - RelatedEvents.Raise(s, event); - END Error; - - (* ***** arithmetic functions for elements out of CC(M) ***** *) - - PROCEDURE RegulaerCCM (x: CCMElement) : BOOLEAN; - (* tests x for regularity [a regular CCMElement contains an odd number of - set bits]; returns TRUE when x is regular, FALSE otherwise *) - VAR - res, i : SHORTINT; - BEGIN - i := 0; - res := 0; - REPEAT (* counting the set bits *) - IF i IN x THEN - INC(res); - END; - INC(i); - UNTIL i>=M; - RETURN ((res MOD 2) = 1); - END RegulaerCCM; - - PROCEDURE EqualCCM (x, y: CCMElement) : BOOLEAN; - (* compares x and y for equality; if x and y are equal TRUE is returned, - FALSE otherwise *) - VAR - i : SHORTINT; - BEGIN - i := 0; - WHILE i < M DO - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - RETURN FALSE; - END; - INC(i); - END; - RETURN TRUE; - END EqualCCM; - - PROCEDURE AddCCM (x, y: CCMElement; VAR z: CCMElement); - (* add x and y in CC(M) *) - VAR - i : SHORTINT; - BEGIN - z := NullCCM; - i := 0; - REPEAT - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - z := z + {i}; - END; - INC(i); - UNTIL i>=M; - END AddCCM; - - PROCEDURE MulCCM (x, y: CCMElement; VAR z: CCMElement); - (* multiply x and y in CC(M) *) - VAR - i, j, diff : SHORTINT; - tmp : INTEGER; - BEGIN - z := NullCCM; - i := 0; - REPEAT - j := 0; - tmp := 0; - REPEAT - diff := i-j; - IF diff >= 0 THEN - IF (j IN x) & (diff IN y) THEN - INC(tmp); - END; - ELSE - IF (j IN x) & ((M+diff) IN y) THEN - INC(tmp); - END; - END; - INC(j); - UNTIL j>=M; - IF (tmp MOD 2) = 1 THEN - z := z + {i}; - END; - INC(i); - UNTIL i>=M; - END MulCCM; - - PROCEDURE PowerCCM (x: CCMElement; exp: INTEGER; VAR z: CCMElement); - (* raises x to the power exp in CC(M) *) - VAR - tmp : CCMElement; - BEGIN - (* some special cases first *) - IF exp >= M THEN - IF ~RegulaerCCM(x) THEN - (* x is singular -> result is zero *) - z := NullCCM; - RETURN; - END; - (* x is regular -> compute the modulus of exp mod M and use this - instead of exp *) - exp := exp MOD M; - END; - IF exp = 0 THEN - z := EinsCCM; - RETURN; - END; - IF exp = 1 THEN - z := x; - RETURN; - END; - - (* default case; use a "square and multiply" technique *) - tmp := x; - z := EinsCCM; - REPEAT - IF exp MOD 2 = 1 THEN - MulCCM(z, tmp, z); - END; - exp := exp DIV 2; - MulCCM(tmp, tmp, tmp); - UNTIL exp < 1; - END PowerCCM; - - PROCEDURE CreateCCM (VAR x: CCMElement; mode: SHORTINT); - (* creates a random element out of CC(M) depending on mode which - can be reg, sing or random; - the result is in any case different from the zero *) - VAR - i, SetBits: SHORTINT; - BEGIN - x := NullCCM; - REPEAT - i := 0; - SetBits := 0; - REPEAT - IF Random.Flip() THEN - (* set bit *) - x := x + {i}; - INC(SetBits); - END; - INC(i); - UNTIL i >= (M-1); - UNTIL SetBits > 0; (* at least one bit must be set so that the result - differs from zero *) - - CASE mode OF - random: - IF Random.Flip() THEN - x := x + {M-1}; - END; - | sing: (* singular element - even # of bits *) - IF (SetBits MOD 2) = 1 THEN - x := x + {M-1}; - END; - | reg: (* regular element - odd # of bits *) - IF ((SetBits + 1) MOD 2) = 1 THEN - x := x + {M-1}; - END; - END; - END CreateCCM; - - (* ***** arithmetic functions for polynomials over CC(M) ***** *) - - PROCEDURE LengthPolynom(p: Polynom) : INTEGER; - (* returns the number of terms which make up the polynomial p *) - VAR - i : INTEGER; - BEGIN - i := 0; - WHILE p # NIL DO - INC(i); - p := p.next; - END; - RETURN i; - END LengthPolynom; - - PROCEDURE RegulaerPolynom (p: Polynom) : BOOLEAN; - (* tests the regularity of a polynomial [a polynomial is regular - iff the # of regular coefficients is odd] *) - VAR - regkoeffs : SHORTINT; - BEGIN - regkoeffs := 0; - WHILE p # NIL DO - IF RegulaerCCM(p.koeff) THEN - (* count # of reg. coefficients *) - INC(regkoeffs); - END; - p := p.next; - END; - RETURN (regkoeffs MOD 2) = 1; - END RegulaerPolynom; - - PROCEDURE CmpExp (exp1, exp2: Exponent) : SHORTINT; - (* compares two exponent vectors and returns 0 on equality, a - positive value if exp1>exp2 and a negative value if exp1 e2 THEN - cmp := 1; diff := TRUE; - END; - END; - INC(i); - UNTIL i >= MaxVar; - - IF sum1 < sum2 THEN - RETURN -2; - END; - IF sum1 > sum2 THEN - RETURN 2; - END; - - RETURN cmp - END CmpExp; - - PROCEDURE ArrangePolynom (VAR p: Polynom); - (* arrange a polynomial according to the order given by CmpExp *) - VAR - r : Polynom; - cnt : INTEGER; - - PROCEDURE SortPolynom(left, right: INTEGER); - (* sort the global field PolFeld with the quicksort algorithm *) - VAR - mid : INTEGER; - - PROCEDURE Partition(l, r: INTEGER) : INTEGER; - VAR - koeff : CCMElement; - exp : Exponent; - cmp : Exponent; - i, j : INTEGER; - BEGIN - cmp := PolFeld[(l+r) DIV 2].exp; - i := l-1; - j := r+1; - LOOP - REPEAT - DEC(j); - UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; - REPEAT - INC(i); - UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; - IF i < j THEN - koeff := PolFeld[i].koeff; - exp := PolFeld[i].exp; - PolFeld[i].koeff := PolFeld[j].koeff; - PolFeld[i].exp := PolFeld[j].exp; - PolFeld[j].koeff := koeff; - PolFeld[j].exp := exp; - ELSE - RETURN j; - END; - END; - END Partition; - - BEGIN - IF left < right THEN - mid := Partition(left, right); - SortPolynom(left, mid); - SortPolynom(mid+1, right); - END; - END SortPolynom; - - BEGIN (* ArrangePolynom *) - IF p = NIL THEN - RETURN; - END; - r := p; - cnt := 0; - WHILE (p # NIL) & (cnt < MaxTerms) DO - PolFeld[cnt] := p; - INC(cnt); - p := p.next; - END; - (* polynomial contains too many terms; this shouldn't happen if all - parameters are set to reasonable values and MaxTerms is high - enough *) - ASSERT(cnt 1 THEN - SortPolynom(0, cnt-1); - END; - p := r; - END ArrangePolynom; - - PROCEDURE CopyPolynom (s: Polynom; VAR t: Polynom); - (* copy the source polynomial s to a new target t *) - VAR - troot : Polynom; - BEGIN - IF s = NIL THEN - t := NIL; - RETURN; - END; - NEW(t); - troot := t; (* save the root of t *) - WHILE s # NIL DO - troot.koeff := s.koeff; - troot.exp := s.exp; - s := s.next; - IF s # NIL THEN - NEW(troot.next); - troot := troot.next; - ELSE - troot.next := NIL; - END; - END; - END CopyPolynom; - - PROCEDURE AddPolynom (p, q: Polynom; VAR r: Polynom); - (* add two polynomial; the polynomials must be sorted by the exponents as - is the result *) - VAR - term1, term2 : Polynom; - last : Polynom; (* the last term of the result *) - tmp : Polynom; - cmpres : SHORTINT; - BEGIN - IF (p = NIL) & (q = NIL) THEN - r := NIL; - RETURN; - END; - NEW(r); - term1 := p; (* term1 runs through all terms of p *) - term2 := q; (* same with term2 for q *) - tmp := r; (* save the root of r *) - last := tmp; - REPEAT - IF (term1 = NIL) OR (term2 = NIL) THEN - IF term2 = NIL THEN - (* no further terms in q *) - WHILE term1 # NIL DO - (* copy the remaining terms of p *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - ELSE (* no further terms in p *) - WHILE term2 # NIL DO - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - END; - ELSE (* both p and q still have a term *) - cmpres := CmpExp(term1.exp, term2.exp); - IF cmpres = 0 THEN (* add when exponents are equal *) - AddCCM(term1.koeff, term2.koeff, tmp.koeff); - tmp.exp := term1.exp; - term1 := term1.next; - term2 := term2.next; - ELSE - IF cmpres < 0 THEN (* exp2 > exp1 *) - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - ELSE (* exp1 > exp2 *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - END; - END; - (* zero coefficients = zero terms shouldn't occur in the result *) - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - NEW(tmp.next); - last := tmp; - tmp := tmp.next; - END; - END; - UNTIL (term1 = NIL) & (term2 = NIL); - - (* forget last created term *) - last.next := NIL; - END AddPolynom; - - PROCEDURE MulTerm (p, term: Polynom; VAR r: Polynom); - (* multiply a polynomial with a single term; is used by MulPolynom *) - VAR - tmp : Polynom; - last : Polynom; - - (* add two exponent vetors; addition is modulo M *) - PROCEDURE AddExp (exp1, exp2 : Exponent; VAR res: Exponent); - VAR - i : SHORTINT; - BEGIN - i := 0; - WHILE i 0 DO - IF (exp MOD 2) = 1 THEN - MulPolynom(res, tmp, res); - END; - MulPolynom(tmp, tmp, tmp); - exp := exp DIV 2; - END; - END InvertPolynom; - - PROCEDURE EvalPolynom (p: Polynom; VAR res: CCMElement); - (* evaluate p; a precomputed list of all the powers of the argument can - be found in the global variable PreEvalArg *) - VAR - i : SHORTINT; - pow, prod : CCMElement; - BEGIN - res := NullCCM; - IF p = NIL THEN - RETURN; - END; - WHILE p # NIL DO - prod := PreEvalArg[p.exp[0]].arg[0]; - i := 1; - REPEAT - pow := PreEvalArg[p.exp[i]].arg[i]; - MulCCM(prod, pow, prod); - INC(i); - UNTIL i >= MaxVar; - MulCCM(prod, p.koeff, prod); - AddCCM(res, prod, res); - p := p.next; - END; - END EvalPolynom; - - PROCEDURE CreateExp (VAR exp: Exponent); - (* creates a random vector of exponents *) - VAR - i : SHORTINT; - BEGIN - i := 0; - WHILE i 0 DO - IF (kk MOD 2) = 1 THEN - MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); - END; - INC(ii,ii); - kk := kk DIV 2; - END; - PreEvalArg[k].arg[i] := tmp; - INC(k); - END; - INC(i); - END; - END PreComputeArgs; - - PROCEDURE EvaluatePhi (arg: TCryptInput; data: Phi) : TCryptTmp; - (* evaluate the public function phi (represented by data) with - argument arg *) - VAR - res : TCryptTmp; - r, d : SHORTINT; - BEGIN - NEW(res); - PreComputeArgs(arg); - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.num[r][d], res.numerator[r][d]); - INC(d); - END; - EvalPolynom(data.denom[r], res.denominator[r]); - INC(r); - END; - RETURN res; - END EvaluatePhi; - - PROCEDURE EvaluatePsi (arg: TCryptTmp; data: Psi) : TCryptRes; - (* evalute the private function psi *) - VAR - res : TCryptRes; - mat, prev : MatCCM; - num, denom, inv : CCMElement; - vek : VektorCCM; - A : ChainCCM; - r, d : SHORTINT; - BEGIN - (* first correct the input with the correlating inverts *) - MulCCM(arg.denominator[0], data.korrDenom[0], denom); - PowerCCM(denom, M-1, inv); - MulCCM(arg.numerator[0][0], data.korrNum[0][0], num); - MulCCM(num, inv, vek[0]); - MulCCM(arg.numerator[0][1], data.korrNum[0][1], num); - MulCCM(num, inv, vek[1]); - MulMatrix(data.initialmatrix, vek, A[0]); - prev := data.initialmatrix; - r := 1; - WHILE r < Rounds DO - (* the matrix for the current round of the recursion must be computed - each round *) - BuildMatrix(mat, prev, A[r-1]); - prev := mat; - MulCCM(arg.denominator[r], data.korrDenom[r], denom); - PowerCCM(denom, M-1, inv); - MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); - MulCCM(num, inv, vek[0]); - MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); - MulCCM(num, inv, vek[1]); - MulMatrix(mat, vek, A[r]); - INC(r); - END; - NEW(res); - r := 0; - WHILE r < LastRounds DO - d := 0; - WHILE d < Dim DO - res.arg[r][d] := A[Rounds-LastRounds+r][d]; - INC(d); - END; - INC(r); - END; - RETURN res; - END EvaluatePsi; - - PROCEDURE EvaluateEta (arg: TCryptInput; data: Eta) : TCryptRes; - (* evaluate the public function eta (composition of phi and psi) *) - VAR - l, d : SHORTINT; - res : TCryptRes; - BEGIN - NEW(res); - PreComputeArgs(arg); - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.p[l][d], res.arg[l][d]); - INC(d); - END; - INC(l); - END; - RETURN res; - END EvaluateEta; - - PROCEDURE Eof (s: Streams.Stream) : BOOLEAN; - (* returns TRUE if no bytes are left to read from stream s *) - VAR - b : SYS.BYTE; - BEGIN - RETURN ~Streams.ReadByte(s, b) OR ~Streams.Back(s); - END Eof; - - PROCEDURE Encrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for Ciphers.Encrypt *) - VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptTmp; - wholeStream : BOOLEAN; - BEGIN - (* check if the whole stream msg shall be encrypted or only a certain - amount of bytes *) - IF length <= 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE - END; - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - IF ~RegulaerCCM(ccmarg.arg[i]) THEN - Error(msg, notRegular); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); - ELSE - ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); - END; - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(i); - END; - DEC(length, MaxVar*(M DIV 8)); - END; - RETURN TRUE; - END Encrypt; - - PROCEDURE Decrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for Ciphers.Decrypt *) - VAR - i, j : SHORTINT; - inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; - ccmarg : TCryptTmp; - ccmres : TCryptRes; - wholeStream : BOOLEAN; - BEGIN - IF length < 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE; - END; - WITH key:PrivateCipher DO - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - ccmres := EvaluatePsi(ccmarg, key.psi); - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, Rounds*Dim*(M DIV 8)); - END; - END; - RETURN TRUE; - END Decrypt; - - PROCEDURE ComposedEncrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for AsymmetricCiphers.ComposedEncrypt *) - VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptRes; - in, out : ARRAY (M DIV 8) OF SYS.BYTE; - wholeStream : BOOLEAN; - BEGIN - IF length < 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE; - END; - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); - ELSE - ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); - END; - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, MaxVar*(M DIV 8)); - END; - RETURN TRUE; - END ComposedEncrypt; - - PROCEDURE RandomStream (s: Streams.Stream); - (* writes some random elements of CC(M) to the stream s which can then - be used as an input for Trautner's TCRYPT *) - VAR - ccm : CCMElement; - bytes : ARRAY M DIV 8 OF SYS.BYTE; - i : INTEGER; - BEGIN - i := 0; - WHILE i < MaxVar DO - CreateCCM(ccm, reg); - IF ~NetIO.WriteSet(s, ccm) THEN - Error(s, writeSetFailed); - END; - INC(i); - END; - END RandomStream; - - PROCEDURE PublicCipherCreate (VAR obj: PersistentObjects.Object); - (* constructor for a public cipher *) - VAR - pub : PublicCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; - BEGIN - NEW(pub); NEW(pub.phi); NEW(pub.eta); - PersistentObjects.Init(pub, pubType); - NEW(if); if.encrypt := Encrypt; if.decrypt := NIL; - if.compencrypt := ComposedEncrypt; if.split := NIL; - if.randomStream := RandomStream; - caps := {AsymmetricCiphers.composed}; - AsymmetricCiphers.Init(pub, if, caps, M*MaxVar, M*Dim); - obj := pub; - END PublicCipherCreate; - - PROCEDURE Split (VAR public: AsymmetricCiphers.Cipher; - key: AsymmetricCiphers.Cipher); - (* interface procedure for asymmetric interface *) - VAR - pub: PublicCipher; - BEGIN - WITH key:PrivateCipher DO - PublicCipherCreate(SYS.VAL(PersistentObjects.Object, pub)); - pub.phi := key.phi; - pub.eta := key.eta; - public := pub; - END; - END Split; - - PROCEDURE CipherCreate (VAR obj: PersistentObjects.Object); - (* constructor for a private cipher *) - VAR - key : PrivateCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; - BEGIN - NEW(key); NEW(key.phi); NEW(key.psi); NEW(key.eta); - PersistentObjects.Init(key, privType); - NEW(if); if.encrypt := Encrypt; if.decrypt := Decrypt; - if.compencrypt := ComposedEncrypt; if.split := Split; - if.randomStream := RandomStream; - caps := {AsymmetricCiphers.composed, AsymmetricCiphers.isPrivateKey}; - AsymmetricCiphers.Init(key, if, caps, M*MaxVar, M*Dim); - obj := key; - END CipherCreate; - - PROCEDURE Create* (VAR key: Ciphers.Cipher); - (* creates a cipher for the use with Trautner's TCRYPT algorithm *) - VAR - tmpKey : PrivateCipher; - phi : Phi; - psi : Psi; - eta : Eta; - BEGIN - CipherCreate(SYS.VAL(PersistentObjects.Object, tmpKey)); - CreateMaps(tmpKey.phi, tmpKey.psi, tmpKey.eta); - key := tmpKey; - END Create; - - PROCEDURE WritePolynom (s: Streams.Stream; p: Polynom) : BOOLEAN; - (* writes the polynomial p onto the stream s *) - CONST - index = M DIV 8; - VAR - nrOfTerms, i : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - nrOfTerms := LengthPolynom(p); - IF ~NetIO.WriteInteger(s, nrOfTerms) THEN - RETURN FALSE; - END; - WHILE nrOfTerms > 0 DO - IF ~NetIO.WriteSet(s, p.koeff) THEN - RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN - RETURN FALSE; - END; - INC(i); - END; - p := p.next; - DEC(nrOfTerms); - END; - RETURN TRUE; - END WritePolynom; - - PROCEDURE ReadPolynom (s: Streams.Stream; VAR p: Polynom) : BOOLEAN; - (* reads a polynomial from stream s *) - CONST - index = M DIV 8; - VAR - nrOfTerms, i : INTEGER; - pol : Polynom; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - IF ~NetIO.ReadInteger(s, nrOfTerms) THEN - RETURN FALSE; - END; - NEW(p); - pol := p; - WHILE nrOfTerms > 0 DO - IF ~NetIO.ReadSet(s, pol.koeff) THEN - RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN - RETURN FALSE; - END; - INC(i); - END; - DEC(nrOfTerms); - IF nrOfTerms > 0 THEN - NEW(pol.next); - pol := pol.next; - END - END; - RETURN TRUE; - END ReadPolynom; - - PROCEDURE PhiWrite (s: Streams.Stream; data: Phi) : BOOLEAN; - (* writes the data structure for the public function phi onto a stream *) - VAR - r, d, k : INTEGER; - BEGIN - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~WritePolynom(s, data.denom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PhiWrite; - - PROCEDURE PhiRead (s: Streams.Stream; VAR data: Phi) : BOOLEAN; - (* reads the data structure for the public function phi from a stream *) - VAR - r, d, k : INTEGER; - BEGIN - NEW(data); - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~ReadPolynom(s, data.denom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PhiRead; - - PROCEDURE PsiWrite (s: Streams.Stream; data: Psi) : BOOLEAN; - (* writes the data structure for the private function psi onto a stream *) - CONST - index = M DIV 8; - VAR - dx, dy, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - dy := 0; - WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); - END; - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PsiWrite; - - PROCEDURE PsiRead (s: Streams.Stream; VAR data: Psi) : BOOLEAN; - (* reads the data structure for the private function psi from a stream *) - CONST - index = M DIV 8; - VAR - dy, dx, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - dy := 0; - WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); - END; - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PsiRead; - - PROCEDURE EtaWrite (s: Streams.Stream; data: Eta) : BOOLEAN; - (* writes the data structure for the public function eta onto a stream *) - VAR - l, d : INTEGER; - BEGIN - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); - END; - RETURN TRUE; - END EtaWrite; - - PROCEDURE EtaRead (s: Streams.Stream; VAR data: Eta) : BOOLEAN; - (* reads the data structure for the public function eta from a stream *) - VAR - l, d : INTEGER; - BEGIN - NEW(data); - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); - END; - RETURN TRUE; - END EtaRead; - - PROCEDURE PubWrite (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PublicCipher DO - RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); - END; - END PubWrite; - - PROCEDURE CipherWrite (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PrivateCipher DO - RETURN PhiWrite(s, obj.phi) & - PsiWrite(s, obj.psi) & - EtaWrite(s, obj.eta); - END; - END CipherWrite; - - PROCEDURE PubRead (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PublicCipher DO - IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; - END; - RETURN TRUE; - END PubRead; - - PROCEDURE CipherRead (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PrivateCipher DO - IF ~PhiRead(s, obj.phi) OR - ~PsiRead(s, obj.psi) OR - ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; - END; - RETURN TRUE; - END CipherRead; - -BEGIN - (* init of the zero and unit of CC(M) *) - NullCCM := {}; - EinsCCM := {0}; - - (* init of the zero exponent *) - k := 0; - WHILE k Priorities.base THEN - desc.caps := desc.caps + {Conditions.select, Conditions.async}; - desc.internal := priorityOfClock < Priorities.interrupts; - END; - END; - NEW(domain); Conditions.InitDomain(domain, if, desc); - domain.clock := clock; - IF Clocks.timer IN Clocks.Capabilities(clock) THEN - Events.Define(domain.alarm); - Events.SetPriority(domain.alarm, priorityOfClock + 1); - Events.Handler(domain.alarm, Wakeup); - ELSE - domain.alarm := NIL; - END; - NEW(clockDisc); clockDisc.id := disciplineId; - clockDisc.domain := domain; - Disciplines.Add(clock, clockDisc); - domain.event := NIL; - END; - Conditions.Init(condition, domain); - FixTime(time, currentTime, clock); condition.time := time; - condition.domain := domain; - condition.passed := Clocks.Passed(clock, time); - condition.scheduled := FALSE; - IF ~condition.passed & - (domain.alarm # NIL) & (clock # Clocks.system) THEN - ScheduleEvent(condition); - END; - END Init; - - PROCEDURE Create*(VAR condition: Conditions.Condition; - clock: Clocks.Clock; time: Times.Time); - (* create and initialize a time condition: - is the current time of the clock greater than or - equal to `time'; - if time is relative then it is taken relative to the current time - *) - VAR - timeCond: Condition; - BEGIN - NEW(timeCond); - Init(timeCond, clock, time); - condition := timeCond; - END Create; - - (* ======== interface procedures ================================ *) - - PROCEDURE GetTime(clock: Clocks.Clock; - VAR currentTime: Times.Time; - errors: RelatedEvents.Object) : BOOLEAN; - (* get the current time of clock and check for errors *) - VAR - oldEvents, newEvents: RelatedEvents.Queue; - BEGIN - RelatedEvents.GetQueue(clock, oldEvents); - Clocks.GetTime(clock, currentTime); - RelatedEvents.GetQueue(clock, newEvents); - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(errors, newEvents); - END; - IF oldEvents # NIL THEN - RelatedEvents.AppendQueue(clock, oldEvents); - END; - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(clock, newEvents); - END; - RETURN newEvents = NIL - END GetTime; - - PROCEDURE Passed(clock: Clocks.Clock; - time: Times.Time; - VAR passed: BOOLEAN; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - oldEvents, newEvents: RelatedEvents.Queue; - BEGIN - RelatedEvents.GetQueue(clock, oldEvents); - passed := Clocks.Passed(clock, time); - RelatedEvents.GetQueue(clock, newEvents); - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(errors, newEvents); - END; - IF oldEvents # NIL THEN - RelatedEvents.AppendQueue(clock, oldEvents); - END; - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(clock, newEvents); - END; - RETURN newEvents = NIL - END Passed; - - PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - currentTime: Times.Time; - BEGIN - WITH domain: Domain DO WITH condition: Condition DO - IF condition.passed THEN RETURN TRUE END; - IF condition.domain.event # NIL THEN RETURN FALSE END; - IF condition.scheduled THEN RETURN FALSE END; - IF ~Passed(domain.clock, condition.time, - condition.passed, errors) THEN - condition.passed := TRUE; - RETURN TRUE - END; - RETURN condition.passed - END; END; - END Test; - - PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet; - VAR minTime: Times.Time; - VAR minCond: Condition); - VAR - condition: Condition; - BEGIN - minTime := NIL; - Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - IF (minTime = NIL) OR (Op.Compare(condition.time, minTime) < 0) THEN - minTime := condition.time; minCond := condition; - END; - END; - Op.Assign(SYSTEM.VAL(Op.Operand, minTime), minTime); (* take a copy *) - END GetMinTime; - - PROCEDURE Select(domain: Conditions.Domain; - conditionSet: Conditions.ConditionSet; - time: Times.Time; - VAR setOfTrueConditions: Conditions.ConditionSet; - errors: RelatedEvents.Object; - retry: BOOLEAN; - VAR interrupted: BOOLEAN) : BOOLEAN; - VAR - minTime: Times.Time; - minCond: Condition; - currentTime: Times.Time; (* of Clocks.system *) - condition: Condition; - wakeup: WakeupEvent; - anythingTrue: BOOLEAN; - - PROCEDURE Failure; - (* we are unable to retrieve the time; - so we have to mark all conditions as passed - and to return the whole set - *) - VAR - condition: Condition; - BEGIN - Conditions.CreateSet(setOfTrueConditions); - Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - condition.passed := TRUE; - Conditions.Incl(setOfTrueConditions, condition); - END; - END Failure; - - BEGIN (* Select *) - WITH domain: Domain DO - GetMinTime(conditionSet, minTime, minCond); - - (* block current process, if necessary *) - interrupted := FALSE; - IF time # NIL THEN - Clocks.GetTime(Clocks.system, currentTime); - FixTime(time, currentTime, Clocks.system); - NEW(wakeup); wakeup.type := domain.alarm; - wakeup.condition := NIL; wakeup.awaked := FALSE; - Timers.Schedule(Clocks.system, time, wakeup); - END; - IF ~GetTime(domain.clock, currentTime, errors) THEN - Failure; RETURN TRUE - END; - - IF ~minCond.passed THEN - LOOP (* goes only into loop if retry = TRUE & we get interrupted *) - Process.Pause; - IF wakeup.awaked THEN EXIT END; - interrupted := ~minCond.passed; - IF ~interrupted THEN EXIT END; - IF ~retry THEN RETURN FALSE END; - END; - END; - - anythingTrue := FALSE; - Conditions.CreateSet(setOfTrueConditions); - Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - IF condition.passed THEN - Conditions.Incl(setOfTrueConditions, condition); - anythingTrue := TRUE; - END; - END; - RETURN anythingTrue - END; - END Select; - - PROCEDURE SendEvent(domain: Conditions.Domain; - condition: Conditions.Condition; - event: Events.Event; - errors: RelatedEvents.Object) : BOOLEAN; - BEGIN - WITH domain: Domain DO WITH condition: Condition DO - IF condition.passed THEN - RETURN FALSE - ELSE - domain.event := event; - ScheduleEvent(condition); - RETURN TRUE - END; - END; END; - END SendEvent; - - PROCEDURE GetNextTime(domain: Conditions.Domain; - conditionSet: Conditions.ConditionSet; - VAR nextTime: Times.Time; - VAR nextCond: Conditions.Condition; - errors: RelatedEvents.Object); - VAR - condition: Condition; - BEGIN - GetMinTime(conditionSet, nextTime, condition); - nextCond := condition; - END GetNextTime; - - PROCEDURE InitInterface; - BEGIN - NEW(if); - if.test := Test; - if.select := Select; - if.sendevent := SendEvent; - if.gettime := GetNextTime; - END InitInterface; - -BEGIN - disciplineId := Disciplines.Unique(); - InitInterface; -END ulmTimeConditions. diff --git a/src/lib/ulm/ulmTimers.Mod b/src/lib/ulm/ulmTimers.Mod deleted file mode 100644 index 88ca1996..00000000 --- a/src/lib/ulm/ulmTimers.Mod +++ /dev/null @@ -1,336 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Timers.om,v $ - Revision 1.3 2001/04/30 14:58:18 borchert - bug fix: recursion via Clocks.TimerOn was not possible - - Revision 1.2 1994/07/18 14:21:51 borchert - bug fix: CreateQueue took uninitialized priority variable instead of - queue.priority - - Revision 1.1 1994/02/22 20:11:37 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 1/92 - ---------------------------------------------------------------------------- -*) - -MODULE ulmTimers; - - IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities, - SYS := ulmSYSTEM, SYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes; - - TYPE - Queue = POINTER TO QueueRec; - Timer* = POINTER TO TimerRec; - TimerRec* = - RECORD - (Objects.ObjectRec) - valid: BOOLEAN; (* a valid timer entry? *) - queue: Queue; (* timer belongs to this queue *) - prev, next: Timer; (* double-linked and sorted list *) - time: Times.Time; (* key *) - event: Events.Event; (* raise this event at the given time *) - END; - QueueRec = - RECORD - (Disciplines.ObjectRec) - clock: Clocks.Clock; (* queue of this clock *) - priority: Priorities.Priority; (* priority of the clock *) - checkQueue: Events.EventType; (* check queue on this event *) - head, tail: Timer; (* sorted list of timers *) - lock: BOOLEAN; - END; - TYPE - CheckQueueEvent = POINTER TO CheckQueueEventRec; - CheckQueueEventRec = - RECORD - (Events.EventRec) - queue: Queue; - END; - TYPE - ClockDiscipline = POINTER TO ClockDisciplineRec; - ClockDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - queue: Queue; - END; - VAR - clockDisciplineId: Disciplines.Identifier; - - CONST - invalidTimer* = 0; (* timer is no longer valid *) - queueLocked* = 1; (* the queue is currently locked *) - badClock* = 2; (* clock is unable to maintain a timer *) - errorcodes* = 3; - TYPE - ErrorEvent* = POINTER TO ErrorEventRec; - ErrorEventRec* = - RECORD - (Events.EventRec) - errorcode*: SHORTINT; - END; - VAR - errormsg*: ARRAY errorcodes OF Events.Message; - error*: Events.EventType; - - PROCEDURE InitErrorHandling; - BEGIN - errormsg[invalidTimer] := "invalid timer given to Timers.Remove"; - errormsg[queueLocked] := "the queue is currently locked"; - errormsg[badClock] := "clock is unable to maintain a timer"; - Events.Define(error); Events.SetPriority(error, Priorities.liberrors); - END InitErrorHandling; - - PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT); - VAR - event: ErrorEvent; - BEGIN - NEW(event); - event.type := error; - event.message := errormsg[code]; - event.errorcode := code; - RelatedEvents.Raise(errors, event); - END Error; - - PROCEDURE CheckQueue(queue: Queue); - VAR - currentTime: Times.Time; - oldTimers: Timer; - p, prev: Timer; - checkQueueEvent: CheckQueueEvent; - nextTimer: Timer; - BEGIN - IF queue.head = NIL THEN queue.lock := FALSE; RETURN END; - - Clocks.GetTime(queue.clock, currentTime); - - (* remove old timers from queue *) - oldTimers := queue.head; - p := queue.head; prev := NIL; - WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO - prev := p; p := p.next; - END; - IF p = NIL THEN - queue.head := NIL; queue.tail := NIL; - ELSE - queue.head := p; - p.prev := NIL; - END; - IF prev = NIL THEN - oldTimers := NIL; - ELSE - prev.next := NIL; - END; - - (* set up next check-queue-event, if necessary *) - nextTimer := queue.head; - queue.lock := FALSE; - (* unlock queue now to allow recursion via Clocks.TimerOn *) - IF nextTimer # NIL THEN - NEW(checkQueueEvent); - checkQueueEvent.type := queue.checkQueue; - checkQueueEvent.message := "check queue of timer"; - checkQueueEvent.queue := queue; - Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent); - ELSE - Clocks.TimerOff(queue.clock); - END; - - (* process old timers *) - p := oldTimers; - WHILE p # NIL DO - p.valid := FALSE; - Events.Raise(p.event); - p := p.next; - END; - END CheckQueue; - - PROCEDURE CatchCheckQueueEvents(event: Events.Event); - BEGIN - WITH event: CheckQueueEvent DO - IF ~SYS.TAS(event.queue.lock) THEN - CheckQueue(event.queue); - (* event.queue.lock := FALSE; (* done by CheckQueue *) *) - END; - END; - END CatchCheckQueueEvents; - - PROCEDURE CreateQueue(errors: RelatedEvents.Object; - VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN; - VAR - clockDiscipline: ClockDiscipline; - BEGIN - IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN - Error(errors, badClock); RETURN FALSE - END; - - NEW(queue); - queue.clock := clock; - queue.head := NIL; queue.tail := NIL; - queue.lock := FALSE; - Events.Define(queue.checkQueue); - Events.Handler(queue.checkQueue, CatchCheckQueueEvents); - Clocks.GetPriority(clock, queue.priority); - IF queue.priority > Priorities.base THEN - Events.SetPriority(queue.checkQueue, queue.priority + 1); - ELSE - queue.priority := Priorities.default; - END; - - NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId; - clockDiscipline.queue := queue; - Disciplines.Add(clock, clockDiscipline); - RETURN TRUE - END CreateQueue; - - PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event; - VAR timer: Timer); - VAR - queue: Queue; - clockDiscipline: ClockDiscipline; - p: Timer; - absTime: Times.Time; - BEGIN - IF Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN - queue := clockDiscipline.queue; - ELSIF ~CreateQueue(clock, queue, clock) THEN - RETURN - END; - - IF SYS.TAS(queue.lock) THEN - Error(clock, queueLocked); RETURN - END; - Events.AssertPriority(queue.priority); - - IF Scales.IsRelative(time) THEN - (* take relative time to be relative to the current time *) - Clocks.GetTime(clock, absTime); - Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time); - ELSE - (* create a copy of time *) - absTime := NIL; Op.Assign(SYSTEM.VAL(Op.Operand, absTime), time); - END; - time := absTime; - NEW(timer); timer.time := time; timer.event := event; - timer.queue := queue; timer.valid := TRUE; - - (* look for the insertion point *) - p := queue.head; - WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO - p := p.next; - END; - - (* insert timer in front of p *) - timer.next := p; - IF p = NIL THEN - (* append timer at the end of the queue *) - timer.prev := queue.tail; - IF queue.tail = NIL THEN - queue.head := timer; - ELSE - queue.tail.next := timer; - END; - queue.tail := timer; - ELSE - timer.prev := p.prev; - timer.next := p; - IF p = queue.head THEN - queue.head := timer; - ELSE - p.prev.next := timer; - END; - p.prev := timer; - END; - - CheckQueue(queue); - (* queue.lock := FALSE; (* done by CheckQueue *) *) - Events.ExitPriority; - END Add; - - PROCEDURE Remove*(timer: Timer); - VAR - queue: Queue; - BEGIN - IF timer.valid THEN - queue := timer.queue; - IF SYS.TAS(queue.lock) THEN - Error(queue.clock, queueLocked); RETURN - END; - Events.AssertPriority(queue.priority); - timer.valid := FALSE; - IF timer.prev = NIL THEN - queue.head := timer.next; - ELSE - timer.prev.next := timer.next; - END; - IF timer.next = NIL THEN - queue.tail := timer.prev; - ELSE - timer.next.prev := timer.prev; - END; - CheckQueue(queue); - (* queue.lock := FALSE; (* done by CheckQueue *) *) - Events.ExitPriority; - ELSE - Error(timer.queue.clock, invalidTimer); - END; - END Remove; - - PROCEDURE Schedule*(clock: Clocks.Clock; - time: Times.Time; event: Events.Event); - VAR - timer: Timer; - BEGIN - Add(clock, time, event, timer); - END Schedule; - - PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN; - VAR - rval: BOOLEAN; - queue: Queue; - clockDiscipline: ClockDiscipline; - BEGIN - IF ~Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN - RETURN FALSE - END; - queue := clockDiscipline.queue; - - IF SYS.TAS(queue.lock) THEN - Error(clock, queueLocked); RETURN FALSE - END; - CheckQueue(queue); - IF queue.head # NIL THEN - time := queue.head.time; - rval := TRUE; - ELSE - rval := FALSE - END; - (* queue.lock := FALSE; (* done by CheckQueue *) *) - RETURN rval - END NextEvent; - -BEGIN - InitErrorHandling; - clockDisciplineId := Disciplines.Unique(); -END ulmTimers. diff --git a/src/lib/ulm/ulmTimes.Mod b/src/lib/ulm/ulmTimes.Mod deleted file mode 100644 index 00f0cd0c..00000000 --- a/src/lib/ulm/ulmTimes.Mod +++ /dev/null @@ -1,392 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Times.om,v $ - Revision 1.3 2001/04/30 14:54:44 borchert - bug fix: base type is TimeRec instead of Times.TimeRec - (invalid self-reference) - - Revision 1.2 1995/04/07 13:25:07 borchert - fixes due to changed if of PersistentObjects - - Revision 1.1 1994/02/22 20:12:02 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- -*) - -MODULE ulmTimes; - - IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales, - Services := ulmServices, Streams := ulmStreams, SYSTEM; - - CONST - relative* = Scales.relative; - absolute* = Scales.absolute; - TYPE - (* the common base type of all time measures *) - Time* = POINTER TO TimeRec; - TimeRec* = RECORD (Scales.MeasureRec) END; - - CONST - usecsPerSec = 1000000; (* 10^6 *) - TYPE - (* units of the reference implementation: - epoch, second and usec - *) - TimeValueRec* = - RECORD - (Objects.ObjectRec) - (* epoch 0: Jan. 1, 1970; - each epoch has a length of MAX(Scales.Value) + 1 seconds; - epoch may be negative: - -1 is the epoch just before 1970 - *) - epoch*: Scales.Value; - (* seconds and ... *) - second*: Scales.Value; - (* ... microseconds since the beginning of the epoch *) - usec*: Scales.Value; - END; - - (* ==== private datatypes for the reference scale *) - TYPE - ReferenceTime = POINTER TO ReferenceTimeRec; - ReferenceTimeRec = - RECORD - (TimeRec) - timeval: TimeValueRec; - END; - VAR - absType, relType: Services.Type; - CONST - epochUnit = 0; secondUnit = 1; usecUnit = 2; - TYPE - Unit = POINTER TO UnitRec; - UnitRec = - RECORD - (Scales.UnitRec) - index: SHORTINT; (* epochUnit..usecUnit *) - END; - - VAR - scale*: Scales.Scale; (* reference scale *) - family*: Scales.Family; (* family of time scales *) - if: Scales.Interface; - - PROCEDURE Create*(VAR time: Time; type: SHORTINT); - (* type = absolute or relative *) - VAR - m: Scales.Measure; - BEGIN - Scales.CreateMeasure(scale, m, type); - time := m(Time); - END Create; - - PROCEDURE Normalize(VAR timeval: TimeValueRec); - (* make sure that second and usec >= 0 *) - VAR - toomanysecs: Scales.Value; - secs: Scales.Value; - BEGIN - IF timeval.second < 0 THEN - INC(timeval.second, 1); - INC(timeval.second, MAX(Scales.Value)); - DEC(timeval.epoch); - END; - IF timeval.usec < 0 THEN - toomanysecs := timeval.usec DIV usecsPerSec; - IF toomanysecs > timeval.second THEN - timeval.second := - toomanysecs + MAX(Scales.Value) + 1 + - timeval.second; - DEC(timeval.epoch); - ELSE - DEC(timeval.second, toomanysecs); - END; - timeval.usec := timeval.usec MOD usecsPerSec; - ELSIF timeval.usec >= usecsPerSec THEN - secs := timeval.usec DIV usecsPerSec; - IF MAX(Scales.Value) - timeval.second <= secs THEN - INC(timeval.second, secs); - ELSE - timeval.second := secs - (MAX(Scales.Value) - timeval.second); - INC(timeval.epoch); - END; - timeval.usec := timeval.usec MOD usecsPerSec; - END; - END Normalize; - - PROCEDURE SetValue*(time: Time; value: TimeValueRec); - VAR - refTime: Time; - scaleOfTime: Scales.Scale; - BEGIN - Normalize(value); - IF time IS ReferenceTime THEN - WITH time: ReferenceTime DO - time.timeval := value; - END; - ELSE - Create(refTime, Scales.MeasureType(time)); - refTime(ReferenceTime).timeval := value; - Scales.GetScale(time, scaleOfTime); - Scales.ConvertMeasure(scaleOfTime, SYSTEM.VAL(Scales.Measure, refTime)); - Operations.Copy(refTime, time); - END; - END SetValue; - - PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT; - epoch, second, usec: Scales.Value); - VAR - timeval: TimeValueRec; - BEGIN - Create(time, type); - timeval.epoch := epoch; timeval.second := second; timeval.usec := usec; - SetValue(time, timeval); - END CreateAndSet; - - PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec); - BEGIN - IF ~(time IS ReferenceTime) THEN - Scales.ConvertMeasure(scale, SYSTEM.VAL(Scales.Measure, time)); - END; - value := time(ReferenceTime).timeval; - END GetValue; - - (* ===== interface procedures =================================== *) - - PROCEDURE InternalCreate(scale: Scales.Scale; - VAR measure: Scales.Measure; abs: BOOLEAN); - VAR - time: ReferenceTime; - BEGIN - NEW(time); - time.timeval.epoch := 0; - time.timeval.second := 0; - time.timeval.usec := 0; - IF abs THEN - PersistentObjects.Init(time, absType); - ELSE - PersistentObjects.Init(time, relType); - END; - measure := time; - END InternalCreate; - - PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit; - VAR value: Scales.Value); - BEGIN - WITH measure: ReferenceTime DO WITH unit: Unit DO - CASE unit.index OF - | epochUnit: value := measure.timeval.epoch; - | secondUnit: value := measure.timeval.second; - | usecUnit: value := measure.timeval.usec; - END; - END; END; - END InternalGetValue; - - PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit; - value: Scales.Value); - BEGIN - WITH measure: ReferenceTime DO WITH unit: Unit DO - CASE unit.index OF - | epochUnit: measure.timeval.epoch := value; - | secondUnit: measure.timeval.second := value; - | usecUnit: measure.timeval.usec := value; - END; - Normalize(measure.timeval); - END; END; - END InternalSetValue; - - PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure); - BEGIN - WITH target: ReferenceTime DO WITH source: ReferenceTime DO - target.timeval := source.timeval; - END; END; - END Assign; - - PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure); - - PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec); - BEGIN - result.epoch := op1.epoch + op2.epoch; - IF op1.second > MAX(Scales.Value) - op2.second THEN - INC(result.epoch); - result.second := op1.second - MAX(Scales.Value) - 1 + - op2.second; - ELSE - result.second := op1.second + op2.second; - END; - result.usec := op1.usec + op2.usec; - IF result.usec > usecsPerSec THEN - DEC(result.usec, usecsPerSec); - IF result.second = MAX(Scales.Value) THEN - result.second := 0; INC(result.epoch); - ELSE - INC(result.second); - END; - END; - END Add; - - PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec); - BEGIN - result.epoch := op1.epoch - op2.epoch; - IF op1.second >= op2.second THEN - result.second := op1.second - op2.second; - ELSE - DEC(result.epoch); - result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second; - END; - result.usec := op1.usec - op2.usec; - IF result.usec < 0 THEN - INC(result.usec, usecsPerSec); - IF result.second = 0 THEN - result.second := MAX(Scales.Value); - DEC(result.epoch); - ELSE - DEC(result.second); - END; - END; - END Sub; - - BEGIN - WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO - WITH result: ReferenceTime DO - CASE op OF - | Scales.add: Add(op1.timeval, op2.timeval, result.timeval); - | Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval); - END; - END; - END; END; - END Op; - - PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER; - - PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER; - BEGIN - IF val1 < val2 THEN - RETURN -1 - ELSIF val1 > val2 THEN - RETURN 1 - ELSE - RETURN 0 - END; - END ReturnVal; - - BEGIN - WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO - IF op1.timeval.epoch # op2.timeval.epoch THEN - RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) - ELSIF op1.timeval.second # op2.timeval.second THEN - RETURN ReturnVal(op1.timeval.second, op2.timeval.second) - ELSE - RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) - END; - END; END; - END Compare; - - (* ========= initialization procedures ========================== *) - - PROCEDURE InitInterface; - VAR - timeType: Services.Type; - BEGIN - NEW(if); - if.create := InternalCreate; - if.getvalue := InternalGetValue; if.setvalue := InternalSetValue; - if.assign := Assign; if.op := Op; if.compare := Compare; - (* conversion procedures are not necessary *) - - PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure", - NIL); - END InitInterface; - - PROCEDURE CreateAbs(VAR object: PersistentObjects.Object); - VAR - measure: Scales.Measure; - BEGIN - Scales.CreateAbsMeasure(scale, measure); - object := measure; - END CreateAbs; - - PROCEDURE CreateRel(VAR object: PersistentObjects.Object); - VAR - measure: Scales.Measure; - BEGIN - Scales.CreateRelMeasure(scale, measure); - object := measure; - END CreateRel; - - PROCEDURE Write(s: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - BEGIN - WITH object: ReferenceTime DO - RETURN NetIO.WriteLongInt(s, object.timeval.epoch) & - NetIO.WriteLongInt(s, object.timeval.second) & - NetIO.WriteLongInt(s, object.timeval.usec) - END; - END Write; - - PROCEDURE Read(s: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - BEGIN - WITH object: ReferenceTime DO - RETURN NetIO.ReadLongInt(s, object.timeval.epoch) & - NetIO.ReadLongInt(s, object.timeval.second) & - NetIO.ReadLongInt(s, object.timeval.usec) - END; - END Read; - - PROCEDURE InitRefScale; - - VAR - poif: PersistentObjects.Interface; - - PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName); - VAR - unit: Unit; - BEGIN - NEW(unit); unit.index := unitIndex; - Scales.InitUnit(scale, unit, name); - END InitUnit; - - BEGIN - NEW(scale); Scales.Init(scale, NIL, if); - InitUnit(epochUnit, "epoch"); - InitUnit(secondUnit, "second"); - InitUnit(usecUnit, "usec"); - - NEW(poif); poif.read := Read; poif.write := Write; - poif.create := CreateAbs; poif.createAndRead := NIL; - PersistentObjects.RegisterType(absType, - "Times.AbsReferenceTime", "Times.Time", poif); - NEW(poif); poif.read := Read; poif.write := Write; - poif.create := CreateRel; poif.createAndRead := NIL; - PersistentObjects.RegisterType(relType, - "Times.RelReferenceTime", "Times.Time", poif); - END InitRefScale; - -BEGIN - InitInterface; - InitRefScale; - NEW(family); Scales.InitFamily(family, scale); -END ulmTimes. diff --git a/src/lib/ulm/x86/ulmSYSTEM.Mod b/src/lib/ulm/x86/ulmSYSTEM.Mod deleted file mode 100644 index 814c0607..00000000 --- a/src/lib/ulm/x86/ulmSYSTEM.Mod +++ /dev/null @@ -1,137 +0,0 @@ -MODULE ulmSYSTEM; -IMPORT SYSTEM, Unix, Sys := ulmSys; - -TYPE pchar = POINTER TO ARRAY 1 OF CHAR; - pstring = POINTER TO ARRAY 1024 OF CHAR; - pstatus = POINTER TO Unix.Status; - - TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - pbytearray* = POINTER TO bytearray; - TYPE longrealarray* = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - plongrealarray* = POINTER TO bytearray; - - PROCEDURE LongToByteArr* ( l : LONGINT; VAR bar : bytearray); (* noch *) - VAR b : SYSTEM.BYTE; - p : pbytearray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(pbytearray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGINT) -1 DO - b := p^[i]; bar[i] := b; - END - END LongToByteArr; - - PROCEDURE LRealToByteArr* ( l : LONGREAL; VAR lar : longrealarray); (* noch *) - VAR b : SYSTEM.BYTE; - p : plongrealarray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(plongrealarray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGREAL) -1 DO - b := p^[i]; lar[i] := b; - END - END LRealToByteArr; - - -(* - PROCEDURE -Write(adr, n: LONGINT): LONGINT - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; -*) - - 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 UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *) - arg1, arg2, arg3: LONGINT) : BOOLEAN; - VAR - n : LONGINT; - ch : CHAR; - pch : pchar; - pstr : pstring; - pst : pstatus; - BEGIN - - IF syscall = Sys.read THEN - d0 := Unix.Read(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - ch := pch^[0]; - n := read(ch); - IF n # 1 THEN - ch := 0X; - RETURN FALSE - ELSE - pch^[0] := ch; - RETURN TRUE - END; - *) - ELSIF syscall = Sys.write THEN - d0 := Unix.Write(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - n := Write(SYSTEM.VAL(LONGINT, pch), 1); - IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END - *) - ELSIF syscall = Sys.open THEN - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Open(pstr^, SYSTEM.VAL(SET, arg3), SYSTEM.VAL(SET, arg2)); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.close THEN - d0 := Unix.Close(arg1); - IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.lseek THEN - d0 := Unix.Lseek(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.ioctl THEN - d0 := Unix.Ioctl(arg1, arg2, arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.fcntl THEN - d0 := Unix.Fcntl (arg1, arg2, arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.dup THEN - d0 := Unix.Dup(arg1); - RETURN d0 > 0; - ELSIF syscall = Sys.pipe THEN - d0 := Unix.Pipe(arg1); - RETURN d0 >= 0; - ELSIF syscall = Sys.newstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Stat(pstr^, pst^); - RETURN d0 >= 0 - ELSIF syscall = Sys.newfstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - d0 := Unix.Fstat(arg1, pst^); - RETURN d0 >= 0; - END - - END UNIXCALL; - - - PROCEDURE UNIXFORK(VAR pid: LONGINT) : BOOLEAN; - BEGIN - - END UNIXFORK; - - PROCEDURE UNIXSIGNAL(signo: INTEGER; p: PROCEDURE; - VAR old: PROCEDURE; VAR error: INTEGER) : BOOLEAN; - BEGIN - - END UNIXSIGNAL; - - PROCEDURE WMOVE*(from, to, n : LONGINT); - VAR l : LONGINT; - BEGIN - SYSTEM.MOVE(from, to, n); - END WMOVE; -END ulmSYSTEM. diff --git a/src/lib/ulm/x86/ulmSysStat.Mod b/src/lib/ulm/x86/ulmSysStat.Mod deleted file mode 100644 index c7f00f04..00000000 --- a/src/lib/ulm/x86/ulmSysStat.Mod +++ /dev/null @@ -1,201 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysStat.om,v $ - Revision 1.3 2000/11/12 13:02:09 borchert - door file type added - - Revision 1.2 2000/11/12 12:48:07 borchert - - conversion adapted to Solaris 2.x - - Lstat added - - Revision 1.1 1994/02/23 08:00:48 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysStat; - - (* examine inode: stat(2) and fstat(2) *) - - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors, - SysTypes := ulmSysTypes; - - CONST - (* file mode: - bit 0 = 1<<0 bit 31 = 1<<31 - - user group other - 3 1 1111 11 - 1 ... 6 5432 109 876 543 210 - +--------+------+-----+-----+-----+-----+ - | unused | type | sst | rwx | rwx | rwx | - +--------+------+-----+-----+-----+-----+ - *) - - type* = {12..15}; - prot* = {0..8}; - - (* file types; example: (stat.mode * type = dir) *) - reg* = {15}; (* regular *) - dir* = {14}; (* directory *) - chr* = {13}; (* character special *) - fifo* = {12}; (* fifo *) - blk* = {13..14}; (* block special *) - symlink* = {13, 15}; (* symbolic link *) - socket* = {14, 15}; (* socket *) - - (* special *) - setuid* = 11; (* set user id on execution *) - setgid* = 10; (* set group id on execution *) - savetext* = 9; (* save swapped text even after use *) - - (* protection *) - uread* = 8; (* read permission owner *) - uwrite* = 7; (* write permission owner *) - uexec* = 6; (* execute/search permission owner *) - gread* = 5; (* read permission group *) - gwrite* = 4; (* write permission group *) - gexec* = 3; (* execute/search permission group *) - oread* = 2; (* read permission other *) - owrite* = 1; (* write permission other *) - oexec* = 0; (* execute/search permission other *) - - (* example for "r-xr-x---": (read + exec) * (owner + group) *) - owner* = {uread, uwrite, uexec}; - group* = {gread, gwrite, gexec}; - other* = {oread, owrite, oexec}; - read* = {uread, gread, oread}; - write* = {uwrite, gwrite, owrite}; - exec* = {uexec, gexec, oexec}; - rwx* = prot; - - TYPE - StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - mode*: SET; (* file mode; see mknod(2) *) - nlinks*: LONGINT; (* number of links *) - uid*: LONGINT; (* user id of the file's owner *) - gid*: LONGINT; (* group id of the file's group *) - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - mtime*: SysTypes.Time; (* time of last data modification *) - ctime*: SysTypes.Time; (* time of last file status change *) - END; - -(* Linux kernel struct stat (2.2.17) - struct stat { - unsigned short st_dev; - unsigned short __pad1; - unsigned long st_ino; - unsigned short st_mode; - unsigned short st_nlink; - unsigned short st_uid; - unsigned short st_gid; - unsigned short st_rdev; - unsigned short __pad2; - unsigned long st_size; - unsigned long st_blksize; - unsigned long st_blocks; - unsigned long st_atime; - unsigned long __unused1; - unsigned long st_mtime; - unsigned long __unused2; - unsigned long st_ctime; - unsigned long __unused3; - unsigned long __unused4; - unsigned long __unused5; - }; -*) - - CONST - statbufsize = 88(*64*); (* see *) (* sizeof struct stat gives us 144 on x86_64 and 88 on x86 *) - TYPE - UnixStatRec = ARRAY statbufsize OF SYS.BYTE; - CONST - statbufconv = - (*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*) - (*"ls=dev/-s=pad1/lL=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/lL=size/2*lL=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";*) - "ll=dev/-l=devx/-s=pad1/ll=ino/Sl=mode/ll=nlink/ll=uid/ll=gid/ll=rdev/-l=rdevx/-s=pad2/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; - VAR - statbuffmt: SysConversions.Format; - - PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newstat, path); - RETURN FALSE - END; - END Stat; -(* - PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: INTEGER; - origbuf: UnixStatRec; - BEGIN - IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newlstat, path); - RETURN FALSE - END; - END Lstat; -*) - PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newfstat, ""); - RETURN FALSE - END; - END Fstat; - -BEGIN - SysConversions.Compile(statbuffmt, statbufconv); -END ulmSysStat. diff --git a/src/lib/ulm/x86/ulmTypes.Mod b/src/lib/ulm/x86/ulmTypes.Mod deleted file mode 100644 index a9aa73d0..00000000 --- a/src/lib/ulm/x86/ulmTypes.Mod +++ /dev/null @@ -1,133 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Types.om,v $ - Revision 1.5 2000/12/13 10:03:00 borchert - SetInt type used in msb constant - - Revision 1.4 2000/12/13 09:51:57 borchert - constants and types for the relationship of INTEGER and SET added - - Revision 1.3 1998/09/25 15:23:09 borchert - Real32..Real128 added - - Revision 1.2 1994/07/01 11:08:04 borchert - IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added - - Revision 1.1 1994/02/22 20:12:14 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/93 - ---------------------------------------------------------------------------- -*) - -MODULE ulmTypes; - - (* compiler-dependent type definitions; - this version works for Ulm's Oberon Compilers on - following architectures: m68k and sparc - *) - - IMPORT SYS := SYSTEM; - - TYPE - Address* = LONGINT (*SYS.ADDRESS*); - (* ulm compiler can accept - VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) - UntracedAddressDesc* = RECORD[1] END; - Count* = LONGINT; - Size* = Count; - Byte* = SYS.BYTE; - IntAddress* = LONGINT; - Int8* = SHORTINT; - Int16* = INTEGER; - Int32* = LONGINT; - Real32* = REAL; - Real64* = LONGREAL; - - CONST - bigEndian* = 0; (* SPARC, M68K etc *) - littleEndian* = 1; (* Intel 80x86, VAX etc *) - byteorder* = littleEndian; (* machine-dependent constant *) - TYPE - ByteOrder* = SHORTINT; (* bigEndian or littleEndian *) - - (* following constants and type definitions try to make - conversions from INTEGER to SET and vice versa more portable - to allow for bit operations on INTEGER values - *) - TYPE - SetInt* = LONGINT; (* INTEGER type that corresponds to SET *) - VAR msb* : SET; - msbIsMax*, msbIs0*: SHORTINT; - msbindex*, lsbindex*, nofbits*: LONGINT; - - PROCEDURE ToInt8*(int: LONGINT) : Int8; - BEGIN - RETURN SHORT(SHORT(int)) - END ToInt8; - - PROCEDURE ToInt16*(int: LONGINT) : Int16; - BEGIN - RETURN SYS.VAL(Int16, int) - END ToInt16; - - PROCEDURE ToInt32*(int: LONGINT) : Int32; - BEGIN - RETURN int - END ToInt32; - - PROCEDURE ToReal32*(real: LONGREAL) : Real32; - BEGIN - RETURN SHORT(real) - END ToReal32; - - PROCEDURE ToReal64*(real: LONGREAL) : Real64; - BEGIN - RETURN real - END ToReal64; - -BEGIN - msb := SYS.VAL(SET, MIN(SetInt)); - (* most significant bit, converted to a SET *) - (* we expect msbIsMax XOR msbIs0 to be 1; - this is checked for by an assertion - *) - msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)})); - (* is 1, if msb equals {MAX(SET)} *) - msbIs0 := SYS.VAL(SHORTINT, (msb = {0})); - (* is 0, if msb equals {0} *) - msbindex := msbIsMax * MAX(SET); - (* set element that corresponds to the most-significant-bit *) - lsbindex := MAX(SET) - msbindex; - (* set element that corresponds to the lowest-significant-bit *) - nofbits := MAX(SET) + 1; - (* number of elements in SETs *) - - ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1)); -END ulmTypes. diff --git a/src/lib/ulm/x86_64/ulmSYSTEM.Mod b/src/lib/ulm/x86_64/ulmSYSTEM.Mod deleted file mode 100644 index fa6c66a6..00000000 --- a/src/lib/ulm/x86_64/ulmSYSTEM.Mod +++ /dev/null @@ -1,137 +0,0 @@ -MODULE ulmSYSTEM; -IMPORT SYSTEM, Unix, Sys := ulmSys; - -TYPE pchar = POINTER TO ARRAY 1 OF CHAR; - pstring = POINTER TO ARRAY 1024 OF CHAR; - pstatus = POINTER TO Unix.Status; - - TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - pbytearray* = POINTER TO bytearray; - TYPE longrealarray* = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - plongrealarray* = POINTER TO bytearray; - - PROCEDURE LongToByteArr* ( l : LONGINT; VAR bar : bytearray); (* noch *) - VAR b : SYSTEM.BYTE; - p : pbytearray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(pbytearray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGINT) -1 DO - b := p^[i]; bar[i] := b; - END - END LongToByteArr; - - PROCEDURE LRealToByteArr* ( l : LONGREAL; VAR lar : longrealarray); (* noch *) - VAR b : SYSTEM.BYTE; - p : plongrealarray; - i : LONGINT; - BEGIN - p := SYSTEM.VAL(plongrealarray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGREAL) -1 DO - b := p^[i]; lar[i] := b; - END - END LRealToByteArr; - - -(* - PROCEDURE -Write(adr, n: LONGINT): LONGINT - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; -*) - - 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 UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *) - arg1, arg2, arg3: LONGINT) : BOOLEAN; - VAR - n : LONGINT; - ch : CHAR; - pch : pchar; - pstr : pstring; - pst : pstatus; - BEGIN - - IF syscall = Sys.read THEN - d0 := Unix.Read(SHORT(arg1), arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - ch := pch^[0]; - n := read(ch); - IF n # 1 THEN - ch := 0X; - RETURN FALSE - ELSE - pch^[0] := ch; - RETURN TRUE - END; - *) - ELSIF syscall = Sys.write THEN - d0 := Unix.Write(SHORT(arg1), arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - (*NEW(pch); - pch := SYSTEM.VAL(pchar, arg2); - n := Write(SYSTEM.VAL(LONGINT, pch), 1); - IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END - *) - ELSIF syscall = Sys.open THEN - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Open(pstr^, SHORT(arg3), arg2); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.close THEN - d0 := Unix.Close(SHORT(arg1)); - IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.lseek THEN - d0 := Unix.Lseek(SHORT(arg1), arg2, SHORT(arg3)); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END - ELSIF syscall = Sys.ioctl THEN - d0 := Unix.Ioctl(SHORT(arg1), SHORT(arg2), arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.fcntl THEN - d0 := Unix.Fcntl (SHORT(arg1), SHORT(arg2), arg3); - RETURN d0 >= 0; - ELSIF syscall = Sys.dup THEN - d0 := Unix.Dup(SHORT(arg1)); - RETURN d0 > 0; - ELSIF syscall = Sys.pipe THEN - d0 := Unix.Pipe(arg1); - RETURN d0 >= 0; - ELSIF syscall = Sys.newstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Stat(pstr^, pst^); - RETURN d0 >= 0 - ELSIF syscall = Sys.newfstat THEN - pst := SYSTEM.VAL(pstatus, arg2); - d0 := Unix.Fstat(SHORT(arg1), pst^); - RETURN d0 >= 0; - END - - END UNIXCALL; - - - PROCEDURE UNIXFORK(VAR pid: LONGINT) : BOOLEAN; - BEGIN - - END UNIXFORK; - - PROCEDURE UNIXSIGNAL(signo: INTEGER; p: PROCEDURE; - VAR old: PROCEDURE; VAR error: INTEGER) : BOOLEAN; - BEGIN - - END UNIXSIGNAL; - - PROCEDURE WMOVE*(from, to, n : LONGINT); - VAR l : LONGINT; - BEGIN - SYSTEM.MOVE(from, to, n); - END WMOVE; -END ulmSYSTEM. diff --git a/src/lib/ulm/x86_64/ulmSysConversions.Mod b/src/lib/ulm/x86_64/ulmSysConversions.Mod deleted file mode 100644 index e1047a58..00000000 --- a/src/lib/ulm/x86_64/ulmSysConversions.Mod +++ /dev/null @@ -1,574 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysConversi.om,v $ - Revision 1.2 1997/07/30 09:38:16 borchert - bug in ReadConv fixed: cv.flags was used but not set for - counts > 1 - - Revision 1.1 1994/02/23 07:58:28 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 8/90 - adapted to linux cae 02/01 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysConversions; - - (* convert Oberon records to/from C structures *) - - IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts; - - TYPE - Address* = SysTypes.Address; - Size* = Address; - - (* format: - - Format = Conversion { "/" Conversion } . - Conversion = [ Factors ] ConvChars [ Comment ] . - Factors = Array | Factor | Array Factor | Factor Array . - Array = Integer ":" . - Factor = Integer "*" . - ConvChars = OberonType CType | Skip CType | OberonType Skip . - OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" . - CType = "a" | "c" | "s" | "i" | "l" . - Integer = Digit { Digit } . - Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" . - Skip = "-" . - Comment = "=" { AnyChar } . - AnyChar = (* all characters except "/" *) . - - Oberon data types: - - a: Address - b: SYS.BYTE - B: BOOLEAN - c: CHAR - s: SHORTINT - i: INTEGER - l: LONGINT - S: SET - - C data types: - - a: char * - c: /* signed */ char - C: unsigned char - s: short int - S: unsigned short int - i: int - I: unsigned int - u: unsigned int - l: long int - L: unsigned long int - - example: - - conversion from - - Rec = - RECORD - a, b: INTEGER; - c: CHAR; - s: SET; - f: ARRAY 3 OF INTEGER; - END; - - to - - struct rec { - short a, b; - char c; - int xx; /* to be skipped on conversion */ - int s; - int f[3]; - }; - - or vice versa: - - "2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f" - - The comments allow to give the field names. - *) - - CONST - (* conversion flags *) - unsigned = 0; (* suppress sign extension *) - boolean = 1; (* convert anything # 0 to 1 *) - TYPE - Flags = SET; - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - format*: Events.Message; - END; - ConvStream = POINTER TO ConvStreamRec; - ConvStreamRec = - RECORD - fmt: Texts.Text; - char: CHAR; - eof: BOOLEAN; - (* 1: Oberon type - 2: C type - *) - type1, type2: CHAR; length: INTEGER; left: INTEGER; - offset1, offset2: Address; - size1, size2: Address; elementsleft: INTEGER; flags: Flags; - END; - - Format* = POINTER TO FormatRec; - FormatRec* = - RECORD - (Objects.ObjectRec) - offset1, offset2: Address; - size1, size2: Address; - flags: Flags; - next: Format; - END; - VAR - badformat*: Events.EventType; - - PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - Strings.Read(event.format, cv.fmt); - Events.Raise(event); - cv.eof := TRUE; - cv.char := 0X; - cv.left := 0; - cv.elementsleft := 0; - END Error; - - PROCEDURE SizeError(msg, format: ARRAY OF CHAR); - VAR - event: Event; - BEGIN - NEW(event); - event.type := badformat; - event.message := "SysConversions: "; - Strings.Concatenate(event.message, msg); - COPY(format, event.format); - Events.Raise(event); - END SizeError; - - PROCEDURE NextCh(cv: ConvStream); - BEGIN - cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X); - IF cv.eof THEN - cv.char := 0X; - END; - END NextCh; - - PROCEDURE IsDigit(ch: CHAR) : BOOLEAN; - BEGIN - RETURN (ch >= "0") & (ch <= "9") - END IsDigit; - - PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER); - BEGIN - i := 0; - REPEAT - i := 10 * i + ORD(cv.char) - ORD("0"); - NextCh(cv); - UNTIL ~IsDigit(cv.char); - END ReadInt; - - PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR); - BEGIN - NEW(cv); - Texts.Open(SYS.VAL(Streams.Stream, cv.fmt)); - Strings.Write(cv.fmt, format); - cv.left := 0; cv.elementsleft := 0; - cv.offset1 := 0; cv.offset2 := 0; - cv.eof := FALSE; - NextCh(cv); - END Open; - - PROCEDURE Close(VAR cv: ConvStream); - BEGIN - IF ~Streams.Close(cv.fmt) THEN END; - END Close; - - PROCEDURE ScanConv(cv: ConvStream; - VAR type1, type2: CHAR; - VAR length: INTEGER) : BOOLEAN; - VAR - i: INTEGER; - factor: INTEGER; - BEGIN - IF cv.left > 0 THEN - type1 := cv.type1; - type2 := cv.type2; - length := cv.length; - DEC(cv.left); - RETURN TRUE - END; - IF cv.char = "/" THEN - NextCh(cv); - END; - IF cv.eof THEN - RETURN FALSE - END; - factor := 0; length := 0; - WHILE IsDigit(cv.char) DO - ReadInt(cv, i); - IF i <= 0 THEN - Error(cv, "integer must be positive"); RETURN FALSE - END; - IF cv.char = ":" THEN - IF length # 0 THEN - Error(cv, "multiple length specification"); RETURN FALSE - END; - length := i; - NextCh(cv); - ELSIF cv.char = "*" THEN - IF factor # 0 THEN - Error(cv, "multiple factor specification"); RETURN FALSE - END; - factor := i; cv.left := factor - 1; - NextCh(cv); - ELSE - Error(cv, "factor or length expected"); RETURN FALSE - END; - END; - type1 := cv.char; NextCh(cv); - type2 := cv.char; NextCh(cv); - IF cv.left > 0 THEN - cv.type1 := type1; cv.type2 := type2; cv.length := length; - END; - IF cv.char = "=" THEN (* comment *) - REPEAT - NextCh(cv); - UNTIL cv.eof OR (cv.char = "/"); - END; - RETURN TRUE - END ScanConv; - - PROCEDURE Align(VAR offset: Address; boundary: Address); - BEGIN - IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN - offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary)); - END; - END Align; - - PROCEDURE ReadConv(cv: ConvStream; - VAR offset1, offset2: Address; - VAR size1, size2: Address; - VAR flags: Flags) : BOOLEAN; - VAR - type1, type2: CHAR; - length: INTEGER; - align: BOOLEAN; - boundary: INTEGER; - BEGIN - IF cv.elementsleft > 0 THEN - DEC(cv.elementsleft); - - (* Oberon type *) - IF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - size1 := cv.size1; size2 := cv.size2; flags := cv.flags; - IF (size1 > 0) & (cv.elementsleft = 0) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - - (* C type *) - IF size2 > 1 THEN - Align(cv.offset2, 2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - RETURN TRUE - END; - IF ScanConv(cv, type1, type2, length) THEN - flags := {}; - (* Oberon type *) - CASE type1 OF - | "a": size1 := SIZE(Address); INCL(flags, unsigned); - | "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned); - | "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean); - | "c": size1 := SIZE(CHAR); INCL(flags, unsigned); - | "s": size1 := SIZE(SHORTINT); - | "i": size1 := SIZE(INTEGER); - | "l": size1 := SIZE(LONGINT); - | "S": size1 := SIZE(SET); INCL(flags, unsigned); - | "-": size1 := 0; - ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE - END; - IF size1 > 0 THEN - IF length > 0 THEN - Align(cv.offset1, SIZE(INTEGER)); - ELSIF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); - END; - END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; - - (* C type *) - CASE type2 OF - | "a": size2 := 8; INCL(flags, unsigned); (* char* *) - | "c": size2 := 1; (* /* signed */ char *) - | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) - | "s": size2 := 2; (* short int *) - | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) - | "i": size2 := 4; (* int *) - | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "l": size2 := 8; (* long int *) - | "L": size2 := 8; INCL(flags, unsigned); (* long int *) - | "-": size2 := 0; - ELSE Error(cv, "bad C type specifier"); RETURN FALSE - END; - IF size2 > 1 THEN - Align(cv.offset2, size2); - END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); - - cv.size1 := size1; cv.size2 := size2; - IF length > 0 THEN - cv.elementsleft := length - 1; - cv.flags := flags; - END; - RETURN TRUE - ELSE - RETURN FALSE - END; - END ReadConv; - - PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags); - TYPE - Bytes = ARRAY 8 OF CHAR; - Pointer = POINTER TO Bytes; - VAR - dest, source: Pointer; - dindex, sindex: INTEGER; - nonzero: BOOLEAN; - fill : CHAR; - BEGIN - IF ssize > 0 THEN - dest := SYS.VAL(Pointer, to); - source := SYS.VAL(Pointer, from); - dindex := 0; sindex := 0; - IF boolean IN flags THEN - nonzero := FALSE; - WHILE ssize > 0 DO - nonzero := nonzero OR (source[sindex] # 0X); - INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1; - END; - IF dsize > 0 THEN - IF nonzero THEN - dest[dindex] := 1X; - ELSE - dest[dindex] := 0X; - END; - dsize := dsize - 1; INC (dindex); - END; - WHILE dsize > 0 DO - dest[dindex] := 0X; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - ELSE - WHILE (dsize > 0) & (ssize > 0) DO - dest[dindex] := source[sindex]; - ssize := SYS.VAL (INTEGER, ssize) - 1; - dsize := dsize - 1; - INC(dindex); INC(sindex); - END; - IF dsize > 0 THEN - (* sindex has been incremented at least once because - * ssize and dsize were greater than 0, i.e. sindex-1 - * is a valid inex. *) - fill := 0X; - IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN - fill := 0FFX; - END; - END; - WHILE dsize > 0 DO - dest[dindex] := fill; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); - END; - END; - END; - END Convert; - - PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset1, to + offset2, size1, size2, flags); - END; - Close(cv); - END ByAddrToC; - - PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR); - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - Convert(from + offset2, to + offset1, size2, size1, flags); - END; - Close(cv); - END ByAddrFromC; - - PROCEDURE CSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the C-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset2 + size2; - Align(size, 2); - RETURN size - END CSize; - - PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size; - (* returns the size of the Oberon-structure described by `format' *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - size: Address; - flags: Flags; - BEGIN - Open(cv, format); - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; - Close(cv); - size := offset1 + size1; - Align(size, SIZE(INTEGER)); - RETURN size - END OberonSize; - - PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(from) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(to) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ToC; - - PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR); - BEGIN - IF OberonSize(format) > LEN(to) THEN - SizeError("Oberon record is too small", format); RETURN - END; - IF CSize(format) > LEN(from) THEN - SizeError("C structure is too small", format); RETURN - END; - ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END FromC; - - PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR); - (* translate format into an internal representation - which is later referenced by fmt; - ByFmtToC and ByFmtFromC are faster than ToC and FromC - *) - VAR - cv: ConvStream; - offset1, offset2, size1, size2: Address; - flags: Flags; - element: Format; - head, tail: Format; - BEGIN - Open(cv, format); - head := NIL; tail := NIL; - WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO - NEW(element); - element.offset1 := offset1; - element.offset2 := offset2; - element.size1 := size1; - element.size2 := size2; - element.flags := flags; - element.next := NIL; - IF tail # NIL THEN - tail.next := element; - ELSE - head := element; - END; - tail := element; - END; - fmt := head; - Close(cv); - END Compile; - - PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset1, to + format.offset2, - format.size1, format.size2, format.flags); - format := format.next; - END; - END ByFmtAndAddrToC; - - PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format); - VAR - offset1, offset2, size1, size2: Address; - flags: Flags; - BEGIN - WHILE format # NIL DO - Convert(from + format.offset2, to + format.offset1, - format.size2, format.size1, format.flags); - format := format.next; - END; - END ByFmtAndAddrFromC; - - PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtToC; - - PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format); - BEGIN - ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format); - END ByFmtFromC; - -BEGIN - Events.Define(badformat); - Events.SetPriority(badformat, Priorities.liberrors); -END ulmSysConversions. diff --git a/src/lib/ulm/x86_64/ulmSysStat.Mod b/src/lib/ulm/x86_64/ulmSysStat.Mod deleted file mode 100644 index 54d1fc41..00000000 --- a/src/lib/ulm/x86_64/ulmSysStat.Mod +++ /dev/null @@ -1,227 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysStat.om,v $ - Revision 1.3 2000/11/12 13:02:09 borchert - door file type added - - Revision 1.2 2000/11/12 12:48:07 borchert - - conversion adapted to Solaris 2.x - - Lstat added - - Revision 1.1 1994/02/23 08:00:48 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysStat; - - (* examine inode: stat(2) and fstat(2) *) - - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors, - SysTypes := ulmSysTypes; - - CONST - (* file mode: - bit 0 = 1<<0 bit 31 = 1<<31 - - user group other - 3 1 1111 11 - 1 ... 6 5432 109 876 543 210 - +--------+------+-----+-----+-----+-----+ - | unused | type | sst | rwx | rwx | rwx | - +--------+------+-----+-----+-----+-----+ - *) - - type* = {12..15}; - prot* = {0..8}; - - (* file types; example: (stat.mode * type = dir) *) - reg* = {15}; (* regular *) - dir* = {14}; (* directory *) - chr* = {13}; (* character special *) - fifo* = {12}; (* fifo *) - blk* = {13..14}; (* block special *) - symlink* = {13, 15}; (* symbolic link *) - socket* = {14, 15}; (* socket *) - - (* special *) - setuid* = 11; (* set user id on execution *) - setgid* = 10; (* set group id on execution *) - savetext* = 9; (* save swapped text even after use *) - - (* protection *) - uread* = 8; (* read permission owner *) - uwrite* = 7; (* write permission owner *) - uexec* = 6; (* execute/search permission owner *) - gread* = 5; (* read permission group *) - gwrite* = 4; (* write permission group *) - gexec* = 3; (* execute/search permission group *) - oread* = 2; (* read permission other *) - owrite* = 1; (* write permission other *) - oexec* = 0; (* execute/search permission other *) - - (* example for "r-xr-x---": (read + exec) * (owner + group) *) - owner* = {uread, uwrite, uexec}; - group* = {gread, gwrite, gexec}; - other* = {oread, owrite, oexec}; - read* = {uread, gread, oread}; - write* = {uwrite, gwrite, owrite}; - exec* = {uexec, gexec, oexec}; - rwx* = prot; - - TYPE - StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - nlinks*: LONGINT(*INTEGER*); (* number of links *) - mode*: SET; (* file mode; see mknod(2) *) - uid*: INTEGER; (* user id of the file's owner *) - gid*: INTEGER; (* group id of the file's group *) - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - mtime*: SysTypes.Time; (* time of last data modification *) - ctime*: SysTypes.Time; (* time of last file status change *) - END; - -(* StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - nlinks*: LONGINT; (* number of links *) - mode*: INTEGER(*SET*); (* file mode; see mknod(2) *) - uid*: INTEGER; (* user id of the file's owner *) - gid*: INTEGER; (* group id of the file's group *) - pad0: INTEGER; - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - atimences* : LONGINT; - mtime*: SysTypes.Time; (* time of last data modification *) - mtimensec* : LONGINT; - ctime*: SysTypes.Time; (* time of last file status change *) - ctimensec* : LONGINT; - unused0*, unused1*, unused2*: LONGINT; - END; -*) -(* Linux kernel struct stat (2.2.17) - struct stat { - unsigned short st_dev; - unsigned short __pad1; - unsigned long st_ino; - unsigned short st_mode; - unsigned short st_nlink; - unsigned short st_uid; - unsigned short st_gid; - unsigned short st_rdev; - unsigned short __pad2; - unsigned long st_size; - unsigned long st_blksize; - unsigned long st_blocks; - unsigned long st_atime; - unsigned long __unused1; - unsigned long st_mtime; - unsigned long __unused2; - unsigned long st_ctime; - unsigned long __unused3; - unsigned long __unused4; - unsigned long __unused5; - }; -*) - - CONST - statbufsize = 144(*64*); (* see *) (* sizeof struct stat gives us 144 on x86_64 and 88 or x86; -- noch *) - TYPE - UnixStatRec = ARRAY statbufsize OF SYS.BYTE; - CONST - statbufconv = - (*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*) - "lL=dev/lL=ino/lL=nlink/Su=mode/2*iu=uid+gid/-i=pad0/lL=rdev/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; (* noch *) - VAR - statbuffmt: SysConversions.Format; - - PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newstat, path); - RETURN FALSE - END; - END Stat; -(* commented temporarily, it is used only in FTPUnixDirLister module *) (* - PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: INTEGER; - origbuf: UnixStatRec; - BEGIN - IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newlstat, path); - RETURN FALSE - END; - END Lstat; -*) - PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newfstat, ""); - RETURN FALSE - END; - END Fstat; - -BEGIN - SysConversions.Compile(statbuffmt, statbufconv); -END ulmSysStat. diff --git a/src/lib/ulm/x86_64/ulmSysTypes.Mod b/src/lib/ulm/x86_64/ulmSysTypes.Mod deleted file mode 100644 index 174140e7..00000000 --- a/src/lib/ulm/x86_64/ulmSysTypes.Mod +++ /dev/null @@ -1,70 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: SysTypes.om,v $ - Revision 1.1 1994/02/23 08:01:38 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/89 - ---------------------------------------------------------------------------- -*) - -MODULE ulmSysTypes; - - IMPORT Types := ulmTypes; - - TYPE - Address* = Types.Address; - UntracedAddress* = Types.UntracedAddress; - Count* = Types.Count; - Size* = Types.Size; - Byte* = Types.Byte; - - File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *) - Offset* = LONGINT; - Device* = LONGINT; - Inode* = LONGINT; - Time* = LONGINT; - - Word* = INTEGER; (* must have the size of C's int-type *) - - (* Note: linux supports wait4 but not waitid, i.e. these - * constants aren't needed. *) - (* - CONST - (* possible values of the idtype parameter (4 bytes), - see - *) - idPid = 0; (* a process identifier *) - idPpid = 1; (* a parent process identifier *) - idPgid = 2; (* a process group (job control group) identifier *) - idSid = 3; (* a session identifier *) - idCid = 4; (* a scheduling class identifier *) - idUid = 5; (* a user identifier *) - idGid = 6; (* a group identifier *) - idAll = 7; (* all processes *) - idLwpid = 8; (* an LWP identifier *) - TYPE - IdType = INTEGER; (* idPid .. idLwpid *) - *) - -END ulmSysTypes. diff --git a/src/lib/ulm/x86_64/ulmTypes.Mod b/src/lib/ulm/x86_64/ulmTypes.Mod deleted file mode 100644 index d46a2c63..00000000 --- a/src/lib/ulm/x86_64/ulmTypes.Mod +++ /dev/null @@ -1,141 +0,0 @@ -(* Ulm's Oberon Library - Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. - - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Types.om,v $ - Revision 1.5 2000/12/13 10:03:00 borchert - SetInt type used in msb constant - - Revision 1.4 2000/12/13 09:51:57 borchert - constants and types for the relationship of INTEGER and SET added - - Revision 1.3 1998/09/25 15:23:09 borchert - Real32..Real128 added - - Revision 1.2 1994/07/01 11:08:04 borchert - IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added - - Revision 1.1 1994/02/22 20:12:14 borchert - Initial revision - - ---------------------------------------------------------------------------- - AFB 9/93 - ---------------------------------------------------------------------------- -*) - -MODULE ulmTypes; - - (* compiler-dependent type definitions; - this version works for Ulm's Oberon Compilers on - following architectures: m68k and sparc - *) - - IMPORT SYS := SYSTEM; - - TYPE - Address* = (*SYS.PTR*) LONGINT (*SYS.ADDRESS*); - (* ulm compiler can accept - VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) - UntracedAddressDesc* = RECORD[1] END; - - intarr64 = ARRAY 8 OF SYS.BYTE; (* to emulate int16 on x86_64; -- noch *) - intarr16 = ARRAY 2 OF SYS.BYTE; - - Count* = LONGINT; - Size* = Count; - Byte* = SYS.BYTE; - IntAddress* = LONGINT; - Int8* = SHORTINT; - Int16* = intarr16(*INTEGER*); (* we don't have 16 bit integer in x86_64 version of voc *) - Int32* = INTEGER; - Real32* = REAL; - Real64* = LONGREAL; - - CONST - bigEndian* = 0; (* SPARC, M68K etc *) - littleEndian* = 1; (* Intel 80x86, VAX etc *) - byteorder* = littleEndian; (* machine-dependent constant *) - TYPE - ByteOrder* = SHORTINT; (* bigEndian or littleEndian *) - - (* following constants and type definitions try to make - conversions from INTEGER to SET and vice versa more portable - to allow for bit operations on INTEGER values - *) - TYPE - SetInt* = LONGINT; (* INTEGER type that corresponds to SET *) - VAR msb* : SET; - msbIsMax*, msbIs0*: SHORTINT; - msbindex*, lsbindex*, nofbits*: LONGINT; - - PROCEDURE ToInt8*(int: LONGINT) : Int8; - BEGIN - RETURN SHORT(SHORT(int)) - END ToInt8; - - PROCEDURE ToInt16*(int: LONGINT; VAR int16: Int16)(* : Int16*); - VAR longintarr : intarr64; - BEGIN - (*RETURN SYS.VAL(Int16, int)*) - longintarr := SYS.VAL(intarr64, int); - int16[0] := longintarr[0]; - int16[1] := longintarr[1]; (* this will work for little endian -- noch *) - END ToInt16; - - PROCEDURE ToInt32*(int: LONGINT) : Int32; - BEGIN - RETURN SHORT(int) - END ToInt32; - - PROCEDURE ToReal32*(real: LONGREAL) : Real32; - BEGIN - RETURN SHORT(real) - END ToReal32; - - PROCEDURE ToReal64*(real: LONGREAL) : Real64; - BEGIN - RETURN real - END ToReal64; - -BEGIN - msb := SYS.VAL(SET, MIN(SetInt)); - (* most significant bit, converted to a SET *) - (* we expect msbIsMax XOR msbIs0 to be 1; - this is checked for by an assertion - *) - msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)})); - (* is 1, if msb equals {MAX(SET)} *) - msbIs0 := SYS.VAL(SHORTINT, (msb = {0})); - (* is 0, if msb equals {0} *) - msbindex := msbIsMax * MAX(SET); - (* set element that corresponds to the most-significant-bit *) - lsbindex := MAX(SET) - msbindex; - (* set element that corresponds to the lowest-significant-bit *) - nofbits := MAX(SET) + 1; - (* number of elements in SETs *) - - ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1)); -END ulmTypes. diff --git a/src/lib/v4/Modules.Mod b/src/lib/v4/Modules.Mod deleted file mode 100644 index e73fefac..00000000 --- a/src/lib/v4/Modules.Mod +++ /dev/null @@ -1,96 +0,0 @@ -MODULE Modules; (* jt 6.1.96 *) - - (* access to list of modules and commands, based on ETH Oberon *) - - - IMPORT SYSTEM, Console; - - CONST - ModNameLen* = 20; - - TYPE - ModuleName* = ARRAY ModNameLen OF CHAR; - Module* = POINTER TO ModuleDesc; - Cmd* = POINTER TO CmdDesc; - ModuleDesc* = RECORD (* cf. SYSTEM.Mod *) - next-: Module; - name-: ModuleName; - refcnt-: LONGINT; - cmds-: Cmd; - types-: LONGINT; - enumPtrs-: PROCEDURE (P: PROCEDURE(p: LONGINT)); - reserved1, reserved2: LONGINT; - END ; - - Command* = PROCEDURE; - - CmdDesc* = RECORD - next-: Cmd; - name-: ARRAY 24 OF CHAR; - cmd-: Command - END ; - - VAR - res*: INTEGER; - resMsg*: ARRAY 256 OF CHAR; - imported*, importing*: ModuleName; - - - PROCEDURE -modules*(): Module - "(Modules_Module)SYSTEM_modules"; - - PROCEDURE -setmodules*(m: Module) - "SYSTEM_modules = m"; - - - PROCEDURE Append(VAR a: ARRAY OF CHAR; b: ARRAY OF CHAR); - VAR i, j: INTEGER; - BEGIN - i := 0; WHILE a[i] # 0X DO INC(i) END; - j := 0; WHILE b[j] # 0X DO a[i] := b[j]; INC(i); INC(j) END; - a[i] := 0X - END Append; - - PROCEDURE ThisMod* (name: ARRAY OF CHAR): Module; - VAR m: Module; bodyname: ARRAY 64 OF CHAR; body: Command; - BEGIN m := modules(); - WHILE (m # NIL) & (m.name # name) DO m := m.next END ; - IF m # NIL THEN res := 0; resMsg := "" - ELSE res := 1; COPY(name, importing); - resMsg := ' module "'; Append(resMsg, name); Append(resMsg, '" not found'); - END ; - RETURN m - END ThisMod; - - PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF CHAR): Command; - VAR c: Cmd; - BEGIN c := mod.cmds; - WHILE (c # NIL) & (c.name # name) DO c := c.next END ; - IF c # NIL THEN res := 0; resMsg := ""; RETURN c.cmd - ELSE res := 2; resMsg := ' command "'; COPY(name, importing); - Append(resMsg, mod.name); Append(resMsg, "."); Append(resMsg, name); Append(resMsg, '" not found'); - RETURN NIL - END - END ThisCommand; - - PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN); - VAR m, p: Module; - BEGIN m := modules(); - IF all THEN - res := 1; resMsg := 'unloading "all" not yet supported' - ELSE - WHILE (m # NIL) & (m.name # name) DO p := m; m := m.next END ; - IF (m # NIL) & (m.refcnt = 0) THEN - IF m = modules() THEN setmodules(m.next) - ELSE p.next := m.next - END ; - res := 0 - ELSE res := 1; - IF m = NIL THEN resMsg := "module not found" - ELSE resMsg := "clients of this module exist" - END - END - END - END Free; - -END Modules. diff --git a/src/lib/v4/Oberon.Mod b/src/lib/v4/Oberon.Mod deleted file mode 100644 index 710e91e4..00000000 --- a/src/lib/v4/Oberon.Mod +++ /dev/null @@ -1,61 +0,0 @@ -MODULE Oberon; - -(* this version should not have dependency on graphics -- noch *) - - IMPORT Kernel, Texts, Args; - - TYPE - - ParList* = POINTER TO ParRec; - - ParRec* = RECORD - (* vwr*: Viewers.Viewer; - frame*: Display.Frame;*) - text*: Texts.Text; - pos*: LONGINT - END; - - VAR - - Log*: Texts.Text; - Par*: ParList; (*actual parameters*) - W : Texts.Writer; - (*clocks*) - - PROCEDURE GetClock* (VAR t, d: LONGINT); - BEGIN Kernel.GetClock(t, d) - END GetClock; - - PROCEDURE Time* (): LONGINT; - BEGIN - RETURN Kernel.Time() - END Time; - - PROCEDURE PopulateParams; - VAR W : Texts.Writer; - i : INTEGER; - str : ARRAY 32 OF CHAR; - BEGIN - - i := 1; (* skip program name *) - Texts.OpenWriter(W); - - REPEAT - IF i < Args.argc THEN - Args.Get(i, str); - Texts.WriteString(W, str); - Texts.WriteString(W, " "); - END; - INC(i) - UNTIL i >= Args.argc; - - Texts.Append (Par^.text, W.buf); - - END PopulateParams; - -BEGIN - NEW(Par); - NEW(Par.text); - Texts.Open(Par.text, ""); - PopulateParams; -END Oberon. diff --git a/src/lib/v4/Sets0.Mod b/src/lib/v4/Sets0.Mod deleted file mode 100644 index f5251990..00000000 --- a/src/lib/v4/Sets0.Mod +++ /dev/null @@ -1,159 +0,0 @@ -MODULE Sets0; - -IMPORT Out := Console; - -CONST (*size* = 32;*) - size* = MAX(SET) + 1; - -PROCEDURE Clear*(VAR s: ARRAY OF SET); - VAR i: INTEGER; -BEGIN - i := 0; WHILE i < LEN(s) DO s[i] := {}; INC(i) END -END Clear; - - -PROCEDURE Fill*(VAR s: ARRAY OF SET); - VAR i: INTEGER; -BEGIN - i := 0; WHILE i < LEN(s) DO s[i] := {0 .. size-1}; INC(i) END -END Fill; - - -PROCEDURE Incl*(VAR s: ARRAY OF SET; x: INTEGER); -BEGIN INCL(s[x DIV size], x MOD size) -END Incl; - - -PROCEDURE Excl*(VAR s: ARRAY OF SET; x: INTEGER); -BEGIN EXCL(s[x DIV size], x MOD size) -END Excl; - - -PROCEDURE In*(VAR s: ARRAY OF SET; x: INTEGER): BOOLEAN; -BEGIN RETURN x MOD size IN s[x DIV size] -END In; - - -PROCEDURE Includes*(VAR s1, s2: ARRAY OF SET): BOOLEAN; - VAR i: INTEGER; -BEGIN - i := 0; - WHILE i < LEN(s1) DO - IF s1[i] + s2[i] # s1[i] THEN RETURN FALSE END ; - INC(i) - END ; - RETURN TRUE; -END Includes; - - -PROCEDURE Elements*(VAR s: ARRAY OF SET; VAR lastElem: INTEGER): INTEGER; - VAR i, n, max: INTEGER; -BEGIN - i := 0; n := 0; max := SHORT(LEN(s)) * size; - WHILE i < max DO - IF (i MOD size) IN s[i DIV size] THEN INC(n); lastElem := i END ; - INC(i) - END ; - RETURN n -END Elements; - - -PROCEDURE Empty*(VAR s: ARRAY OF SET): BOOLEAN; - VAR i: INTEGER; -BEGIN - i := 0; - WHILE i < LEN(s) DO - IF s[i] # {} THEN RETURN FALSE END ; - INC(i) - END ; - RETURN TRUE -END Empty; - - -PROCEDURE Equal*(VAR s1, s2: ARRAY OF SET): BOOLEAN; - VAR i: INTEGER; -BEGIN - i := 0; - WHILE i < LEN(s1) DO - IF s1[i] # s2[i] THEN RETURN FALSE END ; - INC(i) - END ; - RETURN TRUE -END Equal; - - -PROCEDURE Different*(VAR s1, s2: ARRAY OF SET): BOOLEAN; - VAR i: INTEGER; -BEGIN - i := 0; - WHILE i < LEN(s1) DO - IF s1[i] * s2[i] # {} THEN RETURN FALSE END ; - INC(i) - END ; - RETURN TRUE -END Different; - - -PROCEDURE Unite*(VAR s1, s2: ARRAY OF SET); - VAR i: INTEGER; s: SET; -BEGIN - i := 0; WHILE i < LEN(s1) DO s := s1[i] + s2[i]; s1[i] := s; INC(i) END -END Unite; - - -PROCEDURE Differ*(VAR s1, s2: ARRAY OF SET); - VAR i: INTEGER; s: SET; -BEGIN - i := 0; WHILE i < LEN(s1) DO s := s1[i] - s2[i]; s1[i] := s; INC(i) END -END Differ; - - -PROCEDURE Intersect*(VAR s1, s2, s3: ARRAY OF SET); - VAR i: INTEGER; s: SET; -BEGIN - i := 0; WHILE i < LEN(s1) DO s := s1[i] * s2[i]; s3[i] := s; INC(i) END -END Intersect; - -(* -PROCEDURE Print*(VAR f: Texts.Writer; s: ARRAY OF SET; w, indent: INTEGER); - VAR col, i, max: INTEGER; -BEGIN - i := 0; col := indent; max := SHORT(LEN(s)) * size; - Texts.Write(f, "{"); - WHILE i < max DO - IF In(s, i) THEN - IF col + 4 > w THEN - Texts.WriteLn(f); - col := 0; WHILE col < indent DO Texts.Write(f, " "); INC(col) END - END ; - Texts.WriteInt(f, i, 3); Texts.Write(f, ","); - INC(col, 4) - END ; - INC(i) - END ; - Texts.Write(f, "}") -END Print; -*) - -PROCEDURE Write*(s: ARRAY OF SET; w, indent: INTEGER); - VAR col, i, max: INTEGER; -BEGIN - i := 0; col := indent; max := SHORT(LEN(s)) * size; - Out.Char("{"); - WHILE i < max DO - IF In(s, i) THEN - IF col + 4 > w THEN - Out.Ln; - col := 0; WHILE col < indent DO Out.Char(" "); INC(col) END - END ; - Out.Int(i, 3); Out.Char(","); - INC(col, 4) - END ; - INC(i) - END ; - Out.Char("}") -END Write; - - - -END Sets0. diff --git a/src/lib/v4/Texts0.Mod b/src/lib/v4/Texts0.Mod deleted file mode 100644 index 19ecf5a1..00000000 --- a/src/lib/v4/Texts0.Mod +++ /dev/null @@ -1,880 +0,0 @@ -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 Read* (VAR R: Reader; VAR ch: CHAR); - VAR u: Run; pos: LONGINT; nextch: CHAR; - 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 (* << LF to CR *) - ELSIF (ch = CR) & u(Piece).ascii THEN (* << CR LF to CR *) - pos := Files.Pos(R.rider); Files.Read(R.rider, nextch); - IF nextch = 0AX THEN INC(R.off) ELSE Files.Set(R.rider, u(Piece).file, pos) END - END - 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. diff --git a/src/lib/v4/armv6j_hardfp/Reals.Mod b/src/lib/v4/armv6j_hardfp/Reals.Mod deleted file mode 100644 index 087767c1..00000000 --- a/src/lib/v4/armv6j_hardfp/Reals.Mod +++ /dev/null @@ -1,109 +0,0 @@ -MODULE Reals; - (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) - - IMPORT S := SYSTEM; - - - PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT - "(LONGINT)ecvt (x, ndigit, decpt, sign)"; - - PROCEDURE Ten*(e: INTEGER): REAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN r := r * power END ; - power := power * power; e := e DIV 2 - END ; - RETURN SHORT(r) - END Ten; - - PROCEDURE TenL*(e: INTEGER): LONGREAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - LOOP - IF ODD(e) THEN r := r * power END ; - e := e DIV 2; - IF e <= 0 THEN RETURN r END ; - power := power * power - END - END TenL; - - PROCEDURE Expo*(x: REAL): INTEGER; - BEGIN - RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256) - END Expo; - - PROCEDURE ExpoL*(x: LONGREAL): INTEGER; - VAR h: LONGINT; - BEGIN - S.GET(S.ADR(x)+4, h); - RETURN SHORT(ASH(h, -20) MOD 2048) - END ExpoL; - - PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); - CONST expo = {1..8}; - BEGIN - x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23))) - END SetExpo; - - PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); - CONST expo = {1..11}; - VAR h: SET; - BEGIN - S.GET(S.ADR(x)+4, h); - h := h - expo + S.VAL(SET, ASH(LONG(e), 20)); - S.PUT(S.ADR(x)+4, h) - END SetExpoL; - - PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END Convert; -(* - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END ConvertL; - *) - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR decpt, sign, i: LONGINT; buf: LONGINT; - BEGIN - (*x := x - 0.5; already rounded in ecvt*) - buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign)); - i := 0; - WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *) - i := n - i - 1; - WHILE i >= 0 DO d[i] := "0"; DEC(i) END ; - END ConvertL; - - PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE); - VAR i, k: SHORTINT; len: LONGINT; - BEGIN i := 0; len := LEN(b); - WHILE i < len DO - k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16); - IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ; - k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16); - IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ; - INC(i) - END - END Unpack; - - PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(y, d) - END ConvertH; - - PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(x, d) - END ConvertHL; - -END Reals. diff --git a/src/lib/v4/powerpc/Reals.Mod b/src/lib/v4/powerpc/Reals.Mod deleted file mode 100644 index 037cba38..00000000 --- a/src/lib/v4/powerpc/Reals.Mod +++ /dev/null @@ -1,112 +0,0 @@ -MODULE Reals; - (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) - - IMPORT S := SYSTEM; - - - PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT - "(LONGINT)ecvt (x, ndigit, decpt, sign)"; - - PROCEDURE Ten*(e: INTEGER): REAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN r := r * power END ; - power := power * power; e := e DIV 2 - END ; - RETURN SHORT(r) - END Ten; - - PROCEDURE TenL*(e: INTEGER): LONGREAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - LOOP - IF ODD(e) THEN r := r * power END ; - e := e DIV 2; - IF e <= 0 THEN RETURN r END ; - power := power * power - END - END TenL; - - PROCEDURE Expo*(x: REAL): INTEGER; - BEGIN - RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256) - END Expo; - - PROCEDURE ExpoL*(x: LONGREAL): INTEGER; - VAR h: LONGINT; - BEGIN - (*S.GET(S.ADR(x)+4, h);*) (* commented out, powerpc is big endian *) - S.GET(S.ADR(x), h); - RETURN SHORT(ASH(h, -20) MOD 2048) - END ExpoL; - - PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); - CONST expo = {1..8}; - BEGIN - x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23))) - END SetExpo; - - PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); - CONST expo = {1..11}; - VAR h: SET; - BEGIN - (*S.GET(S.ADR(x)+4, h);*) (* big endian *) - S.GET(S.ADR(x), h); - h := h - expo + S.VAL(SET, ASH(LONG(e), 20)); - (*S.PUT(S.ADR(x)+4, h)*) - S.PUT(S.ADR(x), h) - END SetExpoL; - - PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END Convert; -(* - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END ConvertL; - *) - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR decpt, sign, i: LONGINT; buf: LONGINT; - BEGIN - (*x := x - 0.5; already rounded in ecvt*) - buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign)); - i := 0; - WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *) - i := n - i - 1; - WHILE i >= 0 DO d[i] := "0"; DEC(i) END ; - END ConvertL; - - PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE); - VAR i, k: SHORTINT; len: LONGINT; - BEGIN i := 0; len := LEN(b); - WHILE i < len DO - k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16); - IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ; - k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16); - IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ; - INC(i) - END - END Unpack; - - PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(y, d) - END ConvertH; - - PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(x, d) - END ConvertHL; - -END Reals. diff --git a/src/lib/v4/x86/Reals.Mod b/src/lib/v4/x86/Reals.Mod deleted file mode 100644 index 087767c1..00000000 --- a/src/lib/v4/x86/Reals.Mod +++ /dev/null @@ -1,109 +0,0 @@ -MODULE Reals; - (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) - - IMPORT S := SYSTEM; - - - PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT - "(LONGINT)ecvt (x, ndigit, decpt, sign)"; - - PROCEDURE Ten*(e: INTEGER): REAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN r := r * power END ; - power := power * power; e := e DIV 2 - END ; - RETURN SHORT(r) - END Ten; - - PROCEDURE TenL*(e: INTEGER): LONGREAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - LOOP - IF ODD(e) THEN r := r * power END ; - e := e DIV 2; - IF e <= 0 THEN RETURN r END ; - power := power * power - END - END TenL; - - PROCEDURE Expo*(x: REAL): INTEGER; - BEGIN - RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256) - END Expo; - - PROCEDURE ExpoL*(x: LONGREAL): INTEGER; - VAR h: LONGINT; - BEGIN - S.GET(S.ADR(x)+4, h); - RETURN SHORT(ASH(h, -20) MOD 2048) - END ExpoL; - - PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); - CONST expo = {1..8}; - BEGIN - x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23))) - END SetExpo; - - PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); - CONST expo = {1..11}; - VAR h: SET; - BEGIN - S.GET(S.ADR(x)+4, h); - h := h - expo + S.VAL(SET, ASH(LONG(e), 20)); - S.PUT(S.ADR(x)+4, h) - END SetExpoL; - - PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END Convert; -(* - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END ConvertL; - *) - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR decpt, sign, i: LONGINT; buf: LONGINT; - BEGIN - (*x := x - 0.5; already rounded in ecvt*) - buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign)); - i := 0; - WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *) - i := n - i - 1; - WHILE i >= 0 DO d[i] := "0"; DEC(i) END ; - END ConvertL; - - PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE); - VAR i, k: SHORTINT; len: LONGINT; - BEGIN i := 0; len := LEN(b); - WHILE i < len DO - k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16); - IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ; - k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16); - IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ; - INC(i) - END - END Unpack; - - PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(y, d) - END ConvertH; - - PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(x, d) - END ConvertHL; - -END Reals. diff --git a/src/lib/v4/x86_64/Reals.Mod b/src/lib/v4/x86_64/Reals.Mod deleted file mode 100644 index e47d14ae..00000000 --- a/src/lib/v4/x86_64/Reals.Mod +++ /dev/null @@ -1,194 +0,0 @@ -MODULE Reals; - (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) - - IMPORT S := SYSTEM; -(* getting rid of ecvt -- noch - PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT - "(LONGINT)ecvt (x, ndigit, decpt, sign)"; -*) - PROCEDURE Ten*(e: INTEGER): REAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN r := r * power END ; - power := power * power; e := e DIV 2 - END ; - RETURN SHORT(r) - END Ten; - - PROCEDURE TenL*(e: INTEGER): LONGREAL; - VAR r, power: LONGREAL; - BEGIN r := 1.0; - power := 10.0; - LOOP - IF ODD(e) THEN r := r * power END ; - e := e DIV 2; - IF e <= 0 THEN RETURN r END ; - power := power * power - END - END TenL; - - PROCEDURE Expo*(x: REAL): INTEGER; - BEGIN - RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256) - END Expo; - - PROCEDURE ExpoL*(x: LONGREAL): INTEGER; - VAR h: LONGINT; - BEGIN - S.GET(S.ADR(x)+4, h); - RETURN SHORT(ASH(h, -20) MOD 2048) - END ExpoL; - - PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); - CONST expo = {1..8}; - BEGIN - x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23))) - END SetExpo; - - PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); - CONST expo = {1..11}; - VAR h: SET; - BEGIN - S.GET(S.ADR(x)+4, h); - h := h - expo + S.VAL(SET, ASH(LONG(e), 20)); - S.PUT(S.ADR(x)+4, h) - END SetExpoL; - - PROCEDURE Reverse0 (VAR str : ARRAY OF CHAR; start, end : INTEGER); - (* Reverses order of characters in the interval [start..end]. *) - VAR - h : CHAR; - BEGIN - WHILE start < end DO - h := str[start]; str[start] := str[end]; str[end] := h; - INC(start); DEC(end) - END - END Reverse0; - (* these functions ⇅ necessary to get rid of ecvt -- noch *) - PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR); - (* Converts the value of `int' to string form and copies the possibly truncated - result to `str'. *) - VAR - b : ARRAY 21 OF CHAR; - s, e: INTEGER; - maxLength : SHORTINT; (* maximum number of digits representing a LONGINT value *) - BEGIN - IF SIZE(LONGINT) = 4 THEN maxLength := 11 END; - IF SIZE(LONGINT) = 8 THEN maxLength := 20 END; - (* build representation in string 'b' *) - IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *) - IF SIZE(LONGINT) = 4 THEN - b := "-2147483648"; - e := 11 - ELSE (* SIZE(LONGINT) = 8 *) - b := "-9223372036854775808"; - e := 20 - END - ELSE - IF int < 0 THEN (* negative sign *) - b[0] := "-"; int := -int; s := 1 - ELSE (* no sign *) - s := 0 - END; - e := s; (* 's' holds starting position of string *) - REPEAT - b[e] := CHR(int MOD 10+ORD("0")); - int := int DIV 10; - INC(e) - UNTIL int = 0; - b[e] := 0X; - Reverse0(b, s, e-1); - END; - COPY(b, str) (* truncate output if necessary *) - END IntToStr; - - PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN IF x < 0 THEN x := -x END; - i := ENTIER(x); k := 0; - WHILE k < n DO - d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) - END - END Convert; -(* experimental, -- noch - PROCEDURE Convert0*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, j, k: LONGINT; - str : ARRAY 32 OF CHAR; - BEGIN - (* IF x = MIN(LONGREAL) THEN x := MAX(LONGREAL) END;*) - IF x < 0 THEN x := -x END; - i := ENTIER(x); - IF i < 0 THEN i := -i END; - IntToStr(i, str); - IF n >= LEN(d) THEN n := SHORT(LEN(d)) - 1 END; - d[n] := 0X; - j := n - 1 ; - IF j < 0 THEN j := 0 END; - k := 0; - REPEAT - d[j] := str[k]; - DEC(j); - INC(k); - UNTIL (str[k] = 0X) OR (j < 0); - - WHILE j >= 0 DO d[j] := "0"; DEC(j) END ; - END Convert0; -*) - (* this seem to work -- noch *) - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, j, k: LONGINT; - str : ARRAY 32 OF CHAR; - BEGIN - (* IF x = MIN(LONGREAL) THEN x := MAX(LONGREAL) END;*) - IF x < 0 THEN x := -x END; - i := ENTIER(x); - IF i < 0 THEN i := -i END; - IntToStr(i, str); - IF n >= LEN(d) THEN n := SHORT(LEN(d)) - 1 END; - d[n] := 0X; - j := n - 1 ; - IF j < 0 THEN j := 0 END; - k := 0; - REPEAT - d[j] := str[k]; - DEC(j); - INC(k); - UNTIL (str[k] = 0X) OR (j < 0); - - WHILE j >= 0 DO d[j] := "0"; DEC(j) END ; - END ConvertL; -(* getting rid of ecvt -- noch - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR decpt, sign: INTEGER; i: LONGINT; buf: LONGINT; - BEGIN - (*x := x - 0.5; already rounded in ecvt*) - buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign)); - i := 0; - WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *) - i := n - i - 1; - WHILE i >= 0 DO d[i] := "0"; DEC(i) END ; - END ConvertL; -*) - PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE); - VAR i, k: SHORTINT; len: LONGINT; - BEGIN i := 0; len := LEN(b); - WHILE i < len DO - k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16); - IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ; - k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16); - IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ; - INC(i) - END - END Unpack; - - PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(y, d) - END ConvertH; - - PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(x, d) - END ConvertHL; - -END Reals. diff --git a/src/lib/misc/Listen.Mod b/src/library/misc/Listen.Mod similarity index 100% rename from src/lib/misc/Listen.Mod rename to src/library/misc/Listen.Mod diff --git a/src/lib/misc/MersenneTwister.Mod b/src/library/misc/MersenneTwister.Mod similarity index 100% rename from src/lib/misc/MersenneTwister.Mod rename to src/library/misc/MersenneTwister.Mod diff --git a/src/lib/misc/MultiArrayRiders.Mod b/src/library/misc/MultiArrayRiders.Mod similarity index 99% rename from src/lib/misc/MultiArrayRiders.Mod rename to src/library/misc/MultiArrayRiders.Mod index 852dcde0..1d67850b 100644 --- a/src/lib/misc/MultiArrayRiders.Mod +++ b/src/library/misc/MultiArrayRiders.Mod @@ -20,7 +20,7 @@ email Patrick.Hunziker@unibas.ch MODULE MultiArrayRiders; (** Patrick Hunziker, Basel, **) (** Implements an array rider access mechanism for multidimensional arrays of arbitrary dimensions defined in MultiArrays*) -IMPORT MultiArrays, Out:= Console, Input := Kernel; +IMPORT MultiArrays, Out := Console, Input := Platform; CONST (** behaviour of array rider at end of array line; not yet completely implemented. The seemingly more exotic variants are especially useful in image processing *) diff --git a/src/lib/misc/MultiArrays.Mod b/src/library/misc/MultiArrays.Mod similarity index 99% rename from src/lib/misc/MultiArrays.Mod rename to src/library/misc/MultiArrays.Mod index 7bf04447..a2e61b2c 100644 --- a/src/lib/misc/MultiArrays.Mod +++ b/src/library/misc/MultiArrays.Mod @@ -40,7 +40,7 @@ Patrick Hunziker,Basel. email Patrick.Hunziker@unibas.ch *) (** Version 0.9, 19.1.2001 *) -IMPORT Out:= Console, Input:= Kernel; (* Import only needed for Demo purposes *) +IMPORT Out := Console, Input := Platform; (* Import only needed for Demo purposes *) TYPE SIntPtr* = POINTER TO ARRAY OF SHORTINT; diff --git a/src/lib/misc/crt.Mod b/src/library/misc/crt.Mod similarity index 53% rename from src/lib/misc/crt.Mod rename to src/library/misc/crt.Mod index 3fd63b47..eebc5678 100644 --- a/src/lib/misc/crt.Mod +++ b/src/library/misc/crt.Mod @@ -1,7 +1,6 @@ MODULE crt; -IMPORT vt100, Unix, Console, - Strings; (* strings to remove later ? *) +IMPORT VT100, Platform, Out, Strings; CONST @@ -28,159 +27,146 @@ CONST (* Add-in for blinking *) Blink* = 128; -TYPE - PFdSet = POINTER TO Unix.FdSet; - -VAR tmpstr : ARRAY 23 OF CHAR; - PROCEDURE EraseDisplay*; BEGIN - vt100.ED(2); + VT100.ED(2); END EraseDisplay; PROCEDURE ClrScr*; BEGIN - vt100.ED(2); + VT100.ED(2); END ClrScr; PROCEDURE ClrEol*; BEGIN - vt100.EL(0); + VT100.EL(0); END ClrEol; PROCEDURE cursoroff*; BEGIN - vt100.DECTCEMl; + VT100.DECTCEMl; END cursoroff; PROCEDURE cursoron*; BEGIN - vt100.DECTCEMh; + VT100.DECTCEMh; END cursoron; - PROCEDURE Delay*( ms : INTEGER); - VAR i : LONGINT; - tv : Unix.Timeval; - pfd : PFdSet; - BEGIN - tv.sec := 0; - tv.usec := ms * 1000; - pfd := NIL; - i := Unix.Select(0, pfd^, pfd^, pfd^, tv); - END Delay; + PROCEDURE Delay*(ms: INTEGER); + BEGIN Platform.Delay(ms) END Delay; PROCEDURE GotoXY* (x, y: INTEGER); BEGIN - vt100.CUP (y, x); + VT100.CUP (y, x); END GotoXY; PROCEDURE HighVideo*; VAR tmpstr: ARRAY 5 OF CHAR; BEGIN - COPY (vt100.CSI, tmpstr); - Strings.Append(vt100.Bold, tmpstr); - Console.String(tmpstr); + COPY (VT100.CSI, tmpstr); + Strings.Append(VT100.Bold, tmpstr); + Out.String(tmpstr); END HighVideo; - + PROCEDURE DelLine*; BEGIN - vt100.EL(2); + VT100.EL(2); END DelLine; PROCEDURE InsLine*; BEGIN - vt100.SCP; - Console.Ln; - vt100.RCP; + VT100.SCP; + Out.Ln; + VT100.RCP; END InsLine; PROCEDURE LowVideo*; VAR tmpstr : ARRAY 7 OF CHAR; BEGIN - COPY (vt100.CSI, tmpstr); - Strings.Append(vt100.ResetBold, tmpstr); - Console.String(tmpstr); + COPY (VT100.CSI, tmpstr); + Strings.Append(VT100.ResetBold, tmpstr); + Out.String(tmpstr); END LowVideo; PROCEDURE NormVideo*; VAR tmpstr : ARRAY 7 OF CHAR; BEGIN - COPY(vt100.CSI, tmpstr); - Strings.Append(vt100.ResetAll, tmpstr); - Console.String(tmpstr); + COPY(VT100.CSI, tmpstr); + Strings.Append(VT100.ResetAll, tmpstr); + Out.String(tmpstr); END NormVideo; PROCEDURE TextBackground*(color : SHORTINT); BEGIN IF color = Black THEN - vt100.SetAttr(vt100.BBlack) + VT100.SetAttr(VT100.BBlack) ELSIF color = Blue THEN - vt100.SetAttr(vt100.BBlue) + VT100.SetAttr(VT100.BBlue) ELSIF color = Green THEN - vt100.SetAttr(vt100.BGreen) + VT100.SetAttr(VT100.BGreen) ELSIF color = Cyan THEN - vt100.SetAttr(vt100.BCyan) + VT100.SetAttr(VT100.BCyan) ELSIF color = Red THEN - vt100.SetAttr(vt100.BRed) + VT100.SetAttr(VT100.BRed) ELSIF color = Magenta THEN - vt100.SetAttr(vt100.BMagenta) + VT100.SetAttr(VT100.BMagenta) ELSIF color = Brown THEN - vt100.SetAttr(vt100.BYellow) + VT100.SetAttr(VT100.BYellow) ELSIF color = LightGray THEN - vt100.SetAttr(vt100.BLightGray) + VT100.SetAttr(VT100.BLightGray) ELSIF color = DarkGray THEN - vt100.SetAttr(vt100.BDarkGray) + VT100.SetAttr(VT100.BDarkGray) ELSIF color = LightBlue THEN - vt100.SetAttr(vt100.BLightBlue) + VT100.SetAttr(VT100.BLightBlue) ELSIF color = LightGreen THEN - vt100.SetAttr(vt100.BLightBlue) + VT100.SetAttr(VT100.BLightBlue) ELSIF color = LightCyan THEN - vt100.SetAttr(vt100.BLightCyan) + VT100.SetAttr(VT100.BLightCyan) ELSIF color = LightRed THEN - vt100.SetAttr(vt100.BLightRed) + VT100.SetAttr(VT100.BLightRed) ELSIF color = LightMagenta THEN - vt100.SetAttr(vt100.BLightMagenta) + VT100.SetAttr(VT100.BLightMagenta) ELSIF color = Yellow THEN - vt100.SetAttr(vt100.BLightYellow) + VT100.SetAttr(VT100.BLightYellow) ELSIF color = White THEN - vt100.SetAttr(vt100.BWhite) + VT100.SetAttr(VT100.BWhite) END; END TextBackground; PROCEDURE TextColor*(color : SHORTINT); BEGIN IF color = Black THEN - vt100.SetAttr(vt100.Black) + VT100.SetAttr(VT100.Black) ELSIF color = Blue THEN - vt100.SetAttr(vt100.Blue) + VT100.SetAttr(VT100.Blue) ELSIF color = Green THEN - vt100.SetAttr(vt100.Green) + VT100.SetAttr(VT100.Green) ELSIF color = Cyan THEN - vt100.SetAttr(vt100.Cyan) + VT100.SetAttr(VT100.Cyan) ELSIF color = Red THEN - vt100.SetAttr(vt100.Red) + VT100.SetAttr(VT100.Red) ELSIF color = Magenta THEN - vt100.SetAttr(vt100.Magenta) + VT100.SetAttr(VT100.Magenta) ELSIF color = Brown THEN - vt100.SetAttr(vt100.Yellow) + VT100.SetAttr(VT100.Yellow) ELSIF color = LightGray THEN - vt100.SetAttr(vt100.LightGray) + VT100.SetAttr(VT100.LightGray) ELSIF color = DarkGray THEN - vt100.SetAttr(vt100.DarkGray) + VT100.SetAttr(VT100.DarkGray) ELSIF color = LightBlue THEN - vt100.SetAttr(vt100.LightBlue) + VT100.SetAttr(VT100.LightBlue) ELSIF color = LightGreen THEN - vt100.SetAttr(vt100.LightBlue) + VT100.SetAttr(VT100.LightBlue) ELSIF color = LightCyan THEN - vt100.SetAttr(vt100.LightCyan) + VT100.SetAttr(VT100.LightCyan) ELSIF color = LightRed THEN - vt100.SetAttr(vt100.LightRed) + VT100.SetAttr(VT100.LightRed) ELSIF color = LightMagenta THEN - vt100.SetAttr(vt100.LightMagenta) + VT100.SetAttr(VT100.LightMagenta) ELSIF color = Yellow THEN - vt100.SetAttr(vt100.LightYellow) + VT100.SetAttr(VT100.LightYellow) ELSIF color = White THEN - vt100.SetAttr(vt100.White) + VT100.SetAttr(VT100.White) END; END TextColor; diff --git a/src/lib/ooc/oocAscii.Mod b/src/library/ooc/oocAscii.Mod similarity index 100% rename from src/lib/ooc/oocAscii.Mod rename to src/library/ooc/oocAscii.Mod diff --git a/src/lib/ooc/oocBinaryRider.Mod b/src/library/ooc/oocBinaryRider.Mod similarity index 100% rename from src/lib/ooc/oocBinaryRider.Mod rename to src/library/ooc/oocBinaryRider.Mod diff --git a/src/lib/ooc/linux/clang/armv6j_hardfp/oocC.Mod b/src/library/ooc/oocCILP32.Mod similarity index 60% rename from src/lib/ooc/linux/clang/armv6j_hardfp/oocC.Mod rename to src/library/ooc/oocCILP32.Mod index 2e7751ff..66a3cde1 100644 --- a/src/lib/ooc/linux/clang/armv6j_hardfp/oocC.Mod +++ b/src/library/ooc/oocCILP32.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* ILP32 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,39 +30,33 @@ Unix they should be fairly safe. *) TYPE - char* = CHAR; - signedchar* = SHORTINT; (* signed char *) - shortint* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - float* = REAL; - double* = LONGREAL; + char* = CHAR; (* 8 bits *) + signedchar* = SYSTEM.INT8; (* 8 bits *) + shortint* = SYSTEM.INT16; (* 16 bits *) + int* = SYSTEM.INT32; (* 32 bits *) + set* = SYSTEM.INT32; (* 32 bits *) + longint* = SYSTEM.INT32; (* 32 bits on ILP32 (64 bits is 'long long') *) +(*longset* = SET; n/a *) (* 64 bit SET *) + address* = SYSTEM.ADDRESS; (* 32 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) - sizet* = longint; - uidt* = int; - gidt* = int; + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + sizet* = longint; (* 32 bits in i686 *) + 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; + intPtr1d* = POINTER TO ARRAY OF int; TYPE (* C string type, assignment compatible with character arrays and string constants *) diff --git a/src/lib/ooc/linux/clang/armv6j/oocC.Mod b/src/library/ooc/oocCLLP64.Mod similarity index 63% rename from src/lib/ooc/linux/clang/armv6j/oocC.Mod rename to src/library/ooc/oocCLLP64.Mod index 2e7751ff..4b6add95 100644 --- a/src/lib/ooc/linux/clang/armv6j/oocC.Mod +++ b/src/library/ooc/oocCLLP64.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* LP64 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,39 +30,33 @@ Unix they should be fairly safe. *) TYPE - char* = CHAR; - signedchar* = SHORTINT; (* signed char *) - shortint* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - float* = REAL; - double* = LONGREAL; + char* = CHAR; (* 8 bits *) + signedchar* = SYSTEM.INT8; (* 8 bits *) + shortint* = SYSTEM.INT16; (* 16 bits *) + int* = SYSTEM.INT32; (* 32 bits *) + set* = SYSTEM.SET32; (* 32 bits *) + longint* = SYSTEM.INT32; (* 32 bits *) + longset* = SYSTEM.SET64; (* 64 bits *) + address* = SYSTEM.INT64; (* 64 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) sizet* = longint; - uidt* = int; - gidt* = int; + 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; + intPtr1d* = POINTER TO ARRAY OF int; TYPE (* C string type, assignment compatible with character arrays and string constants *) diff --git a/src/lib/ooc/linux/clang/powerpc/oocC.Mod b/src/library/ooc/oocCLP64.Mod similarity index 63% rename from src/lib/ooc/linux/clang/powerpc/oocC.Mod rename to src/library/ooc/oocCLP64.Mod index 2e7751ff..0e97c566 100644 --- a/src/lib/ooc/linux/clang/powerpc/oocC.Mod +++ b/src/library/ooc/oocCLP64.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* LP64 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,39 +30,33 @@ Unix they should be fairly safe. *) TYPE - char* = CHAR; - signedchar* = SHORTINT; (* signed char *) - shortint* = INTEGER; (* short int *) - int* = LONGINT; - set* = SET; (* unsigned int, used as set *) - longint* = LONGINT; (* long int *) - (*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *) - longset* = SET; - address* = LONGINT; - float* = REAL; - double* = LONGREAL; + char* = CHAR; (* 8 bits *) + signedchar* = SYSTEM.INT8; (* 8 bits *) + shortint* = SYSTEM.INT16; (* 16 bits *) + int* = SYSTEM.INT32; (* 32 bits *) + set* = SYSTEM.INT32; (* 32 bits *) + longint* = SYSTEM.INT64; (* 64 bits *) + longset* = SYSTEM.SET64; (* 64 bits *) + address* = SYSTEM.ADDRESS; (* 64 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) sizet* = longint; - uidt* = int; - gidt* = int; + 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; + intPtr1d* = POINTER TO ARRAY OF int; TYPE (* C string type, assignment compatible with character arrays and string constants *) diff --git a/src/lib/ooc/oocChannel.Mod b/src/library/ooc/oocChannel.Mod similarity index 100% rename from src/lib/ooc/oocChannel.Mod rename to src/library/ooc/oocChannel.Mod diff --git a/src/lib/ooc/oocCharClass.Mod b/src/library/ooc/oocCharClass.Mod similarity index 100% rename from src/lib/ooc/oocCharClass.Mod rename to src/library/ooc/oocCharClass.Mod diff --git a/src/lib/ooc/oocComplexMath.Mod b/src/library/ooc/oocComplexMath.Mod similarity index 100% rename from src/lib/ooc/oocComplexMath.Mod rename to src/library/ooc/oocComplexMath.Mod diff --git a/src/lib/ooc/oocConvTypes.Mod b/src/library/ooc/oocConvTypes.Mod similarity index 100% rename from src/lib/ooc/oocConvTypes.Mod rename to src/library/ooc/oocConvTypes.Mod diff --git a/src/lib/ooc/oocFilenames.Mod b/src/library/ooc/oocFilenames.Mod similarity index 100% rename from src/lib/ooc/oocFilenames.Mod rename to src/library/ooc/oocFilenames.Mod diff --git a/src/lib/ooc/oocIntConv.Mod b/src/library/ooc/oocIntConv.Mod similarity index 99% rename from src/lib/ooc/oocIntConv.Mod rename to src/library/ooc/oocIntConv.Mod index 1f6532ab..73185830 100644 --- a/src/lib/ooc/oocIntConv.Mod +++ b/src/library/ooc/oocIntConv.Mod @@ -162,6 +162,7 @@ BEGIN ELSE RETURN strWrongFormat; END; + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/lib/ooc/oocIntStr.Mod b/src/library/ooc/oocIntStr.Mod similarity index 78% rename from src/lib/ooc/oocIntStr.Mod rename to src/library/ooc/oocIntStr.Mod index ec98f128..2b8213ca 100644 --- a/src/lib/ooc/oocIntStr.Mod +++ b/src/library/ooc/oocIntStr.Mod @@ -1,49 +1,49 @@ -(* $Id: IntStr.Mod,v 1.4 1999/09/02 13:07:47 acken Exp $ *) +(* $Id: IntStr.Mod,v 1.4 1999/09/02 13:07:47 acken Exp $ *) MODULE oocIntStr; -(* IntStr - Integer-number/string conversions. +(* IntStr - Integer-number/string conversions. Copyright (C) 1995 Michael Griebling - + This module is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as + 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 this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) - + IMPORT Conv := oocConvTypes, IntConv := oocIntConv; - + TYPE - ConvResults*= Conv.ConvResults; - (* possible values: strAllRight, strOutOfRange, strWrongFormat, strEmpty *) + (** possible values: strAllRight, strOutOfRange, strWrongFormat, strEmpty *) + ConvResults*= Conv.ConvResults; CONST + (** the string format is correct for the corresponding conversion *) strAllRight*=Conv.strAllRight; - (* the string format is correct for the corresponding conversion *) + (** the string is well-formed but the value cannot be represented *) strOutOfRange*=Conv.strOutOfRange; - (* the string is well-formed but the value cannot be represented *) + (** the string is in the wrong format for the conversion *) strWrongFormat*=Conv.strWrongFormat; - (* the string is in the wrong format for the conversion *) + (** the given string is empty *) strEmpty*=Conv.strEmpty; - (* the given string is empty *) - - -(* the string form of a signed whole number is + + +(** the string form of a signed whole number is ["+" | "-"] decimal_digit {decimal_digit} *) - -PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults); -(* Ignores any leading spaces in `str'. If the subsequent characters in `str' +(** Ignores any leading spaces in `str'. If the subsequent characters in `str' are in the format of a signed whole number, assigns a corresponding value to `int'. Assigns a value indicating the format of `str' to `res'. *) + +PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults); BEGIN res:=IntConv.FormatInt(str); IF (res = strAllRight) THEN @@ -63,10 +63,10 @@ BEGIN END END Reverse; +(** Converts the value of `int' to string form and copies the possibly truncated + result to `str'. *) PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR); -(* Converts the value of `int' to string form and copies the possibly truncated - result to `str'. *) CONST maxLength = 11; (* maximum number of digits representing a LONGINT value *) VAR @@ -92,9 +92,9 @@ BEGIN b[e] := 0X; Reverse(b, s, e-1) END; - + COPY(b, str) (* truncate output if necessary *) END IntToStr; - + END oocIntStr. diff --git a/src/lib/ooc/oocJulianDay.Mod b/src/library/ooc/oocJulianDay.Mod similarity index 100% rename from src/lib/ooc/oocJulianDay.Mod rename to src/library/ooc/oocJulianDay.Mod diff --git a/src/lib/ooc/oocLComplexMath.Mod b/src/library/ooc/oocLComplexMath.Mod similarity index 100% rename from src/lib/ooc/oocLComplexMath.Mod rename to src/library/ooc/oocLComplexMath.Mod diff --git a/src/lib/ooc/oocLRealConv.Mod b/src/library/ooc/oocLRealConv.Mod similarity index 99% rename from src/lib/ooc/oocLRealConv.Mod rename to src/library/ooc/oocLRealConv.Mod index a596e6de..7aa13f23 100644 --- a/src/lib/ooc/oocLRealConv.Mod +++ b/src/library/ooc/oocLRealConv.Mod @@ -231,6 +231,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; @@ -285,6 +286,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/lib/ooc/oocLRealMath.Mod b/src/library/ooc/oocLRealMath.Mod similarity index 82% rename from src/lib/ooc/oocLRealMath.Mod rename to src/library/ooc/oocLRealMath.Mod index 3da0cf96..552f8c20 100644 --- a/src/lib/ooc/oocLRealMath.Mod +++ b/src/library/ooc/oocLRealMath.Mod @@ -1,42 +1,42 @@ MODULE oocLRealMath; (* - LRealMath - Target independent mathematical functions for LONGREAL + LRealMath - Target independent mathematical functions for LONGREAL (IEEE double-precision) numbers. - + Numerical approximations are taken from "Software Manual for the Elementary Functions" by Cody & Waite and "Computer Approximations" - by Hart et al. - + by Hart et al. + Copyright (C) 1996-1998 Michael Griebling - + This module is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as + 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 this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -IMPORT l := oocLowLReal, m := oocRealMath; - +IMPORT l := oocLowLReal, m := oocRealMath, SYSTEM; + CONST pi* = 3.1415926535897932384626433832795028841972D0; exp1* = 2.7182818284590452353602874713526624977572D0; - ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *) - + ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *) + (* internally-used constants *) huge=l.large; (* largest number this package accepts *) - miny=l.small; (* smallest number this package accepts *) + miny=l.small; (* smallest number this package accepts *) sqrtHalf=0.70710678118654752440D0; Limit=1.0536712D-8; (* 2**(-MantBits/2) *) eps=5.5511151D-17; (* 2**(-MantBits-1) *) @@ -44,30 +44,30 @@ CONST piByTwo=1.57079632679489661923D0; lnv=0.6931610107421875D0; (* should be exact *) vbytwo=0.13830277879601902638D-4; (* used in sinh/cosh *) - ln2Inv=1.44269504088896340735992468100189213D0; - + ln2Inv=1.44269504088896340735992468100189213D0; + (* error/exception codes *) - NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow; - IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig; - IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped; + NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow; + IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig; + IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped; IllegalHypInvTrig*=m.IllegalHypInvTrig; LossOfAccuracy*=m.LossOfAccuracy; - + VAR a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *) - a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *) - em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *) + a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *) + em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *) LnInfinity: LONGREAL; (* natural log of infinity *) LnSmall: LONGREAL; (* natural log of very small number *) SqrtInfinity: LONGREAL; (* square root of infinity *) TanhMax: LONGREAL; (* maximum Tanh value *) t: LONGREAL; (* internal variables *) - + (* internally used support routines *) PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL; CONST ymax=210828714; (* ENTIER(pi*2**(MantBits/2)) *) - c1=3.1416015625D0; + c1=3.1416015625D0; c2=-8.908910206761537356617D-6; r1=-0.16666666666666665052D+0; r2= 0.83333333333331650314D-2; @@ -77,24 +77,24 @@ PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL; r6= 0.16058936490371589114D-9; r7=-0.76429178068910467734D-12; r8= 0.27204790957888846175D-14; - VAR - n: LONGINT; xn, f, x1, g: LONGREAL; + VAR + n: LONGINT; xn, f, x1, g: LONGREAL; BEGIN IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END; - + (* determine the reduced number *) n:=ENTIER(y*piInv+HALF); xn:=n; IF ODD(n) THEN sign:=-sign END; x:=ABS(x); IF x#y THEN xn:=xn-HALF END; - + (* fractional part of reduced number *) x1:=ENTIER(x); f:=((x1-xn*c1)+(x-x1))-xn*c2; - + (* Pre: |f| <= pi/2 *) IF ABS(f)= 0 *) - CONST + CONST P0=0.41731; P1=0.59016; - VAR - xMant, yEst, z: LONGREAL; xExp: INTEGER; + VAR + xMant, yEst, z: LONGREAL; xExp: INTEGER; BEGIN (* optimize zeros and check for illegal negative roots *) IF x=ZERO THEN RETURN ZERO END; IF x=ZERO THEN n:=SHORT(ENTIER(ln2Inv*x+HALF)) ELSE n:=SHORT(ENTIER(ln2Inv*x-HALF)) END; xn:=n; g:=(x-xn*c1)-xn*c2; - + (* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *) z:=g*g; p:=((P2*z+P1)*z+P0)*g; q:=(Q2*z+Q1)*z+HALF; RETURN l.scale(HALF+p/(q-p), n+1) END exp; - + PROCEDURE ln*(x: LONGREAL): LONGREAL; (* Returns the natural logarithm of x for x > 0 *) CONST @@ -175,27 +175,27 @@ PROCEDURE ln*(x: LONGREAL): LONGREAL; BEGIN (* ensure illegal inputs are trapped and handled *) IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END; - + (* reduce the range of the input *) f:=l.fraction(x)*HALF; n:=l.exponent(x)+1; IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF - ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n) + ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n) END; - + (* evaluate rational approximation from "Software Manual for the Elementary Functions" *) z:=zn/zd; w:=z*z; q:=((w+Q2)*w+Q1)*w+Q0; p:=w*((P2*w+P1)*w+P0); r:=z+z*(p/q); - + (* scale the output *) - xn:=n; + xn:=n; RETURN (xn*c2+r)+xn*c1 END ln; - + (* The angle in all trigonometric functions is measured in radians *) - + PROCEDURE sin* (x: LONGREAL): LONGREAL; BEGIN - IF x 0 *) - CONST - P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1; - P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3; - K=0.44269504088896340736D0; - Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0; + CONST + P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1; + P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3; + K=0.44269504088896340736D0; + Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0; Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2; Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3; Q7=0.14928852680595608186D-4; OneOver16=0.0625D0; XMAX=16*l.expoMax-1; (*XMIN=16*l.expoMin+1;*) XMIN=-16351; (* noch *) - VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT; + VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT; BEGIN (* handle all possible error conditions *) IF ABS(exponent)ZERO THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN -huge END END; - + (* extract the exponent of base to m and clear exponent of base in g *) g:=l.fraction(base)*HALF; m:=l.exponent(base)+1; - + (* determine p table offset with an unrolled binary search *) p:=1; IF g<=a1[9] THEN p:=9 END; IF g<=a1[p+4] THEN INC(p, 4) END; IF g<=a1[p+2] THEN INC(p, 2) END; - + (* compute scaled z so that |z| <= 0.044 *) z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z; (* approximation for log2(z) from "Software Manual for the Elementary Functions" *) - v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16; - + v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16; + (* generate w with extra precision calculations *) y1:=ENTIER(16*exponent)*OneOver16; y2:=exponent-y1; w:=u2*exponent+u1*y2; w1:=ENTIER(16*w)*OneOver16; w2:=w-w1; w:=w1+u1*y1; @@ -283,14 +283,14 @@ BEGIN IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge ELSIF iw1ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END; - mp:=div(iw1, 16)+i; pp:=16*mp-iw1; - z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z; + mp:=div(iw1, 16)+i; pp:=16*mp-iw1; + z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z; RETURN l.scale(z, SHORT(mp)) END power; - + PROCEDURE round*(x: LONGREAL): LONGINT; (* Returns the value of x rounded to the nearest integer *) BEGIN @@ -298,7 +298,7 @@ BEGIN ELSE RETURN ENTIER(x+HALF) END END round; - + PROCEDURE IsRMathException*(): BOOLEAN; (* Returns TRUE if the current coroutine is in the exceptional execution state because of the raising of the RealMath exception; otherwise returns FALSE. @@ -307,15 +307,15 @@ BEGIN RETURN FALSE END IsRMathException; - -(* + +(* Following routines are provided as extensions to the ISO standard. They are either used as the basis of other functions or provide - useful functions which are not part of the ISO standard. + useful functions which are not part of the ISO standard. *) PROCEDURE log* (x, base: LONGREAL): LONGREAL; -(* log(x,base) is the logarithm of x base b. All positive arguments are +(* log(x,base) is the logarithm of x base b. All positive arguments are allowed but base > 0 and base # 1. *) BEGIN (* log(x, base) = log2(x) / log2(base) *) @@ -324,9 +324,9 @@ BEGIN END END log; -PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; +PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; (* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *) - VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT; + VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT; PROCEDURE Adjust(xadj: LONGREAL): LONGREAL; BEGIN @@ -336,17 +336,17 @@ PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; BEGIN (* handle all possible error conditions *) IF base=0 THEN RETURN ONE (* x**0 = 1 *) - ELSIF ABS(x)0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END END; (* trap potential overflows and underflows *) - Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv; + Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv; IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge) ELSIF Exp<-y THEN RETURN ZERO - END; - - (* compute x**base using an optimised algorithm from Knuth, slightly + END; + + (* compute x**base using an optimised algorithm from Knuth, slightly altered : p442, The Art Of Computer Programming, Vol 2 *) y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END; LOOP @@ -355,19 +355,19 @@ BEGIN x:=x*x; END; IF neg THEN RETURN ONE/y ELSE RETURN y END -END ipower; +END ipower; PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL); (* More efficient sin/cos implementation if both values are needed. *) BEGIN Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin) -END sincos; +END sincos; PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL; -(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the +(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the denominator xd is zero, then the numerator xn must not be zero. All arguments are legal except xn = xd = 0. *) - CONST + CONST P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3; P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2; Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3; @@ -387,15 +387,15 @@ BEGIN IF ABS(xn)>ABS(xd) THEN z:=ABS(xd/xn); Quadrant:=2 ELSE z:=ABS(xn/xd); Quadrant:=0 END; - + (* further reduce range to within 0 to 2-sqrt(3) *) IF z>TWO-Sqrt3 THEN z:=(z*Sqrt3-ONE)/(Sqrt3+z); INC(Quadrant) END; - + (* approximation from "Computer Approximations" table ARCTN 5075 *) IF ABS(z)1 THEN atan:=-atan END; CASE Quadrant OF @@ -405,20 +405,20 @@ BEGIN | ELSE (* angle is correct *) END END; - + (* map negative xds into the correct quadrant *) IF xdLnInfinity THEN (* handle exp overflows *) y:=y-lnv; - IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); + IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); IF x>ZERO THEN RETURN huge ELSE RETURN -huge END ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *) END ELSE f:=exp(y); f:=(f-ONE/f)*HALF END; - - (* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *) - IF x>ZERO THEN RETURN f ELSE RETURN -f END + + (* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *) + IF x>ZERO THEN RETURN f ELSE RETURN -f END END sinh; - + PROCEDURE cosh* (x: LONGREAL): LONGREAL; (* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large - that exp(|x|) overflows. *) + that exp(|x|) overflows. *) VAR y, f: LONGREAL; BEGIN y:=ABS(x); IF y>LnInfinity THEN (* handle exp overflows *) y:=y-lnv; - IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); + IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); IF x>ZERO THEN RETURN huge ELSE RETURN -huge END ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *) END ELSE f:=exp(y); RETURN (f+ONE/f)*HALF END END cosh; - + PROCEDURE tanh* (x: LONGREAL): LONGREAL; (* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *) - CONST - P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0; + CONST + P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0; Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3; - ln3over2=0.54930614433405484570D0; + ln3over2=0.54930614433405484570D0; BIG=19.06154747D0; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *) VAR f, t: LONGREAL; BEGIN f:=ABS(x); @@ -487,7 +487,7 @@ BEGIN END arcsinh; PROCEDURE arccosh* (x: LONGREAL): LONGREAL; -(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than +(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than or equal to 1 are legal. *) BEGIN IF x*) - a1[ 1]:=ONE; - a1[ 2]:=ToLONGREAL(3FEEA4AFH, 0A2A490DAH); - a1[ 3]:=ToLONGREAL(3FED5818H, 0DCFBA487H); - a1[ 4]:=ToLONGREAL(3FEC199BH, 0DD85529CH); - a1[ 5]:=ToLONGREAL(3FEAE89FH, 0995AD3ADH); - a1[ 6]:=ToLONGREAL(3FE9C491H, 082A3F090H); - a1[ 7]:=ToLONGREAL(3FE8ACE5H, 0422AA0DBH); - a1[ 8]:=ToLONGREAL(3FE7A114H, 073EB0186H); - a1[ 9]:=ToLONGREAL(3FE6A09EH, 0667F3BCCH); - a1[10]:=ToLONGREAL(3FE5AB07H, 0DD485429H); - a1[11]:=ToLONGREAL(3FE4BFDAH, 0D5362A27H); - a1[12]:=ToLONGREAL(3FE3DEA6H, 04C123422H); - a1[13]:=ToLONGREAL(3FE306FEH, 00A31B715H); - a1[14]:=ToLONGREAL(3FE2387AH, 06E756238H); - a1[15]:=ToLONGREAL(3FE172B8H, 03C7D517AH); - a1[16]:=ToLONGREAL(3FE0B558H, 06CF9890FH); - a1[17]:=HALF; + a1[ 1] := ONE; + a1[ 2] := ToLONGREAL(3FEEA4AFA2A490DAH); (* ToLONGREAL(3FEEA4AFH, 0A2A490DAH); *) + a1[ 3] := ToLONGREAL(3FED5818DCFBA487H); (* ToLONGREAL(3FED5818H, 0DCFBA487H); *) + a1[ 4] := ToLONGREAL(3FEC199BDD85529CH); (* ToLONGREAL(3FEC199BH, 0DD85529CH); *) + a1[ 5] := ToLONGREAL(3FEAE89F995AD3ADH); (* ToLONGREAL(3FEAE89FH, 0995AD3ADH); *) + a1[ 6] := ToLONGREAL(3FE9C49182A3F090H); (* ToLONGREAL(3FE9C491H, 082A3F090H); *) + a1[ 7] := ToLONGREAL(3FE8ACE5422AA0DBH); (* ToLONGREAL(3FE8ACE5H, 0422AA0DBH); *) + a1[ 8] := ToLONGREAL(3FE7A11473EB0186H); (* ToLONGREAL(3FE7A114H, 073EB0186H); *) + a1[ 9] := ToLONGREAL(3FE6A09E667F3BCCH); (* ToLONGREAL(3FE6A09EH, 0667F3BCCH); *) + a1[10] := ToLONGREAL(3FE5AB07DD485429H); (* ToLONGREAL(3FE5AB07H, 0DD485429H); *) + a1[11] := ToLONGREAL(3FE4BFDAD5362A27H); (* ToLONGREAL(3FE4BFDAH, 0D5362A27H); *) + a1[12] := ToLONGREAL(3FE3DEA64C123422H); (* ToLONGREAL(3FE3DEA6H, 04C123422H); *) + a1[13] := ToLONGREAL(3FE306FE0A31B715H); (* ToLONGREAL(3FE306FEH, 00A31B715H); *) + a1[14] := ToLONGREAL(3FE2387A6E756238H); (* ToLONGREAL(3FE2387AH, 06E756238H); *) + a1[15] := ToLONGREAL(3FE172B83C7D517AH); (* ToLONGREAL(3FE172B8H, 03C7D517AH); *) + a1[16] := ToLONGREAL(3FE0B5586CF9890FH); (* ToLONGREAL(3FE0B558H, 06CF9890FH); *) + a1[17] := HALF; (* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *) - a2[1]:=ToLONGREAL(3C90B1EEH, 074320000H); - a2[2]:=ToLONGREAL(3C711065H, 089500000H); - a2[3]:=ToLONGREAL(3C6C7C46H, 0B0700000H); - a2[4]:=ToLONGREAL(3C9AFAA2H, 0047F0000H); - a2[5]:=ToLONGREAL(3C86324CH, 005460000H); - a2[6]:=ToLONGREAL(3C7ADA09H, 011F00000H); - a2[7]:=ToLONGREAL(3C89B07EH, 0B6C80000H); - a2[8]:=ToLONGREAL(3C88A62EH, 04ADC0000H); - + a2[1] := ToLONGREAL(3C90B1EE74320000H); (* ToLONGREAL(3C90B1EEH, 074320000H); *) + a2[2] := ToLONGREAL(3C71106589500000H); (* ToLONGREAL(3C711065H, 089500000H); *) + a2[3] := ToLONGREAL(3C6C7C46B0700000H); (* ToLONGREAL(3C6C7C46H, 0B0700000H); *) + a2[4] := ToLONGREAL(3C9AFAA2047F0000H); (* ToLONGREAL(3C9AFAA2H, 0047F0000H); *) + a2[5] := ToLONGREAL(3C86324C05460000H); (* ToLONGREAL(3C86324CH, 005460000H); *) + a2[6] := ToLONGREAL(3C7ADA0911F00000H); (* ToLONGREAL(3C7ADA09H, 011F00000H); *) + a2[7] := ToLONGREAL(3C89B07EB6C80000H); (* ToLONGREAL(3C89B07EH, 0B6C80000H); *) + a2[8] := ToLONGREAL(3C88A62E4ADC0000H); (* ToLONGREAL(3C88A62EH, 04ADC0000H); *) + (* reenable compiler warnings *) (*<* POP *>*) END oocLRealMath. diff --git a/src/lib/ooc/oocLRealStr.Mod b/src/library/ooc/oocLRealStr.Mod similarity index 100% rename from src/lib/ooc/oocLRealStr.Mod rename to src/library/ooc/oocLRealStr.Mod diff --git a/src/lib/ooc/oocLongInts.Mod b/src/library/ooc/oocLongInts.Mod similarity index 100% rename from src/lib/ooc/oocLongInts.Mod rename to src/library/ooc/oocLongInts.Mod diff --git a/src/lib/ooc/oocLowLReal.Mod b/src/library/ooc/oocLowLReal.Mod similarity index 91% rename from src/lib/ooc/oocLowLReal.Mod rename to src/library/ooc/oocLowLReal.Mod index 0a15f6dd..e28e13cf 100644 --- a/src/lib/ooc/oocLowLReal.Mod +++ b/src/library/ooc/oocLowLReal.Mod @@ -1,21 +1,23 @@ (* $Id: LowLReal.Mod,v 1.6 1999/09/02 13:15:35 acken Exp $ *) MODULE oocLowLReal; +(* ToDo. support 64 bit builds *) + (* - LowLReal - Gives access to the underlying properties of the type LONGREAL - for IEEE double-precision numbers. + LowLReal - Gives access to the underlying properties of the type LONGREAL + for IEEE double-precision numbers. Copyright (C) 1996 Michael Griebling - + This module is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as + 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 this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA @@ -26,7 +28,7 @@ MODULE oocLowLReal; IMPORT Low := oocLowReal, S := SYSTEM; (* - + Real number properties are defined as follows: radix--The whole number value of the radix used to represent the @@ -44,50 +46,50 @@ IMPORT Low := oocLowReal, S := SYSTEM; small--The smallest positive value of the corresponding real number type, represented to maximal precision. - IEC559--A Boolean value that is TRUE if and only if the implementation - of the corresponding real number type conforms to IEC 559:1989 + IEC559--A Boolean value that is TRUE if and only if the implementation + of the corresponding real number type conforms to IEC 559:1989 (IEEE 754:1987) in all regards. NOTES 6 -- If `IEC559' is TRUE, the value of `radix' is 2. - 7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989 + 7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989 is used for the type REAL. - 7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989 + 7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989 is used for the type REAL. - LIA1--A Boolean value that is TRUE if and only if the implementation of - the corresponding real number type conforms to ISO/IEC 10967-1:199x - (LIA-1) in all regards: parameters, arithmetic, exceptions, and + LIA1--A Boolean value that is TRUE if and only if the implementation of + the corresponding real number type conforms to ISO/IEC 10967-1:199x + (LIA-1) in all regards: parameters, arithmetic, exceptions, and notification. - rounds--A Boolean value that is TRUE if and only if each operation produces - a result that is one of the values of the corresponding real number + rounds--A Boolean value that is TRUE if and only if each operation produces + a result that is one of the values of the corresponding real number type nearest to the mathematical result. - gUnderflow--A Boolean value that is TRUE if and only if there are values of - the corresponding real number type between 0.0 and `small'. + gUnderflow--A Boolean value that is TRUE if and only if there are values of + the corresponding real number type between 0.0 and `small'. - exception--A Boolean value that is TRUE if and only if every operation that + exception--A Boolean value that is TRUE if and only if every operation that attempts to produce a real value out of range raises an exception. - extend--A Boolean value that is TRUE if and only if expressions of the - corresponding real number type are computed to higher precision than + extend--A Boolean value that is TRUE if and only if expressions of the + corresponding real number type are computed to higher precision than the stored values. - nModes--The whole number value giving the number of bit positions needed for + nModes--The whole number value giving the number of bit positions needed for the status flags for mode control. - + *) CONST radix*= 2; - places*= 53; - expoMax*= 1023; + places*= 53; + expoMax*= 1023; expoMin*= 1-expoMax; large*= MAX(LONGREAL); (*1.7976931348623157D+308;*) (* MAX(LONGREAL) *) (*small*= 2.2250738585072014D-308;*) small*= 2.2250738585072014/9.9999999999999981D307(*/10^308)*); - IEC559*= TRUE; + IEC559*= TRUE; LIA1*= FALSE; rounds*= FALSE; gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *) @@ -97,23 +99,23 @@ CONST ONE=1.0D0; (* some commonly-used constants *) ZERO=0.0D0; TEN=1.0D1; - + DEBUG = TRUE; - expOffset=expoMax; - hiBit=19; + expOffset=expoMax; + hiBit=19; expBit=hiBit+1; nMask={0..hiBit,31}; (* number mask *) expMask={expBit..30}; (* exponent mask *) - + TYPE Modes*= SET; LongInt=ARRAY 2 OF LONGINT; - LongSet=ARRAY 2 OF SET; - + LongSet=ARRAY 2 OF SET; + VAR (*sml* : LONGREAL; tmp: LONGREAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *) - isBigEndian-: BOOLEAN; (* set when target is big endian *) + isBigEndian-: BOOLEAN; (* set when target is big endian *) (* PROCEDURE power0(i, j : INTEGER) : LONGREAL; (* used to calculate sml at runtime; -- noch *) VAR k : INTEGER; @@ -139,7 +141,7 @@ END err; PROCEDURE ClearError*; BEGIN Low.ClearError -END ClearError; +END ClearError; PROCEDURE ErrorHandler*(err: INTEGER); BEGIN @@ -185,26 +187,26 @@ BEGIN RETURN x END ToReal; (*<* POP *> *) - + PROCEDURE exponent*(x: LONGREAL): INTEGER; -(* +(* The value of the call exponent(x) shall be the exponent value of `x' that lies between `expoMin' and `expoMax'. An exception shall occur and may be raised if `x' is equal to 0.0. - *) + *) VAR ra: LongInt; BEGIN (* NOTE: x=0.0 should raise exception *) IF x=ZERO THEN RETURN 0 - ELSE Move(x, ra); - RETURN SHORT(S.LSH(ra[0],-expBit) MOD 2048)-expOffset + ELSE Move(x, ra); + RETURN SHORT(S.LSH(ra[0],-expBit) MOD 2048)-expOffset END END exponent; PROCEDURE exponent10*(x: LONGREAL): INTEGER; -(* - The value of the call exponent10(x) shall be the base 10 exponent - value of `x'. An exception shall occur and may be raised if `x' is +(* + The value of the call exponent10(x) shall be the base 10 exponent + value of `x'. An exception shall occur and may be raised if `x' is equal to 0.0. *) VAR exp: INTEGER; @@ -215,19 +217,19 @@ BEGIN WHILE x<1 DO x:=x*TEN; DEC(exp) END; RETURN exp END exponent10; - + PROCEDURE fraction*(x: LONGREAL): LONGREAL; (* The value of the call fraction(x) shall be the significand (or significant) part of `x'. Hence the following relationship shall - hold: x = scale(fraction(x), exponent(x)). + hold: x = scale(fraction(x), exponent(x)). *) CONST eZero={(hiBit+2)..29}; VAR ra: LongInt; BEGIN - IF x=ZERO THEN RETURN ZERO + IF x=ZERO THEN RETURN ZERO ELSE Move(x, ra); - ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+eZero); + ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+eZero); RETURN Real(ra)*2.0D0 END END fraction; @@ -246,13 +248,13 @@ PROCEDURE IsNaN * (real: LONGREAL) : BOOLEAN; BEGIN MoveSet(real, ra); RETURN (ra[0]*expMask=expMask) & ((ra[1]#{}) OR (ra[0]*fracMask#{})) -END IsNaN; +END IsNaN; PROCEDURE sign*(x: LONGREAL): LONGREAL; (* The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0, or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or - -1.0 if `x' is equal to 0.0. + -1.0 if `x' is equal to 0.0. *) BEGIN IF x=TEN DO x:=x/TEN; INC(exp) END; - WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END; + WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END; RETURN exp END exponent10; - + +(* TYPE REAL: 1/sign, 8/exponent, 23/significand *) + PROCEDURE fraction*(x: REAL): REAL; (* The value of the call fraction(x) shall be the significand (or significant) part of `x'. Hence the following relationship shall - hold: x = scale(fraction(x), exponent(x)). + hold: x = scale(fraction(x), exponent(x)). *) - CONST eZero={(hiBit+2)..29}; +VAR c: CHAR; BEGIN - IF x=ZERO THEN RETURN ZERO + IF x=ZERO THEN RETURN ZERO + ELSE + (* Set top 7 bits of exponent to 0111111 *) + S.GET(S.ADR(x)+3, c); + c := CHR(((ORD(c) DIV 128) * 128) + 63); (* Set X0111111 (X unchanged) *) + S.PUT(S.ADR(x)+3, c); + (* Set bottom bit of exponent to 0 *) + S.GET(S.ADR(x)+2, c); + c := CHR(ORD(c) MOD 128); (* Set 0XXXXXXX (X unchanged) *) + S.PUT(S.ADR(x)+2, c); + RETURN x * 2.0; + END +(* + CONST eZero={(hiBit+2)..29}; +BEGIN + IF x=ZERO THEN RETURN ZERO ELSE RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+eZero)*2.0 (* set the mantissa's exponent to zero *) END +*) END fraction; PROCEDURE IsInfinity * (real: REAL) : BOOLEAN; - CONST signMask={0..30}; + VAR c0, c1, c2, c3: CHAR; BEGIN - RETURN S.VAL(SET,real)*signMask=expMask + S.GET(S.ADR(real)+0, c3); + S.GET(S.ADR(real)+1, c2); + S.GET(S.ADR(real)+2, c1); + S.GET(S.ADR(real)+3, c0); + RETURN (ORD(c0) MOD 128 = 127) & (ORD(c1) = 128) & (ORD(c2) = 0) & (ORD(c3) = 0) END IsInfinity; PROCEDURE IsNaN * (real: REAL) : BOOLEAN; - CONST fracMask={0..hiBit}; - VAR sreal: SET; + VAR c0, c1, c2, c3: CHAR; BEGIN - sreal:=S.VAL(SET, real); - RETURN (sreal*expMask=expMask) & (sreal*fracMask#{}) -END IsNaN; + S.GET(S.ADR(real)+0, c3); + S.GET(S.ADR(real)+1, c2); + S.GET(S.ADR(real)+2, c1); + S.GET(S.ADR(real)+3, c0); + RETURN (ORD(c0) MOD 128 = 127) + & (ORD(c1) DIV 128 = 1) + & ((ORD(c1) MOD 128 # 0) OR (ORD(c2) # 0) OR (ORD(c3) # 0)) +END IsNaN; PROCEDURE sign*(x: REAL): REAL; (* The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0, or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or - -1.0 if `x' is equal to 0.0. + -1.0 if `x' is equal to 0.0. *) BEGIN IF x"; + +PROCEDURE system*(cmd : ARRAY OF CHAR); +VAR r: INTEGER; +BEGIN + r := Platform.System(cmd) +END system; + + +PROCEDURE -sprntf(s, t0, t1, t2: ARRAY OF CHAR): INTEGER + "sprintf((char*)s, (char*)t0, (char*)t1, (char*)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; + +END oocwrapperlibc. diff --git a/src/lib/ooc2/ooc2Ascii.Mod b/src/library/ooc2/ooc2Ascii.Mod similarity index 100% rename from src/lib/ooc2/ooc2Ascii.Mod rename to src/library/ooc2/ooc2Ascii.Mod diff --git a/src/lib/ooc2/ooc2CharClass.Mod b/src/library/ooc2/ooc2CharClass.Mod similarity index 100% rename from src/lib/ooc2/ooc2CharClass.Mod rename to src/library/ooc2/ooc2CharClass.Mod diff --git a/src/lib/ooc2/ooc2ConvTypes.Mod b/src/library/ooc2/ooc2ConvTypes.Mod similarity index 100% rename from src/lib/ooc2/ooc2ConvTypes.Mod rename to src/library/ooc2/ooc2ConvTypes.Mod diff --git a/src/lib/ooc2/ooc2IntConv.Mod b/src/library/ooc2/ooc2IntConv.Mod similarity index 98% rename from src/lib/ooc2/ooc2IntConv.Mod rename to src/library/ooc2/ooc2IntConv.Mod index 3b9c0d1b..298835d6 100644 --- a/src/lib/ooc2/ooc2IntConv.Mod +++ b/src/library/ooc2/ooc2IntConv.Mod @@ -124,7 +124,7 @@ VAR positive: BOOLEAN; prev, class: Conv.ScanClass; -PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN; + PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN; VAR i: INTEGER; BEGIN (* pre: index-start = maxDigits *) @@ -176,6 +176,7 @@ BEGIN ELSE RETURN strWrongFormat; END; + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/lib/ooc2/ooc2IntStr.Mod b/src/library/ooc2/ooc2IntStr.Mod similarity index 100% rename from src/lib/ooc2/ooc2IntStr.Mod rename to src/library/ooc2/ooc2IntStr.Mod diff --git a/src/lib/ooc2/ooc2LRealConv.Mod b/src/library/ooc2/ooc2LRealConv.Mod similarity index 100% rename from src/lib/ooc2/ooc2LRealConv.Mod rename to src/library/ooc2/ooc2LRealConv.Mod diff --git a/src/lib/ooc2/ooc2Real0.Mod b/src/library/ooc2/ooc2Real0.Mod similarity index 100% rename from src/lib/ooc2/ooc2Real0.Mod rename to src/library/ooc2/ooc2Real0.Mod diff --git a/src/lib/ooc2/ooc2Strings.Mod b/src/library/ooc2/ooc2Strings.Mod similarity index 98% rename from src/lib/ooc2/ooc2Strings.Mod rename to src/library/ooc2/ooc2Strings.Mod index a0ad4362..278f2663 100644 --- a/src/lib/ooc2/ooc2Strings.Mod +++ b/src/library/ooc2/ooc2Strings.Mod @@ -59,7 +59,12 @@ PROCEDURE Length* (stringVal: ARRAY OF CHAR): INTEGER; i: INTEGER; BEGIN i := 0; - WHILE (stringVal[i] # 0X) DO + (* note from noch: + this original ooc code crashes with index out of range + because it doesn't expect a string which has no 0X character + so i had to change it + WHILE (stringVal[i] # 0X) DO *) + WHILE ((i < LEN(stringVal)) & (stringVal[i] # 0X)) DO INC (i) END; RETURN i diff --git a/src/lib/ooc2/darwin/clang/oocwrapperlibc.Mod b/src/library/ooc2/oocwrapperlibc.Mod similarity index 100% rename from src/lib/ooc2/darwin/clang/oocwrapperlibc.Mod rename to src/library/ooc2/oocwrapperlibc.Mod diff --git a/src/lib/oocX11/oocX11.Mod b/src/library/oocX11/oocX11.Mod similarity index 94% rename from src/lib/oocX11/oocX11.Mod rename to src/library/oocX11/oocX11.Mod index fa4e860b..b0e793ac 100644 --- a/src/lib/oocX11/oocX11.Mod +++ b/src/library/oocX11/oocX11.Mod @@ -1,5 +1,5 @@ MODULE oocX11;(* [INTERFACE "C"; - LINK LIB "X11" ADDOPTION LibX11Prefix, LibX11Suffix END];*) + LINK LIB "X11" ADDOPTION LibX11Prefix, LibX11Suffix END];*) IMPORT C := oocC, SYSTEM; @@ -8,6 +8,7 @@ CONST XPROTOCOL* = 11; (* current protocol version *) XPROTOCOLREVISION* = 0; (* current minor version *) + TYPE ulongmask* = C.longset; (*uintmask* = C.set;*) @@ -46,11 +47,11 @@ TYPE CONST None* = 0; (* universal null resource or null atom *) ParentRelative* = 1; (* background pixmap in CreateWindow - and ChangeWindowAttributes *) + and ChangeWindowAttributes *) CopyFromParent* = 0; (* border pixmap in CreateWindow - and ChangeWindowAttributes - special VisualID and special window - class passed to CreateWindow *) + and ChangeWindowAttributes + special VisualID and special window + class passed to CreateWindow *) PointerWindow* = 0; (* destination window in SendEvent *) InputFocus* = 1; (* destination window in SendEvent *) PointerRoot* = 1; (* focus window in SetInputFocus *) @@ -67,96 +68,96 @@ CONST (* Input Event Masks. Used as event-mask window attribute and as arguments to Grab requests. Not to be confused with event names. *) CONST - NoEventMask* = {}; - KeyPressMask* = {0}; - KeyReleaseMask* = {1}; - ButtonPressMask* = {2}; - ButtonReleaseMask* = {3}; - EnterWindowMask* = {4}; - LeaveWindowMask* = {5}; - PointerMotionMask* = {6}; - PointerMotionHintMask* = {7}; - Button1MotionMask* = {8}; - Button2MotionMask* = {9}; - Button3MotionMask* = {10}; - Button4MotionMask* = {11}; - Button5MotionMask* = {12}; - ButtonMotionMask* = {13}; - KeymapStateMask* = {14}; - ExposureMask* = {15}; - VisibilityChangeMask* = {16}; - StructureNotifyMask* = {17}; - ResizeRedirectMask* = {18}; - SubstructureNotifyMask* = {19}; + NoEventMask* = {}; + KeyPressMask* = {0}; + KeyReleaseMask* = {1}; + ButtonPressMask* = {2}; + ButtonReleaseMask* = {3}; + EnterWindowMask* = {4}; + LeaveWindowMask* = {5}; + PointerMotionMask* = {6}; + PointerMotionHintMask* = {7}; + Button1MotionMask* = {8}; + Button2MotionMask* = {9}; + Button3MotionMask* = {10}; + Button4MotionMask* = {11}; + Button5MotionMask* = {12}; + ButtonMotionMask* = {13}; + KeymapStateMask* = {14}; + ExposureMask* = {15}; + VisibilityChangeMask* = {16}; + StructureNotifyMask* = {17}; + ResizeRedirectMask* = {18}; + SubstructureNotifyMask* = {19}; SubstructureRedirectMask* = {20}; - FocusChangeMask* = {21}; - PropertyChangeMask* = {22}; - ColormapChangeMask* = {23}; - OwnerGrabButtonMask* = {24}; + FocusChangeMask* = {21}; + PropertyChangeMask* = {22}; + ColormapChangeMask* = {23}; + OwnerGrabButtonMask* = {24}; (* Event names. Used in "type" field in XEvent structures. Not to be confused with event masks above. They start from 2 because 0 and 1 are reserved in the protocol for errors and replies. *) CONST - KeyPress* = 2; - KeyRelease* = 3; - ButtonPress* = 4; - ButtonRelease* = 5; - MotionNotify* = 6; - EnterNotify* = 7; - LeaveNotify* = 8; - FocusIn* = 9; - FocusOut* = 10; - KeymapNotify* = 11; - Expose* = 12; - GraphicsExpose* = 13; - NoExpose* = 14; + KeyPress* = 2; + KeyRelease* = 3; + ButtonPress* = 4; + ButtonRelease* = 5; + MotionNotify* = 6; + EnterNotify* = 7; + LeaveNotify* = 8; + FocusIn* = 9; + FocusOut* = 10; + KeymapNotify* = 11; + Expose* = 12; + GraphicsExpose* = 13; + NoExpose* = 14; VisibilityNotify* = 15; - CreateNotify* = 16; - DestroyNotify* = 17; - UnmapNotify* = 18; - MapNotify* = 19; - MapRequest* = 20; - ReparentNotify* = 21; - ConfigureNotify* = 22; + CreateNotify* = 16; + DestroyNotify* = 17; + UnmapNotify* = 18; + MapNotify* = 19; + MapRequest* = 20; + ReparentNotify* = 21; + ConfigureNotify* = 22; ConfigureRequest* = 23; - GravityNotify* = 24; - ResizeRequest* = 25; - CirculateNotify* = 26; + GravityNotify* = 24; + ResizeRequest* = 25; + CirculateNotify* = 26; CirculateRequest* = 27; - PropertyNotify* = 28; - SelectionClear* = 29; + PropertyNotify* = 28; + SelectionClear* = 29; SelectionRequest* = 30; - SelectionNotify* = 31; - ColormapNotify* = 32; - ClientMessage* = 33; - MappingNotify* = 34; - LASTEvent* = 35; (* must be bigger than any event # *) + SelectionNotify* = 31; + ColormapNotify* = 32; + ClientMessage* = 33; + MappingNotify* = 34; + LASTEvent* = 35; (* must be bigger than any event # *) (* Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, state in various key-, mouse-, and button-related events. *) CONST - ShiftMask* = {0}; - LockMask* = {1}; + ShiftMask* = {0}; + LockMask* = {1}; ControlMask* = {2}; - Mod1Mask* = {3}; - Mod2Mask* = {4}; - Mod3Mask* = {5}; - Mod4Mask* = {6}; - Mod5Mask* = {7}; + Mod1Mask* = {3}; + Mod2Mask* = {4}; + Mod3Mask* = {5}; + Mod4Mask* = {6}; + Mod5Mask* = {7}; (* modifier names. Used to build a SetModifierMapping request or to read a GetModifierMapping request. These correspond to the masks defined above. *) CONST - ShiftMapIndex* = 0; - LockMapIndex* = 1; + ShiftMapIndex* = 0; + LockMapIndex* = 1; ControlMapIndex* = 2; - Mod1MapIndex* = 3; - Mod2MapIndex* = 4; - Mod3MapIndex* = 5; - Mod4MapIndex* = 6; - Mod5MapIndex* = 7; + Mod1MapIndex* = 3; + Mod2MapIndex* = 4; + Mod3MapIndex* = 5; + Mod4MapIndex* = 6; + Mod5MapIndex* = 7; (* button masks. Used in same manner as Key masks above. Not to be confused with button names below. *) @@ -270,14 +271,14 @@ CONST BadMatch* = 8; (* parameter mismatch *) BadDrawable* = 9; (* parameter not a Pixmap or Window *) BadAccess* = 10; (* depending on context: - - key/button already grabbed - - attempt to free an illegal - cmap entry - - attempt to store into a read-only - color map entry. - - attempt to modify the access control - list from other than the local host. - *) + - key/button already grabbed + - attempt to free an illegal + cmap entry + - attempt to store into a read-only + color map entry. + - attempt to modify the access control + list from other than the local host. + *) BadAlloc* = 11; (* insufficient resources *) BadColor* = 12; (* no such colormap *) BadGC* = 13; (* parameter not a GC *) @@ -630,9 +631,9 @@ CONST $XFree86: xc/lib/X11/Xlib.h,v 3.2 1994/09/17 13:44:15 dawes Exp $ *) (* - * Xlib.h - Header definition and support file for the C subroutine - * interface library (Xlib) to the X Window System Protocol (V11). - * Structures and symbols starting with "" are private to the library. + * Xlib.h - Header definition and support file for the C subroutine + * interface library (Xlib) to the X Window System Protocol (V11). + * Structures and symbols starting with "" are private to the library. *) CONST @@ -706,10 +707,10 @@ TYPE linewidth*: C.int; (* line width *) linestyle*: C.int; (* LineSolid, LineOnOffDash, LineDoubleDash *) capstyle*: C.int; (* CapNotLast, CapButt, - CapRound, CapProjecting *) + CapRound, CapProjecting *) joinstyle*: C.int; (* JoinMiter, JoinRound, JoinBevel *) fillstyle*: C.int; (* FillSolid, FillTiled, - FillStippled, FillOpaeueStippled *) + FillStippled, FillOpaeueStippled *) fillrule*: C.int; (* EvenOddRule, WindingRule *) arcmode*: C.int; (* ArcChord, ArcPieSlice *) tile*: Pixmap; (* tile pixmap for tiling operations *) @@ -1118,9 +1119,9 @@ TYPE xroot*, yroot*: C.int; (* coordinates relative to root *) mode*: C.int; (* NotifyNormal, NotifyGrab, NotifyUngrab *) detail*: C.int; (* - * NotifyAncestor, NotifyVirtual, NotifyInferior, - * NotifyNonlinear,NotifyNonlinearVirtual - *) + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual + *) samescreen*: Bool; (* same screen flag *) focus*: Bool; (* boolean focus *) state*: uintmask; (* key or button mask *) @@ -1137,10 +1138,10 @@ TYPE window*: Window; (* window of event *) mode*: C.int; (* NotifyNormal, NotifyGrab, NotifyUngrab *) detail*: C.int; (* - * NotifyAncestor, NotifyVirtual, NotifyInferior, - * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, - * NotifyPointerRoot, NotifyDetailNone - *) + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, + * NotifyPointerRoot, NotifyDetailNone + *) END; XFocusInEvent* = XFocusChangeEvent; XFocusOutEvent* = XFocusChangeEvent; @@ -1431,7 +1432,7 @@ TYPE display*: DisplayPtr; (* Display the event was read from *) window*: Window; (* unused *) request*: C.int; (* one of MappingModifier, MappingKeyboard, - MappingPointer *) + MappingPointer *) firstkeycode*: C.int; (* first keycode *) count*: C.int; (* defines range of change w. firstkeycode*) END; @@ -1950,6 +1951,13 @@ TYPE XErrorHandler* = PROCEDURE (display: DisplayPtr; errorevent: XErrorEventPtr): C.int; XIOErrorHandler* = PROCEDURE (display: DisplayPtr); XConnectionWatchProc* = PROCEDURE (dpy: DisplayPtr; clientdate: XPointer; fd: C.int; opening: Bool; watchdata: XPointerPtr1d); + + +PROCEDURE -aincludexlib "#include "; +PROCEDURE -aincludexutil "#include "; +PROCEDURE -aincludexresource "#include "; + + (* PROCEDURE XLoadQueryFont* ( display: DisplayPtr; @@ -1987,7 +1995,7 @@ PROCEDURE -XCreateImage* ( height: C.int; bitmapPad: C.int; bytesPerLine: C.int): XImagePtr - "(long)XCreateImage(display, visual, depth, format, offset, data, width, height, bitmapPad, bytesPerLine)"; + "(oocX11_XImagePtr)XCreateImage((struct _XDisplay*)display, (Visual*)visual, depth, format, offset, (char*)data, width, height, bitmapPad, bytesPerLine)"; (* PROCEDURE XInitImage* ( image: XImagePtr): Status; @@ -2017,8 +2025,7 @@ PROCEDURE XGetSubImage* ( * X function declarations. *) *) -PROCEDURE -XOpenDisplay* (name: ARRAY OF C.char): DisplayPtr - "(long)XOpenDisplay(name)"; +PROCEDURE -XOpenDisplay* (name: ARRAY OF C.char): DisplayPtr "(oocX11_DisplayPtr)XOpenDisplay((char*)name)"; PROCEDURE OpenDisplay* (name: ARRAY OF C.char): DisplayPtr; BEGIN @@ -2101,7 +2108,7 @@ PROCEDURE -XCreateGC* ( d: Drawable; valueMask: ulongmask; VAR values: XGCValues): GC - "(long)XCreateGC(display, d, valueMask, values)"; + "(oocX11_GC)XCreateGC((struct _XDisplay*)display, d, valueMask, (XGCValues *)values)"; (* PROCEDURE XGContextFromGC* ( gc: GC): GContext; @@ -2140,7 +2147,7 @@ PROCEDURE -XCreateSimpleWindow* ( borderWidth: C.int; border: C.longint; background: C.longint): Window - "(long)XCreateSimpleWindow(display, parent, x, y, width, height, borderWidth, border, background)"; + "(long)XCreateSimpleWindow((struct _XDisplay*)display, parent, x, y, width, height, borderWidth, border, background)"; (* PROCEDURE XGetSelectionOwner* ( display: DisplayPtr; @@ -2240,7 +2247,7 @@ PROCEDURE XEHeadOfExtensionList* ( PROCEDURE -XRootWindow* ( display: DisplayPtr; screen: C.int): Window - "(long)XRootWindow(display, screen)"; + "(long)XRootWindow((struct _XDisplay*)display, screen)"; (* PROCEDURE XDefaultRootWindow* ( display: DisplayPtr): Window; @@ -2250,7 +2257,7 @@ PROCEDURE XRootWindowOfScreen* ( PROCEDURE -XDefaultVisual* ( display: DisplayPtr; screen: C.int): VisualPtr - "(long)XDefaultVisual(display, screen)"; + "(oocX11_VisualPtr)XDefaultVisual((struct _XDisplay*)display, screen)"; (* PROCEDURE XDefaultVisualOfScreen* ( screen: ScreenPtr): VisualPtr; @@ -2263,12 +2270,12 @@ PROCEDURE XDefaultGCOfScreen* ( PROCEDURE -XBlackPixel* ( display: DisplayPtr; screen: C.int): C.longint - "(long)XBlackPixel(display, screen)"; + "(long)XBlackPixel((struct _XDisplay*)display, screen)"; PROCEDURE -XWhitePixel* ( display: DisplayPtr; screen: C.int): C.longint - "(long)XWhitePixel(display, screen)"; + "(long)XWhitePixel((struct _XDisplay*)display, screen)"; (* PROCEDURE XAllPlanes* (): C.longint; PROCEDURE XBlackPixelOfScreen* ( @@ -2296,7 +2303,7 @@ PROCEDURE XScreenOfDisplay* ( *) PROCEDURE -XDefaultScreenOfDisplay* ( display: DisplayPtr): ScreenPtr - "(long)XDefaultScreen(display)"; + "(long)XDefaultScreen((struct _XDisplay*)display)"; (* PROCEDURE XEventMaskOfScreen* ( screen: ScreenPtr): C.longint; @@ -2523,7 +2530,7 @@ PROCEDURE XClearWindow* ( PROCEDURE -XCloseDisplay* ( display: DisplayPtr) - "XCloseDisplay(display)"; + "XCloseDisplay((struct _XDisplay*)display)"; (* @@ -2577,7 +2584,7 @@ PROCEDURE XDefaultDepthOfScreen* ( *) PROCEDURE -XDefaultScreen* ( display: DisplayPtr): C.int - "(int)XDefaultScreen(display)"; + "(int)XDefaultScreen((struct _XDisplay*)display)"; (* PROCEDURE XDefineCursor* ( display: DisplayPtr; @@ -2591,11 +2598,11 @@ PROCEDURE XDeleteProperty* ( PROCEDURE -XDestroyWindow* ( display: DisplayPtr; w: Window) - "XDestroyWindow(display, w)"; + "XDestroyWindow((struct _XDisplay*)display, w)"; PROCEDURE -XDestroyImage* (image : XImagePtr) - "XDestroyImage(image)"; + "XDestroyImage((struct _XDisplay*)image)"; (* PROCEDURE XDestroySubwindows* ( @@ -2614,7 +2621,7 @@ PROCEDURE XDisplayCells* ( PROCEDURE -XDisplayHeight* ( display: DisplayPtr; screen: C.int): C.int - "(int)XDisplayHeight(display, screen)"; + "(int)XDisplayHeight((struct _XDisplay*)display, screen)"; (* PROCEDURE XDisplayHeightMM* ( display: DisplayPtr; @@ -2630,7 +2637,7 @@ PROCEDURE XDisplayPlanes* ( PROCEDURE -XDisplayWidth* ( display: DisplayPtr; screennumber: C.int): C.int - "(int)XDisplayWidth(display, screen)"; + "(int)XDisplayWidth((struct _XDisplay*)display, screen)"; (* PROCEDURE XDisplayWidthMM* ( display: DisplayPtr; @@ -2690,7 +2697,7 @@ PROCEDURE -XDrawPoint* ( gc: GC; x: C.int; y: C.int) - "XDrawPoint(display, d, gc, x, y)"; + "XDrawPoint((struct _XDisplay*)display, d, (struct _XGC*)gc, x, y)"; (* PROCEDURE XDrawPoints* ( display: DisplayPtr; @@ -2758,7 +2765,7 @@ PROCEDURE XEnableAccessControl* ( PROCEDURE -XEventsQueued* ( display: DisplayPtr; mode: C.int): C.int - "(int)XEventsQueued(display, mode)"; + "(int)XEventsQueued((struct _XDisplay*)display, mode)"; (* PROCEDURE XFetchName* ( display: DisplayPtr; @@ -2797,7 +2804,7 @@ PROCEDURE -XFillRectangle* ( y: C.int; width: C.int; height: C.int) - "XFillRectangle(display, d, gc, x, y, width, height)"; + "XFillRectangle((struct _XDisplay*)display, d, (struct _XGC*)gc, x, y, width, height)"; (* PROCEDURE XFillRectangles* ( display: DisplayPtr; @@ -2808,7 +2815,7 @@ PROCEDURE XFillRectangles* ( *) PROCEDURE -XFlush* ( display: DisplayPtr) - "XFlush(display)"; + "XFlush((struct _XDisplay*)display)"; (* PROCEDURE XForceScreenSaver* ( display: DisplayPtr; @@ -3016,13 +3023,13 @@ PROCEDURE XMapSubwindows* ( PROCEDURE -XMapWindow* ( display: DisplayPtr; w: Window) - "XMapWindow(display, w)"; + "XMapWindow((struct _XDisplay*)display, w)"; PROCEDURE -XMaskEvent* ( display: DisplayPtr; mask: ulongmask; VAR event: XEvent) - "XMaskEvent(display, mask, event)"; + "XMaskEvent((struct _XDisplay*)display, mask, (union _XEvent*)event)"; (* PROCEDURE XMaxCmapsOfScreen* ( @@ -3045,7 +3052,7 @@ PROCEDURE XMoveWindow* ( PROCEDURE -XNextEvent* ( display: DisplayPtr; VAR event: XEvent) - "XNextEvent(display, event)"; + "XNextEvent((struct _XDisplay*)display, (union _XEvent*)event)"; (* PROCEDURE XNoOp* ( display: DisplayPtr); @@ -3091,7 +3098,7 @@ PROCEDURE -XPutImage* ( dstY: C.int; width: C.int; height: C.int) - "XPutImage(display, d, gc, image, srcX, srcY, dstX, dstY, width, height)"; + "XPutImage((struct _XDisplay*)display, d, (struct _XGC*)gc, (struct _XImage*)image, srcX, srcY, dstX, dstY, width, height)"; (* PROCEDURE XQLength* ( display: DisplayPtr): C.int; @@ -3254,7 +3261,7 @@ PROCEDURE -XSelectInput* ( display: DisplayPtr; window: Window; eventMask: ulongmask) - "XSelectInput(display, window, eventMask)"; + "XSelectInput((struct _XDisplay*)display, window, (long)eventMask)"; (* PROCEDURE XSendEvent* ( display: DisplayPtr; @@ -3441,7 +3448,7 @@ PROCEDURE -XStoreName* ( display: DisplayPtr; window: Window; name: ARRAY OF C.char) - "XStoreName(display, window, name)"; + "XStoreName((struct _XDisplay*)display, window, (char*)name)"; (* PROCEDURE XStoreNamedColor* ( display: DisplayPtr; diff --git a/src/lib/oocX11/oocXYplane.Mod b/src/library/oocX11/oocXYplane.Mod similarity index 81% rename from src/lib/oocX11/oocXYplane.Mod rename to src/library/oocX11/oocXYplane.Mod index d0a68210..4da2383f 100644 --- a/src/lib/oocX11/oocXYplane.Mod +++ b/src/library/oocX11/oocXYplane.Mod @@ -32,8 +32,14 @@ VAR initialized: BOOLEAN; (* first call to Open sets this to TRUE *) image: X11.XImagePtr; map: POINTER TO ARRAY OF ARRAY OF SET; + +PROCEDURE -aincludexlib "#include "; +PROCEDURE -aincludexutil "#include "; +PROCEDURE -aincludexresource "#include "; + + PROCEDURE Error (msg: ARRAY OF CHAR); BEGIN Out.String ("Error: "); @@ -70,6 +76,7 @@ PROCEDURE Dot* (x, y, mode: INTEGER); X11.XDrawPoint (display, window, fg, x, H-1-y) | erase: X11.XDrawPoint (display, window, bg, x, H-1-y) + ELSE END; X11.XFlush (display); END @@ -135,44 +142,43 @@ PROCEDURE Key* (): CHAR; PROCEDURE Open*; (* Initializes the drawing plane. *) VAR - screen: C.int; - parent: X11.Window; - bgColor, fgColor: C.longint; + screen: C.int; + parent: X11.Window; + bgColor: C.longint; + fgColor: C.longint; gcValue: X11.XGCValues; - event: X11.XEvent; - x, y: INTEGER; - tmpstr : string; - (*tmpint : INTEGER;*) - scrn : C.int; - vis : X11.VisualPtr; + event: X11.XEvent; + x, y: INTEGER; + tmpstr: string; + scrn : C.int; + vis : X11.VisualPtr; BEGIN - IF ~initialized THEN initialized := TRUE; tmpstr[0] := 0X; (*display := X11.XOpenDisplay (NIL);*) - display := X11.XOpenDisplay (tmpstr); + display := X11.XOpenDisplay(tmpstr); (*display := X11.OpenDisplay (NIL);*) IF (display = NIL) THEN - Error ("Couldn't open display") + Error("Couldn't open display") ELSE - screen := X11.XDefaultScreen (display); + screen := X11.XDefaultScreen(display); X := 0; Y := 0; W := SHORT (X11.XDisplayWidth (display, screen)); - H := SHORT (X11.XDisplayHeight (display, screen)); + H := SHORT (X11.XDisplayHeight(display, screen)); (* adjust ratio W:H to 3:4 [for no paritcular reason] *) IF (W > 3*H DIV 4) THEN W := 3*H DIV 4 END; - parent := X11.XRootWindow (display, screen); - fgColor := X11.XBlackPixel (display, screen); - bgColor := X11.XWhitePixel (display, screen); - window := X11.XCreateSimpleWindow (display, parent, 0, 0, + parent := X11.XRootWindow(display, screen); + fgColor := X11.XBlackPixel(display, screen); + bgColor := X11.XWhitePixel(display, screen); + window := X11.XCreateSimpleWindow(display, parent, 0, 0, W, H, 0, 0, bgColor); - X11.XStoreName (display, window, "XYplane"); - X11.XSelectInput (display, window, X11.KeyPressMask+X11.ExposureMask); - X11.XMapWindow (display, window); + X11.XStoreName(display, window, "XYplane"); + X11.XSelectInput(display, window, X11.KeyPressMask+X11.ExposureMask); + X11.XMapWindow(display, window); X11.XFlush (display); (*tmpint := W + ((*sizeSet*)32-1); tmpint := tmpint DIV 32(*sizeSet*);*) @@ -184,16 +190,16 @@ PROCEDURE Open*; END END; - scrn := X11.XDefaultScreen (display); - vis := X11.XDefaultVisual (display, scrn); - image := X11.XCreateImage (display, + scrn := X11.XDefaultScreen(display); + vis := X11.XDefaultVisual(display, scrn); + image := X11.XCreateImage (display, (*X11.XDefaultVisual (display, X11.XDefaultScreen (display)),*) vis, (*1, X11.XYBitmap, 0, SYSTEM.ADR (map^), W, H, sizeSet, 0);*) - 1, X11.ZPixmap, 0, SYSTEM.ADR (map^), W, H, (*sizeSet*)32, 0); + 1, X11.ZPixmap, 0, SYSTEM.VAL(C.address,SYSTEM.ADR(map^)), W, H, (*sizeSet*)32, 0); (* wait until the window manager gives its ok to draw things *) - X11.XMaskEvent (display, X11.ExposureMask, event); + X11.XMaskEvent(display, X11.ExposureMask, event); (* create graphic context to draw resp. erase a point *) gcValue. foreground := fgColor; @@ -208,7 +214,7 @@ PROCEDURE Open*; END END Open; - PROCEDURE Close*; +PROCEDURE Close*; BEGIN (* X11.XDestroyImage(image); diff --git a/src/lib/oocX11/oocXutil.Mod b/src/library/oocX11/oocXutil.Mod similarity index 99% rename from src/lib/oocX11/oocXutil.Mod rename to src/library/oocX11/oocXutil.Mod index cee7a253..b047cffc 100644 --- a/src/lib/oocX11/oocXutil.Mod +++ b/src/library/oocX11/oocXutil.Mod @@ -359,7 +359,7 @@ PROCEDURE -XLookupString* ( VAR keysymReturn: X.KeySym; (*VAR statusInOut(*[NILCOMPAT]*): XComposeStatus): C.int*) VAR statusInOut(*[NILCOMPAT]*): C.longint): C.int - "(int)XLookupString(eventStruct, bufferReturn, bytesBuffer, keysymReturn, statusInOut)"; + "(int)XLookupString((XKeyEvent*)eventStruct, bufferReturn, bytesBuffer, (KeySym*)keysymReturn, (XComposeStatus*)statusInOut)"; (* PROCEDURE XMatchVisualInfo* ( display: X.DisplayPtr; diff --git a/src/lib/pow/powStrings.Mod b/src/library/pow/powStrings.Mod similarity index 96% rename from src/lib/pow/powStrings.Mod rename to src/library/pow/powStrings.Mod index 5d93fbf3..d3d6d4f8 100644 --- a/src/lib/pow/powStrings.Mod +++ b/src/library/pow/powStrings.Mod @@ -1,639 +1,639 @@ -(*----------------------------------------------------------------------------*) -(* Copyright (c) 1997 by the POW! team *) -(* e-Mail: pow@fim.uni-linz.ac.at *) -(*----------------------------------------------------------------------------*) -(* 08-20-1997 rel. 32/1.0 LEI *) -(* 19-11-1998 rel. 32/1.1 LEI bug in RemoveTrailingSpaces fixed *) -(**--------------------------------------------------------------------------- - This module provides functions for string processing. This includes combining - strings, copying parts of a string, the conversion of a string to a number or - vice-versa etc. - - All functions of this module start to count the character positions with one - i.e. the first character of a string is at position one. - - All procedures applying to characters instead of strings have a - trailing "Char" in their names. - - All procedures should be save. If character arrays are being used which are - to short for a result, the result will be truncated accordingly. - All functions tolerate errors in character position. However, strings - must always be terminated by a character with the code zero in order - to be processed correctly, otherwise runtime errors may occur. - ----------------------------------------------------------------------------*) - -MODULE powStrings; - -CONST - ISSHORTINT*=1; - ISINTEGER*=2; - ISLONGINT*=3; - ISOUTOFRANGE*=4; - STRINGEMPTY*=5; - STRINGILLEGAL*=6; - -TYPE - StringT*=ARRAY OF CHAR; - String*=POINTER TO StringT; - -PROCEDURE Length*(VAR t:StringT):LONGINT; -(** Returns the length of a zero terminated string in characters. *) -VAR - i,maxlen:LONGINT; -BEGIN - maxlen:=LEN(t); - i:=0; - WHILE (i in the string . - If does not occur in zero is returned. If occurs several times the - position of the first occurrence is returned. *) -VAR - maxl:LONGINT; -BEGIN - IF start<1 THEN start:=0 ELSE DEC(start) END; - maxl:=Length(t); - WHILE (start. - If pattern does not occur in zero is returned. If the pattern occurs several - times the position of the first occurrence is returned. *) -VAR - i,j,maxl,patLen:LONGINT; -BEGIN - IF start<1 THEN start:=0 ELSE DEC(start) END; - maxl:=Length(t); - patLen:=Length(pattern); - i:=start; - j:=0; - WHILE (j is copied to the string . The former contents - of are overwritten and therefore lost. - - The copied section in starts at the position and is characters long. - - If is not large enough to hold the copied string then only the - part that fits into is copied. *) -VAR - i,j,l1,l2:LONGINT; -BEGIN - IF pos<1 THEN - dest[0]:=0X; - RETURN; - END; - l1:=Length(source)-pos+1; - IF l1<1 THEN - dest[0]:=0X; - RETURN; - END; - l2:=LEN(dest)-1; - IF l2 is appended to the string . *) -VAR - i,j,lSrc,lDest:LONGINT; -BEGIN - i:=Length(dest); - j:=0; - lDest:=LEN(dest)-1; - lSrc:=LEN(src); - WHILE (i is appended to the string . *) -VAR - l:LONGINT; -BEGIN - l:=Length(dest); - IF LEN(dest)>=l+2 THEN - dest[l]:=ch; - dest[l+1]:=0X; - END; -END AppendChar; - -PROCEDURE UpCaseChar*(x:CHAR):CHAR; -(** For all lower case letters the corresponding capital letter is returned. This also - applies to international characters such as , , , ... All other characters are - returned unchanged. The difference between this function and the Oberon-2 function - CAP(x:CHAR): CHAR is that the return value for characters other than lower case - letters of the latter function depends on the individual compiler implementation. *) -BEGIN - CASE x OF - "a".."z":x:=CHR(ORD(x)+ORD("A")-ORD("a")); - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - | "": x:=""; - ELSE - END; - RETURN x; -END UpCaseChar; - -PROCEDURE UpCase*(VAR t:StringT); -(** All lower case letters in are converted to upper case. This also - applies to international characters such as , , , ... All other characters are - returned unchanged. *) -VAR - i,l:LONGINT; -BEGIN - i:=0; - l:=LEN(t); - WHILE (i characters of the string are deleted. *) -VAR - i,l:LONGINT; -BEGIN - l:=Length(t); - IF (n<1) OR (pos<1) OR (pos>l) THEN RETURN END; - IF n>l-pos+1 THEN n:=l-pos+1 END; - FOR i:=pos-1 TO l-n DO t[i]:=t[i+n]; END; -END Delete; - -PROCEDURE ReverseStringT(VAR t:StringT; n:LONGINT); -VAR - a,b:LONGINT; - x:CHAR; -BEGIN - a:=0; - b:=n-1; - WHILE (a are removed. *) -VAR - i:LONGINT; -BEGIN - i:=Length(t)-1; - WHILE (i>=0) & (t[i]=" ") DO DEC(i) END; - t[i+1]:=0X; -END RemoveTrailingSpaces; - -PROCEDURE RemoveLeadingSpaces*(VAR t:StringT); -(** All blanks at the beginning of are removed. *) -VAR - i,ml:LONGINT; -BEGIN - i:=0; - ml:=LEN(t)-1; - WHILE (i0 THEN Delete(t,1,i) END; -END RemoveLeadingSpaces; - -PROCEDURE Val*(t:StringT):LONGINT; -(** The string is converted to a number and returned as result of the function. - - If the character sequence in does not represent a number and thus the - conversion to a number fails the smallest negative number (MIN(LONGINT)) is returned. - Blanks at the beginning and the end of are ignored. - The number must not contain blanks. *) -CONST - threshDec=MAX(LONGINT) DIV 10; - threshHex=MAX(LONGINT) DIV 16; -VAR - inx,l,v,res:LONGINT; - hex,exit,neg:BOOLEAN; - ch:CHAR; -BEGIN - RemoveTrailingSpaces(t); - RemoveLeadingSpaces(t); - l:=Length(t); - IF l<1 THEN RETURN MIN(LONGINT) END; - hex:=CAP(t[l-1])="H"; - IF hex THEN - DEC(l); - t[l]:=0X; - IF l<1 THEN RETURN MIN(LONGINT) END; - END; - inx:=0; - neg:=FALSE; - res:=0; - IF t[0]="+" THEN INC(inx) - ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END; - IF t[l-1]="+" THEN DEC(l) - ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END; - exit:=FALSE; - IF hex THEN - IF neg THEN - WHILE (inx="0") & (ch<="9") THEN - v:=ORD(ch)-48; - ELSIF (ch>="A") & (ch<="F") THEN - v:=ORD(ch)-65+10; - ELSE - v:=-1; - END; - IF (v<0) OR (v>15) OR (res<-threshHex) THEN - exit:=TRUE - ELSE - res:=res*16-v; - INC(inx); - END; - END; - ELSE - WHILE (inx="0") & (ch<="9") THEN - v:=ORD(ch)-48; - ELSIF (ch>="A") & (ch<="F") THEN - v:=ORD(ch)-65+10; - ELSE - v:=-1; - END; - IF (v<0) OR (v>15) OR (res>threshHex) THEN - exit:=TRUE - ELSE - res:=res*16+v; - INC(inx); - END; - END; - END; - ELSE - IF neg THEN - WHILE (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN - exit:=TRUE - ELSE - res:=res*10-v; - INC(inx); - END; - END; - ELSE - WHILE (inx9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN - exit:=TRUE - ELSE - res:=res*10+v; - INC(inx); - END; - END; - END; - END; - IF exit THEN - RETURN MIN(LONGINT) - ELSE - RETURN res; - END; -END Val; - -PROCEDURE ValResult*(t:StringT):INTEGER; -(** This function can be used to discover whether the string can be converted - to a number, and which kind of integer is at least necessary for storing it. - - The IS??? constants defined for the return value have a numerical order defined - relative to each other: - - ISSHORTINT < ISINTEGER < ISLONGINT < ISOUTOFRANGE < (STRINGEMPTY, STRINGILLEGAL) - - This definition makes it easier to find out if e.g. a number is small enough to - be stored in a INTEGER variable. - - IF Strings.ValResult(txt)<=Strings.ISINTEGER THEN ... - END; - - instead of - - IF (Strings.ValResult(txt)=Strings.ISSHORTINT) OR - (Strings.ValResult(txt)=Strings.ISINTEGER) THEN ... *) -CONST - threshDec=MAX(LONGINT) DIV 10; - threshHex=MAX(LONGINT) DIV 16; - mThreshHex=MIN(LONGINT) DIV 16; -VAR - inx,l,v,res:LONGINT; - h:INTEGER; - hex,exit,neg:BOOLEAN; - ch:CHAR; -BEGIN - RemoveTrailingSpaces(t); - RemoveLeadingSpaces(t); - l:=Length(t); - IF l<1 THEN RETURN STRINGEMPTY END; - hex:=CAP(t[l-1])="H"; - IF hex THEN - DEC(l); - t[l]:=0X; - IF l<1 THEN RETURN STRINGEMPTY END; - END; - inx:=0; - neg:=FALSE; - res:=0; - IF t[0]="+" THEN INC(inx) - ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END; - IF t[l-1]="+" THEN DEC(l) - ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END; - exit:=FALSE; - IF hex THEN - IF neg THEN - WHILE (inx="0") & (ch<="9") THEN - v:=ORD(ch)-48; - ELSIF (ch>="A") & (ch<="F") THEN - v:=ORD(ch)-65+10; - ELSE - v:=-1; - END; - IF (v<0) OR (v>15) OR (res0)) THEN - exit:=TRUE - ELSE - res:=res*16-v; - INC(inx); - END; - END; - ELSE - WHILE (inx="0") & (ch<="9") THEN - v:=ORD(ch)-48; - ELSIF (ch>="A") & (ch<="F") THEN - v:=ORD(ch)-65+10; - ELSE - v:=-1; - END; - IF (v<0) OR (v>15) OR (res>threshHex) THEN - exit:=TRUE - ELSE - res:=res*16+v; - INC(inx); - END; - END; - END; - ELSE - IF neg THEN - WHILE (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN - exit:=TRUE - ELSE - res:=res*10-v; - INC(inx); - END; - END; - ELSE - WHILE (inx9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN - exit:=TRUE - ELSE - res:=res*10+v; - INC(inx); - END; - END; - END; - END; - IF exit THEN - IF (v<0) OR (hex & (v>15)) OR (~hex & (v>9)) THEN RETURN STRINGILLEGAL ELSE RETURN ISOUTOFRANGE END; - ELSE - h:=ISLONGINT; - IF (res>=MIN(INTEGER)) & (res<=MAX(INTEGER)) THEN DEC(h) END; - IF (res>=MIN(SHORTINT)) & (res<=MAX(SHORTINT)) THEN DEC(h) END; - RETURN h; - END; -END ValResult; - -PROCEDURE Str*(x:LONGINT; VAR t:StringT); -(** The number is converted to a string and the result is stored in . - If is not large enough to hold all characters of the number, - is filled with "$" characters. *) -VAR - i:LONGINT; - maxlen:LONGINT; - neg:BOOLEAN; -BEGIN - maxlen:=LEN(t)-1; - IF maxlen<1 THEN - t[0]:=0X; - RETURN; - END; - IF x=0 THEN - t[0]:="0"; - t[1]:=0X; - ELSE - i:=0; - neg:=x<0; - IF neg THEN - IF x=MIN(LONGINT) THEN - COPY("-2147483648",t); - IF Length(t)#11 THEN - FOR i:=0 TO maxlen-1 DO t[i]:="$" END; - t[maxlen]:=0X; - END; - RETURN; - ELSE - x:=-x; - END; - END; - WHILE (x#0) & (i=maxlen)) THEN - FOR i:=0 TO maxlen-1 DO t[i]:="$" END; - t[maxlen]:=0X; - ELSE - IF neg THEN - t[i]:="-"; - INC(i); - END; - t[i]:=0X; - ReverseStringT(t,i); - END; - END; -END Str; - -PROCEDURE HexStr*(x:LONGINT; VAR t:StringT); -(** The number is converted to a string of hexadecimal format and the result is stored - in . At the end of the string an "h" is appended to indicate the hexadecimal - representation of the number. - - If is not large enough to hold all characters of the number, is filled with "$" - characters. Example: 0 becomes "0h", 15 becomes "Fh", 16 becomes "10h". *) -VAR - i:LONGINT; - digit:LONGINT; - maxlen:LONGINT; - neg:BOOLEAN; -BEGIN - maxlen:=LEN(t)-1; - IF maxlen<2 THEN - IF maxlen=1 THEN t[0]:="$"; t[1]:=0X ELSE t[0]:=0X END; - RETURN; - END; - IF x=0 THEN - t[0]:="0"; - t[1]:="h"; - t[2]:=0X; - ELSE - t[0]:="h"; - i:=1; - neg:=x<0; - IF neg THEN - IF x=MIN(LONGINT) THEN - COPY("-80000000h",t); - IF Length(t)#10 THEN - FOR i:=0 TO maxlen-1 DO t[i]:="$" END; - t[maxlen]:=0X; - END; - RETURN; - ELSE - x:=-x; - END; - END; - WHILE (x#0) & (i=maxlen)) THEN - FOR i:=0 TO maxlen-1 DO t[i]:="$" END; - t[maxlen]:=0X; - ELSE - IF neg THEN - t[i]:="-"; - INC(i); - END; - t[i]:=0X; - ReverseStringT(t,i); - END; - END; -END HexStr; - -PROCEDURE InsertChar*(x:CHAR; VAR t:StringT; pos:LONGINT); -(** The character is inserted into the string at the position if - provides space for it. *) -VAR - i,l:LONGINT; -BEGIN - l:=Length(t); - IF l+1l+1 THEN pos:=l+1 END; - FOR i:=l TO pos-1 BY -1 DO t[i+1]:=t[i]; END; - t[pos-1]:=x; - END; -END InsertChar; - -PROCEDURE Insert*(VAR source:StringT; VAR dest:StringT; pos:LONGINT); -(** The string is inserted into the string at the position . - If the maximum length of is insufficient to store the result only - the part of fitting in is inserted. *) -VAR - i,l,dif:LONGINT; -BEGIN - dif:=Length(source); - l:=Length(dest); - IF l+dif+1>LEN(dest) THEN dif:=LEN(dest)-l-1 END; - IF pos<1 THEN pos:=1 ELSIF pos>l+1 THEN pos:=l+1 END; - FOR i:=l TO pos-1 BY -1 DO dest[i+dif]:=dest[i]; END; - FOR i:=pos-1 TO pos-2+dif DO dest[i]:=source[i+1-pos] END; -END Insert; - -PROCEDURE LeftAlign*(VAR t:StringT; n:LONGINT); -(** The length of is increased to characters by appending blanks. If has - already the appropriate length or is longer remains unchanged. *) -VAR - l,i:LONGINT; - maxlen:LONGINT; -BEGIN - maxlen:=LEN(t); - IF n+1>maxlen THEN n:=maxlen-1; END; - l:=Length(t); - IF l<=n-1 THEN - FOR i:=l TO n-1 DO t[i]:=" " END; - t[n]:=0X; - END; -END LeftAlign; - -PROCEDURE RightAlign*(VAR t:StringT; n:LONGINT); -(** The length of is increased to characters by inserting blanks at the - beginning. If has already the appropriate length or is longer remains unchanged. *) -VAR - l,i:LONGINT; - maxlen:LONGINT; -BEGIN - maxlen:=LEN(t); - IF n+1>maxlen THEN n:=maxlen-1; END; - l:=Length(t); - IF l in the string . + If does not occur in zero is returned. If occurs several times the + position of the first occurrence is returned. *) +VAR + maxl:LONGINT; +BEGIN + IF start<1 THEN start:=0 ELSE DEC(start) END; + maxl:=Length(t); + WHILE (start. + If pattern does not occur in zero is returned. If the pattern occurs several + times the position of the first occurrence is returned. *) +VAR + i,j,maxl,patLen:LONGINT; +BEGIN + IF start<1 THEN start:=0 ELSE DEC(start) END; + maxl:=Length(t); + patLen:=Length(pattern); + i:=start; + j:=0; + WHILE (j is copied to the string . The former contents + of are overwritten and therefore lost. + + The copied section in starts at the position and is characters long. + + If is not large enough to hold the copied string then only the + part that fits into is copied. *) +VAR + i,j,l1,l2:LONGINT; +BEGIN + IF pos<1 THEN + dest[0]:=0X; + RETURN; + END; + l1:=Length(source)-pos+1; + IF l1<1 THEN + dest[0]:=0X; + RETURN; + END; + l2:=LEN(dest)-1; + IF l2 is appended to the string . *) +VAR + i,j,lSrc,lDest:LONGINT; +BEGIN + i:=Length(dest); + j:=0; + lDest:=LEN(dest)-1; + lSrc:=LEN(src); + WHILE (i is appended to the string . *) +VAR + l:LONGINT; +BEGIN + l:=Length(dest); + IF LEN(dest)>=l+2 THEN + dest[l]:=ch; + dest[l+1]:=0X; + END; +END AppendChar; + +PROCEDURE UpCaseChar*(x:CHAR):CHAR; +(** For all lower case letters the corresponding capital letter is returned. This also + applies to international characters such as , , , ... All other characters are + returned unchanged. The difference between this function and the Oberon-2 function + CAP(x:CHAR): CHAR is that the return value for characters other than lower case + letters of the latter function depends on the individual compiler implementation. *) +BEGIN + CASE x OF + "a".."z":x:=CHR(ORD(x)+ORD("A")-ORD("a")); + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + | "": x:=""; + ELSE + END; + RETURN x; +END UpCaseChar; + +PROCEDURE UpCase*(VAR t:StringT); +(** All lower case letters in are converted to upper case. This also + applies to international characters such as , , , ... All other characters are + returned unchanged. *) +VAR + i,l:LONGINT; +BEGIN + i:=0; + l:=LEN(t); + WHILE (i characters of the string are deleted. *) +VAR + i,l:LONGINT; +BEGIN + l:=Length(t); + IF (n<1) OR (pos<1) OR (pos>l) THEN RETURN END; + IF n>l-pos+1 THEN n:=l-pos+1 END; + FOR i:=pos-1 TO l-n DO t[i]:=t[i+n]; END; +END Delete; + +PROCEDURE ReverseStringT(VAR t:StringT; n:LONGINT); +VAR + a,b:LONGINT; + x:CHAR; +BEGIN + a:=0; + b:=n-1; + WHILE (a are removed. *) +VAR + i:LONGINT; +BEGIN + i:=Length(t)-1; + WHILE (i>=0) & (t[i]=" ") DO DEC(i) END; + t[i+1]:=0X; +END RemoveTrailingSpaces; + +PROCEDURE RemoveLeadingSpaces*(VAR t:StringT); +(** All blanks at the beginning of are removed. *) +VAR + i,ml:LONGINT; +BEGIN + i:=0; + ml:=LEN(t)-1; + WHILE (i0 THEN Delete(t,1,i) END; +END RemoveLeadingSpaces; + +PROCEDURE Val*(t:StringT):LONGINT; +(** The string is converted to a number and returned as result of the function. + + If the character sequence in does not represent a number and thus the + conversion to a number fails the smallest negative number (MIN(LONGINT)) is returned. + Blanks at the beginning and the end of are ignored. + The number must not contain blanks. *) +CONST + threshDec=MAX(LONGINT) DIV 10; + threshHex=MAX(LONGINT) DIV 16; +VAR + inx,l,v,res:LONGINT; + hex,exit,neg:BOOLEAN; + ch:CHAR; +BEGIN + RemoveTrailingSpaces(t); + RemoveLeadingSpaces(t); + l:=Length(t); + IF l<1 THEN RETURN MIN(LONGINT) END; + hex:=CAP(t[l-1])="H"; + IF hex THEN + DEC(l); + t[l]:=0X; + IF l<1 THEN RETURN MIN(LONGINT) END; + END; + inx:=0; + neg:=FALSE; + res:=0; + IF t[0]="+" THEN INC(inx) + ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END; + IF t[l-1]="+" THEN DEC(l) + ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END; + exit:=FALSE; + IF hex THEN + IF neg THEN + WHILE (inx="0") & (ch<="9") THEN + v:=ORD(ch)-48; + ELSIF (ch>="A") & (ch<="F") THEN + v:=ORD(ch)-65+10; + ELSE + v:=-1; + END; + IF (v<0) OR (v>15) OR (res<-threshHex) THEN + exit:=TRUE + ELSE + res:=res*16-v; + INC(inx); + END; + END; + ELSE + WHILE (inx="0") & (ch<="9") THEN + v:=ORD(ch)-48; + ELSIF (ch>="A") & (ch<="F") THEN + v:=ORD(ch)-65+10; + ELSE + v:=-1; + END; + IF (v<0) OR (v>15) OR (res>threshHex) THEN + exit:=TRUE + ELSE + res:=res*16+v; + INC(inx); + END; + END; + END; + ELSE + IF neg THEN + WHILE (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN + exit:=TRUE + ELSE + res:=res*10-v; + INC(inx); + END; + END; + ELSE + WHILE (inx9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN + exit:=TRUE + ELSE + res:=res*10+v; + INC(inx); + END; + END; + END; + END; + IF exit THEN + RETURN MIN(LONGINT) + ELSE + RETURN res; + END; +END Val; + +PROCEDURE ValResult*(t:StringT):INTEGER; +(** This function can be used to discover whether the string can be converted + to a number, and which kind of integer is at least necessary for storing it. + + The IS??? constants defined for the return value have a numerical order defined + relative to each other: + + ISSHORTINT < ISINTEGER < ISLONGINT < ISOUTOFRANGE < (STRINGEMPTY, STRINGILLEGAL) + + This definition makes it easier to find out if e.g. a number is small enough to + be stored in a INTEGER variable. + + IF Strings.ValResult(txt)<=Strings.ISINTEGER THEN ... + END; + + instead of + + IF (Strings.ValResult(txt)=Strings.ISSHORTINT) OR + (Strings.ValResult(txt)=Strings.ISINTEGER) THEN ... *) +CONST + threshDec=MAX(LONGINT) DIV 10; + threshHex=MAX(LONGINT) DIV 16; + mThreshHex=MIN(LONGINT) DIV 16; +VAR + inx,l,v,res:LONGINT; + h:INTEGER; + hex,exit,neg:BOOLEAN; + ch:CHAR; +BEGIN + RemoveTrailingSpaces(t); + RemoveLeadingSpaces(t); + l:=Length(t); + IF l<1 THEN RETURN STRINGEMPTY END; + hex:=CAP(t[l-1])="H"; + IF hex THEN + DEC(l); + t[l]:=0X; + IF l<1 THEN RETURN STRINGEMPTY END; + END; + inx:=0; + neg:=FALSE; + res:=0; + IF t[0]="+" THEN INC(inx) + ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END; + IF t[l-1]="+" THEN DEC(l) + ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END; + exit:=FALSE; + IF hex THEN + IF neg THEN + WHILE (inx="0") & (ch<="9") THEN + v:=ORD(ch)-48; + ELSIF (ch>="A") & (ch<="F") THEN + v:=ORD(ch)-65+10; + ELSE + v:=-1; + END; + IF (v<0) OR (v>15) OR (res0)) THEN + exit:=TRUE + ELSE + res:=res*16-v; + INC(inx); + END; + END; + ELSE + WHILE (inx="0") & (ch<="9") THEN + v:=ORD(ch)-48; + ELSIF (ch>="A") & (ch<="F") THEN + v:=ORD(ch)-65+10; + ELSE + v:=-1; + END; + IF (v<0) OR (v>15) OR (res>threshHex) THEN + exit:=TRUE + ELSE + res:=res*16+v; + INC(inx); + END; + END; + END; + ELSE + IF neg THEN + WHILE (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN + exit:=TRUE + ELSE + res:=res*10-v; + INC(inx); + END; + END; + ELSE + WHILE (inx9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN + exit:=TRUE + ELSE + res:=res*10+v; + INC(inx); + END; + END; + END; + END; + IF exit THEN + IF (v<0) OR (hex & (v>15)) OR (~hex & (v>9)) THEN RETURN STRINGILLEGAL ELSE RETURN ISOUTOFRANGE END; + ELSE + h:=ISLONGINT; + IF (res>=MIN(INTEGER)) & (res<=MAX(INTEGER)) THEN DEC(h) END; + IF (res>=MIN(SHORTINT)) & (res<=MAX(SHORTINT)) THEN DEC(h) END; + RETURN h; + END; +END ValResult; + +PROCEDURE Str*(x:LONGINT; VAR t:StringT); +(** The number is converted to a string and the result is stored in . + If is not large enough to hold all characters of the number, + is filled with "$" characters. *) +VAR + i:LONGINT; + maxlen:LONGINT; + neg:BOOLEAN; +BEGIN + maxlen:=LEN(t)-1; + IF maxlen<1 THEN + t[0]:=0X; + RETURN; + END; + IF x=0 THEN + t[0]:="0"; + t[1]:=0X; + ELSE + i:=0; + neg:=x<0; + IF neg THEN + IF x=MIN(LONGINT) THEN + COPY("-2147483648",t); + IF Length(t)#11 THEN + FOR i:=0 TO maxlen-1 DO t[i]:="$" END; + t[maxlen]:=0X; + END; + RETURN; + ELSE + x:=-x; + END; + END; + WHILE (x#0) & (i=maxlen)) THEN + FOR i:=0 TO maxlen-1 DO t[i]:="$" END; + t[maxlen]:=0X; + ELSE + IF neg THEN + t[i]:="-"; + INC(i); + END; + t[i]:=0X; + ReverseStringT(t,i); + END; + END; +END Str; + +PROCEDURE HexStr*(x:LONGINT; VAR t:StringT); +(** The number is converted to a string of hexadecimal format and the result is stored + in . At the end of the string an "h" is appended to indicate the hexadecimal + representation of the number. + + If is not large enough to hold all characters of the number, is filled with "$" + characters. Example: 0 becomes "0h", 15 becomes "Fh", 16 becomes "10h". *) +VAR + i:LONGINT; + digit:LONGINT; + maxlen:LONGINT; + neg:BOOLEAN; +BEGIN + maxlen:=LEN(t)-1; + IF maxlen<2 THEN + IF maxlen=1 THEN t[0]:="$"; t[1]:=0X ELSE t[0]:=0X END; + RETURN; + END; + IF x=0 THEN + t[0]:="0"; + t[1]:="h"; + t[2]:=0X; + ELSE + t[0]:="h"; + i:=1; + neg:=x<0; + IF neg THEN + IF x=MIN(LONGINT) THEN + COPY("-80000000h",t); + IF Length(t)#10 THEN + FOR i:=0 TO maxlen-1 DO t[i]:="$" END; + t[maxlen]:=0X; + END; + RETURN; + ELSE + x:=-x; + END; + END; + WHILE (x#0) & (i=maxlen)) THEN + FOR i:=0 TO maxlen-1 DO t[i]:="$" END; + t[maxlen]:=0X; + ELSE + IF neg THEN + t[i]:="-"; + INC(i); + END; + t[i]:=0X; + ReverseStringT(t,i); + END; + END; +END HexStr; + +PROCEDURE InsertChar*(x:CHAR; VAR t:StringT; pos:LONGINT); +(** The character is inserted into the string at the position if + provides space for it. *) +VAR + i,l:LONGINT; +BEGIN + l:=Length(t); + IF l+1l+1 THEN pos:=l+1 END; + FOR i:=l TO pos-1 BY -1 DO t[i+1]:=t[i]; END; + t[pos-1]:=x; + END; +END InsertChar; + +PROCEDURE Insert*(VAR source:StringT; VAR dest:StringT; pos:LONGINT); +(** The string is inserted into the string at the position . + If the maximum length of is insufficient to store the result only + the part of fitting in is inserted. *) +VAR + i,l,dif:LONGINT; +BEGIN + dif:=Length(source); + l:=Length(dest); + IF l+dif+1>LEN(dest) THEN dif:=LEN(dest)-l-1 END; + IF pos<1 THEN pos:=1 ELSIF pos>l+1 THEN pos:=l+1 END; + FOR i:=l TO pos-1 BY -1 DO dest[i+dif]:=dest[i]; END; + FOR i:=pos-1 TO pos-2+dif DO dest[i]:=source[i+1-pos] END; +END Insert; + +PROCEDURE LeftAlign*(VAR t:StringT; n:LONGINT); +(** The length of is increased to characters by appending blanks. If has + already the appropriate length or is longer remains unchanged. *) +VAR + l,i:LONGINT; + maxlen:LONGINT; +BEGIN + maxlen:=LEN(t); + IF n+1>maxlen THEN n:=maxlen-1; END; + l:=Length(t); + IF l<=n-1 THEN + FOR i:=l TO n-1 DO t[i]:=" " END; + t[n]:=0X; + END; +END LeftAlign; + +PROCEDURE RightAlign*(VAR t:StringT; n:LONGINT); +(** The length of is increased to characters by inserting blanks at the + beginning. If has already the appropriate length or is longer remains unchanged. *) +VAR + l,i:LONGINT; + maxlen:LONGINT; +BEGIN + maxlen:=LEN(t); + IF n+1>maxlen THEN n:=maxlen-1; END; + l:=Length(t); + IF l= 0X) & (ch < 80X) THEN + codes[i] := decTable[ORD(ch)]; + ok := codes[i] >= 0; INC(i); + IF ok THEN + Texts.Read(R, ch) + END + ELSE + ok := FALSE + END + END; + IF i > 0 THEN + IF ok & (i = 4) THEN + Files.Write(Ri, CHR(ASH(codes[0], 2)+ASH(codes[1], -4))); + Files.Write(Ri, CHR(ASH(codes[1], 4)+ASH(codes[2], -2))); + Files.Write(Ri, CHR(ASH(codes[2], 6)+codes[3])) + ELSIF ch = "=" THEN + ok := TRUE; end := TRUE; DEC(i); + IF i = 2 THEN + Files.Write(Ri, CHR(ASH(codes[0], 2)+ASH(codes[1], -4))) + ELSIF i = 3 THEN + Files.Write(Ri, CHR(ASH(codes[0], 2)+ASH(codes[1], -4))); + Files.Write(Ri, CHR(ASH(codes[1], 4)+ASH(codes[2], -2))) + ELSIF i # 0 THEN + ok := FALSE + END + ELSE + end := TRUE + END + ELSE + end := TRUE + END + UNTIL R.eot OR end; + RETURN ok +END DecodeText; + +PROCEDURE Decode*; +VAR + S: Texts.Scanner; + F: Files.File; + T: Texts.Text; + beg, end, time: LONGINT; + res: INTEGER; +BEGIN + Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); + Texts.Scan(S); + IF S.class IN {Texts.Name, Texts.String} THEN + Texts.WriteString(W, S.s); + F := Files.New(S.s); + Texts.Scan(S); + IF (S.class = Texts.Char) & ((S.c = "@") OR (S.c = "^")) THEN + T := NIL; + time := -1; + Oberon.GetSelection(T, beg, end, time); + IF T = NIL THEN + Texts.WriteString(W, " - no selection"); + Texts.WriteLn(W); + Texts.Append(Oberon.Log, W.buf); + RETURN + END + ELSIF S.class IN {Texts.Name, Texts.String} THEN + NEW(T); + Texts.Open(T, S.s); + beg := 0 + ELSE + beg := Texts.Pos(S); + T := Oberon.Par.text + END; + IF DecodeText(T, beg, F) THEN + Files.Register(F); + Texts.WriteString(W, " done") + ELSE + Texts.WriteString(W, " failed") + END; + Texts.WriteLn(W); + Texts.Append(Oberon.Log, W.buf) + END +END Decode; + +PROCEDURE EncodeFile*(F: Files.File; T: Texts.Text); +VAR + R: Files.Rider; + i, j, c, c0, c1, c2, l: LONGINT; + chars: ARRAY 3 OF CHAR; + + PROCEDURE OutCode(); + BEGIN + IF l > 76 THEN (* Standard line length for Base64 *) + Texts.WriteLn(W); + Texts.Append(T, W.buf); + l := 0 + END; + c0 := ORD(chars[0]); + c := ASH(c0, -2); + Texts.Write(W, encTable[c]); + c0 := c0 - ASH(c, 2); + + c1 := ORD(chars[1]); + c := ASH(c0, 4) + ASH(c1, -4); + Texts.Write(W, encTable[c]); + c1 := c1 MOD 16; + + c2 := ORD(chars[2]); + c := ASH(c1, 2) + ASH(c2, -6); + Texts.Write(W, encTable[c]); + c2 := c2 MOD 64; + + Texts.Write(W, encTable[c2]); + INC(l, 4) + END OutCode; + +BEGIN + l := 0; + Files.Set(R, F, 0); + Files.Read(R, chars[0]); + i := 1; + WHILE ~R.eof DO + IF i >= 3 THEN + OutCode(); + i := 0 + END; + Files.Read(R, chars[i]); + INC(i) + END; + DEC(i); + IF i > 0 THEN + j := i; + WHILE i < 3 DO + chars[i] := 0X; + INC(i) + END; + OutCode(); + (* Handle padding *) + IF j < 3 THEN + Texts.Append(T, W.buf); + (* Remove extra characters and add padding *) + j := 3 - j; + Texts.Delete(T, T.len - j, T.len); + FOR i := 1 TO j DO + Texts.Write(W, "=") + END + END + END; + Texts.WriteLn(W); + Texts.Append(T, W.buf) +END EncodeFile; + +PROCEDURE Encode*; +VAR + S: Texts.Scanner; + F: Files.File; + T: Texts.Text; + name: ARRAY 256 OF CHAR; +BEGIN + NEW(T); + Texts.Open(T, ""); + Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); + Texts.Scan(S); + IF S.class IN {Texts.Name, Texts.String} THEN + COPY(S.s, name); + F := Files.Old(name); + IF F # NIL THEN + EncodeFile(F, T); + (* In VOC, we'll output to console instead of opening a viewer *) + Out.String("=== Base64 Encoded: "); Out.String(name); + Out.String(" ==="); Out.Ln; + (* Output the encoded text - would need a helper to print Text to console *) + Out.String("[Base64 encoded content would be here]"); Out.Ln; + Out.String("=== End ==="); Out.Ln; + ELSE + Out.String("File not found: "); Out.String(name); Out.Ln; + END + END +END Encode; + +PROCEDURE InitTables(); +VAR i, max: INTEGER; +BEGIN + (* Build encoding table *) + max := ORD("Z") - ORD("A"); + FOR i := 0 TO max DO + encTable[i] := CHR(i + ORD("A")) + END; + INC(max); + FOR i := max TO max + ORD("z") - ORD("a") DO + encTable[i] := CHR(i - max + ORD("a")) + END; + max := max + ORD("z") - ORD("a") + 1; + FOR i := max TO max + ORD("9") - ORD("0") DO + encTable[i] := CHR(i - max + ORD("0")) + END; + encTable[62] := "+"; + encTable[63] := "/"; + + (* Build decoding table *) + FOR i := 0 TO 127 DO + decTable[i] := -1 + END; + FOR i := 0 TO 63 DO + decTable[ORD(encTable[i])] := i + END +END InitTables; + +BEGIN + InitTables(); + Texts.OpenWriter(W) +END ethBase64. diff --git a/src/lib/s3/ethDates.Mod b/src/library/s3/ethDates.Mod similarity index 100% rename from src/lib/s3/ethDates.Mod rename to src/library/s3/ethDates.Mod diff --git a/src/lib/s3/ethGZReaders.Mod b/src/library/s3/ethGZReaders.Mod similarity index 100% rename from src/lib/s3/ethGZReaders.Mod rename to src/library/s3/ethGZReaders.Mod diff --git a/src/lib/s3/ethGZWriters.Mod b/src/library/s3/ethGZWriters.Mod similarity index 100% rename from src/lib/s3/ethGZWriters.Mod rename to src/library/s3/ethGZWriters.Mod diff --git a/src/lib/s3/ethMD5.Mod b/src/library/s3/ethMD5.Mod similarity index 62% rename from src/lib/s3/ethMD5.Mod rename to src/library/s3/ethMD5.Mod index 57975454..4d33a026 100644 --- a/src/lib/s3/ethMD5.Mod +++ b/src/library/s3/ethMD5.Mod @@ -4,6 +4,8 @@ Refer to the "General ETH Oberon System Source License" contract available at: h MODULE ethMD5; (** portable *) (* ejz *) IMPORT SYSTEM; +(* todo. Use fixed size integers and sets. *) + (** The MD5 Message-Digest Algorithm (RFC1321) The algorithm takes as input a message of arbitrary length and produces @@ -29,17 +31,18 @@ under a public-key cryptosystem such as RSA. *) VAR cont: Context; BEGIN NEW(cont); - cont.buf[0] := 067452301H; - cont.buf[1] := 0EFCDAB89H; - cont.buf[2] := 098BADCFEH; - cont.buf[3] := 010325476H; + cont.buf[0] := 00000000067452301H; + cont.buf[1] := 0FFFFFFFFEFCDAB89H; + cont.buf[2] := 0FFFFFFFF98BADCFEH; + cont.buf[3] := 00000000010325476H; cont.bits := 0; RETURN cont END New; PROCEDURE ByteReverse(VAR in: ARRAY OF SYSTEM.BYTE; VAR out: ARRAY OF LONGINT; longs: LONGINT); VAR - adr, t, i: LONGINT; + adr: SYSTEM.ADDRESS; + t, i: LONGINT; bytes: ARRAY 4 OF CHAR; BEGIN adr := SYSTEM.ADR(in[0]); i := 0; @@ -107,73 +110,73 @@ under a public-key cryptosystem such as RSA. *) BEGIN a := buf[0]; b := buf[1]; c := buf[2]; d := buf[3]; - STEP1(a, b, c, d, in[0]+0D76AA478H, 7); - STEP1(d, a, b, c, in[1]+0E8C7B756H, 12); - STEP1(c, d, a, b, in[2]+0242070DBH, 17); - STEP1(b, c, d, a, in[3]+0C1BDCEEEH, 22); - STEP1(a, b, c, d, in[4]+0F57C0FAFH, 7); - STEP1(d, a, b, c, in[5]+04787C62AH, 12); - STEP1(c, d, a, b, in[6]+0A8304613H, 17); - STEP1(b, c, d, a, in[7]+0FD469501H, 22); - STEP1(a, b, c, d, in[8]+0698098D8H, 7); - STEP1(d, a, b, c, in[9]+08B44F7AFH, 12); - STEP1(c, d, a, b, in[10]+0FFFF5BB1H, 17); - STEP1(b, c, d, a, in[11]+0895CD7BEH, 22); - STEP1(a, b, c, d, in[12]+06B901122H, 7); - STEP1(d, a, b, c, in[13]+0FD987193H, 12); - STEP1(c, d, a, b, in[14]+0A679438EH, 17); - STEP1(b, c, d, a, in[15]+049B40821H, 22); + STEP1(a, b, c, d, in[0] + 0FFFFFFFFD76AA478H, 7); + STEP1(d, a, b, c, in[1] + 0FFFFFFFFE8C7B756H, 12); + STEP1(c, d, a, b, in[2] + 000000000242070DBH, 17); + STEP1(b, c, d, a, in[3] + 0FFFFFFFFC1BDCEEEH, 22); + STEP1(a, b, c, d, in[4] + 0FFFFFFFFF57C0FAFH, 7); + STEP1(d, a, b, c, in[5] + 0000000004787C62AH, 12); + STEP1(c, d, a, b, in[6] + 0FFFFFFFFA8304613H, 17); + STEP1(b, c, d, a, in[7] + 0FFFFFFFFFD469501H, 22); + STEP1(a, b, c, d, in[8] + 000000000698098D8H, 7); + STEP1(d, a, b, c, in[9] + 0FFFFFFFF8B44F7AFH, 12); + STEP1(c, d, a, b, in[10] + 0FFFFFFFFFFFF5BB1H, 17); + STEP1(b, c, d, a, in[11] + 0FFFFFFFF895CD7BEH, 22); + STEP1(a, b, c, d, in[12] + 0000000006B901122H, 7); + STEP1(d, a, b, c, in[13] + 0FFFFFFFFFD987193H, 12); + STEP1(c, d, a, b, in[14] + 0FFFFFFFFA679438EH, 17); + STEP1(b, c, d, a, in[15] + 00000000049B40821H, 22); - STEP2(a, b, c, d, in[1]+0F61E2562H, 5); - STEP2(d, a, b, c, in[6]+0C040B340H, 9); - STEP2(c, d, a, b, in[11]+0265E5A51H, 14); - STEP2(b, c, d, a, in[0]+0E9B6C7AAH, 20); - STEP2(a, b, c, d, in[5]+0D62F105DH, 5); - STEP2(d, a, b, c, in[10]+02441453H, 9); - STEP2(c, d, a, b, in[15]+0D8A1E681H, 14); - STEP2(b, c, d, a, in[4]+0E7D3FBC8H, 20); - STEP2(a, b, c, d, in[9]+021E1CDE6H, 5); - STEP2(d, a, b, c, in[14]+0C33707D6H, 9); - STEP2(c, d, a, b, in[3]+0F4D50D87H, 14); - STEP2(b, c, d, a, in[8]+0455A14EDH, 20); - STEP2(a, b, c, d, in[13]+0A9E3E905H, 5); - STEP2(d, a, b, c, in[2]+0FCEFA3F8H, 9); - STEP2(c, d, a, b, in[7]+0676F02D9H, 14); - STEP2(b, c, d, a, in[12]+08D2A4C8AH, 20); + STEP2(a, b, c, d, in[1] + 0FFFFFFFFF61E2562H, 5); + STEP2(d, a, b, c, in[6] + 0FFFFFFFFC040B340H, 9); + STEP2(c, d, a, b, in[11] + 000000000265E5A51H, 14); + STEP2(b, c, d, a, in[0] + 0FFFFFFFFE9B6C7AAH, 20); + STEP2(a, b, c, d, in[5] + 0FFFFFFFFD62F105DH, 5); + STEP2(d, a, b, c, in[10] + 00000000002441453H, 9); + STEP2(c, d, a, b, in[15] + 0FFFFFFFFD8A1E681H, 14); + STEP2(b, c, d, a, in[4] + 0FFFFFFFFE7D3FBC8H, 20); + STEP2(a, b, c, d, in[9] + 00000000021E1CDE6H, 5); + STEP2(d, a, b, c, in[14] + 0FFFFFFFFC33707D6H, 9); + STEP2(c, d, a, b, in[3] + 0FFFFFFFFF4D50D87H, 14); + STEP2(b, c, d, a, in[8] + 000000000455A14EDH, 20); + STEP2(a, b, c, d, in[13] + 0FFFFFFFFA9E3E905H, 5); + STEP2(d, a, b, c, in[2] + 0FFFFFFFFFCEFA3F8H, 9); + STEP2(c, d, a, b, in[7] + 000000000676F02D9H, 14); + STEP2(b, c, d, a, in[12] + 0FFFFFFFF8D2A4C8AH, 20); - STEP3(a, b, c, d, in[5]+0FFFA3942H, 4); - STEP3(d, a, b, c, in[8]+08771F681H, 11); - STEP3(c, d, a, b, in[11]+06D9D6122H, 16); - STEP3(b, c, d, a, in[14]+0FDE5380CH, 23); - STEP3(a, b, c, d, in[1]+0A4BEEA44H, 4); - STEP3(d, a, b, c, in[4]+04BDECFA9H, 11); - STEP3(c, d, a, b, in[7]+0F6BB4B60H, 16); - STEP3(b, c, d, a, in[10]+0BEBFBC70H, 23); - STEP3(a, b, c, d, in[13]+0289B7EC6H, 4); - STEP3(d, a, b, c, in[0]+0EAA127FAH, 11); - STEP3(c, d, a, b, in[3]+0D4EF3085H, 16); - STEP3(b, c, d, a, in[6]+04881D05H, 23); - STEP3(a, b, c, d, in[9]+0D9D4D039H, 4); - STEP3(d, a, b, c, in[12]+0E6DB99E5H, 11); - STEP3(c, d, a, b, in[15]+01FA27CF8H, 16); - STEP3(b, c, d, a, in[2]+0C4AC5665H, 23); + STEP3(a, b, c, d, in[5] + 0FFFFFFFFFFFA3942H, 4); + STEP3(d, a, b, c, in[8] + 0FFFFFFFF8771F681H, 11); + STEP3(c, d, a, b, in[11] + 0000000006D9D6122H, 16); + STEP3(b, c, d, a, in[14] + 0FFFFFFFFFDE5380CH, 23); + STEP3(a, b, c, d, in[1] + 0FFFFFFFFA4BEEA44H, 4); + STEP3(d, a, b, c, in[4] + 0000000004BDECFA9H, 11); + STEP3(c, d, a, b, in[7] + 0FFFFFFFFF6BB4B60H, 16); + STEP3(b, c, d, a, in[10] + 0FFFFFFFFBEBFBC70H, 23); + STEP3(a, b, c, d, in[13] + 000000000289B7EC6H, 4); + STEP3(d, a, b, c, in[0] + 0FFFFFFFFEAA127FAH, 11); + STEP3(c, d, a, b, in[3] + 0FFFFFFFFD4EF3085H, 16); + STEP3(b, c, d, a, in[6] + 00000000004881D05H, 23); + STEP3(a, b, c, d, in[9] + 0FFFFFFFFD9D4D039H, 4); + STEP3(d, a, b, c, in[12] + 0FFFFFFFFE6DB99E5H, 11); + STEP3(c, d, a, b, in[15] + 0000000001FA27CF8H, 16); + STEP3(b, c, d, a, in[2] + 0FFFFFFFFC4AC5665H, 23); - STEP4(a, b, c, d, in[0]+0F4292244H, 6); - STEP4(d, a, b, c, in[7]+0432AFF97H, 10); - STEP4(c, d, a, b, in[14]+0AB9423A7H, 15); - STEP4(b, c, d, a, in[5]+0FC93A039H, 21); - STEP4(a, b, c, d, in[12]+0655B59C3H, 6); - STEP4(d, a, b, c, in[3]+08F0CCC92H, 10); - STEP4(c, d, a, b, in[10]+0FFEFF47DH, 15); - STEP4(b, c, d, a, in[1]+085845DD1H, 21); - STEP4(a, b, c, d, in[8]+06FA87E4FH, 6); - STEP4(d, a, b, c, in[15]+0FE2CE6E0H, 10); - STEP4(c, d, a, b, in[6]+0A3014314H, 15); - STEP4(b, c, d, a, in[13]+04E0811A1H, 21); - STEP4(a, b, c, d, in[4]+0F7537E82H, 6); - STEP4(d, a, b, c, in[11]+ 0BD3AF235H, 10); - STEP4(c, d, a, b, in[2]+02AD7D2BBH, 15); - STEP4(b, c, d, a, in[9]+0EB86D391H, 21); + STEP4(a, b, c, d, in[0] + 0FFFFFFFFF4292244H, 6); + STEP4(d, a, b, c, in[7] + 000000000432AFF97H, 10); + STEP4(c, d, a, b, in[14] + 0FFFFFFFFAB9423A7H, 15); + STEP4(b, c, d, a, in[5] + 0FFFFFFFFFC93A039H, 21); + STEP4(a, b, c, d, in[12] + 000000000655B59C3H, 6); + STEP4(d, a, b, c, in[3] + 0FFFFFFFF8F0CCC92H, 10); + STEP4(c, d, a, b, in[10] + 0FFFFFFFFFFEFF47DH, 15); + STEP4(b, c, d, a, in[1] + 0FFFFFFFF85845DD1H, 21); + STEP4(a, b, c, d, in[8] + 0000000006FA87E4FH, 6); + STEP4(d, a, b, c, in[15] + 0FFFFFFFFFE2CE6E0H, 10); + STEP4(c, d, a, b, in[6] + 0FFFFFFFFA3014314H, 15); + STEP4(b, c, d, a, in[13] + 0000000004E0811A1H, 21); + STEP4(a, b, c, d, in[4] + 0FFFFFFFFF7537E82H, 6); + STEP4(d, a, b, c, in[11] + 0FFFFFFFFBD3AF235H, 10); + STEP4(c, d, a, b, in[2] + 0000000002AD7D2BBH, 15); + STEP4(b, c, d, a, in[9] + 0FFFFFFFFEB86D391H, 21); INC(buf[0], a); INC(buf[1], b); INC(buf[2], c); INC(buf[3], d) @@ -231,7 +234,7 @@ under a public-key cryptosystem such as RSA. *) SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), 64); ByteReverse(context.in, in, 16); Transform(context.buf, in); - INC(beg, 64); DEC(len, 64) + INC(beg, 64); DEC(len, 64) END; IF len > 0 THEN SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), len) diff --git a/src/lib/s3/ethRandomNumbers.Mod b/src/library/s3/ethRandomNumbers.Mod similarity index 95% rename from src/lib/s3/ethRandomNumbers.Mod rename to src/library/s3/ethRandomNumbers.Mod index f5724267..f3624414 100644 --- a/src/lib/s3/ethRandomNumbers.Mod +++ b/src/library/s3/ethRandomNumbers.Mod @@ -3,7 +3,7 @@ Refer to the "General ETH Oberon System Source License" contract available at: h MODULE ethRandomNumbers; (** portable *) (* Random Number Generator, page 12 *) -IMPORT Math := oocOakMath, Oberon := Kernel, SYSTEM; +IMPORT Math := oocOakMath, Oberon := Platform, SYSTEM; VAR Z, t, d: LONGINT; diff --git a/src/lib/s3/armv6j_hardfp/ethReals.Mod b/src/library/s3/ethReals.Mod similarity index 55% rename from src/lib/s3/armv6j_hardfp/ethReals.Mod rename to src/library/s3/ethReals.Mod index a7189089..484b186c 100644 --- a/src/lib/s3/armv6j_hardfp/ethReals.Mod +++ b/src/library/s3/ethReals.Mod @@ -3,14 +3,14 @@ Refer to the "General ETH Oberon System Source License" contract available at: h MODULE ethReals; (** portable *) -(** Implementation of the non-portable components of IEEE REAL and -LONGREAL manipulation. The routines here are required to do conversion -of reals to strings and back. -Implemented by Bernd Moesli, Seminar for Applied Mathematics, +(** Implementation of the non-portable components of IEEE REAL and +LONGREAL manipulation. The routines here are required to do conversion +of reals to strings and back. +Implemented by Bernd Moesli, Seminar for Applied Mathematics, Swiss Federal Institute of Technology Zrich. *) -IMPORT SYSTEM; +IMPORT SYSTEM, Modules; (* Bernd Moesli Seminar for Applied Mathematics @@ -33,6 +33,7 @@ IMPORT SYSTEM; 7.11.1995 jt: dynamic endianess test 22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps) 05.01.98 prk: NaN with INF support + 17.02.16 dcb: Adapt for 32 bit INTEGER and 64 bit LONGINT. *) VAR @@ -45,55 +46,109 @@ VAR (** Returns the shifted binary exponent (0 <= e < 256). *) PROCEDURE Expo* (x: REAL): LONGINT; BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 + IF SIZE(INTEGER) = 4 THEN + RETURN SHORT(ASH(SYSTEM.VAL(INTEGER, x), -23)) MOD 256 + ELSIF SIZE(LONGINT) = 4 THEN + RETURN SHORT(ASH(SYSTEM.VAL(LONGINT, x), -23)) MOD 256 + ELSE Modules.Halt(-15); + END END Expo; (** Returns the shifted binary exponent (0 <= e < 2048). *) PROCEDURE ExpoL* (x: LONGREAL): LONGINT; VAR i: LONGINT; BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 + IF SIZE(LONGINT) = 8 THEN + RETURN ASH(SYSTEM.VAL(LONGINT, x), -50) MOD 256 + ELSE + SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 + END END ExpoL; (** Sets the shifted binary exponent. *) -PROCEDURE SetExpo* (e: LONGINT; VAR x: REAL); - VAR i: LONGINT; +PROCEDURE SetExpo* (e: INTEGER; VAR x: REAL); + VAR i: INTEGER; l: LONGINT; BEGIN - SYSTEM.GET(SYSTEM.ADR(x), i); - i:= ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23); - SYSTEM.PUT(SYSTEM.ADR(x), i) + IF SIZE(LONGINT) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x), l); + l := ASH(ASH(ASH(l, -31), 8) + e MOD 256, 23) + l MOD ASH(1, 23); + SYSTEM.PUT(SYSTEM.ADR(x), l) + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x), i); + i := SHORT(ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23)); + SYSTEM.PUT(SYSTEM.ADR(x), i) + ELSE Modules.Halt(-15) + END END SetExpo; (** Sets the shifted binary exponent. *) PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL); - VAR i: LONGINT; + VAR i: INTEGER; l: LONGINT; BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, i); - i:= ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20); - SYSTEM.PUT(SYSTEM.ADR(x) + H, i) + IF SIZE(LONGINT) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x) + H, l); + l := ASH(ASH(ASH(l, -31), 11) + e MOD 2048, 20) + l MOD ASH(1, 20); + SYSTEM.PUT(SYSTEM.ADR(x) + H, l) + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x) + H, i); + i := SHORT(ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20)); + SYSTEM.PUT(SYSTEM.ADR(x) + H, i) + ELSE Modules.Halt(-15) + END END SetExpoL; (** Convert hexadecimal to REAL. *) PROCEDURE Real* (h: LONGINT): REAL; VAR x: REAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x), h); RETURN x +BEGIN + IF SIZE(LONGINT) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(x), h) + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(x), SYSTEM.VAL(INTEGER, h)) + ELSE Modules.Halt(-15) + END; + RETURN x END Real; (** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*) PROCEDURE RealL* (h, l: LONGINT): LONGREAL; VAR x: LONGREAL; -BEGIN SYSTEM.PUT(SYSTEM.ADR(x) + H, h); SYSTEM.PUT(SYSTEM.ADR(x) + L, l); RETURN x +BEGIN + IF SIZE(LONGINT) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(x) + H, h); + SYSTEM.PUT(SYSTEM.ADR(x) + L, l) + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(x) + H, SYSTEM.VAL(INTEGER, h)); + SYSTEM.PUT(SYSTEM.ADR(x) + L, SYSTEM.VAL(INTEGER, l)) + ELSE Modules.Halt(-15) + END; + RETURN x END RealL; (** Convert REAL to hexadecimal. *) PROCEDURE Int* (x: REAL): LONGINT; - VAR i: LONGINT; -BEGIN SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i + VAR i: INTEGER; l: LONGINT; +BEGIN + IF SIZE(LONGINT) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(l), x); RETURN l + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i + ELSE Modules.Halt(-15) + END END Int; (** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *) PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT); -BEGIN SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l) + VAR i: INTEGER; +BEGIN + IF SIZE(LONGINT) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x) + H, h); + SYSTEM.GET(SYSTEM.ADR(x) + L, l) + ELSIF SIZE(INTEGER) = 4 THEN + SYSTEM.GET(SYSTEM.ADR(x) + H, i); h := i; + SYSTEM.GET(SYSTEM.ADR(x) + L, i); l := i + ELSE Modules.Halt(-15) + END END IntL; (** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *) @@ -112,8 +167,9 @@ END Ten; (** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *) PROCEDURE NaNCode* (x: REAL): LONGINT; + VAR e: LONGINT; BEGIN - IF ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 THEN (* Infinite or NaN *) + IF Expo(x) = 255 THEN (* Infinite or NaN *) RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *) ELSE RETURN -1 @@ -123,7 +179,7 @@ END NaNCode; (** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *) PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT); BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l); + IntL(x, h, l); IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *) h := h MOD 100000H (* lowest 20 bits *) ELSE @@ -131,37 +187,6 @@ BEGIN END END NaNCodeL; -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaN* (x: REAL): BOOLEAN; -BEGIN - RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 -END IsNaN; - -(** Returns TRUE iff x is NaN/Infinite. *) -PROCEDURE IsNaNL* (x: LONGREAL): BOOLEAN; -VAR h: LONGINT; -BEGIN - SYSTEM.GET(SYSTEM.ADR(x) + H, h); - RETURN ASH(h, -20) MOD 2048 = 2047 -END IsNaNL; - -(** Returns NaN with specified code (0 <= l < 8399608). *) -PROCEDURE NaN* (l: LONGINT): REAL; -VAR x: REAL; -BEGIN - SYSTEM.PUT(SYSTEM.ADR(x), (l MOD 800000H) + 7F800000H); - RETURN x -END NaN; - -(** Returns NaN with specified code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)). *) -PROCEDURE NaNL* (h, l: LONGINT): LONGREAL; -VAR x: LONGREAL; -BEGIN - h := (h MOD 100000H) + 7FF00000H; - SYSTEM.PUT(SYSTEM.ADR(x) + H, h); - SYSTEM.PUT(SYSTEM.ADR(x) + L, l); - RETURN x -END NaNL; (* PROCEDURE fcr(): SET; CODE {SYSTEM.i386, SYSTEM.FPU} @@ -192,74 +217,64 @@ BEGIN IF Kernel.copro THEN setfcr(s) END END SetFCR; *) -PROCEDURE RealX (h, l: LONGINT; adr: LONGINT); -BEGIN SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l); + + +PROCEDURE RealX (v: HUGEINT; VAR lr: LONGREAL); +BEGIN lr := SYSTEM.VAL(LONGREAL, v) END RealX; -PROCEDURE InitHL; - VAR (*i: LONGINT; dmy: INTEGER;*) littleEndian: BOOLEAN; BEGIN - (*DefaultFCR := (FCR() - {0,2,3,10,11}) + {0..5,8,9}; - SetFCR(DefaultFCR); - - dmy := 1; i := SYSTEM.ADR(dmy); - SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)*) - littleEndian := TRUE; (* endianness will be set for each architecture -- noch *) - IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END -END InitHL; + RealX(03FF0000000000000H, tene[0]); + RealX(04024000000000000H, tene[1]); (* 1 *) + RealX(04059000000000000H, tene[2]); (* 2 *) + RealX(0408F400000000000H, tene[3]); (* 3 *) + RealX(040C3880000000000H, tene[4]); (* 4 *) + RealX(040F86A0000000000H, tene[5]); (* 5 *) + RealX(0412E848000000000H, tene[6]); (* 6 *) + RealX(0416312D000000000H, tene[7]); (* 7 *) + RealX(04197D78400000000H, tene[8]); (* 8 *) + RealX(041CDCD6500000000H, tene[9]); (* 9 *) + RealX(04202A05F20000000H, tene[10]); (* 10 *) + RealX(042374876E8000000H, tene[11]); (* 11 *) + RealX(0426D1A94A2000000H, tene[12]); (* 12 *) + RealX(042A2309CE5400000H, tene[13]); (* 13 *) + RealX(042D6BCC41E900000H, tene[14]); (* 14 *) + RealX(0430C6BF526340000H, tene[15]); (* 15 *) + RealX(04341C37937E08000H, tene[16]); (* 16 *) + RealX(04376345785D8A000H, tene[17]); (* 17 *) + RealX(043ABC16D674EC800H, tene[18]); (* 18 *) + RealX(043E158E460913D00H, tene[19]); (* 19 *) + RealX(04415AF1D78B58C40H, tene[20]); (* 20 *) + RealX(0444B1AE4D6E2EF50H, tene[21]); (* 21 *) + RealX(04480F0CF064DD592H, tene[22]); (* 22 *) -BEGIN InitHL; - RealX(03FF00000H, 0, SYSTEM.ADR(tene[0])); - RealX(040240000H, 0, SYSTEM.ADR(tene[1])); (* 1 *) - RealX(040590000H, 0, SYSTEM.ADR(tene[2])); (* 2 *) - RealX(0408F4000H, 0, SYSTEM.ADR(tene[3])); (* 3 *) - RealX(040C38800H, 0, SYSTEM.ADR(tene[4])); (* 4 *) - RealX(040F86A00H, 0, SYSTEM.ADR(tene[5])); (* 5 *) - RealX(0412E8480H, 0, SYSTEM.ADR(tene[6])); (* 6 *) - RealX(0416312D0H, 0, SYSTEM.ADR(tene[7])); (* 7 *) - RealX(04197D784H, 0, SYSTEM.ADR(tene[8])); (* 8 *) - RealX(041CDCD65H, 0, SYSTEM.ADR(tene[9])); (* 9 *) - RealX(04202A05FH, 020000000H, SYSTEM.ADR(tene[10])); (* 10 *) - RealX(042374876H, 0E8000000H, SYSTEM.ADR(tene[11])); (* 11 *) - RealX(0426D1A94H, 0A2000000H, SYSTEM.ADR(tene[12])); (* 12 *) - RealX(042A2309CH, 0E5400000H, SYSTEM.ADR(tene[13])); (* 13 *) - RealX(042D6BCC4H, 01E900000H, SYSTEM.ADR(tene[14])); (* 14 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(tene[15])); (* 15 *) - RealX(04341C379H, 037E08000H, SYSTEM.ADR(tene[16])); (* 16 *) - RealX(043763457H, 085D8A000H, SYSTEM.ADR(tene[17])); (* 17 *) - RealX(043ABC16DH, 0674EC800H, SYSTEM.ADR(tene[18])); (* 18 *) - RealX(043E158E4H, 060913D00H, SYSTEM.ADR(tene[19])); (* 19 *) - RealX(04415AF1DH, 078B58C40H, SYSTEM.ADR(tene[20])); (* 20 *) - RealX(0444B1AE4H, 0D6E2EF50H, SYSTEM.ADR(tene[21])); (* 21 *) - RealX(04480F0CFH, 064DD592H, SYSTEM.ADR(tene[22])); (* 22 *) - - RealX(031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *) - RealX(04F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *) - RealX(09BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *) - RealX(0E84D669H, 05B193BF8H, SYSTEM.ADR(ten[3])); (* -238 *) - RealX(0134B9408H, 0EEFEA839H, SYSTEM.ADR(ten[4])); (* -215 *) - RealX(018123FF0H, 06EEA847AH, SYSTEM.ADR(ten[5])); (* -192 *) - RealX(01CD82742H, 091C6065BH, SYSTEM.ADR(ten[6])); (* -169 *) - RealX(0219FF779H, 0FD329CB9H, SYSTEM.ADR(ten[7])); (* -146 *) - RealX(02665275EH, 0D8D8F36CH, SYSTEM.ADR(ten[8])); (* -123 *) - RealX(02B2BFF2EH, 0E48E0530H, SYSTEM.ADR(ten[9])); (* -100 *) - RealX(02FF286D8H, 0EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *) - RealX(034B8851AH, 0B548EA4H, SYSTEM.ADR(ten[11])); (* -54 *) - RealX(0398039D6H, 065896880H, SYSTEM.ADR(ten[12])); (* -31 *) - RealX(03E45798EH, 0E2308C3AH, SYSTEM.ADR(ten[13])); (* -8 *) - RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(ten[14])); (* 15 *) - RealX(047D2CED3H, 02A16A1B1H, SYSTEM.ADR(ten[15])); (* 38 *) - RealX(04C98E45EH, 01DF3B015H, SYSTEM.ADR(ten[16])); (* 61 *) - RealX(0516078E1H, 011C3556DH, SYSTEM.ADR(ten[17])); (* 84 *) - RealX(05625CCFEH, 03D35D80EH, SYSTEM.ADR(ten[18])); (* 107 *) - RealX(05AECDA62H, 055B2D9EH, SYSTEM.ADR(ten[19])); (* 130 *) - RealX(05FB317E5H, 0EF3AB327H, SYSTEM.ADR(ten[20])); (* 153 *) - RealX(064794514H, 05230B378H, SYSTEM.ADR(ten[21])); (* 176 *) - RealX(06940B8E0H, 0ACAC4EAFH, SYSTEM.ADR(ten[22])); (* 199 *) - RealX(06E0621B1H, 0C28AC20CH, SYSTEM.ADR(ten[23])); (* 222 *) - RealX(072CD4A7BH, 0EBFA31ABH, SYSTEM.ADR(ten[24])); (* 245 *) - RealX(077936214H, 09CBD3226H, SYSTEM.ADR(ten[25])); (* 268 *) - RealX(07C59A742H, 0461887F6H, SYSTEM.ADR(ten[26])); (* 291 *) + RealX(00031FA182C40C60DH, ten[0]); (* -307 *) + RealX(004F7CAD23DE82D7BH, ten[1]); (* -284 *) + RealX(009BF7D228322BAF5H, ten[2]); (* -261 *) + RealX(00E84D6695B193BF8H, ten[3]); (* -238 *) + RealX(0134B9408EEFEA839H, ten[4]); (* -215 *) + RealX(018123FF06EEA847AH, ten[5]); (* -192 *) + RealX(01CD8274291C6065BH, ten[6]); (* -169 *) + RealX(0219FF779FD329CB9H, ten[7]); (* -146 *) + RealX(02665275ED8D8F36CH, ten[8]); (* -123 *) + RealX(02B2BFF2EE48E0530H, ten[9]); (* -100 *) + RealX(02FF286D80EC190DCH, ten[10]); (* -77 *) + RealX(034B8851A0B548EA4H, ten[11]); (* -54 *) + RealX(0398039D665896880H, ten[12]); (* -31 *) + RealX(03E45798EE2308C3AH, ten[13]); (* -8 *) + RealX(0430C6BF526340000H, ten[14]); (* 15 *) + RealX(047D2CED32A16A1B1H, ten[15]); (* 38 *) + RealX(04C98E45E1DF3B015H, ten[16]); (* 61 *) + RealX(0516078E111C3556DH, ten[17]); (* 84 *) + RealX(05625CCFE3D35D80EH, ten[18]); (* 107 *) + RealX(05AECDA62055B2D9EH, ten[19]); (* 130 *) + RealX(05FB317E5EF3AB327H, ten[20]); (* 153 *) + RealX(0647945145230B378H, ten[21]); (* 176 *) + RealX(06940B8E0ACAC4EAFH, ten[22]); (* 199 *) + RealX(06E0621B1C28AC20CH, ten[23]); (* 222 *) + RealX(072CD4A7BEBFA31ABH, ten[24]); (* 245 *) + RealX(0779362149CBD3226H, ten[25]); (* 268 *) + RealX(07C59A742461887F6H, ten[26]); (* 291 *) eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31}; eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31}; diff --git a/src/lib/s3/ethSets.Mod b/src/library/s3/ethSets.Mod similarity index 100% rename from src/lib/s3/ethSets.Mod rename to src/library/s3/ethSets.Mod diff --git a/src/lib/s3/ethStrings.Mod b/src/library/s3/ethStrings.Mod similarity index 94% rename from src/lib/s3/ethStrings.Mod rename to src/library/s3/ethStrings.Mod index c9b2fe0a..b2cf4901 100644 --- a/src/lib/s3/ethStrings.Mod +++ b/src/library/s3/ethStrings.Mod @@ -6,17 +6,22 @@ MODULE ethStrings; (** portable *) (* ejz, *) (** Strings is a utility module that provides procedures to manipulate strings. Note: All strings MUST be 0X terminated. *) - IMPORT Oberon, Texts, Dates := ethDates, Reals := ethReals; - - CONST - CR* = 0DX; (** the Oberon end of line character *) - Tab* = 09X; (** the horizontal tab character *) - LF* = 0AX; (** the UNIX end of line character *) + IMPORT Texts, Dates := ethDates, Reals := ethReals; + CONST + (** the Oberon end of line character *) + CR* = 0DX; + (** the horizontal tab character *) + Tab* = 09X; + (** the UNIX end of line character *) + LF* = 0AX; VAR - isAlpha*: ARRAY 256 OF BOOLEAN; (** all letters in the oberon charset *) - ISOToOberon*, OberonToISO*: ARRAY 256 OF CHAR; (** Translation tables for iso-8859-1 to oberon ascii code. *) - CRLF*: ARRAY 4 OF CHAR; (** end of line "string" used by MS-DOS and most TCP protocols *) + (** all letters in the oberon charset *) + isAlpha*: ARRAY 256 OF BOOLEAN; + (** Translation tables for iso-8859-1 to oberon ascii code. *) + ISOToOberon*, OberonToISO*: ARRAY 256 OF CHAR; + (** end of line "string" used by MS-DOS and most TCP protocols *) + CRLF*: ARRAY 4 OF CHAR; sDayName: ARRAY 7, 4 OF CHAR; lDayName: ARRAY 7, 12 OF CHAR; sMonthName: ARRAY 12, 4 OF CHAR; @@ -24,7 +29,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) dateform, timeform: ARRAY 32 OF CHAR; (** Length of str. *) - PROCEDURE Length*(VAR str(** in *): ARRAY OF CHAR): LONGINT; + PROCEDURE Length*(VAR str(* in *): ARRAY OF CHAR): LONGINT; VAR i, l: LONGINT; BEGIN l := LEN(str); i := 0; @@ -35,7 +40,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Length; (** Append this to to. *) - PROCEDURE Append*(VAR to(** in/out *): ARRAY OF CHAR; this: ARRAY OF CHAR); + PROCEDURE Append*(VAR to(* in/out *): ARRAY OF CHAR; this: ARRAY OF CHAR); VAR i, j, l: LONGINT; BEGIN i := 0; @@ -50,7 +55,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Append; (** Append this to to. *) - PROCEDURE AppendCh*(VAR to(** in/out *): ARRAY OF CHAR; this: CHAR); + PROCEDURE AppendCh*(VAR to(* in/out *): ARRAY OF CHAR; this: CHAR); VAR i: LONGINT; BEGIN i := 0; @@ -124,7 +129,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END UpperCh; (** Convert str to all lower-case letters. *) - PROCEDURE Lower*(VAR str(** in *), lstr(** out *): ARRAY OF CHAR); + PROCEDURE Lower*(VAR str(* in *), lstr(* out *): ARRAY OF CHAR); VAR i: LONGINT; BEGIN i := 0; @@ -135,7 +140,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Lower; (** Convert str to all upper-case letters. *) - PROCEDURE Upper*(VAR str(** in *), ustr(** out *): ARRAY OF CHAR); + PROCEDURE Upper*(VAR str(* in *), ustr(* out *): ARRAY OF CHAR); VAR i: LONGINT; BEGIN i := 0; @@ -146,7 +151,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Upper; (** Is str prefixed by pre? *) - PROCEDURE Prefix*(pre: ARRAY OF CHAR; VAR str(** in *): ARRAY OF CHAR): BOOLEAN; + PROCEDURE Prefix*(pre: ARRAY OF CHAR; VAR str(* in *): ARRAY OF CHAR): BOOLEAN; VAR i: LONGINT; BEGIN i := 0; @@ -157,7 +162,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Prefix; (** Checks if str is prefixed by pre. The case is ignored. *) - PROCEDURE CAPPrefix*(pre: ARRAY OF CHAR; VAR str(** in *): ARRAY OF CHAR): BOOLEAN; + PROCEDURE CAPPrefix*(pre: ARRAY OF CHAR; VAR str(* in *): ARRAY OF CHAR): BOOLEAN; VAR i: LONGINT; BEGIN i := 0; @@ -168,7 +173,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END CAPPrefix; (** Compare str1 to str2. The case is ignored. *) - PROCEDURE CAPCompare*(VAR str1(** in *), str2(** in *): ARRAY OF CHAR): BOOLEAN; + PROCEDURE CAPCompare*(VAR str1(* in *), str2(* in *): ARRAY OF CHAR): BOOLEAN; VAR i: LONGINT; BEGIN i := 0; @@ -179,7 +184,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END CAPCompare; (** Get the parameter-value on line. The parameter value is started behind the first colon character. *) - PROCEDURE GetPar*(VAR line(** in *), par(** out *): ARRAY OF CHAR); + PROCEDURE GetPar*(VAR line(* in *), par(* out *): ARRAY OF CHAR); VAR i, j, l: LONGINT; BEGIN i := 0; @@ -200,7 +205,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END GetPar; (** Get the suffix of str. The suffix is started by the last dot in str. *) - PROCEDURE GetSuffix*(VAR str(** in *), suf(** out *): ARRAY OF CHAR); + PROCEDURE GetSuffix*(VAR str(* in *), suf(* out *): ARRAY OF CHAR); VAR i, j, l, dot: LONGINT; BEGIN dot := -1; i := 0; @@ -223,7 +228,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END GetSuffix; (** Change the suffix of str to suf. *) - PROCEDURE ChangeSuffix*(VAR str(** in/out *): ARRAY OF CHAR; suf: ARRAY OF CHAR); + PROCEDURE ChangeSuffix*(VAR str(* in/out *): ARRAY OF CHAR; suf: ARRAY OF CHAR); VAR i, j, l, dot: LONGINT; BEGIN dot := -1; i := 0; @@ -245,7 +250,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END ChangeSuffix; (** Search in src starting at pos for the next occurrence of pat. Returns pos=-1 if not found. *) - PROCEDURE Search*(pat: ARRAY OF CHAR; VAR src(** in *): ARRAY OF CHAR; VAR pos(** in/out *): LONGINT); + PROCEDURE Search*(pat: ARRAY OF CHAR; VAR src(* in *): ARRAY OF CHAR; VAR pos(** in/out *): LONGINT); CONST MaxPat = 128; VAR buf: ARRAY MaxPat OF CHAR; @@ -306,7 +311,7 @@ MODULE ethStrings; (** portable *) (* ejz, *) END Search; (** Search in src starting at pos for the next occurrence of pat. *) - PROCEDURE CAPSearch*(pat: ARRAY OF CHAR; VAR src(** in *): ARRAY OF CHAR; VAR pos(** in/out *): LONGINT); + PROCEDURE CAPSearch*(pat: ARRAY OF CHAR; VAR src(* in *): ARRAY OF CHAR; VAR pos(* in/out *): LONGINT); CONST MaxPat = 128; VAR buf: ARRAY MaxPat OF CHAR; @@ -445,13 +450,13 @@ MODULE ethStrings; (** portable *) (* ejz, *) (** Converts a real to a string. *) PROCEDURE RealToStr*(x: LONGREAL; VAR s: ARRAY OF CHAR); VAR e, h, l, n, len: LONGINT; i, j, pos: INTEGER; z: LONGREAL; d: ARRAY 16 OF CHAR; - + PROCEDURE Wr(ch: CHAR); BEGIN IF ch = 0X THEN HALT(42) END; IF pos < len THEN s[pos] := ch; INC(pos) END; END Wr; - + BEGIN len := LEN(s)-1; pos := 0; e:= Reals.ExpoL(x); @@ -573,14 +578,14 @@ BEGIN WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; IF s[p] = "-" THEN neg := TRUE; INC(p) ELSE neg := FALSE END; WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; - + y := 0; WHILE ("0" <= s[p]) & (s[p] <= "9") DO y := y * 10 + (ORD(s[p]) - 30H); INC(p); END; IF s[p] = "." THEN - INC(p); g := 1; + INC(p); g := 1; WHILE ("0" <= s[p]) & (s[p] <= "9") DO g := g / 10; y := y + g * (ORD(s[p]) - 30H); INC(p); @@ -706,7 +711,7 @@ END StrToReal; IF CAP(form[j]) = "M" THEN INC(j); IF CAP(form[j]) = "M" THEN INC(j); COPY(lMonthName[x-1], name) - ELSE COPY(sMonthName[x-1], name) + ELSE COPY(sMonthName[x-1], name) END; k := 0; WHILE name[k] # 0X DO str[i] := name[k]; INC(i); INC(k) END ELSE @@ -735,14 +740,14 @@ END StrToReal; str[i] := 0X END DateToStr; -(** Returns a month's name (set short to get the abbreviation) *) +(** Returns a month's name (set short to get the abbreviation) *) PROCEDURE MonthToStr* (month: INTEGER; VAR str: ARRAY OF CHAR; short: BOOLEAN); BEGIN month := (month - 1) MOD 12; IF short THEN COPY(sMonthName[month], str) ELSE COPY(lMonthName[month], str) END END MonthToStr; -(** Returns a day's name (set short to get the abbreviation) *) +(** Returns a day's name (set short to get the abbreviation) *) PROCEDURE DayToStr* (day: INTEGER; VAR str: ARRAY OF CHAR; short: BOOLEAN); BEGIN IF short THEN COPY(sDayName[day MOD 7], str) ELSE COPY(lDayName[day MOD 7], str) END diff --git a/src/lib/s3/ethUnicode.Mod b/src/library/s3/ethUnicode.Mod similarity index 100% rename from src/lib/s3/ethUnicode.Mod rename to src/library/s3/ethUnicode.Mod diff --git a/src/lib/s3/ethZip.Mod b/src/library/s3/ethZip.Mod similarity index 99% rename from src/lib/s3/ethZip.Mod rename to src/library/s3/ethZip.Mod index 182e74f4..add56a53 100644 --- a/src/lib/s3/ethZip.Mod +++ b/src/library/s3/ethZip.Mod @@ -486,6 +486,7 @@ BEGIN ELSE res := DataError END + ELSE END; IF res = Ok THEN Files.Close(Files.Base(dst)); diff --git a/src/lib/s3/ethZlib.Mod b/src/library/s3/ethZlib.Mod similarity index 100% rename from src/lib/s3/ethZlib.Mod rename to src/library/s3/ethZlib.Mod diff --git a/src/lib/s3/ethZlibBuffers.Mod b/src/library/s3/ethZlibBuffers.Mod similarity index 88% rename from src/lib/s3/ethZlibBuffers.Mod rename to src/library/s3/ethZlibBuffers.Mod index 9db0736c..f484a980 100644 --- a/src/lib/s3/ethZlibBuffers.Mod +++ b/src/library/s3/ethZlibBuffers.Mod @@ -3,8 +3,7 @@ Refer to the "General ETH Oberon System Source License" contract available at: h MODULE ethZlibBuffers; (** Stefan Walthert **) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* should be portable even if SYSTEM is imported: - PUT and GET only with byte sized operands @@ -13,13 +12,14 @@ IMPORT TYPE (** input/output buffer **) - Address = LONGINT; + Address = SYSTEM.ADDRESS; Buffer* = RECORD - avail-: LONGINT; (** number of bytes that can be produced/consumed **) - size-: LONGINT; (** total number of bytes in buffer memory **) - totalOut-, totalIn-: LONGINT; (** total number of bytes produced/consumed **) - next: Address; (* address of next byte to produce/consume **) - adr: Address; (* buffer memory *) + avail-: LONGINT; (** number of bytes that can be produced/consumed **) + size-: LONGINT; (** total number of bytes in buffer memory **) + totalOut-: LONGINT; (** total number of bytes produced **) + totalIn-: LONGINT; (** total number of bytes consumed **) + next: Address; (* address of next byte to produce/consume **) + adr: Address; (* buffer memory *) END; @@ -50,9 +50,9 @@ PROCEDURE ReadBytes* (VAR buf: Buffer; VAR dst: ARRAY OF CHAR; offset, len: LONG BEGIN ASSERT((0 <= offset) & (0 < len) & (offset + len <= LEN(dst)) & (len <= buf.avail), 100); SYSTEM.MOVE(buf.next, SYSTEM.ADR(dst[offset]), len); - INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalIn, len) + INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalIn, len) END ReadBytes; - + (** write byte into (output) buffer **) PROCEDURE Write* (VAR buf: Buffer; ch: CHAR); BEGIN @@ -89,7 +89,7 @@ PROCEDURE Rewrite* (VAR buf: Buffer); BEGIN buf.next := buf.adr; buf.avail := buf.size END Rewrite; - + (** fill input buffer with new bytes to consume **) PROCEDURE Fill* (VAR buf: Buffer; VAR src: ARRAY OF CHAR; offset, size: LONGINT); BEGIN diff --git a/src/lib/s3/ethZlibDeflate.Mod b/src/library/s3/ethZlibDeflate.Mod similarity index 99% rename from src/lib/s3/ethZlibDeflate.Mod rename to src/library/s3/ethZlibDeflate.Mod index 0b62ee66..d487111a 100644 --- a/src/lib/s3/ethZlibDeflate.Mod +++ b/src/library/s3/ethZlibDeflate.Mod @@ -257,6 +257,7 @@ PROCEDURE SetDataType(VAR stream: Stream); VAR n, ascii, bin: LONGINT; BEGIN + n := 0; ascii := 0; bin := 0; WHILE n < 7 DO INC(bin, LONG(stream.lnode[n].freqOrCode)); INC(n) END; WHILE n < 128 DO INC(ascii, LONG(stream.lnode[n].freqOrCode)); INC(n) END; WHILE n < Literals DO INC(bin, LONG(stream.lnode[n].freqOrCode)); INC(n) END; diff --git a/src/lib/s3/ethZlibInflate.Mod b/src/library/s3/ethZlibInflate.Mod similarity index 99% rename from src/lib/s3/ethZlibInflate.Mod rename to src/library/s3/ethZlibInflate.Mod index ab72c053..fb508ffe 100644 --- a/src/lib/s3/ethZlibInflate.Mod +++ b/src/library/s3/ethZlibInflate.Mod @@ -777,6 +777,7 @@ MODULE ethZlibInflate; (** eos **) s.block.state := BlkBad; s.res.code := DataError; Flush(s); EXIT + ELSE END | BlkLens: (* read length of uncompressed block *) @@ -890,6 +891,7 @@ MODULE ethZlibInflate; (** eos **) | 18: (* repeat code length 0 for 11-138 times, using another 7 bits *) IF ~Need(s, node.bits+7) THEN EXIT END; Dump(s, node.bits); cnt := 11 + s.buf MOD 128; Dump(s, 7); len := 0 + ELSE END; IF s.block.index + cnt > s.block.nlit + s.block.ndist THEN SetMsg(s.res, "invalid bit length repeat"); @@ -1125,6 +1127,7 @@ MODULE ethZlibInflate; (** eos **) | InfBad: (* error in stream *) stream.res.code := DataError; EXIT + ELSE END END END diff --git a/src/lib/s3/ethZlibReaders.Mod b/src/library/s3/ethZlibReaders.Mod similarity index 100% rename from src/lib/s3/ethZlibReaders.Mod rename to src/library/s3/ethZlibReaders.Mod diff --git a/src/lib/s3/ethZlibWriters.Mod b/src/library/s3/ethZlibWriters.Mod similarity index 100% rename from src/lib/s3/ethZlibWriters.Mod rename to src/library/s3/ethZlibWriters.Mod diff --git a/src/lib/ulm/ulmASCII.Mod b/src/library/ulm/ulmASCII.Mod similarity index 100% rename from src/lib/ulm/ulmASCII.Mod rename to src/library/ulm/ulmASCII.Mod diff --git a/src/lib/ulm/ulmAssertions.Mod b/src/library/ulm/ulmAssertions.Mod similarity index 98% rename from src/lib/ulm/ulmAssertions.Mod rename to src/library/ulm/ulmAssertions.Mod index 0f6fe59e..dcceea08 100644 --- a/src/lib/ulm/ulmAssertions.Mod +++ b/src/library/ulm/ulmAssertions.Mod @@ -35,7 +35,7 @@ MODULE ulmAssertions; (* general error handling of library routines *) - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, IO := ulmIO, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices; + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, IO := ulmIO, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices, Types := ulmTypes; TYPE Object = Disciplines.Object; diff --git a/src/lib/ulm/ulmAsymmetricCiphers.Mod b/src/library/ulm/ulmAsymmetricCiphers.Mod similarity index 95% rename from src/lib/ulm/ulmAsymmetricCiphers.Mod rename to src/library/ulm/ulmAsymmetricCiphers.Mod index ba8dfdda..069972bd 100644 --- a/src/lib/ulm/ulmAsymmetricCiphers.Mod +++ b/src/library/ulm/ulmAsymmetricCiphers.Mod @@ -30,13 +30,13 @@ MODULE ulmAsymmetricCiphers; (* Michael Szczuka *) (* abstraction for the use of public key ciphers *) - IMPORT BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams; + IMPORT BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes; CONST composed* = 0; isPrivateKey* = 1; TYPE - CapabilitySet* = SET; + CapabilitySet* = Types.Set; TYPE Cipher* = POINTER TO CipherRec; @@ -66,13 +66,13 @@ MODULE ulmAsymmetricCiphers; (* Michael Szczuka *) (* need to have this in case anyone wants to decrypt something with a public cipher ... *) PROCEDURE Identity(in: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; + length: Types.Int32; out: Streams.Stream) : BOOLEAN; BEGIN RETURN Streams.Copy(in, out, length); END Identity; PROCEDURE Init* (key: Cipher; if: Interface; - cap: CapabilitySet; inLength, outLength: INTEGER); + cap: CapabilitySet; inLength, outLength: Types.Int32); BEGIN IF if.decrypt = NIL THEN (* decrypt is not defined, so we have only the public part of a cipher; @@ -122,7 +122,7 @@ MODULE ulmAsymmetricCiphers; (* Michael Szczuka *) END ComposedEncrypt; PROCEDURE ComposedEncryptPart* (in: Streams.Stream; key: Cipher; - length: INTEGER; + length: Types.Int32; out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.asymIf.compencrypt(in, key, length, out); @@ -131,7 +131,7 @@ MODULE ulmAsymmetricCiphers; (* Michael Szczuka *) PROCEDURE ComposedEncryptBlock* (in: Streams.Stream; key: Cipher; out: Streams.Stream) : BOOLEAN; VAR - length : INTEGER; + length : Types.Int32; BEGIN length := BlockCiphers.GetInLength(key); RETURN key.asymIf.compencrypt(in, key, length, out); diff --git a/src/lib/ulm/ulmBlockCiphers.Mod b/src/library/ulm/ulmBlockCiphers.Mod similarity index 92% rename from src/lib/ulm/ulmBlockCiphers.Mod rename to src/library/ulm/ulmBlockCiphers.Mod index 41e3355c..630b4c91 100644 --- a/src/lib/ulm/ulmBlockCiphers.Mod +++ b/src/library/ulm/ulmBlockCiphers.Mod @@ -30,7 +30,7 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) (* abstraction for the use of block ciphers *) - IMPORT Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams; + IMPORT Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes; TYPE Cipher* = POINTER TO CipherRec; @@ -38,8 +38,8 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) CipherRec* = RECORD (Ciphers.CipherRec) (* private *) - inLength: INTEGER; - outLength: INTEGER; + inLength: Types.Int32; + outLength: Types.Int32; END; VAR @@ -47,7 +47,7 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) if : PersistentObjects.Interface; PROCEDURE Init* (key: Cipher; if: Ciphers.Interface; - inLength, outLength: INTEGER); + inLength, outLength: Types.Int32); (* init a block cipher with its special interface *) BEGIN Ciphers.Init(key, if); @@ -57,13 +57,13 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) key.outLength := outLength; END Init; - PROCEDURE GetInLength* (key: Cipher) : INTEGER; + PROCEDURE GetInLength* (key: Cipher) : Types.Int32; (* returns the input block length of a block cipher *) BEGIN RETURN key.inLength; END GetInLength; - PROCEDURE GetOutLength* (key: Cipher) : INTEGER; + PROCEDURE GetOutLength* (key: Cipher) : Types.Int32; (* returns the output block length of a block cipher *) BEGIN RETURN key.outLength; @@ -72,7 +72,7 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) PROCEDURE EncryptBlock* (in: Streams.Stream; key: Cipher; out: Streams.Stream) : BOOLEAN; VAR - length : INTEGER; + length : Types.Int32; BEGIN length := GetInLength(key); RETURN Ciphers.EncryptPart(in, key, length, out); @@ -81,7 +81,7 @@ MODULE ulmBlockCiphers; (* Michael Szczuka *) PROCEDURE DecryptBlock* (in: Streams.Stream; key: Cipher; out: Streams.Stream) : BOOLEAN; VAR - length : INTEGER; + length : Types.Int32; BEGIN length := GetOutLength(key); RETURN Ciphers.DecryptPart(in, key, length, out); diff --git a/src/library/ulm/ulmCipherOps.Mod b/src/library/ulm/ulmCipherOps.Mod new file mode 100644 index 00000000..39d951c2 --- /dev/null +++ b/src/library/ulm/ulmCipherOps.Mod @@ -0,0 +1,69 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: CipherOps.om,v 1.1 1997/04/02 11:53:20 borchert Exp borchert $ + ---------------------------------------------------------------------------- + $Log: CipherOps.om,v $ + Revision 1.1 1997/04/02 11:53:20 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmCipherOps; (* Michael Szczuka *) + + (* useful functions for stream ciphers *) + + IMPORT Streams := ulmStreams, SYS := SYSTEM, Write := ulmWrite, Types := ulmTypes; + + PROCEDURE XorByte* (b1, b2: SYS.BYTE) : SYS.BYTE; + (* adds two bytes bitwise modulo 2 *) + BEGIN + (*RETURN SYS.VAL(SYS.BYTE, SYS.VAL(Types.Set, LONG(b1)) / SYS.VAL(Types.Set, LONG(b2)))*) + RETURN SYS.VAL(SYS.BYTE, SYS.VAL(Types.Set, LONG(LONG(SYS.VAL(Types.Int8, b1)))) + / SYS.VAL(Types.Set, LONG(LONG(SYS.VAL(Types.Int8, b2))))) + END XorByte; + + PROCEDURE XorStream* (in1, in2, out: Streams.Stream; + length: Types.Int32) : BOOLEAN; + (* adds two streams bitwise modulo 2; restricted to length bytes *) + VAR + b1, b2, res : SYS.BYTE; + wholeStream : BOOLEAN; + BEGIN + IF length < 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE; + END; + WHILE wholeStream OR (length > 0) DO + IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN + res := XorByte(b1, b2); + IF ~Streams.WriteByte(out, res) THEN + RETURN FALSE + END; + ELSE + RETURN wholeStream + END; + DEC(length); + END; + RETURN TRUE + END XorStream; + +END ulmCipherOps. diff --git a/src/lib/ulm/ulmCiphers.Mod b/src/library/ulm/ulmCiphers.Mod similarity index 75% rename from src/lib/ulm/ulmCiphers.Mod rename to src/library/ulm/ulmCiphers.Mod index bc881c83..fbd97445 100644 --- a/src/lib/ulm/ulmCiphers.Mod +++ b/src/library/ulm/ulmCiphers.Mod @@ -29,15 +29,15 @@ (* abstraction for the use of ciphers and cryptographic methods *) MODULE ulmCiphers; -IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices, - Streams := ulmStreams, Write := ulmWrite; +IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices, + Streams := ulmStreams, Write := ulmWrite, Types := ulmTypes; TYPE Cipher* = POINTER TO CipherRec; -TYPE - CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +TYPE + CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher; + length: Types.Int32; out: Streams.Stream) : BOOLEAN; TYPE Interface* = POINTER TO InterfaceRec; @@ -48,7 +48,7 @@ TYPE END; TYPE - CipherRec* = RECORD + CipherRec* = RECORD (PersistentDisciplines.ObjectRec) (* private *) if : Interface @@ -64,31 +64,31 @@ BEGIN key.if := if; END Init; -PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher; - out: Streams.Stream) : BOOLEAN; +PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher; + out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.encrypt(in, key, -1, out); END Encrypt; -PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher; - out: Streams.Stream) : BOOLEAN; +PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher; + out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.decrypt(in, key, -1, out); END Decrypt; -PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher; + length: Types.Int32; out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.encrypt(in, key, length, out); END EncryptPart; -PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher; + length: Types.Int32; out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.decrypt(in, key, length, out); END DecryptPart; BEGIN - PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher", + PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher", "PersistentDisciplines.Object", NIL); END ulmCiphers. diff --git a/src/lib/ulm/ulmClocks.Mod b/src/library/ulm/ulmClocks.Mod similarity index 97% rename from src/lib/ulm/ulmClocks.Mod rename to src/library/ulm/ulmClocks.Mod index d0416cfb..6a72d661 100644 --- a/src/lib/ulm/ulmClocks.Mod +++ b/src/library/ulm/ulmClocks.Mod @@ -37,7 +37,7 @@ MODULE ulmClocks; IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities, - RelatedEvents := ulmRelatedEvents, Services := ulmServices, Times := ulmTimes; + RelatedEvents := ulmRelatedEvents, Services := ulmServices, Times := ulmTimes, Types := ulmTypes; TYPE Clock* = POINTER TO ClockRec; @@ -45,7 +45,7 @@ MODULE ulmClocks; CONST settime* = 0; timer* = 1; passed* = 2; TYPE - CapabilitySet* = SET; (* OF [settime..passed] *) + CapabilitySet* = Types.Set; (* OF [settime..passed] *) TYPE GetTimeProc* = PROCEDURE (clock: Clock; VAR time: Times.Time); SetTimeProc* = PROCEDURE (clock: Clock; time: Times.Time); @@ -102,13 +102,13 @@ MODULE ulmClocks; ErrorEventRec* = RECORD (Events.EventRec) - errorcode*: SHORTINT; + errorcode*: Types.Int8; END; VAR errormsg*: ARRAY errorcodes OF Events.Message; error*: Events.EventType; - PROCEDURE Error(clock: Clock; code: SHORTINT); + PROCEDURE Error(clock: Clock; code: Types.Int8); VAR event: ErrorEvent; BEGIN diff --git a/src/lib/ulm/ulmConclusions.Mod b/src/library/ulm/ulmConclusions.Mod similarity index 95% rename from src/lib/ulm/ulmConclusions.Mod rename to src/library/ulm/ulmConclusions.Mod index 2d0a6ade..7012b15c 100644 --- a/src/lib/ulm/ulmConclusions.Mod +++ b/src/library/ulm/ulmConclusions.Mod @@ -39,22 +39,22 @@ MODULE ulmConclusions; *) IMPORT Errors := ulmErrors, Events := ulmEvents, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines, - Streams := ulmStreams, Strings := ulmStrings, Write := ulmWrite; + Streams := ulmStreams, Strings := ulmStrings, Write := ulmWrite, Types := ulmTypes; VAR handlerSet*: Errors.HandlerSet; - errors*: INTEGER; (* number of errors *) - fatalcode*: INTEGER; (* exit code on fatal events *) + errors*: Types.Int32; (* number of errors *) + fatalcode*: Types.Int32; (* exit code on fatal events *) (* private variables *) cmdName: Process.Name; (* should be sufficient for a base name *) - cmdNameLen: INTEGER; (* Strings.Len(cmdName) *) + cmdNameLen: Types.Int32; (* Strings.Len(cmdName) *) (* private procedures *) PROCEDURE GeneralHandler(event: Events.Event; kind: Errors.Kind); VAR - width: INTEGER; + width: Types.Int32; BEGIN IF event # NIL THEN Write.IndentS(Streams.stderr); @@ -114,7 +114,7 @@ MODULE ulmConclusions; text: ARRAY OF CHAR); VAR queue: RelatedEvents.Queue; - width: INTEGER; + width: Types.Int32; PROCEDURE ReverseQueue(VAR queue: RelatedEvents.Queue); VAR diff --git a/src/lib/ulm/ulmConditions.Mod b/src/library/ulm/ulmConditions.Mod similarity index 96% rename from src/lib/ulm/ulmConditions.Mod rename to src/library/ulm/ulmConditions.Mod index 2b983470..101d590c 100644 --- a/src/lib/ulm/ulmConditions.Mod +++ b/src/library/ulm/ulmConditions.Mod @@ -60,12 +60,12 @@ MODULE ulmConditions; IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, - Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM; + Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM, Types := ulmTypes; CONST tags = 64; TYPE - Tag = INTEGER; (* 0..tags-1 *) + Tag = Types.Int32; (* 0..tags-1 *) (* tags are used for the hashs *) VAR nextTag: Tag; (* 0..tags-1, 0..tags-1, ... *) @@ -95,16 +95,16 @@ MODULE ulmConditions; ConditionSetRec* = RECORD (Objects.ObjectRec) - cardinality: INTEGER; + cardinality: Types.Int32; bucket: BucketTable; (* for the iterator *) - next: ConditionList; i: INTEGER; + next: ConditionList; i: Types.Int32; END; CONST select* = 0; timelimit* = 1; async* = 2; timecond* = 3; preconditions* = 4; TYPE - CapabilitySet* = SET; (* OF [select..preconditions] *) + CapabilitySet* = Types.Set; (* OF [select..preconditions] *) TYPE SelectProc* = PROCEDURE (domain: Domain; conditionSet: ConditionSet; time: Times.Time; @@ -159,7 +159,7 @@ MODULE ulmConditions; END; TYPE - GetTimeOfNextTryProc* = PROCEDURE (iteration: INTEGER; + GetTimeOfNextTryProc* = PROCEDURE (iteration: Types.Int32; VAR time: Times.Time); (* return a relative time measure *) VAR @@ -188,7 +188,7 @@ MODULE ulmConditions; getTimeOfNextTry := p; END SetGetTimeOfNextTryProc; - PROCEDURE GetTimeOfNextTry(iteration: INTEGER; VAR time: Times.Time); + PROCEDURE GetTimeOfNextTry(iteration: Types.Int32; VAR time: Times.Time); BEGIN Times.CreateAndSet(time, Times.relative, 0, 1, 0); iteration := iteration DIV 5; @@ -203,7 +203,7 @@ MODULE ulmConditions; PROCEDURE CreateSet*(VAR conditionSet: ConditionSet); VAR - i: INTEGER; + i: Types.Int32; cset: ConditionSet; BEGIN NEW(cset); @@ -226,7 +226,7 @@ MODULE ulmConditions; VAR listp: ConditionList; new: ConditionList; - i: INTEGER; + i: Types.Int32; BEGIN (* check if condition is already present in conditionSet *) i := condition.tag; @@ -245,7 +245,7 @@ MODULE ulmConditions; PROCEDURE Excl*(conditionSet: ConditionSet; condition: Condition); VAR prev, listp: ConditionList; - i: INTEGER; + i: Types.Int32; BEGIN i := condition.tag; listp := conditionSet.bucket[i]; prev := NIL; @@ -282,8 +282,8 @@ MODULE ulmConditions; VAR listp: ConditionList; newelem, newelems: ConditionList; - count: INTEGER; (* # of added elements in newelems *) - i: INTEGER; + count: Types.Int32; (* # of added elements in newelems *) + i: Types.Int32; BEGIN count := 0; i := 0; @@ -320,7 +320,7 @@ MODULE ulmConditions; CreateSet(result); Union(result, set1); Union(result, set2); END Union3; - PROCEDURE Card*(conditionSet: ConditionSet) : INTEGER; + PROCEDURE Card*(conditionSet: ConditionSet) : Types.Int32; BEGIN RETURN conditionSet.cardinality END Card; @@ -334,7 +334,7 @@ MODULE ulmConditions; PROCEDURE GetNextCondition*(conditionSet: ConditionSet; VAR condition: Condition) : BOOLEAN; VAR - i: INTEGER; + i: Types.Int32; BEGIN IF conditionSet.next = NIL THEN i := conditionSet.i; @@ -380,7 +380,7 @@ MODULE ulmConditions; VAR domain: Domain) : BOOLEAN; VAR dom: Domain; - i: INTEGER; + i: Types.Int32; listp: ConditionList; BEGIN dom := NIL; @@ -448,7 +448,7 @@ MODULE ulmConditions; VAR listp: ConditionList; - i: INTEGER; + i: Types.Int32; PROCEDURE CreateList(VAR list: List); BEGIN @@ -555,7 +555,7 @@ MODULE ulmConditions; PROCEDURE SetupAsyncEvents(list: List) : BOOLEAN; VAR elp: Element; - listp: ConditionList; i: INTEGER; + listp: ConditionList; i: Types.Int32; wakeupEvent: WakeupEvent; sendevent: SendEventProc; anythingTrue: BOOLEAN; @@ -603,7 +603,7 @@ MODULE ulmConditions; queue: RelatedEvents.Queue; (* queue of waitErrors *) busyLoop: BOOLEAN; (* TRUE if we have to resort to a busy loop *) wakeupEvent: Events.Event; (* iteration event for busy loops *) - loopCnt: INTEGER; (* number of iterations *) + loopCnt: Types.Int32; (* number of iterations *) nextTime: Times.Time; minTime: Times.Time; minTimeCond: Condition; @@ -679,7 +679,7 @@ MODULE ulmConditions; VAR setOfTrueConditions: ConditionSet; errors: RelatedEvents.Object) : BOOLEAN; VAR - listp: ConditionList; i: INTEGER; + listp: ConditionList; i: Types.Int32; condition: Condition; anythingTrue: BOOLEAN; BEGIN (* TestAndSelect *) @@ -728,7 +728,7 @@ MODULE ulmConditions; PROCEDURE TestAsyncList(list: List) : BOOLEAN; VAR element: Element; - listp: ConditionList; i: INTEGER; + listp: ConditionList; i: Types.Int32; condition: Condition; anythingFound: BOOLEAN; BEGIN @@ -872,7 +872,7 @@ MODULE ulmConditions; VAR setOfTrueConditions: ConditionSet; errors: RelatedEvents.Object); VAR - listp: ConditionList; i: INTEGER; + listp: ConditionList; i: Types.Int32; testSet: ConditionSet; preconds: ConditionSet; domain: Domain; @@ -881,7 +881,7 @@ MODULE ulmConditions; PROCEDURE PretestClosure(testSet, preconds: ConditionSet); VAR - listp: ConditionList; i: INTEGER; + listp: ConditionList; i: Types.Int32; domain: Domain; morePreconditions: ConditionSet; evenMorePreconditions: ConditionSet; diff --git a/src/lib/ulm/ulmConstStrings.Mod b/src/library/ulm/ulmConstStrings.Mod similarity index 93% rename from src/lib/ulm/ulmConstStrings.Mod rename to src/library/ulm/ulmConstStrings.Mod index 3b4de5ba..61f73a28 100644 --- a/src/lib/ulm/ulmConstStrings.Mod +++ b/src/library/ulm/ulmConstStrings.Mod @@ -49,8 +49,7 @@ MODULE ulmConstStrings; (* WORM-device for strings *) - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Process := ulmProcess, Services := ulmServices, Streams := ulmStreams, Strings := ulmStrings, - Texts := ulmTexts, Types := ulmTypes; + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Process := ulmProcess, Services := ulmServices, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, Types := ulmTypes; CONST tabsize = 1031; (* should be a prime number *) @@ -65,7 +64,7 @@ MODULE ulmConstStrings; BufferRec = RECORD buf: ARRAY bufsize OF CHAR; - free: INTEGER; (* buf[free..bufsize-1] is unused *) + free: Types.Int32; (* buf[free..bufsize-1] is unused *) next: Buffer; END; @@ -74,17 +73,17 @@ MODULE ulmConstStrings; RECORD (Disciplines.ObjectRec) (* read-only *) - len-: Streams.Count; (* length of string in bytes *) - hashval-: LONGINT; (* hash value *) + len*: Streams.Count; (* length of string in bytes *) + hashval*: Types.Int32; (* hash value *) (* private part *) domain: Domain; length: Streams.Count; (* private copy of length *) buf: Buffer; (* first buffer containing the string *) - offset: INTEGER; (* offset into buf *) + offset: Types.Int32; (* offset into buf *) next: String; (* list of strings with same hash value *) END; - TYPE + TYPE DomainRec* = RECORD (Disciplines.ObjectRec) @@ -108,7 +107,7 @@ MODULE ulmConstStrings; (Streams.StreamRec) string: String; buf: Buffer; (* current buffer *) - offset: INTEGER; (* index in current buffer *) + offset: Types.Int32; (* index in current buffer *) pos: Streams.Count; (* current position *) END; @@ -121,7 +120,7 @@ MODULE ulmConstStrings; (* === internal procedures =========================================== *) PROCEDURE HashVal(s: Streams.Stream; len: Streams.Count; - VAR hashval, orighashval: LONGINT); + VAR hashval, orighashval: Types.Int32); (* compute the hash value of the first `len' bytes of `s'; the hash value is returned in two variants: hashval: hash value MOD tabsize @@ -130,7 +129,7 @@ MODULE ulmConstStrings; CONST shift = 4; VAR - ordval: INTEGER; + ordval: Types.Int32; ch: CHAR; index: Streams.Count; @@ -159,7 +158,7 @@ MODULE ulmConstStrings; *) VAR ch: CHAR; - buf: Buffer; offset: INTEGER; + buf: Buffer; offset: Types.Int32; index: Streams.Count; BEGIN Streams.SetPos(s, 0); @@ -183,7 +182,7 @@ MODULE ulmConstStrings; END Equal; PROCEDURE Allocate(domain: Domain; len: Streams.Count; - VAR buf: Buffer; VAR offset: INTEGER); + VAR buf: Buffer; VAR offset: Types.Int32); (* allocate space for `len' bytes; `buf' and `offset' are returned, designating the begin of the allocated area; note that @@ -214,9 +213,9 @@ MODULE ulmConstStrings; offset := buf.free; WHILE len > 0 DO IF len <= bufsize - domain.tail.free THEN - INC(domain.tail.free, SHORT(len)); len := 0; + INC(domain.tail.free, len); len := 0; ELSE - DEC(len, bufsize - LONG(domain.tail.free)); + DEC(len, bufsize - domain.tail.free); domain.tail.free := bufsize; NewBuffer; END; @@ -224,7 +223,7 @@ MODULE ulmConstStrings; END Allocate; PROCEDURE CopyString(s: Streams.Stream; length: Streams.Count; - buf: Buffer; offset: INTEGER); + buf: Buffer; offset: Types.Int32); (* copy `length' bytes from `s' to `buf' at the given offset and its subsequent buffers *) @@ -254,7 +253,7 @@ MODULE ulmConstStrings; VAR string: String); (* common part of CloseD and CreateD *) VAR - orighashval, hashval: LONGINT; + orighashval, hashval: Types.Int32; str: String; BEGIN HashVal(s, length, hashval, orighashval); @@ -358,7 +357,7 @@ MODULE ulmConstStrings; s := rs; END Open; - PROCEDURE Compare*(string1, string2: String) : INTEGER; + PROCEDURE Compare*(string1, string2: String) : Types.Int32; (* returns < 0: if string1 < string2 = 0: if string1 = string2 (see note above) > 0: if string1 > string2 @@ -366,10 +365,10 @@ MODULE ulmConstStrings; VAR ch1, ch2: CHAR; buf1, buf2: Buffer; - offset1, offset2: INTEGER; + offset1, offset2: Types.Int32; len1, len2: Streams.Count; - PROCEDURE Next(VAR buf: Buffer; VAR offset: INTEGER; VAR ch: CHAR); + PROCEDURE Next(VAR buf: Buffer; VAR offset: Types.Int32; VAR ch: CHAR); BEGIN ch := buf.buf[offset]; INC(offset); @@ -409,7 +408,7 @@ MODULE ulmConstStrings; VAR len: Streams.Count; buf: Buffer; - offset: INTEGER; + offset: Types.Int32; count: Streams.Count; bytes: Streams.Count; BEGIN @@ -427,7 +426,7 @@ MODULE ulmConstStrings; INC(count, s.count); EXIT END; - INC(count, bytes); DEC(len, bytes); INC(offset, SHORT(bytes)); + INC(count, bytes); DEC(len, bytes); INC(offset, bytes); IF offset >= bufsize THEN buf := buf.next; offset := 0; @@ -441,7 +440,7 @@ MODULE ulmConstStrings; VAR len: Streams.Count; buf: Buffer; - offset: INTEGER; + offset: Types.Int32; index: Streams.Count; BEGIN len := string.length; @@ -480,7 +479,7 @@ MODULE ulmConstStrings; END; END ReadByte; - PROCEDURE ReadBuf(s: Streams.Stream; VAR buf: ARRAY OF Types.Byte(*BYTE*); + PROCEDURE ReadBuf(s: Streams.Stream; VAR buf: ARRAY OF Types.Byte; off, cnt: Streams.Count) : Streams.Count; VAR bytes, max: Streams.Count; @@ -530,10 +529,10 @@ MODULE ulmConstStrings; END; WHILE s.pos < realpos DO IF realpos - s.pos < bufsize - s.offset THEN - INC(s.offset, SHORT(realpos - s.pos)); + INC(s.offset, realpos - s.pos); s.pos := realpos; ELSE - INC(s.pos, LONG(bufsize - s.offset)); + INC(s.pos, bufsize - s.offset); s.offset := 0; s.buf := s.buf.next; END; diff --git a/src/library/ulm/ulmDisciplines.Mod b/src/library/ulm/ulmDisciplines.Mod new file mode 100644 index 00000000..d96617a6 --- /dev/null +++ b/src/library/ulm/ulmDisciplines.Mod @@ -0,0 +1,140 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Disciplines.om,v $ + Revision 1.1 1994/02/22 20:07:03 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 5/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmDisciplines; + + (* Disciplines allows to attach additional data structures to + abstract datatypes like Streams; + these added data structures permit to parametrize operations + which are provided by other modules (e.g. Read or Write for Streams) + *) + + IMPORT Objects := ulmObjects; + + TYPE + Identifier* = LONGINT; + + Discipline* = POINTER TO DisciplineRec; + DisciplineRec* = + RECORD + (Objects.ObjectRec) + id*: Identifier; (* should be unique for all types of disciplines *) + END; + + DisciplineList = POINTER TO DisciplineListRec; + DisciplineListRec = + RECORD + discipline: Discipline; + id: Identifier; (* copied from discipline.id *) + next: DisciplineList; + END; + + Object* = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (Objects.ObjectRec) + (* private part *) + list: DisciplineList; (* set of disciplines *) + END; + + VAR + unique: Identifier; + + PROCEDURE Unique*() : Identifier; + (* returns a unique identifier; + this procedure should be called during initialization by + all modules defining a discipline type + *) + BEGIN + INC(unique); + RETURN unique + END Unique; + + PROCEDURE Remove*(object: Object; id: Identifier); + (* remove the discipline with the given id from object, if it exists *) + VAR + prev, dl: DisciplineList; + BEGIN + prev := NIL; + dl := object.list; + WHILE (dl # NIL) & (dl.id # id) DO + prev := dl; dl := dl.next; + END; + IF dl # NIL THEN + IF prev = NIL THEN + object.list := dl.next; + ELSE + prev.next := dl.next; + END; + END; + END Remove; + + PROCEDURE Add*(object: Object; discipline: Discipline); + (* adds a new discipline to the given object; + if already a discipline with the same identifier exist + it is deleted first + *) + VAR + dl: DisciplineList; + BEGIN + dl := object.list; + WHILE (dl # NIL) & (dl.id # discipline.id) DO + dl := dl.next; + END; + IF dl = NIL THEN + NEW(dl); + dl.id := discipline.id; + dl.next := object.list; + object.list := dl; + END; + dl.discipline := discipline; + END Add; + + PROCEDURE Seek*(object: Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + (* returns TRUE if a discipline with the given id is found *) + VAR + dl: DisciplineList; + BEGIN + dl := object.list; + WHILE (dl # NIL) & (dl.id # id) DO + dl := dl.next; + END; + IF dl # NIL THEN + discipline := dl.discipline; + ELSE + discipline := NIL; + END; + RETURN discipline # NIL + END Seek; + +BEGIN + unique := 0; +END ulmDisciplines. diff --git a/src/library/ulm/ulmErrors.Mod b/src/library/ulm/ulmErrors.Mod new file mode 100644 index 00000000..7336bca2 --- /dev/null +++ b/src/library/ulm/ulmErrors.Mod @@ -0,0 +1,161 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Errors.om,v $ + Revision 1.2 1994/07/18 14:16:33 borchert + unused variables of Write (ch & index) removed + + Revision 1.1 1994/02/22 20:07:15 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 11/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmErrors; + + (* translate events to errors *) + + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, + SYS := SYSTEM; + + CONST + (* Kind = (debug, message, warning, error, fatal, bug) *) + debug* = 0; + message* = 1; + warning* = 2; + error* = 3; + fatal* = 4; + bug* = 5; + nkinds* = 6; + TYPE + Kind* = SHORTINT; (* debug..bug *) + VAR + kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR; + + TYPE + Handler* = PROCEDURE (event: Events.Event; kind: Kind); + HandlerSet* = POINTER TO HandlerSetRec; + HandlerSetRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + handlerSet: SET; (* set of installed handlers *) + handler: ARRAY nkinds OF Handler; + END; + + (* ========== write discipline ========================================= *) + TYPE + WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event); + WriteDiscipline = POINTER TO WriteDisciplineRec; + WriteDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + write: WriteProcedure; + END; + VAR + writeDiscId: Disciplines.Identifier; + + (* ========== handler discipline ======================================= *) + TYPE + HandlerDiscipline = POINTER TO HandlerDisciplineRec; + HandlerDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + hs: HandlerSet; + kind: Kind; + END; + VAR + handlerDiscId: Disciplines.Identifier; + + VAR + null*: HandlerSet; (* empty handler set *) + + PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet); + BEGIN + NEW(hs); hs.handlerSet := {}; + END CreateHandlerSet; + + PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler); + BEGIN + hs.handler[kind] := handler; + INCL(hs.handlerSet, kind); + END InstallHandler; + + PROCEDURE AssignWriteProcedure*(eventType: Events.EventType; + write: WriteProcedure); + VAR + writeDiscipline: WriteDiscipline; + BEGIN + NEW(writeDiscipline); + writeDiscipline.id := writeDiscId; + writeDiscipline.write := write; + Disciplines.Add(eventType, writeDiscipline); + END AssignWriteProcedure; + + PROCEDURE Write*(s: Streams.Stream; event: Events.Event); + VAR + writeDiscipline: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(event.type, writeDiscId, writeDiscipline) THEN + writeDiscipline(WriteDiscipline).write(s, event); + ELSE + IF ~Streams.WritePart(s, event.message, 0, + Strings.Len(event.message)) THEN + END; + END; + END Write; + + PROCEDURE GeneralEventHandler(event: Events.Event); + VAR + disc: Disciplines.Discipline; + hdisc: HandlerDiscipline; + BEGIN + IF Disciplines.Seek(event.type, handlerDiscId, disc) THEN + hdisc := disc(HandlerDiscipline); + IF hdisc.kind IN hdisc.hs.handlerSet THEN + hdisc.hs.handler[hdisc.kind](event, hdisc.kind) + END + END; + END GeneralEventHandler; + + PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType); + VAR + handlerDiscipline: HandlerDiscipline; + BEGIN + NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId; + handlerDiscipline.hs := hs; handlerDiscipline.kind := kind; + Disciplines.Add(type, handlerDiscipline); + Events.Handler(type, GeneralEventHandler); + END CatchEvent; + +BEGIN + writeDiscId := Disciplines.Unique(); + handlerDiscId := Disciplines.Unique(); + CreateHandlerSet(null); + kindText[debug] := "debug"; + kindText[message] := "message"; + kindText[warning] := "warning"; + kindText[error] := "error"; + kindText[fatal] := "fatal"; + kindText[bug] := "bug"; +END ulmErrors. diff --git a/src/lib/ulm/ulmEvents.Mod b/src/library/ulm/ulmEvents.Mod similarity index 59% rename from src/lib/ulm/ulmEvents.Mod rename to src/library/ulm/ulmEvents.Mod index 605dced8..07deb129 100644 --- a/src/lib/ulm/ulmEvents.Mod +++ b/src/library/ulm/ulmEvents.Mod @@ -39,95 +39,95 @@ MODULE ulmEvents; - IMPORT Objects := ulmObjects, Priorities := ulmPriorities, Services := ulmServices, SYS := ulmSYSTEM; + IMPORT Objects := ulmObjects, Priorities := ulmPriorities, Services := ulmServices, SYS := ulmSYSTEM, Types := ulmTypes; TYPE EventType* = POINTER TO EventTypeRec; CONST (* possibilities on receipt of an event: *) - default* = 0; (* causes abortion *) - ignore* = 1; (* ignore event *) - funcs* = 2; (* call associated event handlers *) + default* = 0; (* causes abortion *) + ignore* = 1; (* ignore event *) + funcs* = 2; (* call associated event handlers *) TYPE - Reaction* = INTEGER; (* one of default, ignore, or funcs *) + Reaction* = Types.Int32; (* one of default, ignore, or funcs *) Message* = ARRAY 80 OF CHAR; Event* = POINTER TO EventRec; EventRec* = - RECORD - (Objects.ObjectRec) - type*: EventType; - message*: Message; - (* private part *) - next: Event; (* queue *) - END; + RECORD + (Objects.ObjectRec) + type*: EventType; + message*: Message; + (* private part *) + next: Event; (* queue *) + END; EventHandler = PROCEDURE (event: Event); (* event managers are needed if there is any action necessary - on changing the kind of reaction + on changing the kind of reaction *) EventManager = PROCEDURE (type: EventType; reaction: Reaction); - Priority = INTEGER; (* must be non-negative *) + Priority = Types.Int32; (* must be non-negative *) (* every event with reaction `funcs' has a handler list; - the list is in calling order which is reverse to - the order of `Handler'-calls + the list is in calling order which is reverse to + the order of `Handler'-calls *) HandlerList = POINTER TO HandlerRec; HandlerRec* = - RECORD - (Objects.ObjectRec) - handler*: EventHandler; - next*: HandlerList; - END; + RECORD + (Objects.ObjectRec) + handler*: EventHandler; + next*: HandlerList; + END; SaveList = POINTER TO SaveRec; SaveRec = - RECORD - reaction: Reaction; - handlers: HandlerList; - next: SaveList; - END; + RECORD + reaction: Reaction; + handlers: HandlerList; + next: SaveList; + END; EventTypeRec* = - RECORD - (Services.ObjectRec) - (* private components *) - handlers: HandlerList; - priority: Priority; - reaction: Reaction; - manager: EventManager; - savelist: SaveList; - END; + RECORD + (Services.ObjectRec) + (* private components *) + handlers: HandlerList; + priority: Priority; + reaction: Reaction; + manager: EventManager; + savelist: SaveList; + END; Queue = POINTER TO QueueRec; QueueRec = - RECORD - priority: INTEGER; (* queue for this priority *) - head, tail: Event; - next: Queue; (* queue with lower priority *) - END; + RECORD + priority: Types.Int32; (* queue for this priority *) + head, tail: Event; + next: Queue; (* queue with lower priority *) + END; VAR eventTypeType: Services.Type; - + CONST - priotabsize = 256; (* size of a priority table *) - maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *) + priotabsize = 256; (* size of a priority table *) + maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *) TYPE (* in some cases coroutines uses local priority systems *) PrioritySystem* = POINTER TO PrioritySystemRec; PrioritySystemRec* = - RECORD - (Objects.ObjectRec) - (* private part *) - currentPriority: Priority; - priotab: ARRAY priotabsize OF Priority; - priotop: INTEGER; - overflow: INTEGER; (* of priority table *) - END; + RECORD + (Objects.ObjectRec) + (* private part *) + currentPriority: Priority; + priotab: ARRAY priotabsize OF Priority; + priotop: Types.Int32; + overflow: Types.Int32; (* of priority table *) + END; CONST priorityViolation* = 0; (* priority violation (EnterPriority *) @@ -139,10 +139,10 @@ MODULE ulmEvents; TYPE ErrorEvent* = POINTER TO ErrorEventRec; ErrorEventRec* = - RECORD - (EventRec) - errorcode*: SHORTINT; - END; + RECORD + (EventRec) + errorcode*: Types.Int8; + END; VAR errormsg*: ARRAY errorcodes OF Message; @@ -151,10 +151,10 @@ MODULE ulmEvents; VAR (* private part *) abort, log, queueHandler: EventHandler; - nestlevel: INTEGER; (* of Raise calls *) + nestlevel: Types.Int32; (* of Raise calls *) queue: Queue; - lock: BOOLEAN; (* lock critical operations *) - psys: PrioritySystem; (* current priority system *) + lock: BOOLEAN; (* lock critical operations *) + psys: PrioritySystem; (* current priority system *) PROCEDURE ^ Define*(VAR type: EventType); PROCEDURE ^ SetPriority*(type: EventType; priority: Priority); @@ -164,16 +164,16 @@ MODULE ulmEvents; BEGIN Define(error); SetPriority(error, Priorities.liberrors); errormsg[priorityViolation] := - "priority violation (Events.EnterPriority)"; + "priority violation (Events.EnterPriority)"; errormsg[unbalancedExitPriority] := - "unbalanced call of Events.ExitPriority"; + "unbalanced call of Events.ExitPriority"; errormsg[unbalancedRestoreReaction] := - "unbalanced call of Events.RestoreReaction"; + "unbalanced call of Events.RestoreReaction"; errormsg[negPriority] := - "negative priority given to Events.SetPriority"; + "negative priority given to Events.SetPriority"; END InitErrorHandling; - PROCEDURE Error(code: SHORTINT); + PROCEDURE Error(code: Types.Int8); VAR event: ErrorEvent; BEGIN NEW(event); event.type := error; @@ -187,7 +187,7 @@ MODULE ulmEvents; PROCEDURE Init*(type: EventType); VAR - stype: Services.Type; + stype: Services.Type; BEGIN Services.GetType(type, stype); ASSERT(stype # NIL); type.handlers := NIL; @@ -199,8 +199,8 @@ MODULE ulmEvents; PROCEDURE Define*(VAR type: EventType); (* definition of a new event; - an unique event number is returned; - the reaction on receipt of `type' is defined to be `default' + an unique event number is returned; + the reaction on receipt of `type' is defined to be `default' *) BEGIN NEW(type); @@ -218,9 +218,9 @@ MODULE ulmEvents; (* (re-)defines the priority of an event *) BEGIN IF priority <= 0 THEN - Error(negPriority); + Error(negPriority); ELSE - type.priority := priority; + type.priority := priority; END; END SetPriority; @@ -238,42 +238,42 @@ MODULE ulmEvents; PROCEDURE Handler*(type: EventType; handler: EventHandler); (* add `handler' to the list of handlers for event `type' *) VAR - newhandler: HandlerList; + newhandler: HandlerList; BEGIN NEW(newhandler); newhandler.handler := handler; newhandler.next := type.handlers; type.handlers := newhandler; IF type.reaction # funcs THEN - type.reaction := funcs; type.manager(type, funcs); + type.reaction := funcs; type.manager(type, funcs); END; END Handler; PROCEDURE RemoveHandlers*(type: EventType); (* remove list of handlers for event `type'; - implies default reaction (abortion) on - receipt of `type' + implies default reaction (abortion) on + receipt of `type' *) BEGIN type.handlers := NIL; IF type.reaction # default THEN - type.reaction := default; type.manager(type, default); + type.reaction := default; type.manager(type, default); END; END RemoveHandlers; PROCEDURE Ignore*(type: EventType); (* implies RemoveHandlers(type) and causes receipt - of `type' to be ignored + of `type' to be ignored *) BEGIN type.handlers := NIL; IF type.reaction # ignore THEN - type.reaction := ignore; type.manager(type, ignore); + type.reaction := ignore; type.manager(type, ignore); END; END Ignore; PROCEDURE GetHandlers*(type: EventType; handlers: HandlerList); (* returns the list of handlers in `handlers'; - the reaction of `type' must be `funcs' + the reaction of `type' must be `funcs' *) BEGIN handlers := type.handlers; @@ -281,8 +281,8 @@ MODULE ulmEvents; PROCEDURE Log*(loghandler: EventHandler); (* call `loghandler' for every event; - subsequent calls of `Log' replace the loghandler; - the loghandler is not called on default and ignore + subsequent calls of `Log' replace the loghandler; + the loghandler is not called on default and ignore *) BEGIN log := loghandler; @@ -301,27 +301,27 @@ MODULE ulmEvents; (* now QueueHandler will translate partly like BOOLEAN b; handler_EventHandler tmphandler; - LONGINT i, j; - i = (LONGINT)handler; + Types.Int32 i, j; + i = (Types.Int32)handler; tmphandler = handler_NilHandler; - j = (LONGINT)tmphandler; + j = (Types.Int32)tmphandler; b = i != j; *) (* changed because voc cannot compara handler and NilHandler -- noch *) PROCEDURE QueueHandler*(handler: EventHandler); (* setup an alternative handler of events - that cannot be processed now because - of their unsufficient priority + that cannot be processed now because + of their unsufficient priority *) VAR b : BOOLEAN; (* noch *) tmphandler : EventHandler; - (*i,j : LONGINT;*) + (*i,j : Types.Int32;*) BEGIN - (*i := SYSTEM.VAL(LONGINT, handler);*) + (*i := SYSTEM.VAL(Types.Int32, handler);*) tmphandler := NilHandler; (*b := tmphandler = handler;*) - (*j := SYSTEM.VAL(LONGINT, tmphandler); + (*j := SYSTEM.VAL(Types.Int32, tmphandler); b := i # j;*) b := handler # tmphandler; (*ASSERT (handler # NilHandler);*) @@ -345,92 +345,93 @@ MODULE ulmEvents; PROCEDURE WorkupQueue; VAR - ptr: Event; + ptr: Event; BEGIN WHILE (queue # NIL) & (queue.priority > psys.currentPriority) DO - IF SYS.TAS(lock) THEN RETURN END; - ptr := queue.head; queue := queue.next; - lock := FALSE; - WHILE ptr # NIL DO - CallHandlers(ptr); - ptr := ptr.next; - END; + IF SYS.TAS(lock) THEN RETURN END; + ptr := queue.head; queue := queue.next; + lock := FALSE; + WHILE ptr # NIL DO + CallHandlers(ptr); + ptr := ptr.next; + END; END; END WorkupQueue; PROCEDURE CallHandlers(event: Event); VAR - ptr: HandlerList; - oldPriority: Priority; + ptr: HandlerList; + oldPriority: Priority; BEGIN CASE event.type.reaction OF | default: abort(event); | ignore: | funcs: oldPriority := psys.currentPriority; - psys.currentPriority := event.type.priority; - log(event); - ptr := event.type.handlers; - WHILE ptr # NIL DO - ptr.handler(event); - ptr := ptr.next; - END; - psys.currentPriority := oldPriority; + psys.currentPriority := event.type.priority; + log(event); + ptr := event.type.handlers; + WHILE ptr # NIL DO + ptr.handler(event); + ptr := ptr.next; + END; + psys.currentPriority := oldPriority; + ELSE (* Explicitly ignore unhandled even type reactions *) END; END CallHandlers; PROCEDURE Raise*(event: Event); (* call all event handlers (in reverse order) - associated with event.type; - abort if there are none; - some system events may abort in another way - (i.e. they do not cause the abortion handler to be called) + associated with event.type; + abort if there are none; + some system events may abort in another way + (i.e. they do not cause the abortion handler to be called) *) VAR - priority: Priority; + priority: Priority; PROCEDURE AddToQueue(event: Event); - VAR - prev, ptr: Queue; + VAR + prev, ptr: Queue; BEGIN - event.next := NIL; - ptr := queue; prev := NIL; - WHILE (ptr # NIL) & (ptr.priority > priority) DO - prev := ptr; - ptr := ptr.next; - END; - IF (ptr # NIL) & (ptr.priority = priority) THEN - ptr.tail.next := event; - ptr.tail := event; - ELSE - NEW(ptr); - ptr.priority := priority; - ptr.head := event; ptr.tail := event; - IF prev = NIL THEN - ptr.next := queue; - queue := ptr; - ELSE - ptr.next := prev.next; - prev.next := ptr; - END; - END; + event.next := NIL; + ptr := queue; prev := NIL; + WHILE (ptr # NIL) & (ptr.priority > priority) DO + prev := ptr; + ptr := ptr.next; + END; + IF (ptr # NIL) & (ptr.priority = priority) THEN + ptr.tail.next := event; + ptr.tail := event; + ELSE + NEW(ptr); + ptr.priority := priority; + ptr.head := event; ptr.tail := event; + IF prev = NIL THEN + ptr.next := queue; + queue := ptr; + ELSE + ptr.next := prev.next; + prev.next := ptr; + END; + END; END AddToQueue; BEGIN (* Raise *) INC(nestlevel); IF nestlevel >= maxnestlevel THEN - abort(event); + abort(event); ELSE - IF event.type.reaction # ignore THEN - priority := event.type.priority; - IF psys.currentPriority < priority THEN - CallHandlers(event); WorkupQueue; - ELSIF queueHandler # NIL THEN - queueHandler(event); - ELSIF ~SYS.TAS(lock) THEN - AddToQueue(event); - lock := FALSE; - END; - END; + IF event.type.reaction # ignore THEN + priority := event.type.priority; + IF psys.currentPriority < priority THEN + CallHandlers(event); WorkupQueue; + ELSIF queueHandler # NIL THEN + queueHandler(event); + ELSIF ~SYS.TAS(lock) THEN + AddToQueue(event); + lock := FALSE; + END; + END; END; DEC(nestlevel); END Raise; @@ -451,7 +452,7 @@ MODULE ulmEvents; PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem); (* switch to another priority system; this is typically - done in case of task switches + done in case of task switches *) BEGIN psys := prioritySystem; @@ -459,52 +460,52 @@ MODULE ulmEvents; PROCEDURE EnterPriority*(priority: Priority); (* sets the current priority to `priority'; - it is an error to give a priority less than - the current priority (event `badpriority') + it is an error to give a priority less than + the current priority (event `badpriority') *) BEGIN IF psys.currentPriority <= priority THEN - IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN - psys.priotab[psys.priotop] := psys.currentPriority; - INC(psys.priotop); - psys.currentPriority := priority; - ELSE - INC(psys.overflow); - END; + IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN + psys.priotab[psys.priotop] := psys.currentPriority; + INC(psys.priotop); + psys.currentPriority := priority; + ELSE + INC(psys.overflow); + END; ELSE - Error(priorityViolation); - INC(psys.overflow); + Error(priorityViolation); + INC(psys.overflow); END; END EnterPriority; PROCEDURE AssertPriority*(priority: Priority); (* current priority - < priority: set the current priority to `priority' - >= priority: the current priority remains unchanged + < priority: set the current priority to `priority' + >= priority: the current priority remains unchanged *) BEGIN IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN - psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop); - IF psys.currentPriority < priority THEN - psys.currentPriority := priority; - END; + psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop); + IF psys.currentPriority < priority THEN + psys.currentPriority := priority; + END; ELSE - INC(psys.overflow); + INC(psys.overflow); END; END AssertPriority; PROCEDURE ExitPriority*; (* causes the priority before the last effective call - of SetPriority or AssertPriority to be restored + of SetPriority or AssertPriority to be restored *) BEGIN IF psys.overflow > 0 THEN - DEC(psys.overflow); + DEC(psys.overflow); ELSIF psys.priotop = 0 THEN - Error(unbalancedExitPriority); + Error(unbalancedExitPriority); ELSE - DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop]; - WorkupQueue; + DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop]; + WorkupQueue; END; END ExitPriority; @@ -516,11 +517,11 @@ MODULE ulmEvents; PROCEDURE SaveReaction*(type: EventType); (* saves current reaction until call of RestoreReaction; - the new reaction of `type' is defined to be `ignore' - but can be changed by Events.Handler or Events.RemoveHandlers + the new reaction of `type' is defined to be `ignore' + but can be changed by Events.Handler or Events.RemoveHandlers *) VAR - savelist: SaveList; + savelist: SaveList; BEGIN NEW(savelist); savelist.reaction := type.reaction; @@ -529,27 +530,27 @@ MODULE ulmEvents; type.savelist := savelist; type.handlers := NIL; IF type.reaction # ignore THEN - type.reaction := ignore; type.manager(type, ignore); + type.reaction := ignore; type.manager(type, ignore); END; END SaveReaction; PROCEDURE RestoreReaction*(type: EventType); (* restores old reaction; - must be properly nested + must be properly nested *) VAR - savelist: SaveList; + savelist: SaveList; BEGIN IF type.savelist = NIL THEN - Error(unbalancedRestoreReaction); + Error(unbalancedRestoreReaction); ELSE - savelist := type.savelist; - type.savelist := savelist.next; - type.handlers := savelist.handlers; - IF type.reaction # savelist.reaction THEN - type.reaction := savelist.reaction; - type.manager(type, savelist.reaction); - END; + savelist := type.savelist; + type.savelist := savelist.next; + type.handlers := savelist.handlers; + IF type.reaction # savelist.reaction THEN + type.reaction := savelist.reaction; + type.manager(type, savelist.reaction); + END; END; END RestoreReaction; diff --git a/src/library/ulm/ulmForwarders.Mod b/src/library/ulm/ulmForwarders.Mod new file mode 100644 index 00000000..27f68104 --- /dev/null +++ b/src/library/ulm/ulmForwarders.Mod @@ -0,0 +1,252 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Forwarders.om,v $ + Revision 1.1 1996/01/04 16:40:57 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmForwarders; (* AFB 3/95 *) + + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices; + + TYPE + Object* = Services.Object; + ForwardProc* = PROCEDURE (from, to: Object); + + TYPE + ListOfForwarders = POINTER TO ListOfForwardersRec; + ListOfForwardersRec = + RECORD + forward: ForwardProc; + next: ListOfForwarders; + END; + ListOfDependants = POINTER TO ListOfDependantsRec; + ListOfDependantsRec = + RECORD + dependant: Object; + next: ListOfDependants; + END; + TypeDiscipline = POINTER TO TypeDisciplineRec; + TypeDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + list: ListOfForwarders; + END; + ObjectDiscipline = POINTER TO ObjectDisciplineRec; + ObjectDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + dependants: ListOfDependants; + forwarders: ListOfForwarders; + dependsOn: Object; + END; + VAR + genlist: ListOfForwarders; (* list which applies to all types *) + typeDiscID: Disciplines.Identifier; + objectDiscID: Disciplines.Identifier; + + (* === private procedures ============================================ *) + + PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object); + VAR + prev, p: ListOfDependants; + BEGIN + prev := NIL; p := list; + WHILE (p # NIL) & (p.dependant # dependant) DO + prev := p; p := p.next; + END; + IF p # NIL THEN + IF prev = NIL THEN + list := p.next; + ELSE + prev.next := p.next; + END; + END; + END RemoveDependant; + + PROCEDURE TerminationHandler(event: Events.Event); + (* remove list of dependants in case of termination and + remove event.resource from the list of dependants of that + object it depends on + *) + VAR + odisc: Disciplines.Discipline; + dependsOn: Object; + BEGIN + WITH event: Resources.Event DO + IF event.change = Resources.terminated THEN + IF Disciplines.Seek(event.resource, objectDiscID, odisc) THEN + Disciplines.Remove(event.resource, objectDiscID); + dependsOn := odisc(ObjectDiscipline).dependsOn; + IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) & + Disciplines.Seek(dependsOn, objectDiscID, odisc) THEN + RemoveDependant(odisc(ObjectDiscipline).dependants, event.resource(Object)); + END; + END; + END; + END; + END TerminationHandler; + + PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc); + VAR + member: ListOfForwarders; + BEGIN + NEW(member); member.forward := forward; + member.next := list; list := member; + END Insert; + + PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline); + VAR + disc: Disciplines.Discipline; + resourceNotification: Events.EventType; + BEGIN + IF Disciplines.Seek(object, objectDiscID, disc) THEN + odisc := disc(ObjectDiscipline) + ELSE + NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL; + odisc.forwarders := NIL; odisc.dependsOn := NIL; + (* let's state our interest in termination of `object' if + we see this object the first time + *) + Resources.TakeInterest(object, resourceNotification); + Events.Handler(resourceNotification, TerminationHandler); + Disciplines.Add(object, odisc); + END; + END GetObjectDiscipline; + + (* === exported procedures =========================================== *) + + PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc); + (* register a forwarder which is to be called for all + forward operations which affects extensions of `for'; + "" may be given for Services.Object + *) + + VAR + type: Services.Type; + tdisc: TypeDiscipline; + disc: Disciplines.Discipline; + + BEGIN (* Register *) + IF for = "" THEN + Insert(genlist, forward); + ELSE + Services.SeekType(for, type); + ASSERT(type # NIL); + IF Disciplines.Seek(type, typeDiscID, disc) THEN + tdisc := disc(TypeDiscipline) + ELSE + NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL; + END; + Insert(tdisc.list, forward); + Disciplines.Add(type, tdisc); + END; + END Register; + + PROCEDURE RegisterObject*(object: Object; forward: ForwardProc); + (* to be called instead of Register if specific objects + are supported only and not all extensions of a type + *) + VAR + odisc: ObjectDiscipline; + BEGIN + GetObjectDiscipline(object, odisc); + Insert(odisc.forwarders, forward); + END RegisterObject; + + PROCEDURE Update*(object: Object; forward: ForwardProc); + (* is to be called by one of the registered forwarders if + an interface for object has been newly installed or changed + in a way which needs forward to be called for each of + the filter objects which delegate to `object' + *) + VAR + odisc: ObjectDiscipline; + disc: Disciplines.Discipline; + client: ListOfDependants; + BEGIN + IF Disciplines.Seek(object, objectDiscID, disc) THEN + odisc := disc(ObjectDiscipline); + client := odisc.dependants; + WHILE client # NIL DO + forward(client.dependant, object); + client := client.next; + END; + END; + END Update; + + PROCEDURE Forward*(from, to: Object); + (* forward (as far as supported) all operations from `from' to `to' *) + VAR + type, otherType, baseType: Services.Type; + disc: Disciplines.Discipline; + tdisc: TypeDiscipline; + odisc: ObjectDiscipline; + client: ListOfDependants; + forwarder: ListOfForwarders; + + PROCEDURE CallForwarders(list: ListOfForwarders); + BEGIN + WHILE list # NIL DO + list.forward(from, to); + list := list.next; + END; + END CallForwarders; + + BEGIN (* Forward *) + Services.GetType(from, type); + Services.GetType(to, otherType); + ASSERT((type # NIL) & (otherType # NIL)); + + IF Resources.Terminated(to) OR Resources.Terminated(from) THEN + (* forwarding operations is no longer useful *) + RETURN + END; + Resources.DependsOn(from, to); + + (* update the list of dependants for `to' *) + GetObjectDiscipline(to, odisc); + NEW(client); client.dependant := from; + client.next := odisc.dependants; odisc.dependants := client; + + (* call object-specific forwarders *) + CallForwarders(odisc.forwarders); + + LOOP (* go through the list of base types in descending order *) + IF Disciplines.Seek(type, typeDiscID, disc) & Services.IsExtensionOf(otherType, type) THEN + tdisc := disc(TypeDiscipline); + CallForwarders(tdisc.list); + END; + Services.GetBaseType(type, baseType); + IF baseType = NIL THEN EXIT END; + type := baseType; + END; + CallForwarders(genlist); + END Forward; + +BEGIN + genlist := NIL; + typeDiscID := Disciplines.Unique(); + objectDiscID := Disciplines.Unique(); +END ulmForwarders. diff --git a/src/lib/ulm/ulmIEEE.Mod b/src/library/ulm/ulmIEEE.Mod similarity index 100% rename from src/lib/ulm/ulmIEEE.Mod rename to src/library/ulm/ulmIEEE.Mod diff --git a/src/library/ulm/ulmIO.Mod b/src/library/ulm/ulmIO.Mod new file mode 100644 index 00000000..31aedf8a --- /dev/null +++ b/src/library/ulm/ulmIO.Mod @@ -0,0 +1,259 @@ +MODULE ulmIO; + + IMPORT SYS := ulmSYSTEM, SYSTEM, Platform, Types := ulmTypes; + + CONST nl = 0AX; + + (* conversions *) + + CONST + oct = 0; + dec = 1; + hex = 2; + TYPE + Basetype = Types.Int8; (* oct..hex *) + + (* basic IO *) + + VAR + Done*: BOOLEAN; + oldch: CHAR; + readAgain: BOOLEAN; + + (* ==================== conversions ================================= *) + + PROCEDURE ConvertNumber(num, len: Types.Int32; btyp: Basetype; neg: BOOLEAN; + VAR str: ARRAY OF CHAR); + + (* conversion of a number into a string of characters *) + (* num must get the absolute value of the number *) + (* len is the minimal length of the generated string *) + (* neg means: "the number is negative" for btyp = dec *) + + (*CONST + NumberLen = 11;*) + (* we need it as variable to change the value depending on architecture; -- noch *) + VAR + (*digits : ARRAY NumberLen+1 OF CHAR;*) + digits : POINTER TO ARRAY OF CHAR; + base : Types.Int32; + cnt, ix : Types.Int32; + maxlen : Types.Int32; + dig : Types.Int32; + NumberLen : Types.Int8; + BEGIN + IF SIZE(Types.Int32) = 8 THEN + NumberLen := 21 + ELSE + NumberLen := 11 (* default value, corresponds to 32 bit *) + END; + NEW(digits, NumberLen + 1 ); + ASSERT(num >= 0); + ix := 1; + WHILE ix <= NumberLen DO + digits[ix] := "0"; + INC(ix); + END; (* initialisation *) + IF btyp = oct THEN + base := 8; + ELSIF btyp = dec THEN + base := 10; + ELSIF btyp = hex THEN + base := 10H; + END; + cnt := 0; + REPEAT + INC(cnt); + dig := num MOD base; + num := num DIV base; + IF dig < 10 THEN + dig := dig + ORD("0"); + ELSE + dig := dig - 10 + ORD("A"); + END; + digits[cnt] := CHR(dig); + UNTIL num = 0; + (* (* i don't like this *) + IF btyp = oct THEN + cnt := 11; + ELSIF btyp = hex THEN + cnt := 8; + ELSIF neg THEN + *) + IF neg THEN + INC(cnt); + digits[cnt] := "-"; + END; + maxlen := LEN(str); (* get maximal length *) + IF len > maxlen THEN + len := SHORT(maxlen); + END; + IF cnt > maxlen THEN + cnt := SHORT(maxlen); + END; + ix := 0; + WHILE len > cnt DO + str[ix] := " "; + INC(ix); + DEC(len); + END; + WHILE cnt > 0 DO + str[ix] := digits[cnt]; + INC(ix); + DEC(cnt); + END; + IF ix < maxlen THEN + str[ix] := 0X; + END; + END ConvertNumber; + + PROCEDURE ConvertInteger(num: Types.Int32; len: Types.Int32; VAR str: ARRAY OF + CHAR); + (* conversion of an integer decimal number to a string *) + BEGIN + ConvertNumber(ABS(num),len,dec,num < 0,str); + END ConvertInteger; + + (* ========================= terminal ============================ *) + +(* + PROCEDURE ReadChar(VAR ch: CHAR) : BOOLEAN; + CONST read = 3; + (*VAR r0, r1: Types.Int32;*) + VAR r0, r1: Types.Int32; (* in ulm system Types.Int32 and Types.Int32 have the same 4 byte size; -- noch *) + BEGIN + RETURN SYS.UNIXCALL(read, r0, r1, 0, SYSTEM.ADR(ch), 1) & (r0 > 0) + END ReadChar; +*) + + PROCEDURE ReadChar(VAR ch: CHAR) : BOOLEAN; + (* Read one byte, returning success flag *) + VAR error: Platform.ErrorCode; readcount: Types.Int32; + BEGIN + error := Platform.ReadBuf(Platform.StdIn, ch, readcount); + RETURN readcount > 0 + END ReadChar; + +(* + PROCEDURE WriteChar(ch: CHAR) : BOOLEAN; + CONST write = 4; + (*VAR r0, r1: Types.Int32;*) + VAR r0, r1: Types.Int32; (* same here *) + BEGIN + RETURN SYS.UNIXCALL(write, r0, r1, 1, SYSTEM.ADR(ch), 1) + END WriteChar; +*) + + PROCEDURE WriteChar(ch: CHAR) : BOOLEAN; + (* Write one byte, returning success flag *) + BEGIN + RETURN Platform.Write(Platform.StdOut, SYSTEM.ADR(ch), 1) = 0 + END WriteChar; + + PROCEDURE Read*(VAR ch: CHAR); + BEGIN + Done := TRUE; + IF readAgain THEN + ch := oldch; + readAgain := FALSE; + ELSIF ~ReadChar(ch) THEN + Done := FALSE; + ch := 0X; + ELSE + oldch := ch; + END; + END Read; + + PROCEDURE ReadAgain*; + BEGIN + IF readAgain THEN + Done := FALSE; + ELSE + Done := TRUE; + readAgain := TRUE; + END; + END ReadAgain; + + PROCEDURE Write*(ch: CHAR); + BEGIN + Done := WriteChar(ch); + END Write; + + PROCEDURE WriteLn*; + CONST nl = 0AX; + BEGIN + Write(nl); + END WriteLn; + + PROCEDURE WriteString*(s: ARRAY OF CHAR); + VAR i: Types.Int32; + BEGIN + i := 0; + WHILE (i < LEN(s)) & (s[i] # 0X) DO + Write(s[i]); + INC(i); + END; + END WriteString; + + PROCEDURE InitIO; + BEGIN + readAgain := FALSE; + Done := TRUE; + END InitIO; + + PROCEDURE WriteInt*(arg: Types.Int32); + VAR field: ARRAY 23 OF CHAR; + BEGIN (* the field size should be big enough to hold the long number. it was 12 to hold just 32 bit numbers, now it can hold 64 bit numbers; need to be more for 128bit numbers; -- noch *) + ConvertInteger(arg, 1, field); + WriteString(field); + END WriteInt; + + PROCEDURE ReadInt*(VAR arg: Types.Int32); + VAR ch: CHAR; + minus: BOOLEAN; + BEGIN + minus := FALSE; + REPEAT + Read(ch); + IF ~Done THEN RETURN END; + IF ch = "-" THEN + minus := TRUE; + ELSIF (ch # " ") & (ch # nl) & ((ch < "0") OR (ch > "9")) THEN + WriteString("--- Integer expected on input"); WriteLn; + END; + UNTIL (ch >= "0") & (ch <= "9"); + arg := ORD(ch) - ORD("0"); + REPEAT + Read(ch); + IF ~Done THEN RETURN END; + IF (ch >= "0") & (ch <= "9") THEN + arg := arg*10 + (ORD(ch) - ORD("0")); + END; + UNTIL (ch < "0") OR (ch > "9"); + ReadAgain; + IF minus THEN arg := -arg; END; + END ReadInt; + + PROCEDURE ReadLine*(VAR string: ARRAY OF CHAR); + VAR + index: Types.Int32; + ch: CHAR; + ok: BOOLEAN; + BEGIN + index := 0; ok := TRUE; + LOOP + IF ~ReadChar(ch) THEN ok := FALSE; EXIT END; + IF ch = nl THEN EXIT END; + IF index < LEN(string) THEN + string[index] := ch; INC(index); + END; + END; + IF index < LEN(string) THEN + string[index] := 0X; + END; + Done := ok OR (index > 0); + END ReadLine; + +BEGIN + InitIO; +END ulmIO. diff --git a/src/lib/ulm/ulmIndirectDisciplines.Mod b/src/library/ulm/ulmIndirectDisciplines.Mod similarity index 74% rename from src/lib/ulm/ulmIndirectDisciplines.Mod rename to src/library/ulm/ulmIndirectDisciplines.Mod index 3118852e..22e06b14 100644 --- a/src/lib/ulm/ulmIndirectDisciplines.Mod +++ b/src/library/ulm/ulmIndirectDisciplines.Mod @@ -43,23 +43,24 @@ MODULE ulmIndirectDisciplines; TYPE IndDiscipline = POINTER TO IndDisciplineRec; IndDisciplineRec = - RECORD - (DisciplineRec) - forwardTo: Object; - END; + RECORD + (DisciplineRec) + forwardTo: Object; + END; + VAR discID: Identifier; PROCEDURE Forward*(from, to: Object); VAR - disc: IndDiscipline; + disc: IndDiscipline; BEGIN IF to = NIL THEN - Disciplines.Remove(from, discID); + Disciplines.Remove(from, discID); ELSE - NEW(disc); disc.id := discID; - disc.forwardTo := to; - Disciplines.Add(from, disc); + NEW(disc); disc.id := discID; + disc.forwardTo := to; + Disciplines.Add(from, disc); END; END Forward; @@ -70,44 +71,43 @@ MODULE ulmIndirectDisciplines; PROCEDURE Add*(object: Object; discipline: Discipline); VAR - disc: IndDiscipline; + disc: Discipline; BEGIN - WHILE Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) DO - object := disc.forwardTo; + WHILE Disciplines.Seek(object, discID, disc) DO + object := disc(IndDiscipline).forwardTo; END; Disciplines.Add(object, discipline); END Add; PROCEDURE Remove*(object: Object; id: Identifier); VAR - dummy: Discipline; - disc: IndDiscipline; + dummy, disc: Discipline; BEGIN LOOP - IF Disciplines.Seek(object, id, dummy) THEN - Disciplines.Remove(object, id); - EXIT - END; - IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - EXIT - END; - object := disc.forwardTo; + IF Disciplines.Seek(object, id, dummy) THEN + Disciplines.Remove(object, id); + EXIT + END; + IF ~Disciplines.Seek(object, discID, disc) THEN + EXIT + END; + object := disc(IndDiscipline).forwardTo; END; END Remove; PROCEDURE Seek*(object: Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; + VAR discipline: Discipline) : BOOLEAN; VAR - disc: IndDiscipline; + disc: Discipline; BEGIN LOOP - IF Disciplines.Seek(object, id, discipline) THEN - RETURN TRUE - END; - IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - RETURN FALSE - END; - object := disc.forwardTo; + IF Disciplines.Seek(object, id, discipline) THEN + RETURN TRUE + END; + IF ~Disciplines.Seek(object, discID, disc) THEN + RETURN FALSE + END; + object := disc(IndDiscipline).forwardTo; END; END Seek; diff --git a/src/lib/ulm/ulmIntOperations.Mod b/src/library/ulm/ulmIntOperations.Mod similarity index 66% rename from src/lib/ulm/ulmIntOperations.Mod rename to src/library/ulm/ulmIntOperations.Mod index 33ec3161..739bb5a4 100644 --- a/src/lib/ulm/ulmIntOperations.Mod +++ b/src/library/ulm/ulmIntOperations.Mod @@ -28,52 +28,53 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) - IMPORT Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes, SYSTEM; + IMPORT + Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, + Services := ulmServices, Streams := ulmStreams, + Types := ulmTypes; -(* SYSTEM added to make casts necessary to port ulm library because ulm compiler is not as strict (read it's wrong) as it had to be --noch *) - - CONST + CONST mod* = 5; pow* = 6; inc* = 7; dec* = 8; mmul* = 9; mpow* = 10; odd* = 11; shift* = 12; - TYPE + TYPE Operation* = Operations.Operation; (* Operations.add..mpow *) Operand* = POINTER TO OperandRec; TYPE - CapabilitySet* = Operations.CapabilitySet; - (* SET of [Operations.add..shift] *) + CapabilitySet* = Operations.CapabilitySet; + (* Types.Set of [Operations.add..shift] *) IsLargeEnoughForProc* = PROCEDURE (op: Operations.Operand; - n: LONGINT): BOOLEAN; + n: Types.Int32): BOOLEAN; UnsignedProc* = PROCEDURE (op: Operations.Operand): BOOLEAN; IntToOpProc* = PROCEDURE (int32: Types.Int32; VAR op: Operations.Operand); OpToIntProc* = PROCEDURE (op: Operations.Operand; VAR int32: Types.Int32); - Log2Proc* = PROCEDURE (op: Operations.Operand): LONGINT; + Log2Proc* = PROCEDURE (op: Operations.Operand): Types.Int32; OddProc* = PROCEDURE (op: Operations.Operand): BOOLEAN; - ShiftProc* = PROCEDURE (op: Operations.Operand; - n: INTEGER): Operations.Operand; - IntOperatorProc* = PROCEDURE(op: Operation; - op1, op2, op3: Operations.Operand; - VAR result: Operations.Operand); + ShiftProc* = PROCEDURE (op: Operations.Operand; + n: Types.Int32): Operations.Operand; + IntOperatorProc* = PROCEDURE(op: Operation; + op1, op2, op3: Operations.Operand; + VAR result: Operations.Operand); Interface* = POINTER TO InterfaceRec; InterfaceRec* = RECORD - (Operations.InterfaceRec) - isLargeEnoughFor*: IsLargeEnoughForProc; - unsigned* : UnsignedProc; - intToOp* : IntToOpProc; - opToInt* : OpToIntProc; - log2* : Log2Proc; - odd* : OddProc; - shift* : ShiftProc; - intOp* : IntOperatorProc; + (Operations.InterfaceRec) + isLargeEnoughFor*: IsLargeEnoughForProc; + unsigned* : UnsignedProc; + intToOp* : IntToOpProc; + opToInt* : OpToIntProc; + log2* : Log2Proc; + odd* : OddProc; + shift* : ShiftProc; + intOp* : IntOperatorProc; END; TYPE OperandRec* = RECORD - (Operations.OperandRec); - (* private components *) - if : Interface; - caps: CapabilitySet; + (Operations.OperandRec); + (* private components *) + if : Interface; + caps: CapabilitySet; END; VAR @@ -94,10 +95,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END Capabilities; - PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: LONGINT): BOOLEAN; + PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: Types.Int32): BOOLEAN; BEGIN WITH op: Operand DO - RETURN op.if.isLargeEnoughFor(op, n) + RETURN op.if.isLargeEnoughFor(op, n) END; END IsLargeEnoughFor; @@ -105,34 +106,18 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE Unsigned*(op: Operations.Operand): BOOLEAN; BEGIN WITH op: Operand DO - RETURN op.if.unsigned(op) + RETURN op.if.unsigned(op) END; END Unsigned; PROCEDURE IntToOp*(int32: Types.Int32; VAR op: Operations.Operand); (* converts int32 into operand type, and stores result in already - initialized op + initialized op *) BEGIN - (*WITH op: Operand DO*) - (* - with original ulm source we were getting: - - WITH op: Operand DO - ^ - pos 4101 err 245 guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable - - thus we considered changing WITH op: Operand by op(Operand) - - -- noch - - *) - (*ASSERT(op.if # NIL);*) - ASSERT(op(Operand).if # NIL); - (*op.if.intToOp(int32, op);*) - op(Operand).if.intToOp(int32, op(Operations.Operand)); - (*END;*) + ASSERT(op(Operand).if # NIL); + op(Operand).if.intToOp(int32, op); END IntToOp; @@ -140,15 +125,15 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) (* converts op into int32 *) BEGIN WITH op: Operand DO - op.if.opToInt(op, int32); + op.if.opToInt(op, int32); END; END OpToInt; - PROCEDURE Log2*(op: Operations.Operand): LONGINT; + PROCEDURE Log2*(op: Operations.Operand): Types.Int32; BEGIN WITH op: Operand DO - RETURN op.if.log2(op) + RETURN op.if.log2(op) END; END Log2; @@ -162,27 +147,27 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END Odd; - PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand; - VAR result: Operations.Operand); + PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand; + VAR result: Operations.Operand); VAR tmpresult: Operations.Operand; BEGIN WITH op1: Operand DO - IF (op2#NIL) & (op3#NIL) THEN - ASSERT((op1.if = op2(Operand).if) & - (op2(Operand).if = op3(Operand).if)); - ELSIF (op2#NIL) THEN - ASSERT(op1.if = op2(Operand).if); - END; - ASSERT(op IN op1.caps); - op1.if.create(tmpresult); - op1.if.intOp(op, op1, op2, op3, tmpresult); - result := tmpresult; + IF (op2#NIL) & (op3#NIL) THEN + ASSERT((op1.if = op2(Operand).if) & + (op2(Operand).if = op3(Operand).if)); + ELSIF (op2#NIL) THEN + ASSERT(op1.if = op2(Operand).if); + END; + ASSERT(op IN op1.caps); + op1.if.create(tmpresult); + op1.if.intOp(op, op1, op2, op3, tmpresult); + result := tmpresult; END; END Op; - PROCEDURE Shift*(op1: Operations.Operand; n: INTEGER): Operations.Operand; + PROCEDURE Shift*(op1: Operations.Operand; n: Types.Int32): Operations.Operand; BEGIN WITH op1: Operand DO ASSERT(shift IN op1.caps); @@ -191,21 +176,21 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END Shift; - PROCEDURE Shift2*(VAR op1: Operations.Operand; n: INTEGER); + PROCEDURE Shift2*(VAR op1: Operations.Operand; n: Types.Int32); BEGIN op1 := Shift(op1, n); END Shift2; - PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand; - n : INTEGER); + PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand; + n : Types.Int32); VAR tmpresult: Operations.Operand; BEGIN WITH op1: Operand DO - op1.if.create(tmpresult); - tmpresult := Shift(op1, n); - result := tmpresult; + op1.if.create(tmpresult); + tmpresult := Shift(op1, n); + result := tmpresult; END; END Shift3; @@ -230,7 +215,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) BEGIN Op(inc,op1,NIL,NIL,result); END Inc3; - + PROCEDURE Dec*(op1: Operations.Operand): Operations.Operand; VAR @@ -252,7 +237,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) BEGIN Op(dec,op1,NIL,NIL,result); END Dec3; - + PROCEDURE Mod*(op1, op2: Operations.Operand): Operations.Operand; VAR @@ -278,11 +263,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE Pow*(op1, op2: Operations.Operand): Operations.Operand; VAR - result : Operand; + result: Operations.Operand; BEGIN result := NIL; - (*Op(pow, op1, op2, NIL, result);*) - Op(pow, op1, op2, NIL, SYSTEM.VAL(Operations.Operand, result)); (* -- noch *) + Op(pow, op1, op2, NIL, result); RETURN result END Pow; @@ -301,11 +285,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE MMul*(op1, op2, op3: Operations.Operand): Operations.Operand; VAR - result : Operand; + result : Operations.Operand; BEGIN result := NIL; - (*Op(mmul, op1, op2, op3, result); *) - Op(mmul, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* --noch*) + Op(mmul, op1, op2, op3, result); RETURN result END MMul; @@ -316,8 +299,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END MMul2; - PROCEDURE MMul3*(VAR result: Operations.Operand; - op1, op2, op3: Operations.Operand); + PROCEDURE MMul3*(VAR result: Operations.Operand; + op1, op2, op3: Operations.Operand); BEGIN Op(mmul, op1, op2, op3, result); END MMul3; @@ -325,11 +308,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE MPow*(op1, op2, op3: Operations.Operand): Operations.Operand; VAR - result : Operand; + result : Operations.Operand; BEGIN result := NIL; - (*Op(mpow, op1, op2, op3, result); *) - Op(mpow, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* -- noch*) + Op(mpow, op1, op2, op3, result); RETURN result END MPow; @@ -340,8 +322,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END MPow2; - PROCEDURE MPow3*(VAR result: Operations.Operand; - op1, op2, op3: Operations.Operand); + PROCEDURE MPow3*(VAR result: Operations.Operand; + op1, op2, op3: Operations.Operand); BEGIN Op(mpow, op1, op2, op3, result); END MPow3; diff --git a/src/lib/ulm/ulmLoader.Mod b/src/library/ulm/ulmLoader.Mod similarity index 100% rename from src/lib/ulm/ulmLoader.Mod rename to src/library/ulm/ulmLoader.Mod diff --git a/src/lib/ulm/ulmMC68881.Mod b/src/library/ulm/ulmMC68881.Mod similarity index 60% rename from src/lib/ulm/ulmMC68881.Mod rename to src/library/ulm/ulmMC68881.Mod index 4bcf69a0..fc3986d0 100644 --- a/src/lib/ulm/ulmMC68881.Mod +++ b/src/library/ulm/ulmMC68881.Mod @@ -5,7 +5,7 @@ MODULE ulmMC68881; (* library interface to MC68881 instructions *) - IMPORT SYS := SYSTEM; + IMPORT SYS := SYSTEM, Types := ulmTypes; CONST available* = FALSE; (* TRUE if MC68881 present *) @@ -36,130 +36,130 @@ MODULE ulmMC68881; (* monadic operations *) - PROCEDURE FACOS*(x: LONGREAL) : LONGREAL; + PROCEDURE FACOS*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FACOS; - PROCEDURE FASIN*(x: LONGREAL) : LONGREAL; + PROCEDURE FASIN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FASIN; - PROCEDURE FATAN*(x: LONGREAL) : LONGREAL; + PROCEDURE FATAN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FATAN; - PROCEDURE FATANH*(x: LONGREAL) : LONGREAL; + PROCEDURE FATANH*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FATANH; - PROCEDURE FCOS*(x: LONGREAL) : LONGREAL; + PROCEDURE FCOS*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FCOS; - PROCEDURE FCOSH*(x: LONGREAL) : LONGREAL; + PROCEDURE FCOSH*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FCOSH; - PROCEDURE FETOX*(x: LONGREAL) : LONGREAL; + PROCEDURE FETOX*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FETOX; - PROCEDURE FETOXM1*(x: LONGREAL) : LONGREAL; + PROCEDURE FETOXM1*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FETOXM1; - PROCEDURE FGETEXP*(x: LONGREAL) : LONGREAL; + PROCEDURE FGETEXP*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FGETEXP; - PROCEDURE FGETMAN*(x: LONGREAL) : LONGREAL; + PROCEDURE FGETMAN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FGETMAN; - PROCEDURE FLOG10*(x: LONGREAL) : LONGREAL; + PROCEDURE FLOG10*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FLOG10; - PROCEDURE FLOG2*(x: LONGREAL) : LONGREAL; + PROCEDURE FLOG2*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FLOG2; - PROCEDURE FLOGN*(x: LONGREAL) : LONGREAL; + PROCEDURE FLOGN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FLOGN; - PROCEDURE FLOGNP1*(x: LONGREAL) : LONGREAL; + PROCEDURE FLOGNP1*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FLOGNP1; - PROCEDURE FSIN*(x: LONGREAL) : LONGREAL; + PROCEDURE FSIN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FSIN; - PROCEDURE FSINH*(x: LONGREAL) : LONGREAL; + PROCEDURE FSINH*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FSINH; - PROCEDURE FSQRT*(x: LONGREAL) : LONGREAL; + PROCEDURE FSQRT*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FSQRT; - PROCEDURE FTAN*(x: LONGREAL) : LONGREAL; + PROCEDURE FTAN*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FTAN; - PROCEDURE FTANH*(x: LONGREAL) : LONGREAL; + PROCEDURE FTANH*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FTANH; - PROCEDURE FTENTOX*(x: LONGREAL) : LONGREAL; + PROCEDURE FTENTOX*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FTENTOX; - PROCEDURE FTWOTOX*(x: LONGREAL) : LONGREAL; + PROCEDURE FTWOTOX*(x: Types.Real64) : Types.Real64; BEGIN RETURN ABS(x) END FTWOTOX; - PROCEDURE GetExceptionEnable*(VAR exceptions: SET); + PROCEDURE GetExceptionEnable*(VAR exceptions: Types.Set); BEGIN exceptions := {}; END GetExceptionEnable; - PROCEDURE SetExceptionEnable*(exceptions: SET); + PROCEDURE SetExceptionEnable*(exceptions: Types.Set); BEGIN exceptions := {}; END SetExceptionEnable; - PROCEDURE GetRoundingMode*(VAR precision, mode: INTEGER); + PROCEDURE GetRoundingMode*(VAR precision, mode: Types.Int32); BEGIN precision := 1; mode := 2; END GetRoundingMode; - PROCEDURE SetRoundingMode*(precision, mode: INTEGER); + PROCEDURE SetRoundingMode*(precision, mode: Types.Int32); BEGIN precision := 1; mode := 2; @@ -170,12 +170,12 @@ MODULE ulmMC68881; float must consist of at least floatlen bytes *) - PROCEDURE RealToFloat*(real: LONGREAL; VAR float: ARRAY OF SYS.BYTE); + PROCEDURE RealToFloat*(real: Types.Real64; VAR float: ARRAY OF SYS.BYTE); BEGIN (*SYS.WMOVE(SYS.ADR(real), SYS.ADR(float), floatlen DIV 4);*) END RealToFloat; - PROCEDURE FloatToReal*(float: ARRAY OF SYS.BYTE; VAR real: LONGREAL); + PROCEDURE FloatToReal*(float: ARRAY OF SYS.BYTE; VAR real: Types.Real64); BEGIN (*SYS.WMOVE(SYS.ADR(float), SYS.ADR(real), floatlen DIV 4);*) END FloatToReal; diff --git a/src/library/ulm/ulmNetIO.Mod b/src/library/ulm/ulmNetIO.Mod new file mode 100644 index 00000000..3db6887b --- /dev/null +++ b/src/library/ulm/ulmNetIO.Mod @@ -0,0 +1,554 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: NetIO.om,v $ + Revision 1.4 2004/05/21 15:19:03 borchert + performance improvements: + - ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD, + if possible + (based on code by Christian Ehrhardt) + - WriteConstString uses Streams.Copy instead of a loop that uses + Streams.ReadByte and Streams.WriteByte + + Revision 1.3 1995/03/17 16:28:20 borchert + - SizeOf stuff removed + - support of const strings added + - support of Forwarders added + + Revision 1.2 1994/07/18 14:18:37 borchert + unused variables of WriteString (ch + index) removed + + Revision 1.1 1994/02/22 20:08:43 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 6/93 + ---------------------------------------------------------------------------- +*) + +MODULE ulmNetIO; + + (* abstraction for the exchange of Oberon base types which + are components of persistent data structures + *) + + IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings, + SYS := SYSTEM, Types := ulmTypes; + + TYPE + Byte* = Types.Byte; + + TYPE + ReadByteProc* = + PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + ReadCharProc* = + PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + ReadBooleanProc* = + PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + ReadShortIntProc* = + PROCEDURE (s: Streams.Stream; VAR shortint: Types.Int8) : BOOLEAN; + ReadIntegerProc* = + PROCEDURE (s: Streams.Stream; VAR integer: Types.Int32) : BOOLEAN; + ReadLongIntProc* = + PROCEDURE (s: Streams.Stream; VAR longint: Types.Int32) : BOOLEAN; + ReadRealProc* = + PROCEDURE (s: Streams.Stream; VAR real: Types.Real32) : BOOLEAN; + ReadLongRealProc* = + PROCEDURE (s: Streams.Stream; VAR longreal: Types.Real64) : BOOLEAN; + ReadSetProc* = + PROCEDURE (s: Streams.Stream; VAR set: Types.Set) : BOOLEAN; + ReadStringProc* = + PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + ReadConstStringProc* = + PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; + + WriteByteProc* = + PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN; + WriteCharProc* = + PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN; + WriteBooleanProc* = + PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + WriteShortIntProc* = + PROCEDURE (s: Streams.Stream; shortint: Types.Int8) : BOOLEAN; + WriteIntegerProc* = + PROCEDURE (s: Streams.Stream; integer: Types.Int32) : BOOLEAN; + WriteLongIntProc* = + PROCEDURE (s: Streams.Stream; longint: Types.Int32) : BOOLEAN; + WriteRealProc* = + PROCEDURE (s: Streams.Stream; real: Types.Real32) : BOOLEAN; + WriteLongRealProc* = + PROCEDURE (s: Streams.Stream; longreal: Types.Real64) : BOOLEAN; + WriteSetProc* = + PROCEDURE (s: Streams.Stream; set: Types.Set) : BOOLEAN; + WriteStringProc* = + PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + WriteConstStringProc* = + PROCEDURE (s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + readByte*: ReadByteProc; + readChar*: ReadCharProc; + readBoolean*: ReadBooleanProc; + readShortInt*: ReadShortIntProc; + readInteger*: ReadIntegerProc; + readLongInt*: ReadLongIntProc; + readReal*: ReadRealProc; + readLongReal*: ReadLongRealProc; + readSet*: ReadSetProc; + readString*: ReadStringProc; + readConstString*: ReadConstStringProc; + + writeByte*: WriteByteProc; + writeChar*: WriteCharProc; + writeBoolean*: WriteBooleanProc; + writeShortInt*: WriteShortIntProc; + writeInteger*: WriteIntegerProc; + writeLongInt*: WriteLongIntProc; + writeReal*: WriteRealProc; + writeLongReal*: WriteLongRealProc; + writeSet*: WriteSetProc; + writeString*: WriteStringProc; + writeConstString*: WriteConstStringProc; + END; + + (* private data structures *) + TYPE + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + if: Interface; + END; + VAR + discID: Disciplines.Identifier; + + PROCEDURE Seek(s: Streams.Stream; id: Disciplines.Identifier; disc: Discipline): BOOLEAN; + VAR d: Disciplines.Discipline; result: BOOLEAN; + BEGIN + result := Disciplines.Seek(s, id, d); + IF result THEN disc := d(Discipline) ELSE disc := NIL END; + RETURN result + END Seek; + + PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,j : Types.Int32; + tmp : SYS.BYTE; + BEGIN + i := 0; j := LEN (a) - 1; + WHILE i < j DO + tmp := a[i]; a[i] := a[j]; a[j] := tmp; + INC (i); DEC (j); + END; + END Swap; + + PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,old, bit : Types.Int32; + new : Types.Int32; + + BEGIN + i := 0; + WHILE i < LEN (a) DO + old := ORD (SYS.VAL (CHAR, a[i])); + new := 0; bit := 080H; + WHILE old # 0 DO + IF ODD (old) THEN + INC (new, bit); + END; + bit := ASH (bit, -1);; + old := ASH (old, -1); + END; + a[i] := SYS.VAL (SYS.BYTE, new); + INC (i); + END; + END BitSwap; + + PROCEDURE ^ Forward(from, to: Forwarders.Object); + + PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface); + VAR + disc: Discipline; + BEGIN + IF if # NIL THEN + NEW(disc); disc.id := discID; disc.if := if; + Disciplines.Add(s, disc); + ELSE + Disciplines.Remove(s, discID); + END; + Forwarders.Update(s, Forward); + END AttachInterface; + + PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface); + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + if := disc.if; + ELSE + if := NIL; + END; + END GetInterface; + + PROCEDURE CopyInterface*(from, to: Streams.Stream); + VAR + if: Interface; + BEGIN + GetInterface(from, if); + AttachInterface(to, if); + END CopyInterface; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + (* this check is necessary because of Forwarders.Update *) + IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN + RETURN + END; + + WITH from: Streams.Stream DO WITH to: Streams.Stream DO + (* be careful here, from & to must be reversed *) + CopyInterface(to, from); + END; END; + END Forward; + + PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readByte(s, byte) + ELSE + RETURN Streams.ReadByte(s, byte) + END; + END ReadByte; + + PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readChar(s, char) + ELSE + RETURN Streams.ReadByte(s, char) + END; + END ReadChar; + + PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readBoolean(s, boolean) + ELSE + RETURN Streams.Read(s, boolean) + END; + END ReadBoolean; + + PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: Types.Int8) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readShortInt(s, shortint) + ELSE + RETURN Streams.ReadByte(s, shortint) + END; + END ReadShortInt; + + PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: Types.Int32) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readInteger(s, integer) + ELSE + ret := Streams.Read(s, integer); + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN ret; + END; + END ReadInteger; + + PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: Types.Int32) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readLongInt(s, longint) + ELSE + ret := Streams.Read(s, longint); + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN ret; + END; + END ReadLongInt; + + PROCEDURE ReadReal*(s: Streams.Stream; VAR real: Types.Real32) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readReal(s, real) + ELSE + RETURN Streams.Read(s, real) + END; + END ReadReal; + + PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: Types.Real64) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readLongReal(s, longreal) + ELSE + RETURN Streams.Read(s, longreal) + END; + END ReadLongReal; + + PROCEDURE ReadSet*(s: Streams.Stream; VAR set: Types.Set) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readSet(s, set) + ELSE + ret := Streams.Read(s, set); + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN ret; + END; + END ReadSet; + + PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + ch: CHAR; index: Types.Int32; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readString(s, string) + ELSE + index := 0; + WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO + IF index + 1 < LEN(string) THEN + string[index] := ch; INC(index); + END; + END; + string[index] := 0X; + RETURN ~s.error + END; + END ReadString; + + PROCEDURE ReadConstStringD*(s: Streams.Stream; + domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; + CONST + bufsize = 512; + VAR + length: Types.Int32; + buf: Streams.Stream; + ch: CHAR; + disc: Discipline; + stringbuf: ARRAY bufsize OF CHAR; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readConstString(s, domain, string) + ELSE + IF ReadLongInt(s, length) THEN + IF length >= bufsize THEN + ConstStrings.Init(buf); + IF ~Streams.Copy(s, buf, length) THEN + RETURN FALSE + END; + ConstStrings.CloseD(buf, domain, string); + RETURN length = s.count; + ELSE + IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN + RETURN FALSE + END; + stringbuf[length] := 0X; + ConstStrings.CreateD(string, domain, stringbuf); + RETURN TRUE + END; + ELSE + RETURN FALSE + END; + END; + END ReadConstStringD; + + PROCEDURE ReadConstString*(s: Streams.Stream; + VAR string: ConstStrings.String) : BOOLEAN; + BEGIN + RETURN ReadConstStringD(s, ConstStrings.std, string) + END ReadConstString; + + PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeByte(s, byte) + ELSE + RETURN Streams.WriteByte(s, byte) + END; + END WriteByte; + + PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeChar(s, char) + ELSE + RETURN Streams.WriteByte(s, char) + END; + END WriteChar; + + PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeBoolean(s, boolean) + ELSE + RETURN Streams.Write(s, boolean) + END; + END WriteBoolean; + + PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: Types.Int8) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeShortInt(s, shortint) + ELSE + RETURN Streams.WriteByte(s, shortint) + END; + END WriteShortInt; + + PROCEDURE WriteInteger*(s: Streams.Stream; integer: Types.Int32) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeInteger(s, integer) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN Streams.Write(s, integer); + END; + END WriteInteger; + + PROCEDURE WriteLongInt*(s: Streams.Stream; longint: Types.Int32) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeLongInt(s, longint) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN Streams.Write(s, longint); + END; + END WriteLongInt; + + PROCEDURE WriteReal*(s: Streams.Stream; real: Types.Real32) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeReal(s, real) + ELSE + RETURN Streams.Write(s, real) + END; + END WriteReal; + + PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: Types.Real64) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeLongReal(s, longreal) + ELSE + RETURN Streams.Write(s, longreal) + END; + END WriteLongReal; + + PROCEDURE WriteSet*(s: Streams.Stream; set: Types.Set) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeSet(s, set) + ELSE + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN Streams.Write(s, set) + END; + END WriteSet; + + PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeString(s, string) + ELSE + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) & + Streams.WriteByte(s, 0X) + END; + END WriteString; + + PROCEDURE WriteConstString*(s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; + VAR + ch: CHAR; + buf: Streams.Stream; + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeConstString(s, string) + ELSE + IF WriteLongInt(s, string.len) THEN + ConstStrings.Open(buf, string); + RETURN Streams.Copy(buf, s, string.len) + ELSE + RETURN FALSE + END; + END; + END WriteConstString; + +BEGIN + discID := Disciplines.Unique(); + Forwarders.Register("Streams.Stream", Forward); +END ulmNetIO. diff --git a/src/lib/ulm/ulmObjects.Mod b/src/library/ulm/ulmObjects.Mod similarity index 100% rename from src/lib/ulm/ulmObjects.Mod rename to src/library/ulm/ulmObjects.Mod diff --git a/src/library/ulm/ulmOperations.Mod b/src/library/ulm/ulmOperations.Mod new file mode 100644 index 00000000..317b42d8 --- /dev/null +++ b/src/library/ulm/ulmOperations.Mod @@ -0,0 +1,234 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Operations.om,v $ + Revision 1.4 2004/09/16 18:31:54 borchert + optimization for Assign added in case of a non-NIL target + and identical types for target and source + + Revision 1.3 1997/02/05 16:27:45 borchert + Init asserts now that Services.Init hat been called previously + for ``op'' + + Revision 1.2 1995/01/16 21:39:50 borchert + - assertions of Assertions have been converted into real assertions + - some fixes due to changes of PersistentObjects + + Revision 1.1 1994/02/22 20:09:03 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmOperations; + + (* generic support of arithmetic operations *) + + IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Types := ulmTypes; + + CONST + add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4; + TYPE + Operation* = Types.Int8; (* add..cmp *) + Operand* = POINTER TO OperandRec; + + TYPE + CapabilitySet* = Types.Set; (* Types.Set OF [add..cmp] *) + CreateProc* = PROCEDURE (VAR op: Operand); + (* should call Operations.Init for op *) + OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand; + VAR result: Operand); + AssignProc* = PROCEDURE (VAR target: Operand; source: Operand); + CompareProc* = PROCEDURE (op1, op2: Operand) : Types.Int32; + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; + assign*: AssignProc; + op*: OperatorProc; + compare*: CompareProc; + END; + + TYPE + OperandRec* = + RECORD + (PersistentDisciplines.ObjectRec) + if: Interface; + caps: CapabilitySet; + END; + VAR + operandType: Services.Type; + + PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet); + VAR + type: Services.Type; + BEGIN + Services.GetType(op, type); ASSERT(type # NIL); + op.if := if; op.caps := caps; + END Init; + + PROCEDURE Capabilities*(op: Operand) : CapabilitySet; + BEGIN + RETURN op.caps + END Capabilities; + + PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN; + (* return TRUE if both operands have the same interface *) + BEGIN + RETURN op1.if = op2.if + END Compatible; + + (* the interface of the first operand must match the interface + of all other operands; + the result parameter must be either NIL or already initialized + with the same interface + *) + + PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand); + + VAR + tmpresult: Operand; + BEGIN + ASSERT(op1.if = op2.if); + ASSERT(op IN op1.caps); + (* we are very defensive here because the type of tmpresult + is perhaps not identical to result or an extension of it; + op1.if.create(result) will not work in all cases + because of type guard failures + *) + op1.if.create(tmpresult); + op1.if.op(op, op1, op2, tmpresult); + result := tmpresult; + END Op; + + PROCEDURE Add*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(add, op1, op2, result); + RETURN result + END Add; + + PROCEDURE Add2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(add, op1, op2, op1); + END Add2; + + PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(add, op1, op2, result); + END Add3; + + PROCEDURE Sub*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(sub, op1, op2, result); + RETURN result + END Sub; + + PROCEDURE Sub2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(sub, op1, op2, op1); + END Sub2; + + PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(sub, op1, op2, result); + END Sub3; + + PROCEDURE Mul*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(mul, op1, op2, result); + RETURN result + END Mul; + + PROCEDURE Mul2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(mul, op1, op2, op1); + END Mul2; + + PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(mul, op1, op2, result); + END Mul3; + + PROCEDURE Div*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(div, op1, op2, result); + RETURN result + END Div; + + PROCEDURE Div2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(div, op1, op2, op1); + END Div2; + + PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(div, op1, op2, result); + END Div3; + + PROCEDURE Compare*(op1, op2: Operand) : Types.Int32; + BEGIN + ASSERT(op1.if = op2.if); + ASSERT(cmp IN op1.caps); + RETURN op1.if.compare(op1, op2) + END Compare; + + PROCEDURE Assign*(VAR target: Operand; source: Operand); + VAR + tmpTarget: Operand; + typesIdentical: BOOLEAN; + targetType, sourceType: Services.Type; + BEGIN + IF (target # NIL) & (target.if = source.if) THEN + Services.GetType(target, targetType); + Services.GetType(source, sourceType); + typesIdentical := targetType = sourceType; + ELSE + typesIdentical := FALSE; + END; + IF typesIdentical THEN + source.if.assign(target, source); + ELSE + source.if.create(tmpTarget); + source.if.assign(tmpTarget, source); + target := tmpTarget; + END; + END Assign; + + PROCEDURE Copy*(source, target: Operand); + BEGIN + source.if.assign(target, source); + END Copy; + +BEGIN + PersistentObjects.RegisterType(operandType, + "Operations.Operand", "PersistentDisciplines.Object", NIL); +END ulmOperations. diff --git a/src/library/ulm/ulmPersistentDisciplines.Mod b/src/library/ulm/ulmPersistentDisciplines.Mod new file mode 100644 index 00000000..538b8de6 --- /dev/null +++ b/src/library/ulm/ulmPersistentDisciplines.Mod @@ -0,0 +1,392 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentD.om,v $ + Revision 1.4 1998/02/22 10:25:22 borchert + bug fix in GetObject: Disciplines.Add was missing if the main object + is just an extension of Disciplines.Object and not of + PersistentDisciplines.Object + + Revision 1.3 1996/07/24 07:41:28 borchert + bug fix: count component was not initialized (with the + exception of CreateObject) -- detected by Martin Hasch + + Revision 1.2 1995/03/17 16:13:33 borchert + - persistent disciplines may now be attached to non-persistent objects + - some fixes due to changes of PersistentObjects + + Revision 1.1 1994/02/22 20:09:12 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmPersistentDisciplines; + + IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, + Services := ulmServices, Streams := ulmStreams; + + CONST + objectName = "PersistentDisciplines.Object"; + disciplineName = "PersistentDisciplines.Discipline"; + + TYPE + Identifier* = LONGINT; + + Discipline* = POINTER TO DisciplineRec; + DisciplineRec* = + RECORD + (PersistentObjects.ObjectRec) + id*: Identifier; (* should be unique for all types of disciplines *) + END; + + DisciplineList = POINTER TO DisciplineListRec; + DisciplineListRec = + RECORD + discipline: Discipline; + id: Identifier; (* copied from discipline.id *) + next: DisciplineList; + END; + + Interface = POINTER TO InterfaceRec; + Object = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (PersistentObjects.ObjectRec) + (* private part *) + count: LONGINT; (* number of attached disciplines *) + list: DisciplineList; (* set of disciplines *) + if: Interface; (* overrides builtins if # NIL *) + forwardTo: Object; + usedBy: Object; (* used as target of UseInterfaceOf *) + (* very restrictive way of avoiding reference cycles: + forwardTo references must be built from inner to + outer objects and not vice versa + *) + END; + + TYPE + VolatileDiscipline = POINTER TO VolatileDisciplineRec; + VolatileDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + object: Object; + END; + VAR + volDiscID: Disciplines.Identifier; + + TYPE + AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline); + RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier); + SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + add*: AddProc; + remove*: RemoveProc; + seek*: SeekProc; + END; + + VAR + unique: Identifier; + objIf: PersistentObjects.Interface; + objDatatype, discDatatype: Services.Type; + + CONST + hashtabsize = 32; + TYPE + Sample = POINTER TO SampleRec; + SampleRec = + RECORD + id: Identifier; + sample: Discipline; + next: Sample; + END; + BucketTable = ARRAY hashtabsize OF Sample; + VAR + samples: BucketTable; + + PROCEDURE CreateObject*(VAR object: Object); + (* creates a new object; this procedures should be called instead of + NEW for objects of type `Object' + *) + BEGIN + NEW(object); + object.count := 0; (* up to now, there are no attached disciplines *) + object.list := NIL; + object.if := NIL; + PersistentObjects.Init(object, objDatatype); + END CreateObject; + + PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object); + VAR + disc: Disciplines.Discipline; + vdisc: VolatileDiscipline; + BEGIN + IF obj IS Object THEN + object := obj(Object); + (* initialize private components now if not done already; + we assume here that pointers which have not been + initialized yet are defined to be NIL + (because of the garbage collection); + a similar assumption does not necessarily hold for + other types (e.g. integers) + *) + IF object.list = NIL THEN + object.count := 0; + END; + ELSIF Disciplines.Seek(obj, volDiscID, disc) THEN + object := disc(VolatileDiscipline).object; + ELSE + CreateObject(object); + NEW(vdisc); vdisc.id := volDiscID; vdisc.object := object; + Disciplines.Add(obj, vdisc); + END; + END GetObject; + + (* === normal stuff for disciplines ===================================== *) + + PROCEDURE Unique*(sample: Discipline) : Identifier; + (* returns a unique identifier; + this procedure should be called during initialization by + all modules defining a discipline type; + a sample of the associated discipline has to be provided + *) + VAR + hashval: Identifier; + entry: Sample; + BEGIN + INC(unique); + NEW(entry); entry.id := unique; entry.sample := sample; + hashval := unique MOD hashtabsize; + entry.next := samples[hashval]; samples[hashval] := entry; + RETURN unique + END Unique; + + PROCEDURE GetSample*(id: Identifier) : Discipline; + (* return sample for the given identifier; + NIL will be returned if id has not yet been returned by Unique + *) + VAR + hashval: Identifier; + ptr: Sample; + BEGIN + hashval := id MOD hashtabsize; + ptr := samples[hashval]; + WHILE (ptr # NIL) & (ptr.id # id) DO + ptr := ptr.next; + END; + IF ptr # NIL THEN + RETURN ptr.sample + ELSE + RETURN NIL + END; + END GetSample; + + PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface); + (* override the builtin implementations of Add, Remove and + Seek for `object' with the implementations given by `if' + *) + VAR + po: Object; + BEGIN + GetObject(object, po); + IF (po.list = NIL) & (po.forwardTo = NIL) THEN + po.if := if; + END; + END AttachInterface; + + PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object); + (* forward Add, Remove and Seek operations from object to host *) + VAR + po, phost: Object; + BEGIN + GetObject(object, po); GetObject(host, phost); + IF (po.list = NIL) & (po.forwardTo = NIL) & + (po.usedBy = NIL) THEN + po.forwardTo := phost; + phost.usedBy := po; (* avoid reference cycles *) + END; + END UseInterfaceOf; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + UseInterfaceOf(from, to); + END Forward; + + PROCEDURE Remove*(object: Disciplines.Object; id: Identifier); + (* remove the discipline with the given id from object, if it exists *) + VAR + po: Object; + prev, dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + prev := NIL; + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + prev := dl; dl := dl.next; + END; + IF dl # NIL THEN + IF prev = NIL THEN + po.list := dl.next; + ELSE + prev.next := dl.next; + END; + DEC(po.count); (* discipline removed *) + END; + ELSE + po.if.remove(po, id); + END; + END Remove; + + PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline); + (* adds a new discipline to the given object; + if already a discipline with the same identifier exist + it is deleted first + *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # discipline.id) DO + dl := dl.next; + END; + IF dl = NIL THEN + NEW(dl); + dl.id := discipline.id; + dl.next := po.list; + po.list := dl; + INC(po.count); (* discipline added *) + END; + dl.discipline := discipline; + ELSE + po.if.add(po, discipline); + END; + END Add; + + PROCEDURE Seek*(object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + (* returns TRUE if a discipline with the given id is found *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + dl := dl.next; + END; + IF dl # NIL THEN + discipline := dl.discipline; + ELSE + discipline := NIL; + END; + RETURN discipline # NIL + ELSE + RETURN po.if.seek(po, id, discipline) + END; + END Seek; + + (* === interface procedures for PersistentObjects for Object === *) + + PROCEDURE ReadObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* read data and attached disciplines of given object from stream *) + VAR + discipline: PersistentObjects.Object; (* Discipline *) + count: LONGINT; + BEGIN + (* get number of attached disciplines *) + IF ~NetIO.ReadLongInt(stream, count) THEN + RETURN FALSE; + END; + (* read all disciplines from `stream' and attach them to `object' *) + WHILE count > 0 DO + IF ~PersistentObjects.Read(stream, discipline) THEN + RETURN FALSE; + END; + Add(object(Object), discipline(Discipline)); + DEC(count); + END; + RETURN TRUE; + END ReadObjectData; + + PROCEDURE WriteObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* write data and attached disciplines of given object to stream *) + VAR + dl: DisciplineList; + BEGIN + WITH object: Object DO + (* write number of attached disciplines to `stream' *) + IF ~NetIO.WriteLongInt(stream, object.count) THEN + RETURN FALSE; + END; + (* write all attached disciplines to the stream *) + dl := object.list; + WHILE dl # NIL DO + IF ~PersistentObjects.Write(stream, dl.discipline) THEN + RETURN FALSE; + END; + dl := dl.next; + END; + END; + RETURN TRUE; + END WriteObjectData; + + PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object); + VAR + myObject: Object; + BEGIN + CreateObject(myObject); + obj := myObject; + END InternalCreate; + +BEGIN + unique := 0; + + NEW(objIf); + objIf.read := ReadObjectData; + objIf.write := WriteObjectData; + objIf.create := InternalCreate; + objIf.createAndRead := NIL; + PersistentObjects.RegisterType(objDatatype, objectName, "", objIf); + PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL); + + volDiscID := Disciplines.Unique(); + + Forwarders.Register("", Forward); +END ulmPersistentDisciplines. diff --git a/src/library/ulm/ulmPersistentObjects.Mod b/src/library/ulm/ulmPersistentObjects.Mod new file mode 100644 index 00000000..b34b3645 --- /dev/null +++ b/src/library/ulm/ulmPersistentObjects.Mod @@ -0,0 +1,1086 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: PersistentO.om,v 1.8 2004/03/30 13:14:16 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentO.om,v $ + Revision 1.8 2004/03/30 13:14:16 borchert + introduced more elaborate error events for cannotReadData + + Revision 1.7 1998/04/09 16:55:48 borchert + bug fix: ReadTypeInfo failed on hierarchical mode if none of the + types were known by returning TRUE with type set to NIL + + Revision 1.6 1998/03/24 22:42:28 borchert + improvements: + - it is now acceptable that read and write if procedures are given + but neither create nor createAndRead -- this is fine for + abstractions that maintain some components + - Read operates now immediately on the given object to support + LinearizedStructures -- otherwise it would be nearly impossible + to reconstruct self-referential data structures; + note that this is *not supported* by GuardedRead + + Revision 1.5 1995/04/04 12:36:39 borchert + major redesign of PersistentObjects: + - new type encoding schemes + - size if proc removed + - support for NIL and guards added + + Revision 1.4 1994/07/18 14:19:13 borchert + bug fix: SizeOf used uninitialized variable (name) and added the + length of all type names of the hierarchy to the sum + + Revision 1.3 1994/07/05 08:47:26 borchert + bug fix: modifications due to last bug fix didn't work correctly in + in all cases + code cleaned up at several locations + + Revision 1.2 1994/03/25 15:54:09 borchert + bug fix: the complete type hierarchy together with all abstract types + was written -- this caused a NIL-procedure to be called in + case of projections. Now, we write shorter type hierarchies and + GetCreate checks the create-procedure against NIL + + Revision 1.1 1994/02/22 20:09:21 borchert + Initial revision + + ---------------------------------------------------------------------------- + DB 7/93 + ---------------------------------------------------------------------------- +*) + +MODULE ulmPersistentObjects; + + (* handling of persistent objects *) + + IMPORT ASCII := ulmASCII, ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Errors := ulmErrors, Events := ulmEvents, Forwarders := ulmForwarders, + IndirectDisciplines := ulmIndirectDisciplines, Loader := ulmLoader, NetIO := ulmNetIO, Objects := ulmObjects, Priorities := ulmPriorities, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, SYS := SYSTEM, Types := ulmTypes; + + CONST + maxNameLen = 128; (* max length of data type names *) + TYPE + TypeName = ARRAY maxNameLen OF CHAR; (* for temporary use only *) + ShortTypeName = ARRAY 32 OF CHAR; (* for error messages only *) + + CONST + cannotReadData* = 0; + cannotWriteData* = 1; + cannotReadType* = 2; + cannotWriteType* = 3; + invalidType* = 4; + unknownType* = 5; + otherTypeHier* = 6; + eofReached* = 7; + cannotSkip* = 8; + typeGuardFailure* = 9; (* GuardedRead failed to type guard failure *) + errorcodes* = 10; (* number of error codes *) + + (* how are types specified: fullTypeName, typeCode, incrTypeCode + with or without size info: withSize, withoutSize + with or without type hier: withHier, withoutHier + + combinations are given as additions, + e.g. typeCode + withSize + withHier + *) + fullTypeName* = 1; typeCode* = 2; incrTypeCode* = 3; + withSize* = 4; withoutSize* = 0; + withHier* = 8; withoutHier* = 0; + + defaultMode = fullTypeName + withSize + withHier; + (* provide all informations on default *) + + (* forms: + type spec: codeF | incrF | nameF | incrhierF | hierF + size spec: sizeF | noSizeF + add specs, eg. codeF + sizeF + *) + codeF = 1; (* just a type code *) + incrF = 2; (* type name + code given *) + nameF = 3; (* type name given *) + incrhierF = 4; (* type hierarchy with codes *) + hierF = 5; (* type hierarchy without codes *) + sizeF = 8; (* size information given *) + noSizeF = 0; (* no size information given *) + maskF = 8; + maxF = 13; (* maximal valid form code *) + + TYPE + Mode* = Types.Int8; + Form = Types.Int8; + + Object* = POINTER TO ObjectRec; + Type = POINTER TO TypeRec; + + ReadProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + WriteProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + CreateProc* = PROCEDURE (VAR o: Object); + CreateAndReadProc* = PROCEDURE (s: Streams.Stream; + create: BOOLEAN; + VAR o: Object) : BOOLEAN; + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; (* create object *) + read*: ReadProc; (* read data from stream *) + write*: WriteProc; (* write data to stream *) + createAndRead*: CreateAndReadProc; (* replaces create & read *) + END; + + ObjectRec* = + RECORD + (Services.ObjectRec) + (* private data *) + type: Type; + projected: BOOLEAN; (* set after Read *) + END; + + CONST + ttlen = 16; + TYPE + TypeEntry = POINTER TO TypeEntryRec; + TypeEntryRec = + RECORD + code: Types.Int32; + type: Type; + next: TypeEntry; + END; + TypeTable = ARRAY ttlen OF TypeEntry; + StreamDiscipline = POINTER TO StreamDisciplineRec; + StreamDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + mode: Mode; (* type encoding mode for the stream *) + rtypes, wtypes: TypeTable; + END; + + InterfaceList = POINTER TO InterfaceListRec; + InterfaceListRec = + RECORD + if: Interface; + next: InterfaceList; (* points to next extension *) + END; + TypeRec = + RECORD + (Services.TypeRec) + baseType: Type; (* the next non-abstract base type *) + if: Interface; (* may be = NIL for abstract types *) + ifs: InterfaceList; (* list of interfaces in reverse order *) + code: Types.Int32; (* unique number *) + END; + + (* this list is used for storing the base type list of an object during + reading this object + *) + BaseTypeList = POINTER TO BaseTypeRec; + BaseTypeRec = + RECORD + name: ConstStrings.String; (* name of the base type *) + next: BaseTypeList; + END; + + (* each error causes an event; the error number is stored in + event.errorcode; the associated text can be taken from event.message + *) + ErrorCode = Types.Int8; + Event = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + stream*: Streams.Stream; + errorcode*: ErrorCode; + END; + UnknownTypeEvent = POINTER TO UnknownTypeEventRec; + UnknownTypeEventRec = + RECORD + (EventRec) + typeName: ARRAY 80 OF CHAR; + END; + DecodeFailureEvent = POINTER TO DecodeFailureEventRec; + DecodeFailureEventRec = + RECORD + (EventRec) + objectType: Services.Type; + END; + TypeGuardFailureEvent = POINTER TO TypeGuardFailureEventRec; + TypeGuardFailureEventRec = + RECORD + (EventRec) + found, expected: Services.Type; + END; + + VAR + id: Disciplines.Identifier; + nextTypeCode: Types.Int32; (* for the generation of unique numbers *) + potype: Services.Type; + + errormsg*: ARRAY errorcodes OF Events.Message; + (* readable text for error codes *) + error*: Events.EventType; + (* raised on failed stream operations; ignored by default *) + + (* ===== for internal use only ========================================== *) + + PROCEDURE Error(stream: Streams.Stream; code: ErrorCode); + (* raise an error event with the error code `code' *) + VAR + event: Event; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.stream := stream; + event.errorcode := code; + RelatedEvents.Raise(stream, event); + END Error; + + PROCEDURE UnknownType(stream: Streams.Stream; typeName: ARRAY OF CHAR); + VAR + event: UnknownTypeEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[unknownType]; + event.stream := stream; + event.errorcode := unknownType; + COPY(typeName, event.typeName); + RelatedEvents.Raise(stream, event); + END UnknownType; + + PROCEDURE TypeGuardFailure(stream: Streams.Stream; + found, expected: Services.Type); + VAR + event: TypeGuardFailureEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[typeGuardFailure]; + event.stream := stream; + event.errorcode := typeGuardFailure; + event.found := found; + event.expected := expected; + RelatedEvents.Raise(stream, event); + END TypeGuardFailure; + + PROCEDURE WriteEvent(s: Streams.Stream; event: Events.Event); + + VAR + typename: ARRAY 128 OF CHAR; + + PROCEDURE WriteString(s: Streams.Stream; + string: ARRAY OF CHAR) : BOOLEAN; + BEGIN + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) + END WriteString; + + PROCEDURE WriteLn(s: Streams.Stream) : BOOLEAN; + VAR + lineterm: StreamDisciplines.LineTerminator; + width: Types.Int32; + BEGIN + StreamDisciplines.GetLineTerm(s, lineterm); + IF ~WriteString(s, lineterm) THEN RETURN FALSE END; + StreamDisciplines.GetIndentationWidth(s, width); + WHILE width > 0 DO + IF ~Streams.WriteByte(s, " ") THEN RETURN FALSE END; + DEC(width); + END; + RETURN TRUE + END WriteLn; + + PROCEDURE WriteType(s: Streams.Stream; + type: Services.Type) : BOOLEAN; + VAR + name: TypeName; + BEGIN + Services.GetTypeName(type, name); + RETURN Streams.WriteByte(s, ASCII.quote) & + WriteString(s, name) & + Streams.WriteByte(s, ASCII.quote) + END WriteType; + + BEGIN + IF event IS UnknownTypeEvent THEN + WITH event: UnknownTypeEvent DO + IF WriteString(s, event.message) & + WriteString(s, ": ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, event.typeName) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSIF event IS TypeGuardFailureEvent THEN + WITH event: TypeGuardFailureEvent DO + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "expected extension of ") & + WriteType(s, event.expected) & + WriteString(s, " but got ") & + WriteType(s, event.found) THEN + END; + END; + ELSIF event IS DecodeFailureEvent THEN + WITH event: DecodeFailureEvent DO + Services.GetTypeName(event.objectType, typename); + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "unable to parse object of type ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, typename) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSE + IF WriteString(s, event.message) THEN END; + END; + END WriteEvent; + + PROCEDURE InitErrorHandling; + BEGIN + errormsg[cannotReadData] := "cannot read data part of persistent object"; + errormsg[cannotWriteData] := "cannot write data part of persistent object"; + errormsg[cannotReadType] := "cannot read type of persistent object"; + errormsg[cannotWriteType] := "cannot write type of persistent object"; + errormsg[invalidType] := "invalid type form read"; + errormsg[unknownType] := "unknown type information found"; + errormsg[otherTypeHier] := "different & nonconforming type hierarchy found"; + errormsg[eofReached] := "unexpected EOF encountered during reading"; + errormsg[cannotSkip] := "unable to skip unknown data parts"; + errormsg[typeGuardFailure] := "read object is of unexpected type"; + + Events.Define(error); + Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); + Errors.AssignWriteProcedure(error, WriteEvent); + END InitErrorHandling; + + (* ==== marshalling procedures ======================================== *) + + (* encoding scheme: + + Object = Form Type Size ObjectInfo . + Form = Types.Int8; + Type = Code (* codeF *) | + Code TypeName (* incrF *) | + TypeName (* nameF *) | + Code TypeName { Code TypeName } 0 (* incrhierF *) | + TypeName { TypeName } 0X (* hierF *) . + Size = (* noSizeF *) | + Size (* sizeF *) . (* size of object info in bytes *) + ObjectInfo = { Byte } . + *) + + PROCEDURE DecodeForm(form: Form; + VAR nameGiven, codeGiven, hier, size: BOOLEAN); + VAR + typeform: Types.Int8; + sizeform: Types.Int8; + BEGIN + typeform := form MOD maskF; sizeform := form DIV maskF; + nameGiven := typeform IN {incrF, nameF, hierF, incrhierF}; + codeGiven := typeform IN {codeF, incrF, incrhierF}; + hier := (typeform = incrhierF) OR (typeform = hierF); + size := (sizeform = sizeF); + END DecodeForm; + + PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); + (* get the name of the module where 'name' was defined *) + VAR + index: Types.Int32; + BEGIN + index := 0; + WHILE (name[index] # ".") & (name[index] # 0X) & + (index < LEN(module)-1) DO + module[index] := name[index]; INC(index); + END; + module[index] := 0X; + END GetModule; + + PROCEDURE Failure(s: Streams.Stream; code: ErrorCode); + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE + Error(s, code); + END; + END Failure; + + PROCEDURE DecodeFailure(s: Streams.Stream; type: Services.Type); + VAR + event: DecodeFailureEvent; + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE + NEW(event); + event.type := error; + event.message := errormsg[cannotReadData]; + event.stream := s; + event.errorcode := cannotReadData; + event.objectType := type; + RelatedEvents.Raise(s, event); + END; + END DecodeFailure; + + PROCEDURE GetStreamDisc(s: Streams.Stream; VAR disc: StreamDiscipline); + VAR d: IndirectDisciplines.Discipline; + BEGIN + IF IndirectDisciplines.Seek(s, id, d) THEN + disc := d(StreamDiscipline) + ELSE + NEW(disc); disc.id := id; disc.mode := defaultMode; + IndirectDisciplines.Add(s, disc); + END; + END GetStreamDisc; + + PROCEDURE ReadTypeInfo(s: Streams.Stream; VAR type: Type; + VAR projection: BOOLEAN; + VAR size: Streams.Count) : BOOLEAN; + VAR + form: Form; + btype: Type; + nameGiven, codeGiven, hier, sizeGiven: BOOLEAN; + disc: StreamDiscipline; + sentinelFound, unknownTypeFound: BOOLEAN; + lastType: Type; + + PROCEDURE ReadType(s: Streams.Stream; VAR type: Type; + VAR sentinelFound, unknownTypeFound: BOOLEAN) : BOOLEAN; + VAR + code: Types.Int32; + entry: TypeEntry; + typeName: TypeName; + btype: Type; + + PROCEDURE SeekType(typeName: ARRAY OF CHAR; + VAR type: Type) : BOOLEAN; + VAR + t: Services.Type; + module: TypeName; + BEGIN + Services.SeekType(typeName, t); + IF t = NIL THEN + GetModule(typeName, module); + IF Loader.Load(module, s) THEN + (* maybe the type is now registered *) + Services.SeekType(typeName, t); + END; + END; + IF (t # NIL) & (t IS Type) THEN + type := t(Type); RETURN TRUE + END; + RETURN FALSE + END SeekType; + + BEGIN (* ReadType *) + sentinelFound := FALSE; unknownTypeFound := FALSE; + type := NIL; + IF codeGiven THEN + IF ~NetIO.ReadLongInt(s, code) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF code = 0 THEN sentinelFound := TRUE; RETURN FALSE END; + entry := disc.rtypes[code MOD ttlen]; + WHILE (entry # NIL) & (entry.code # code) DO + entry := entry.next; + END; + IF entry # NIL THEN + type := entry.type; + END; + IF (entry = NIL) & ~nameGiven THEN + Failure(s, unknownType); unknownTypeFound := TRUE; RETURN FALSE + END; + END; + IF nameGiven THEN + IF ~NetIO.ReadString(s, typeName) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF typeName[0] = 0X THEN sentinelFound := TRUE; RETURN FALSE END; + IF (type = NIL) & ~SeekType(typeName, type) THEN + UnknownType(s, typeName); unknownTypeFound := TRUE; RETURN FALSE + END; + END; + IF codeGiven & (entry = NIL) THEN + NEW(entry); + entry.code := code; + entry.type := type; + entry.next := disc.rtypes[code MOD ttlen]; + disc.rtypes[code MOD ttlen] := entry; + END; + RETURN TRUE + END ReadType; + + BEGIN (* ReadTypeInfo *) + (* read & check form of type info *) + IF ~NetIO.ReadShortInt(s, form) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF (form <= 0) OR (form > maxF) THEN + Failure(s, invalidType); RETURN FALSE + END; + DecodeForm(form, nameGiven, codeGiven, hier, sizeGiven); + IF codeGiven THEN + GetStreamDisc(s, disc); + END; + + (* read first type information *) + IF ~ReadType(s, type, sentinelFound, unknownTypeFound) & ~hier THEN + RETURN FALSE + END; + + (* read type hierarchy, if any *) + projection := FALSE; + IF hier THEN + IF sentinelFound THEN + Failure(s, invalidType); RETURN FALSE + END; + lastType := type; + LOOP (* until type hierarchy is read *) + IF ReadType(s, btype, sentinelFound, unknownTypeFound) THEN + IF (lastType # NIL) & (lastType.baseType # btype) THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + IF type = NIL THEN + projection := TRUE; + type := btype; + END; + lastType := btype; + ELSIF sentinelFound THEN + EXIT + ELSIF unknownTypeFound THEN + IF lastType # NIL THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + ELSE + RETURN FALSE + END; + END; + IF type = NIL THEN + (* error events already generated by ReadType *) + RETURN FALSE + END; + END; + + (* read size information, if any *) + IF sizeGiven THEN + IF ~NetIO.ReadLongInt(s, size) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF size < 0 THEN + Failure(s, invalidType); RETURN FALSE + END; + ELSE + size := -1; + END; + RETURN TRUE + END ReadTypeInfo; + + PROCEDURE ReadData(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* use the interface list to read all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.read(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE + END; + ifList := ifList.next; + END; + RETURN (object.type.if.read = NIL) OR object.type.if.read(s, object) + END ReadData; + + PROCEDURE EncodeForm(s: Streams.Stream; type: Type; VAR form: Form); + VAR + mode: Mode; + disc: IndirectDisciplines.Discipline; + hier: BOOLEAN; + + PROCEDURE KnownType() : BOOLEAN; + VAR + p: TypeEntry; + BEGIN + p := disc(StreamDiscipline).wtypes[type.code MOD ttlen]; + WHILE (p # NIL) & (p.type # type) DO + p := p.next; + END; + RETURN p # NIL + END KnownType; + + BEGIN + IF ~IndirectDisciplines.Seek(s, id, disc) THEN + mode := defaultMode; disc := NIL; + ELSE + mode := disc(StreamDiscipline).mode; + END; + form := 0; + hier := mode DIV 8 MOD 2 > 0; + CASE mode MOD 4 OF + | fullTypeName: IF hier THEN form := hierF ELSE form := nameF END; + | typeCode: form := codeF; ASSERT(~hier); + | incrTypeCode: IF KnownType() THEN + form := codeF; + ELSIF hier THEN + form := incrhierF; + ELSE + form := incrF; + END; + ELSE + END; + IF mode DIV 4 MOD 2 > 0 THEN + INC(form, sizeF); + ELSE + INC(form, noSizeF); + END; + END EncodeForm; + + PROCEDURE WriteTypeInfo(s: Streams.Stream; type: Type; + VAR giveSize: BOOLEAN) : BOOLEAN; + (* write type information without size *) + VAR + form: Form; + giveName, giveCode, hier: BOOLEAN; + mode: Mode; incr: BOOLEAN; + disc: IndirectDisciplines.Discipline; + btype: Type; + + PROCEDURE WriteType(s: Streams.Stream; type: Type) : BOOLEAN; + VAR + typeName: TypeName; + entry: TypeEntry; + BEGIN + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, type.code) THEN + Error(s, cannotWriteType); RETURN FALSE + END; + END; + IF giveName THEN + Services.GetTypeName(type, typeName); + IF ~NetIO.WriteString(s, typeName) THEN + Error(s, cannotWriteType); RETURN FALSE + END; + END; + IF incr THEN + NEW(entry); entry.type := type; entry.code := type.code; + entry.next := disc(StreamDiscipline).wtypes[type.code MOD ttlen]; + disc(StreamDiscipline).wtypes[type.code MOD ttlen] := entry; + END; + RETURN TRUE + END WriteType; + + BEGIN (* WriteTypeInfo *) + EncodeForm(s, type, form); + IF ~NetIO.WriteShortInt(s, form) THEN + Error(s, cannotWriteType); + END; + DecodeForm(form, giveName, giveCode, hier, giveSize); + IF ~IndirectDisciplines.Seek(s, id, disc) THEN + mode := defaultMode; + END; + incr := giveName & giveCode; + + IF ~WriteType(s, type) THEN RETURN FALSE END; + + IF hier THEN + btype := type.baseType; + WHILE btype # NIL DO + IF ~WriteType(s, btype) THEN RETURN FALSE END; + btype := btype.baseType; + END; + (* write sentinel *) + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteType); + RETURN FALSE + END; + ELSE + IF ~NetIO.WriteString(s, "") THEN + Error(s, cannotWriteType); + RETURN FALSE + END; + END; + END; + + RETURN TRUE + END WriteTypeInfo; + + PROCEDURE WriteData(s: Streams.Stream; object: Object) : BOOLEAN; + (* use the interface list to write all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.write(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE + END; + ifList := ifList.next; + END; + RETURN (object.type.if.write = NIL) OR object.type.if.write(s, object) + END WriteData; + + (* ===== exported procedures ============================================ *) + + PROCEDURE RegisterType*(VAR type: Services.Type; + name, baseName: ARRAY OF CHAR; + if: Interface); + VAR + newtype: Type; + baseType: Services.Type; + member: InterfaceList; + bt: Type; + ifval: Types.Int32; + BEGIN + (* check the parameters *) + ASSERT(name[0] # 0X); + IF if # NIL THEN + ifval := 0; + IF if.create # NIL THEN INC(ifval, 1) END; + IF if.read # NIL THEN INC(ifval, 2) END; + IF if.write # NIL THEN INC(ifval, 4) END; + IF if.createAndRead # NIL THEN INC(ifval, 8) END; + (* legal variants: + + if = NIL abstract data type + + create read write createAndRead + #NIL NIL NIL NIL 1 empty data type + NIL #NIL #NIL NIL 6 abstract data type + #NIL #NIL #NIL NIL 7 normal case + NIL NIL #NIL #NIL 12 special case + + note that the special case must not be given as base type! + *) + ASSERT(ifval IN {1, 6, 7, 12}); + END; + + (* create type and determine next non-abstract base type *) + NEW(newtype); + newtype.code := nextTypeCode; INC(nextTypeCode); + newtype.if := if; + IF baseName = "" THEN + Services.InitType(newtype, name, "PersistentObjects.Object"); + ELSE + Services.InitType(newtype, name, baseName); + END; + IF baseName = "" THEN + newtype.baseType := NIL; + ELSE + Services.GetBaseType(newtype, baseType); + ASSERT((baseType # NIL) & (baseType IS Type)); + WHILE (baseType # NIL) & (baseType IS Type) & + (baseType(Type).if = NIL) DO + Services.GetBaseType(baseType, baseType); + END; + IF (baseType = NIL) OR ~(baseType IS Type) THEN + newtype.baseType := NIL; + ELSE + newtype.baseType := baseType(Type); + ASSERT(newtype.baseType.if.createAndRead = NIL); + END; + END; + + (* build up list of interfaces *) + newtype.ifs := NIL; bt := newtype.baseType; + WHILE bt # NIL DO + NEW(member); member.if := bt.if; + member.next := newtype.ifs; newtype.ifs := member; + bt := bt.baseType; + END; + + type := newtype; + END RegisterType; + + PROCEDURE Init*(object: Object; type: Services.Type); + BEGIN + ASSERT(type IS Type); + WITH type: Type DO + ASSERT((type.if.create # NIL) OR (type.if.createAndRead # NIL)); + object.type := type; + object.projected := FALSE; + Services.Init(object, type); + END; + END Init; + + PROCEDURE SetMode*(s: Streams.Stream; mode: Mode); + VAR + disc: StreamDiscipline; + d: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, d) THEN + disc := d(StreamDiscipline) + ELSE + NEW(disc); disc.id := id; + END; + disc.mode := mode; + Disciplines.Add(s, disc); + END SetMode; + + PROCEDURE GetMode*(s: Streams.Stream; VAR mode: Mode); + (* return the current mode for the given stream *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + mode := disc(StreamDiscipline).mode; + ELSE + mode := defaultMode; + END; + END GetMode; + + PROCEDURE IsProjected*(object: Object) : BOOLEAN; + (* show whether the object was a victim of projection or not *) + BEGIN + RETURN object.projected + END IsProjected; + + PROCEDURE InternalRead(s: Streams.Stream; create: BOOLEAN; + VAR object: Object) : BOOLEAN; + (* read `object' from `s'; + note that we have to operate on `object' directly because + LinearizedStructures relies on this in case of cyclic + references + *) + VAR + streamCaps: Streams.CapabilitySet; + type: Type; + objectType: Services.Type; + projection: BOOLEAN; (* necessary due to unknown types? *) + size: Streams.Count; (* size information, if unknown it equals -1 *) + skipUnknownParts: BOOLEAN; (* are we able to skip data if necessary? *) + + (* these vars are used for skipping unknown data areas *) + oldPos, newPos: Streams.Count; + textbuf: Texts.Text; + + BEGIN (* InternalRead *) + IF ~ReadTypeInfo(s, type, projection, size) THEN RETURN FALSE END; + IF ~create & (type.if.createAndRead = NIL) THEN + (* projection necessary due to target object? *) + Services.GetType(object, objectType); + IF ~Services.IsExtensionOf(type, objectType) THEN + TypeGuardFailure(s, type, objectType); RETURN FALSE + END; + projection := projection OR (type # objectType); + END; + skipUnknownParts := projection & (size > 0); + streamCaps := Streams.Capabilities(s); + IF skipUnknownParts THEN + IF Streams.tell IN streamCaps THEN + Streams.GetPos(s, oldPos); + ELSE + Texts.Open(SYS.VAL(Streams.Stream, textbuf)); + IF ~Streams.Copy(s, textbuf, size) THEN + Failure(s, cannotReadData); RETURN FALSE + END; + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + s := textbuf; + skipUnknownParts := FALSE; + END; + END; + + IF type.if.createAndRead # NIL THEN + IF ~type.if.createAndRead(s, create, object) THEN + DecodeFailure(s, type); object := NIL; RETURN FALSE + END; + ELSE + IF create THEN + type.if.create(object); + END; + IF ~ReadData(s, object) THEN + DecodeFailure(s, type); + object := NIL; + RETURN FALSE + END; + END; + + (* store information about projection into object *) + object.projected := projection; + + IF skipUnknownParts THEN + IF Streams.seek IN streamCaps THEN + Streams.SetPos(s, oldPos + size); + ELSE + Streams.GetPos(s, newPos); + IF ~Streams.Copy(s, Streams.null, size - newPos + oldPos) THEN + Failure(s, cannotSkip); RETURN FALSE + END; + END; + ELSIF projection & (size < 0) THEN + Error(s, cannotSkip); RETURN FALSE + END; + + s.count := 1; (* show success *) + RETURN TRUE + END InternalRead; + + PROCEDURE Read*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* read `object' from `s'; object # NIL on success *) + BEGIN + RETURN InternalRead(s, (* create = *) TRUE, object) + END Read; + + PROCEDURE ReadInto*(s: Streams.Stream; object: Object) : BOOLEAN; + (* read an object from `s' and assign it to `object'; + this fails if `object' doesn't has the IDENTICAL type + (thus projections are not supported here) + *) + BEGIN + RETURN InternalRead(s, (* create = *) FALSE, object) + END ReadInto; + + PROCEDURE GuardedRead*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* read an object from `s' and return it, provided + the type of the read object is an extension of `guard' + *) + VAR + testObject: Object; + type: Services.Type; + BEGIN + IF ~Read(s, testObject) THEN RETURN FALSE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedRead; + + PROCEDURE Write*(s: Streams.Stream; object: Object) : BOOLEAN; + (* write `obj' to `s' *) + VAR + giveSize: BOOLEAN; + streamCaps: Streams.CapabilitySet; + patchSize: BOOLEAN; + sizePos, beginPos, endPos: Streams.Count; + textbuf, origStream: Streams.Stream; + mode: Mode; + BEGIN + IF ~WriteTypeInfo(s, object.type, giveSize) THEN RETURN FALSE END; + IF giveSize THEN + streamCaps := Streams.Capabilities(s); + patchSize := ({Streams.tell, Streams.seek} - streamCaps = {}) & + Streams.Tell(s, sizePos); + IF patchSize THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + Streams.GetPos(s, beginPos); + ELSE + Texts.Open(textbuf); + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + GetMode(s, mode); SetMode(textbuf, mode); + origStream := s; s := textbuf; + END; + END; + + IF object.type.if.createAndRead # NIL THEN + IF ~object.type.if.write(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + ELSE + IF ~WriteData(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + END; + + IF giveSize THEN + IF patchSize THEN + Streams.GetPos(s, endPos); + Streams.SetPos(s, sizePos); + IF ~NetIO.WriteLongInt(s, endPos - beginPos) THEN + Streams.SetPos(s, endPos); + Error(s, cannotWriteData); + RETURN FALSE + END; + Streams.SetPos(s, endPos); + ELSE + Streams.GetPos(textbuf, endPos); + Streams.SetPos(textbuf, 0); + s := origStream; + IF ~NetIO.WriteLongInt(s, endPos) OR + ~Streams.Copy(textbuf, s, endPos) THEN + Error(s, cannotWriteData); + END; + END; + END; + s.count := 1; + RETURN TRUE + END Write; + + PROCEDURE ReadObjectOrNIL*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + object := NIL; + RETURN NetIO.ReadBoolean(s, nil) & (nil OR Read(s, object)) + END ReadObjectOrNIL; + + PROCEDURE GuardedReadObjectOrNIL*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* may be used instead of ReadObjectOrNIL *) + VAR + testObject: Object; + type: Services.Type; + nil: BOOLEAN; + BEGIN + IF ~NetIO.ReadBoolean(s, nil) THEN RETURN FALSE END; + IF nil THEN + object := NIL; + RETURN TRUE + END; + IF ~Read(s, testObject) THEN RETURN FALSE END; + IF testObject = NIL THEN RETURN TRUE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedReadObjectOrNIL; + + PROCEDURE WriteObjectOrNIL*(s: Streams.Stream; object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + nil := object = NIL; + RETURN NetIO.WriteBoolean(s, nil) & (nil OR Write(s, object)) + END WriteObjectOrNIL; + +BEGIN + id := Disciplines.Unique(); + nextTypeCode := 1; + InitErrorHandling; + Services.CreateType(potype, "PersistentObjects.Object", ""); +END ulmPersistentObjects. diff --git a/src/lib/ulm/ulmPlotters.Mod b/src/library/ulm/ulmPlotters.Mod similarity index 85% rename from src/lib/ulm/ulmPlotters.Mod rename to src/library/ulm/ulmPlotters.Mod index 59ee292d..58d1fda6 100644 --- a/src/lib/ulm/ulmPlotters.Mod +++ b/src/library/ulm/ulmPlotters.Mod @@ -28,7 +28,7 @@ MODULE ulmPlotters; - IMPORT Events := ulmEvents, Objects := ulmObjects, Resources := ulmResources, Services := ulmServices, SYS := ulmSYSTEM; + IMPORT Events := ulmEvents, Objects := ulmObjects, Resources := ulmResources, Services := ulmServices, SYS := ulmSYSTEM, Types := ulmTypes; TYPE Plotter* = POINTER TO PlotterRec; @@ -41,7 +41,7 @@ MODULE ulmPlotters; longdashed* = 4; lineModes* = 5; TYPE - LineMode* = SHORTINT; (* solid ... *) + LineMode* = Types.Int8; (* solid ... *) CONST setspace* = 0; @@ -50,34 +50,34 @@ MODULE ulmPlotters; linemodes* = 3; linewidth* = 4; TYPE - CapabilitySet* = SET; (* OF setspace, erase ... *) + CapabilitySet* = Types.Set; (* OF setspace, erase ... *) TYPE Description* = POINTER TO DescriptionRec; DescriptionRec* = RECORD (Objects.ObjectRec) - xmin*, ymin, xmax, ymax: INTEGER; (* maximal supported range *) + xmin*, ymin, xmax, ymax: Types.Int32; (* maximal supported range *) END; TYPE GetSpaceProc* = PROCEDURE ( plotter: Plotter; - VAR xmin, ymin, xmax, ymax: INTEGER); + VAR xmin, ymin, xmax, ymax: Types.Int32); SetSpaceProc* = PROCEDURE ( plotter: Plotter; - xmin, ymin, xmax, ymax: INTEGER); + xmin, ymin, xmax, ymax: Types.Int32); EraseProc* = PROCEDURE (plotter: Plotter); - MoveProc* = PROCEDURE (plotter: Plotter; xto, yto: INTEGER); - LineProc* = PROCEDURE (plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER); + MoveProc* = PROCEDURE (plotter: Plotter; xto, yto: Types.Int32); + LineProc* = PROCEDURE (plotter: Plotter; xfrom, yfrom, xto, yto: Types.Int32); ArcProc* = PROCEDURE ( plotter: Plotter; - xcenter, ycenter, xstart, ystart, xend, yend: INTEGER); + xcenter, ycenter, xstart, ystart, xend, yend: Types.Int32); CircleProc* = PROCEDURE ( - plotter: Plotter; xcenter, ycenter, radius: INTEGER); + plotter: Plotter; xcenter, ycenter, radius: Types.Int32); StringProc* = PROCEDURE (plotter: Plotter; str: ARRAY OF CHAR); SetLineModeProc* = PROCEDURE (plotter: Plotter; mode: LineMode); - SetLineWidthProc* = PROCEDURE (plotter: Plotter; width: INTEGER); + SetLineWidthProc* = PROCEDURE (plotter: Plotter; width: Types.Int32); CloseProc* = PROCEDURE (plotter: Plotter); TYPE Interface* = POINTER TO InterfaceRec; @@ -105,7 +105,7 @@ MODULE ulmPlotters; if: Interface; caps: CapabilitySet; desc: Description; - xmin, ymin, xmax, ymax: INTEGER; (* current range *) + xmin, ymin, xmax, ymax: Types.Int32; (* current range *) terminated: BOOLEAN; END; VAR @@ -162,7 +162,7 @@ MODULE ulmPlotters; PROCEDURE GetSpace*(plotter: Plotter; VAR xmin, ymin, - xmax, ymax: INTEGER); + xmax, ymax: Types.Int32); BEGIN xmin := plotter.xmin; xmax := plotter.xmax; @@ -172,7 +172,7 @@ MODULE ulmPlotters; PROCEDURE GetMaxSpace*(plotter: Plotter; VAR xmin, ymin, - xmax, ymax: INTEGER); + xmax, ymax: Types.Int32); BEGIN xmin := plotter.desc.xmin; xmax := plotter.desc.xmax; @@ -182,7 +182,7 @@ MODULE ulmPlotters; PROCEDURE SetSpace*(plotter: Plotter; xmin, ymin, - xmax, ymax: INTEGER); + xmax, ymax: Types.Int32); BEGIN ASSERT((xmin < xmax) & (ymin < ymax)); ASSERT((xmin >= plotter.desc.xmin) & @@ -203,33 +203,33 @@ MODULE ulmPlotters; plotter.if.erase(plotter); END Erase; - PROCEDURE Move*(plotter: Plotter; xto, yto: INTEGER); + PROCEDURE Move*(plotter: Plotter; xto, yto: Types.Int32); BEGIN plotter.if.move(plotter, xto, yto); END Move; - PROCEDURE Cont*(plotter: Plotter; xto, yto: INTEGER); + PROCEDURE Cont*(plotter: Plotter; xto, yto: Types.Int32); BEGIN plotter.if.cont(plotter, xto, yto); END Cont; - PROCEDURE Point*(plotter: Plotter; xpoint, ypoint: INTEGER); + PROCEDURE Point*(plotter: Plotter; xpoint, ypoint: Types.Int32); BEGIN plotter.if.point(plotter, xpoint, ypoint); END Point; - PROCEDURE Line*(plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER); + PROCEDURE Line*(plotter: Plotter; xfrom, yfrom, xto, yto: Types.Int32); BEGIN plotter.if.line(plotter, xfrom, yfrom, xto, yto); END Line; PROCEDURE Arc*(plotter: Plotter; - xcenter, ycenter, xstart, ystart, xend, yend: INTEGER); + xcenter, ycenter, xstart, ystart, xend, yend: Types.Int32); BEGIN plotter.if.arc(plotter, xcenter, ycenter, xstart, ystart, xend, yend); END Arc; - PROCEDURE Circle*(plotter: Plotter; xcenter, ycenter, radius: INTEGER); + PROCEDURE Circle*(plotter: Plotter; xcenter, ycenter, radius: Types.Int32); BEGIN plotter.if.circle(plotter, xcenter, ycenter, radius); END Circle; @@ -246,7 +246,7 @@ MODULE ulmPlotters; plotter.if.setLineMode(plotter, mode); END SetLineMode; - PROCEDURE SetLineWidth*(plotter: Plotter; width: INTEGER); + PROCEDURE SetLineWidth*(plotter: Plotter; width: Types.Int32); BEGIN ASSERT((linewidth IN plotter.caps) & (width > 0)); plotter.if.setLineWidth(plotter, width); diff --git a/src/lib/ulm/ulmPrint.Mod b/src/library/ulm/ulmPrint.Mod similarity index 85% rename from src/lib/ulm/ulmPrint.Mod rename to src/library/ulm/ulmPrint.Mod index 35f46457..a2fb35e0 100644 --- a/src/lib/ulm/ulmPrint.Mod +++ b/src/library/ulm/ulmPrint.Mod @@ -44,7 +44,7 @@ MODULE ulmPrint; *) IMPORT Events := ulmEvents, IEEE := ulmIEEE, Priorities := ulmPriorities, Reals := ulmReals, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines, - Streams := ulmStreams, SYS := SYSTEM; + Streams := ulmStreams, SYS := SYSTEM, Types := ulmTypes; CONST tooManyArgs* = 0; (* too many arguments given *) @@ -54,15 +54,15 @@ MODULE ulmPrint; errors* = 4; TYPE FormatString* = ARRAY 128 OF CHAR; - ErrorCode* = SHORTINT; + ErrorCode* = Types.Int8; ErrorEvent* = POINTER TO ErrorEventRec; ErrorEventRec* = RECORD (Events.EventRec) errorcode*: ErrorCode; format*: FormatString; - errpos*: LONGINT; - nargs*: INTEGER; + errpos*: Types.Int32; + nargs*: Types.Int32; END; VAR error*: Events.EventType; @@ -80,20 +80,20 @@ MODULE ulmPrint; "size of argument doesn't conform to the corresponding format element"; END InitErrorHandling; - PROCEDURE Out(out: Streams.Stream; VAR fmt: ARRAY OF CHAR; nargs: INTEGER; + PROCEDURE Out(out: Streams.Stream; VAR fmt: ARRAY OF CHAR; nargs: Types.Int32; VAR p1,p2,p3,p4,p5,p6,p7,p8,p9: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); CONST maxargs = 9; (* maximal number of arguments *) - maxargsize = SIZE(LONGREAL); (* maximal arg size (except strings) *) + maxargsize = SIZE(Types.Real64); (* maximal arg size (except strings) *) fmtcmd = "%"; escape = "\"; VAR - arglen: ARRAY maxargs OF LONGINT; - nextarg: INTEGER; - fmtindex: LONGINT; + arglen: ARRAY maxargs OF Types.Int32; + nextarg: Types.Int32; + fmtindex: Types.Int32; fmtchar: CHAR; - hexcharval: LONGINT; + hexcharval: Types.Int32; PROCEDURE Error(errorcode: ErrorCode); VAR @@ -143,7 +143,7 @@ MODULE ulmPrint; PROCEDURE WriteLn; VAR lineterm: StreamDisciplines.LineTerminator; - i: INTEGER; + i: Types.Int32; BEGIN StreamDisciplines.GetLineTerm(out, lineterm); Write(lineterm[0]); @@ -153,7 +153,7 @@ MODULE ulmPrint; END; END WriteLn; - PROCEDURE Int(VAR int: LONGINT; base: INTEGER) : BOOLEAN; + PROCEDURE Int(VAR int: Types.Int32; base: Types.Int32) : BOOLEAN; PROCEDURE ValidDigit(ch: CHAR) : BOOLEAN; BEGIN @@ -166,10 +166,10 @@ MODULE ulmPrint; REPEAT int := int * base; IF (fmtchar >= "0") & (fmtchar <= "9") THEN - INC(int, LONG(ORD(fmtchar) - ORD("0"))); + INC(int, ORD(fmtchar) - ORD("0")); ELSIF (base = 16) & (CAP(fmtchar) >= "A") & (CAP(fmtchar) <= "F") THEN - INC(int, LONG(10 + ORD(CAP(fmtchar)) - ORD("A"))); + INC(int, 10 + ORD(CAP(fmtchar)) - ORD("A")); ELSE RETURN FALSE END; @@ -179,7 +179,7 @@ MODULE ulmPrint; PROCEDURE SetSize; VAR - index: INTEGER; + index: Types.Int32; BEGIN index := 0; WHILE index < nargs DO @@ -193,12 +193,13 @@ MODULE ulmPrint; | 6: arglen[index] := LEN(p7); | 7: arglen[index] := LEN(p8); | 8: arglen[index] := LEN(p9); + ELSE END; INC(index); END; END SetSize; - PROCEDURE Access(par: INTEGER; at: LONGINT) : SYS.BYTE; + PROCEDURE Access(par: Types.Int32; at: Types.Int32) : SYS.BYTE; BEGIN CASE par OF | 0: RETURN p1[at] @@ -210,11 +211,12 @@ MODULE ulmPrint; | 6: RETURN p7[at] | 7: RETURN p8[at] | 8: RETURN p9[at] + ELSE END; END Access; - PROCEDURE Convert(from: INTEGER; VAR to: ARRAY OF SYS.BYTE); - VAR i: INTEGER; + PROCEDURE Convert(from: Types.Int32; VAR to: ARRAY OF SYS.BYTE); + VAR i: Types.Int32; BEGIN i := 0; WHILE i < arglen[from] DO @@ -222,23 +224,23 @@ MODULE ulmPrint; END; END Convert; - PROCEDURE GetInt(index: INTEGER; VAR long: LONGINT) : BOOLEAN; + PROCEDURE GetInt(index: Types.Int32; VAR long: Types.Int32) : BOOLEAN; (* access index-th parameter (counted from 0); - fails if arglen[index] > SIZE(LONGINT) + fails if arglen[index] > SYS.SIZE(Types.Int32) *) VAR - short: SHORTINT; - (*int16: SYS.INT16;*) - int: INTEGER; + short: Types.Int8; + int16: SYS.INT16; + int: Types.Int32; BEGIN - IF arglen[index] = SIZE(SHORTINT) THEN + IF arglen[index] = SIZE(Types.Int8) THEN Convert(index, short); long := short; - (*ELSIF arglen[index] = SIZE(SYS.INT16) THEN - Convert(index, int16); long := int16;*) - ELSIF arglen[index] = SIZE(INTEGER) THEN + ELSIF arglen[index] = SIZE(SYS.INT16) THEN + Convert(index, int16); long := int16; + ELSIF arglen[index] = SIZE(Types.Int32) THEN Convert(index, int); long := int; - ELSIF arglen[index] = SIZE(LONGINT) THEN + ELSIF arglen[index] = SIZE(Types.Int32) THEN Convert(index, long); ELSE Error(badArgumentSize); @@ -254,9 +256,9 @@ MODULE ulmPrint; insert: BOOLEAN; (* insert between sign and 1st digit *) sign: BOOLEAN; (* sign even positive values *) leftaligned: BOOLEAN; (* output left aligned *) - width, scale: LONGINT; + width, scale: Types.Int32; - PROCEDURE NextArg(VAR index: INTEGER) : BOOLEAN; + PROCEDURE NextArg(VAR index: Types.Int32) : BOOLEAN; BEGIN IF nextarg < nargs THEN index := nextarg; INC(nextarg); RETURN TRUE @@ -284,9 +286,9 @@ MODULE ulmPrint; RETURN FALSE (* unexpected end *) END Flags; - PROCEDURE FetchInt(VAR int: LONGINT) : BOOLEAN; + PROCEDURE FetchInt(VAR int: Types.Int32) : BOOLEAN; VAR - index: INTEGER; + index: Types.Int32; BEGIN RETURN (fmtchar = "*") & Next() & NextArg(index) & GetInt(index, int) OR @@ -321,9 +323,9 @@ MODULE ulmPrint; PROCEDURE Conversion() : BOOLEAN; - PROCEDURE Fill(cnt: LONGINT); + PROCEDURE Fill(cnt: Types.Int32); (* cnt: space used by normal output *) - VAR i: LONGINT; + VAR i: Types.Int32; BEGIN IF cnt < width THEN i := width - cnt; @@ -334,14 +336,14 @@ MODULE ulmPrint; END; END Fill; - PROCEDURE FillLeft(cnt: LONGINT); + PROCEDURE FillLeft(cnt: Types.Int32); BEGIN IF ~leftaligned THEN Fill(cnt); END; END FillLeft; - PROCEDURE FillRight(cnt: LONGINT); + PROCEDURE FillRight(cnt: Types.Int32); BEGIN IF leftaligned THEN Fill(cnt); @@ -349,10 +351,10 @@ MODULE ulmPrint; END FillRight; PROCEDURE WriteBool(true, false: ARRAY OF CHAR) : BOOLEAN; - VAR index: INTEGER; val: LONGINT; + VAR index: Types.Int32; val: Types.Int32; PROCEDURE WriteString(VAR s: ARRAY OF CHAR); - VAR i, len: INTEGER; + VAR i, len: Types.Int32; BEGIN len := 0; WHILE (len < LEN(s)) & (s[len] # 0X) DO @@ -379,8 +381,8 @@ MODULE ulmPrint; PROCEDURE WriteChar() : BOOLEAN; VAR - val: LONGINT; - index: INTEGER; + val: Types.Int32; + index: Types.Int32; BEGIN IF NextArg(index) & GetInt(index, val) & (val >= 0) & (val <= ORD(MAX(CHAR))) THEN @@ -392,21 +394,21 @@ MODULE ulmPrint; RETURN FALSE END WriteChar; - PROCEDURE WriteInt(base: INTEGER) : BOOLEAN; + PROCEDURE WriteInt(base: Types.Int32) : BOOLEAN; VAR - index: INTEGER; - val: LONGINT; + index: Types.Int32; + val: Types.Int32; neg: BOOLEAN; (* set by Convert *) buf: ARRAY 12 OF CHAR; (* filled by Convert *) - i: INTEGER; - len: INTEGER; (* space needed for val *) - signcnt: INTEGER; (* =1 if sign printed; else 0 *) + i: Types.Int32; + len: Types.Int32; (* space needed for val *) + signcnt: Types.Int32; (* =1 if sign printed; else 0 *) signch: CHAR; PROCEDURE Convert; VAR - index: INTEGER; - digit: LONGINT; + index: Types.Int32; + digit: Types.Int32; BEGIN neg := val < 0; index := 0; @@ -462,36 +464,36 @@ MODULE ulmPrint; CONST defaultscale = 6; VAR - index: INTEGER; - lr: LONGREAL; - r: REAL; - shortint: SHORTINT; int: INTEGER; longint: LONGINT; - (*int16: SYS.INT16;*) + index: Types.Int32; + lr: Types.Real64; + r: Types.Real32; + shortint: Types.Int8; int: Types.Int32; longint: Types.Int32; + int16: SYS.INT16; long: BOOLEAN; - exponent: INTEGER; - mantissa: LONGREAL; + exponent: Types.Int32; + mantissa: Types.Real64; digits: ARRAY Reals.maxlongdignum OF CHAR; neg: BOOLEAN; - ndigits: INTEGER; - decpt: INTEGER; + ndigits: Types.Int32; + decpt: Types.Int32; - PROCEDURE Print(decpt: INTEGER; withexp: BOOLEAN; exp: INTEGER); + PROCEDURE Print(decpt: Types.Int32; withexp: BOOLEAN; exp: Types.Int32); (* decpt: position of decimal point = 0: just before the digits > 0: after decpt digits < 0: ABS(decpt) zeroes before digits needed *) VAR - needed: INTEGER; (* space needed *) - index: INTEGER; - count: LONGINT; + needed: Types.Int32; (* space needed *) + index: Types.Int32; + count: Types.Int32; - PROCEDURE WriteExp(exp: INTEGER); + PROCEDURE WriteExp(exp: Types.Int32); CONST base = 10; VAR - power: INTEGER; - digit: INTEGER; + power: Types.Int32; + digit: Types.Int32; BEGIN IF long THEN Write("D"); @@ -536,7 +538,7 @@ MODULE ulmPrint; INC(needed, 3); END; END; - INC(needed, SHORT(scale)); + INC(needed, scale); FillLeft(needed); IF neg THEN @@ -581,26 +583,26 @@ MODULE ulmPrint; BEGIN (* WriteReal *) IF NextArg(index) THEN - IF arglen[index] = SIZE(LONGREAL) THEN + IF arglen[index] = SIZE(Types.Real64) THEN long := TRUE; Convert(index, lr); - ELSIF arglen[index] = SIZE(REAL) THEN + ELSIF arglen[index] = SIZE(Types.Real32) THEN long := FALSE; Convert(index, r); lr := r; - ELSIF arglen[index] = SIZE(LONGINT) THEN + ELSIF arglen[index] = SIZE(Types.Int32) THEN long := FALSE; Convert(index, longint); lr := longint; - ELSIF arglen[index] = SIZE(INTEGER) THEN + ELSIF arglen[index] = SIZE(Types.Int32) THEN long := FALSE; Convert(index, int); lr := int; - (*ELSIF arglen[index] = SIZE(SYS.INT16) THEN + ELSIF arglen[index] = SIZE(SYS.INT16) THEN long := FALSE; Convert(index, int16); - lr := int16;*) - ELSIF arglen[index] = SIZE(SHORTINT) THEN + lr := int16; + ELSIF arglen[index] = SIZE(Types.Int8) THEN long := FALSE; Convert(index, shortint); lr := shortint; @@ -634,6 +636,7 @@ MODULE ulmPrint; ndigits := 1; END; | "g": ndigits := SHORT(scale); + ELSE END; Reals.Digits(mantissa, 10, digits, neg, (* force = *) format # "g", ndigits); @@ -648,12 +651,13 @@ MODULE ulmPrint; ELSE INC(decpt, exponent); scale := ndigits-1; - DEC(scale, LONG(exponent)); + DEC(scale, exponent); IF scale < 0 THEN scale := 0; END; Print(decpt, (* withexp = *) FALSE, 0); END; + ELSE END; RETURN TRUE ELSE @@ -663,16 +667,16 @@ MODULE ulmPrint; PROCEDURE WriteString() : BOOLEAN; VAR - index: INTEGER; - i: LONGINT; + index: Types.Int32; + i: Types.Int32; byte: SYS.BYTE; - len: LONGINT; + len: Types.Int32; BEGIN IF NextArg(index) THEN len := 0; WHILE (len < arglen[index]) & ((scale = -1) OR (len < scale)) & - ((*CHR*)SYS.VAL(CHAR, (Access(index, len))) # 0X) DO + ((*CHR*)SYS.VAL(CHAR, Access(index, len)) # 0X) DO INC(len); END; FillLeft(len); @@ -756,56 +760,56 @@ MODULE ulmPrint; (* === public part ============================================== *) PROCEDURE F*(fmt: ARRAY OF CHAR); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 0, x,x,x,x,x,x,x,x,x, NIL); END F; PROCEDURE F1*(fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL); END F1; PROCEDURE F2*(fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL); END F2; PROCEDURE F3*(fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL); END F3; PROCEDURE F4*(fmt: ARRAY OF CHAR; p1, p2, p3, p4: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL); END F4; PROCEDURE F5*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL); END F5; PROCEDURE F6*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL); END F6; PROCEDURE F7*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL); END F7; PROCEDURE F8*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(Streams.stdout, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL); END F8; @@ -818,60 +822,60 @@ MODULE ulmPrint; PROCEDURE S*(out: Streams.Stream; fmt: ARRAY OF CHAR); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL); END S; PROCEDURE S1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL); END S1; PROCEDURE S2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL); END S2; PROCEDURE S3*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL); END S3; PROCEDURE S4*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL); END S4; PROCEDURE S5*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL); END S5; PROCEDURE S6*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL); END S6; PROCEDURE S7*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL); END S7; PROCEDURE S8*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL); END S8; @@ -885,21 +889,21 @@ MODULE ulmPrint; PROCEDURE SE*(out: Streams.Stream; fmt: ARRAY OF CHAR; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL); END SE; PROCEDURE SE1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, errors); END SE1; PROCEDURE SE2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, errors); END SE2; @@ -907,7 +911,7 @@ MODULE ulmPrint; PROCEDURE SE3*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, errors); END SE3; @@ -915,7 +919,7 @@ MODULE ulmPrint; PROCEDURE SE4*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, errors); END SE4; @@ -923,7 +927,7 @@ MODULE ulmPrint; PROCEDURE SE5*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, errors); END SE5; @@ -931,7 +935,7 @@ MODULE ulmPrint; PROCEDURE SE6*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, errors); END SE6; @@ -939,7 +943,7 @@ MODULE ulmPrint; PROCEDURE SE7*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, errors); END SE7; @@ -947,7 +951,7 @@ MODULE ulmPrint; PROCEDURE SE8*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); - VAR x: INTEGER; + VAR x: Types.Int32; BEGIN Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, errors); END SE8; diff --git a/src/lib/ulm/ulmPriorities.Mod b/src/library/ulm/ulmPriorities.Mod similarity index 98% rename from src/lib/ulm/ulmPriorities.Mod rename to src/library/ulm/ulmPriorities.Mod index e171907a..a308df8f 100644 --- a/src/lib/ulm/ulmPriorities.Mod +++ b/src/library/ulm/ulmPriorities.Mod @@ -49,7 +49,7 @@ MODULE ulmPriorities; - gap defines the minimum distance between two priority regions defined in this module *) - + IMPORT Types := ulmTypes; CONST region* = 10; gap* = 10; @@ -59,7 +59,7 @@ MODULE ulmPriorities; *) TYPE - Priority* = INTEGER; + Priority* = Types.Int32; VAR (* current priority at begin of execution (after init of Events); diff --git a/src/lib/ulm/ulmProcess.Mod b/src/library/ulm/ulmProcess.Mod similarity index 97% rename from src/lib/ulm/ulmProcess.Mod rename to src/library/ulm/ulmProcess.Mod index 20bb5186..ce4ce70f 100644 --- a/src/lib/ulm/ulmProcess.Mod +++ b/src/library/ulm/ulmProcess.Mod @@ -36,7 +36,7 @@ MODULE ulmProcess; - IMPORT Events := ulmEvents, Priorities := ulmPriorities; + IMPORT Events := ulmEvents, Priorities := ulmPriorities, Types := ulmTypes; (* user readable name of our process *) TYPE @@ -48,7 +48,7 @@ MODULE ulmProcess; (* exit codes *) TYPE - ExitCode* = INTEGER; + ExitCode* = Types.Int32; VAR indicateSuccess*: ExitCode; indicateFailure*: ExitCode; @@ -83,7 +83,7 @@ MODULE ulmProcess; (* private declarations *) VAR handlers: Interface; - nestlevel: INTEGER; + nestlevel: Types.Int32; PROCEDURE SetHandlers*(if: Interface); BEGIN diff --git a/src/library/ulm/ulmRandomGenerators.Mod b/src/library/ulm/ulmRandomGenerators.Mod new file mode 100644 index 00000000..baa0219e --- /dev/null +++ b/src/library/ulm/ulmRandomGenerators.Mod @@ -0,0 +1,421 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: RandomGener.om,v $ + Revision 1.9 2004/03/09 21:44:12 borchert + unpredictable added to the standard set of PRNGs + + Revision 1.8 2004/03/06 07:22:09 borchert + Init asserts that the sequence has been registered at Services + + Revision 1.7 1998/02/14 22:04:09 martin + Missing calls of Services.Init and Services.CreateType added. + + Revision 1.6 1997/10/11 21:22:03 martin + assertion in ValS added, obsolete variable removed + + Revision 1.5 1997/10/10 16:26:49 martin + RestartSequence added, range conversions improved, + default implementation replaced. + + Revision 1.4 1997/04/01 16:33:41 borchert + major revision of Random: + - module renamed to RandomGenerators + - abstraction instead of simple implementation (work by Frank Fischer) + + Revision 1.3 1994/09/01 18:15:41 borchert + bug fix: avoid arithmetic overflow in ValS + + Revision 1.2 1994/08/30 09:48:00 borchert + sequences added + + Revision 1.1 1994/02/23 07:25:30 borchert + Initial revision + + ---------------------------------------------------------------------------- + original implementation by AFB 2/90 + conversion to abstraction by Frank B.J. Fischer 3/97 + ---------------------------------------------------------------------------- +*) + +MODULE ulmRandomGenerators; + + (* Anyone who considers arithmetical + methods of producing random digits + is, of course, in a state of sin. + - John von Neumann (1951) + *) + + IMPORT + Clocks := ulmClocks, Disciplines := ulmDisciplines, + Objects := ulmObjects, Operations := ulmOperations, + Process := ulmProcess, Services := ulmServices, + Times := ulmTimes, Types := ulmTypes; + + TYPE + Sequence* = POINTER TO SequenceRec; + + Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32; + LongRealValSProc* = PROCEDURE (sequence: Sequence): Types.Real64; + RewindSequenceProc* = PROCEDURE (sequence: Sequence); + RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence); + SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand); + + CONST + int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3; + + TYPE + CapabilitySet* = Types.Set; (* of [int32ValS..restartSequence] *) + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + int32ValS* : Int32ValSProc; (* at least one of ... *) + longRealValS* : LongRealValSProc; (* ... these required *) + rewindSequence* : RewindSequenceProc; (* optional *) + restartSequence*: RestartSequenceProc; (* optional *) + END; + + SequenceRec* = + RECORD + (Services.ObjectRec) + (* private components *) + if : Interface; + caps: CapabilitySet; + END; + + VAR + std* : Sequence; (* default sequence *) + seed*: Sequence; (* sequence of seed values *) + unpredictable*: Sequence; + (* reasonably fast sequence of unpredictable values; + is initially NIL + *) + + (* ----- private definitions ----- *) + + CONST + modulus1 = 2147483647; (* a Mersenne prime *) + factor1 = 48271; (* passes spectral test *) + quotient1 = modulus1 DIV factor1; (* 44488 *) + remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *) + modulus2 = 2147483399; (* a non-Mersenne prime *) + factor2 = 40692; (* also passes spectral test *) + quotient2 = modulus2 DIV factor2; (* 52774 *) + remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *) + + TYPE + DefaultSequence = POINTER TO DefaultSequenceRec; + DefaultSequenceRec = + RECORD + (SequenceRec) + seed1, seed2: Types.Int32; + value1, value2: Types.Int32; + END; + + ServiceDiscipline = POINTER TO ServiceDisciplineRec; + ServiceDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + setValS: SetValSProc; + END; + + VAR + service : Services.Service; + serviceDiscID: Disciplines.Identifier; + sequenceType, + defaultSequenceType: Services.Type; + + (* ----- bug workaround ----- *) + + PROCEDURE Entier(value: Types.Real64): Types.Int32; + VAR + result: Types.Int32; + BEGIN + result := ENTIER(value); + IF result > value THEN + DEC(result); + END; + RETURN result + END Entier; + + (* ----- exported procedures ----- *) + + PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet); + (* initialize sequence *) + VAR + type: Services.Type; + BEGIN + ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL)); + ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL)); + ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL)); + ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL)); + Services.GetType(sequence, type); ASSERT(type # NIL); + sequence.if := if; + sequence.caps := caps; + END Init; + + PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet; + (* tell which procedures are implemented *) + BEGIN + RETURN sequence.caps + END Capabilities; + + PROCEDURE RewindSequence*(sequence: Sequence); + (* re-examine sequence *) + BEGIN + ASSERT(rewindSequence IN sequence.caps); + sequence.if.rewindSequence(sequence); + END RewindSequence; + + PROCEDURE RestartSequence*(sequence, seed: Sequence); + (* restart sequence with new seed values *) + BEGIN + ASSERT(restartSequence IN sequence.caps); + sequence.if.restartSequence(sequence, seed); + END RestartSequence; + + PROCEDURE ^ LongRealValS*(sequence: Sequence): Types.Real64; + + PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32; + (* get random 32-bit value from sequence *) + VAR + real: Types.Real64; + BEGIN + IF int32ValS IN sequence.caps THEN + RETURN sequence.if.int32ValS(sequence) + ELSE + real := LongRealValS(sequence); + RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) )) + END; + END Int32ValS; + + PROCEDURE Int32Val*(): Types.Int32; + (* get random 32-bit value from std sequence *) + BEGIN + RETURN Int32ValS(std); + END Int32Val; + + PROCEDURE LongRealValS*(sequence: Sequence): Types.Real64; + (* get a uniformly distributed longreal value in [0..1) *) + BEGIN + IF longRealValS IN sequence.caps THEN + RETURN sequence.if.longRealValS(sequence) + ELSE + RETURN 0.5 + + Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32)) + END; + END LongRealValS; + + PROCEDURE LongRealVal*(): Types.Real64; + (* get a uniformly distributed longreal value in [0..1) *) + BEGIN + RETURN LongRealValS(std) + END LongRealVal; + + PROCEDURE RealValS*(sequence: Sequence): Types.Real32; + (* get a uniformly distributed real value in [0..1) *) + BEGIN + RETURN SHORT(LongRealValS(sequence)) + END RealValS; + + PROCEDURE RealVal*(): Types.Real32; + (* get a uniformly distributed real value in [0..1) *) + BEGIN + RETURN SHORT(LongRealValS(std)) + END RealVal; + + PROCEDURE ValS*(sequence: Sequence; low, high: Types.Int32): Types.Int32; + (* get a uniformly distributed integer in [low..high] *) + BEGIN + ASSERT(low <= high); + RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) ) + END ValS; + + PROCEDURE Val*(low, high: Types.Int32): Types.Int32; + (* get a uniformly distributed integer in [low..high] *) + BEGIN + RETURN ValS(std, low, high) + END Val; + + PROCEDURE FlipS*(sequence: Sequence): BOOLEAN; + (* return TRUE or FALSE *) + BEGIN + IF int32ValS IN sequence.caps THEN + RETURN sequence.if.int32ValS(sequence) >= 0 + ELSE + RETURN sequence.if.longRealValS(sequence) >= 0.5 + END; + END FlipS; + + PROCEDURE Flip*(): BOOLEAN; + (* return TRUE or FALSE *) + BEGIN + RETURN FlipS(std) + END Flip; + + PROCEDURE Support*(type: Services.Type; setValS: SetValSProc); + (* support service for type *) + VAR + serviceDisc: ServiceDiscipline; + BEGIN + NEW(serviceDisc); + serviceDisc.id := serviceDiscID; + serviceDisc.setValS := setValS; + Disciplines.Add(type, serviceDisc); + Services.Define(type, service, NIL); + END Support; + + PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand); + (* store random value from sequence into already initialized value *) + VAR + baseType : Services.Type; + serviceDisc: Disciplines.Discipline; (* ServiceDiscipline *) + ok : BOOLEAN; + BEGIN + Services.GetSupportedBaseType(value, service, baseType); + ok := Disciplines.Seek(baseType, serviceDiscID, serviceDisc); + ASSERT(ok); + serviceDisc(ServiceDiscipline).setValS(sequence, value); + END SetValS; + + PROCEDURE SetVal*(value: Operations.Operand); + (* store random value from std sequence into already initialized value *) + BEGIN + SetValS(std, value); + END SetVal; + + (* ----- DefaultSequence ----- *) + + PROCEDURE CongruentialStep(VAR value1, value2: Types.Int32); + BEGIN + value1 := + factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1); + IF value1 < 0 THEN + INC(value1, modulus1); + END; + value2 := + factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2); + IF value2 < 0 THEN + INC(value2, modulus2); + END; + END CongruentialStep; + + PROCEDURE DefaultSequenceValue(sequence: Sequence): Types.Real64; + VAR + value: Types.Int32; + BEGIN + WITH sequence: DefaultSequence DO + CongruentialStep(sequence.value1, sequence.value2); + value := sequence.value1 - sequence.value2; + IF value <= 0 THEN + INC(value, modulus1); + END; + RETURN (value - 1.) / (modulus1 - 1.) + END; + END DefaultSequenceValue; + + PROCEDURE DefaultSequenceRewind(sequence: Sequence); + BEGIN + WITH sequence: DefaultSequence DO + sequence.value1 := sequence.seed1; + sequence.value2 := sequence.seed2; + END; + END DefaultSequenceRewind; + + PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence); + BEGIN + WITH sequence: DefaultSequence DO + sequence.seed1 := ValS(seed, 1, modulus1-1); + sequence.seed2 := ValS(seed, 1, modulus2-1); + sequence.value1 := sequence.seed1; + sequence.value2 := sequence.seed2; + END; + END DefaultSequenceRestart; + + PROCEDURE CreateDefaultSequences; + VAR + mySeed, myStd: DefaultSequence; + if: Interface; + daytime: Times.Time; + timeval: Times.TimeValueRec; + count: Types.Int32; + + PROCEDURE Hash(str: ARRAY OF CHAR): Types.Int32; + VAR + index, + val: Types.Int32; + BEGIN + val := 27567352; + index := 0; + WHILE str[index] # 0X DO + val := (val MOD 16777216) * 128 + + (val DIV 16777216 + ORD(str[index])) MOD 128; + INC(index); + END; (*WHILE*) + RETURN val + END Hash; + + BEGIN + (* define interface for all default sequences *) + NEW(if); + if.longRealValS := DefaultSequenceValue; + if.rewindSequence := DefaultSequenceRewind; + if.restartSequence := DefaultSequenceRestart; + + (* fake initial randomness using some portably accessible sources *) + NEW(mySeed); + Services.Init(mySeed, defaultSequenceType); + Init(mySeed, if, {longRealValS}); + Clocks.GetTime(Clocks.system, daytime); + Times.GetValue(daytime, timeval); + (* extract those 31 bits from daytime that are most likely to vary *) + mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1; + (* generate 31 more bits from the process name *) + mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1; + (* scramble these values *) + count := 0; + WHILE count < 4 DO + CongruentialStep(mySeed.value1, mySeed.value2); + INC(count); + END; + (* mix them together *) + DefaultSequenceRestart(mySeed, mySeed); + seed := mySeed; + + (* now use our seed to initialize std sequence *) + NEW(myStd); + Services.Init(myStd, defaultSequenceType); + Init(myStd, if, {longRealValS, rewindSequence, restartSequence}); + DefaultSequenceRestart(myStd, mySeed); + std := myStd; + + unpredictable := NIL; + END CreateDefaultSequences; + +BEGIN + serviceDiscID := Disciplines.Unique(); + Services.Create(service, "RandomGenerators"); + Services.CreateType(sequenceType, "RandomGenerators.Sequence", ""); + Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence", + "RandomGenerators.Sequence"); + CreateDefaultSequences; +END ulmRandomGenerators. diff --git a/src/lib/ulm/ulmReals.Mod b/src/library/ulm/ulmReals.Mod similarity index 87% rename from src/lib/ulm/ulmReals.Mod rename to src/library/ulm/ulmReals.Mod index f941c05a..a646512d 100644 --- a/src/lib/ulm/ulmReals.Mod +++ b/src/library/ulm/ulmReals.Mod @@ -33,14 +33,14 @@ MODULE ulmReals; - IMPORT IEEE := ulmIEEE, MC68881 := ulmMC68881; + IMPORT IEEE := ulmIEEE, MC68881 := ulmMC68881, Types := ulmTypes; CONST - (* for REAL *) + (* for Types.Real32 *) maxexp* = 309; minexp* = -323; maxdignum* = 16; - (* for LONGREAL *) + (* for Types.Real64 *) (* maxlongexp = 4932; minlongexp = -4951; @@ -55,30 +55,30 @@ MODULE ulmReals; TYPE PowerRec = RECORD - p10: LONGREAL; - n: INTEGER; + p10: Types.Real64; + n: Types.Int32; END; VAR powtab: ARRAY powers OF PowerRec; - sigdigits: ARRAY maxbase+1 OF INTEGER; (* valid range: [2..maxbase] *) + sigdigits: ARRAY maxbase+1 OF Types.Int32; (* valid range: [2..maxbase] *) - PROCEDURE ExpAndMan*(r: LONGREAL; long: BOOLEAN; base: INTEGER; - VAR exponent: INTEGER; VAR mantissa: LONGREAL); + PROCEDURE ExpAndMan*(r: Types.Real64; long: BOOLEAN; base: Types.Int32; + VAR exponent: Types.Int32; VAR mantissa: Types.Real64); (* get exponent and mantissa from `r': (1.0 >= ABS(mantissa)) & (ABS(mantissa) < base) r = mantissa * base^exponent - long should be false if a REAL-value is passed to `r' + long should be false if a Types.Real32-value is passed to `r' valid values of base: 2, 8, 10, and 16 *) VAR neg: BOOLEAN; - index: INTEGER; - roundoff: LONGREAL; - i: INTEGER; - ndigits: INTEGER; + index: Types.Int32; + roundoff: Types.Real64; + i: Types.Int32; + ndigits: Types.Int32; BEGIN IF r = 0.0 THEN exponent := 0; mantissa := 0; RETURN @@ -164,10 +164,10 @@ MODULE ulmReals; END; END ExpAndMan; - PROCEDURE Power*(base: LONGREAL; exp: INTEGER) : LONGREAL; + PROCEDURE Power*(base: Types.Real64; exp: Types.Int32) : Types.Real64; (* efficient calculation of base^exp *) VAR - r, res: LONGREAL; + r, res: Types.Real64; neg: BOOLEAN; (* negative exponent? *) BEGIN IF MC68881.available & (base = 10) THEN @@ -197,10 +197,10 @@ MODULE ulmReals; END; END Power; - PROCEDURE Digits*(mantissa: LONGREAL; base: INTEGER; + PROCEDURE Digits*(mantissa: Types.Real64; base: Types.Int32; VAR buf: ARRAY OF CHAR; VAR neg: BOOLEAN; - force: BOOLEAN; VAR ndigits: INTEGER); + force: BOOLEAN; VAR ndigits: Types.Int32); (* PRE: mantissa holds the post-condition of ExpAndMan; valid values for base are 2, 8, 10, and 16 @@ -216,11 +216,11 @@ MODULE ulmReals; ndigits is unchanged *) VAR - index: INTEGER; (* of buf *) - i: INTEGER; roundoff: LONGREAL; - lastnz: INTEGER; (* last index with buf[index] # "0" *) + index: Types.Int32; (* of buf *) + i: Types.Int32; roundoff: Types.Real64; + lastnz: Types.Int32; (* last index with buf[index] # "0" *) ch: CHAR; - digit: LONGINT; + digit: Types.Int32; maxdig: CHAR; (* base-1 converted *) BEGIN @@ -269,14 +269,14 @@ MODULE ulmReals; buf[index] := 0X; ndigits := index; END Digits; - PROCEDURE Convert*(digits: ARRAY OF CHAR; base: INTEGER; neg: BOOLEAN; - VAR mantissa: LONGREAL); + PROCEDURE Convert*(digits: ARRAY OF CHAR; base: Types.Int32; neg: BOOLEAN; + VAR mantissa: Types.Real64); (* convert normalized `digits' (decimal point after 1st digit) into `mantissa' *) VAR - index: INTEGER; - factor: LONGREAL; + index: Types.Int32; + factor: Types.Real64; BEGIN IF digits = "0" THEN mantissa := 0; @@ -304,7 +304,7 @@ BEGIN powtab[4].p10 := 1.0D2; powtab[4].n := 2; powtab[5].p10 := 1.0D1; powtab[5].n := 1; - (* for LONGREAL *) + (* for Types.Real64 *) sigdigits[2] := 64; sigdigits[3] := 40; sigdigits[4] := 32; sigdigits[5] := 27; sigdigits[6] := 24; sigdigits[7] := 22; sigdigits[8] := 21; sigdigits[9] := 20; sigdigits[10] := 19; diff --git a/src/library/ulm/ulmRelatedEvents.Mod b/src/library/ulm/ulmRelatedEvents.Mod new file mode 100644 index 00000000..a5ad5453 --- /dev/null +++ b/src/library/ulm/ulmRelatedEvents.Mod @@ -0,0 +1,429 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: RelatedEven.om,v $ + Revision 1.8 2005/04/28 08:30:09 borchert + added assertion to Forward that takes care that from # to + (otherwise we get a nasty infinite loop) + + Revision 1.7 2004/09/09 21:04:24 borchert + undoing change of Revision 1.5: + fields dependants and dependson must not be subject of + Save/Restore as this makes it impossible to undo the + dependencies within the TerminationHandler + we no longer remove the discipline in case of terminated + objects as this causes a list of error events to be lost + + Revision 1.6 2004/02/18 17:01:59 borchert + Raise asserts now that event.type # NIL + + Revision 1.5 2004/02/18 16:53:48 borchert + fields dependants and dependson moved from discipline to state + object to support them for Save/Restore + + Revision 1.4 1998/01/12 14:39:18 borchert + some bug fixes around RelatedEvents.null + + Revision 1.3 1995/03/20 17:05:13 borchert + - Save & Restore added + - support for Forwarders & Resources added + + Revision 1.2 1994/08/27 14:49:44 borchert + null object added + + Revision 1.1 1994/02/22 20:09:53 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 11/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmRelatedEvents; + + (* relate events to objects *) + + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM; + + CONST + (* possible directions of propagated events *) + forward = 0; (* forward along the forwardTo chain, if given *) + backward = 1; (* forward event to all dependants, if present *) + both = 2; (* forward event to both directions *) + TYPE + Direction = SHORTINT; (* forward, backward, both *) + + TYPE + Object* = Disciplines.Object; + Event* = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + object*: Object; + event*: Events.Event; + END; + Queue* = POINTER TO QueueRec; + QueueRec* = + RECORD + (Objects.ObjectRec) + event*: Events.Event; + next*: Queue; + END; + ObjectList = POINTER TO ObjectListRec; + ObjectListRec = + RECORD + object: Object; + next: ObjectList; + END; + + TYPE + State = POINTER TO StateRec; + StateRec = + RECORD + default: BOOLEAN; (* default reaction? *) + eventType: Events.EventType; (* may be NIL *) + queue: BOOLEAN; (* are events to be queued? *) + forwardto: Object; + head, tail: Queue; + saved: State; + END; + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + state: State; + dependants: ObjectList; + dependsOn: Object; + END; + VAR + id: Disciplines.Identifier; + VAR + null*: Object; (* object which ignores all related events *) + nullevent: Events.EventType; + + PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object); + VAR + prev, p: ObjectList; + BEGIN + prev := NIL; p := list; + WHILE (p # NIL) & (p.object # dependant) DO + prev := p; p := p.next; + END; + IF p # NIL THEN + IF prev = NIL THEN + list := p.next; + ELSE + prev.next := p.next; + END; + END; + END RemoveDependant; + + PROCEDURE Seek(object: Object; id: Disciplines.Identifier; + VAR discipline: Discipline): BOOLEAN; + VAR + disc: Disciplines.Discipline; + result: BOOLEAN; + BEGIN + result := Disciplines.Seek(object, id, disc); + IF result THEN discipline := disc(Discipline) ELSE discipline := NIL END; + RETURN result + END Seek; + + PROCEDURE TerminationHandler(event: Events.Event); + VAR + disc: Discipline; + BEGIN + WITH event: Resources.Event DO + IF (event.change = Resources.terminated) & Seek(event.resource, id, disc) THEN + IF (disc.dependsOn # NIL) & Seek(disc.dependsOn, id, disc) THEN + RemoveDependant(disc.dependants, event.resource); + disc.dependsOn := NIL; + END; + (* + afb 9/2004: + do not remove this discipline for dead objects + as this makes it impossible to retrieve the final + list of error events + Disciplines.Remove(event.resource, id); + *) + END; + END; + END TerminationHandler; + + PROCEDURE CreateState(VAR state: State); + BEGIN + NEW(state); + state.eventType := NIL; + state.queue := FALSE; state.head := NIL; state.tail := NIL; + state.forwardto := NIL; + state.default := TRUE; + state.saved := NIL; + END CreateState; + + PROCEDURE CreateDiscipline(VAR disc: Discipline); + BEGIN + NEW(disc); disc.id := id; CreateState(disc.state); + END CreateDiscipline; + + PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType); + (* returns an event type for the given object; + all events related to the object are also handled by this event type + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object = null THEN + eventType := nullevent; + ELSE + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); + END; + state := disc.state; + state.default := FALSE; + IF state.eventType = NIL THEN + Events.Define(state.eventType); + Events.SetPriority(state.eventType, Priorities.liberrors + 1); + Events.Ignore(state.eventType); + END; + eventType := state.eventType; + END; + END GetEventType; + + PROCEDURE Forward*(from, to: Object); + (* causes all events related to `from' to be forwarded to `to' *) + VAR + disc: Discipline; + BEGIN + IF (from # NIL) & (from # null) THEN + ASSERT(from # to); + IF ~Seek(from, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(from, disc); + END; + IF to = null THEN + to := NIL; + END; + disc.state.forwardto := to; + disc.state.default := FALSE; + END; + END Forward; + + PROCEDURE ForwardToDependants(from, to: Forwarders.Object); + (* is called by Forwarders.Forward: + build a backward chain from `to' to `from' + *) + VAR + fromDisc, toDisc: Discipline; + member: ObjectList; + eventType: Events.EventType; + BEGIN + IF (from = null) OR (to = null) THEN RETURN END; + IF ~Seek(from, id, fromDisc) THEN + CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc); + END; + IF fromDisc.dependsOn # NIL THEN RETURN END; + fromDisc.dependsOn := to; + Resources.TakeInterest(from, eventType); + Events.Handler(eventType, TerminationHandler); + + IF ~Seek(to, id, toDisc) THEN + CreateDiscipline(toDisc); Disciplines.Add(to, toDisc); + END; + NEW(member); member.object := from; + member.next := toDisc.dependants; toDisc.dependants := member; + END ForwardToDependants; + + PROCEDURE QueueEvents*(object: Object); + (* put all incoming events into a queue *) + VAR + disc: Discipline; + state: State; + BEGIN + IF (object # NIL) & (object # null) THEN + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); + END; + state := disc.state; + state.default := FALSE; + IF ~state.queue THEN + state.queue := TRUE; state.head := NIL; state.tail := NIL; + END; + END; + END QueueEvents; + + PROCEDURE GetQueue*(object: Object; VAR queue: Queue); + (* return queue of related events which is removed + from the object; + object must have been prepared by QueueEvents + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN + state := disc.state; + queue := state.head; state.head := NIL; state.tail := NIL; + ELSE + queue := NIL; + END; + END GetQueue; + + PROCEDURE EventsPending*(object: Object) : BOOLEAN; + (* return TRUE if GetQueue will return a queue # NIL *) + VAR + disc: Discipline; + BEGIN + IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN + RETURN disc.state.head # NIL + ELSE + RETURN FALSE + END; + END EventsPending; + + PROCEDURE Reset*(object: Object); + (* return to default behaviour *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object # null THEN + IF Seek(object, id, disc) THEN + IF (disc.state.saved = NIL) & + (disc.dependsOn = NIL) & + (disc.dependants = NIL) THEN + Disciplines.Remove(object, id); + ELSE + state := disc.state; + state.queue := FALSE; state.head := NIL; state.tail := NIL; + state.eventType := NIL; state.forwardto := NIL; + state.default := TRUE; + END; + END; + END; + END Reset; + + PROCEDURE Save*(object: Object); + (* save current status of the given object and reset to + default behaviour; + the status includes the reaction types and event queues; + Save operations may be nested + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object # null THEN + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); + END; + CreateState(state); + state.saved := disc.state; disc.state := state; + END; + END Save; + + PROCEDURE Restore*(object: Object); + (* restore status saved earlier by Save *) + VAR + disc: Discipline; + BEGIN + IF Seek(object, id, disc) & (disc.state.saved # NIL) THEN + disc.state := disc.state.saved; + END; + END Restore; + + PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event); + VAR + disc: Discipline; + state: State; + relEvent: Event; + element: Queue; (* new element of queue *) + dependant: ObjectList; + BEGIN + IF (object = null) OR ~Seek(object, id, disc) THEN RETURN END; + + (* backward chaining *) + IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN + dependant := disc.dependants; + WHILE dependant # NIL DO + InternalRaise(dependant.object, backward, event); + dependant := dependant.next; + END; + END; + + (* local handling & forward chaining *) + IF ~disc.state.default THEN + state := disc.state; + IF state.queue THEN + NEW(element); element.next := NIL; element.event := event; + IF state.tail # NIL THEN + state.tail.next := element; + ELSE + state.head := element; + END; + state.tail := element; + END; + IF state.eventType # NIL THEN + NEW(relEvent); + relEvent.message := event.message; + relEvent.type := state.eventType; + relEvent.object := object; + relEvent.event := event; + Events.Raise(relEvent); + END; + IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN + InternalRaise(state.forwardto, forward, event); + END; + END; + END InternalRaise; + + PROCEDURE Raise*(object: Object; event: Events.Event); + VAR + disc: Discipline; + BEGIN + ASSERT(event.type # NIL); + IF object # null THEN + IF (object = NIL) OR ~Seek(object, id, disc) THEN + Events.Raise(event); + ELSE + InternalRaise(object, both, event); + END; + END; + END Raise; + + PROCEDURE AppendQueue*(object: Object; queue: Queue); + (* Raise(object, event) for all events of the queue *) + BEGIN + WHILE queue # NIL DO + Raise(object, queue.event); + queue := queue.next; + END; + END AppendQueue; + +BEGIN + id := Disciplines.Unique(); + NEW(null); + Events.Define(nullevent); + Forwarders.Register("", ForwardToDependants); +END ulmRelatedEvents. diff --git a/src/lib/ulm/ulmResources.Mod b/src/library/ulm/ulmResources.Mod similarity index 60% rename from src/lib/ulm/ulmResources.Mod rename to src/library/ulm/ulmResources.Mod index 08b9ae20..a700d22a 100644 --- a/src/lib/ulm/ulmResources.Mod +++ b/src/library/ulm/ulmResources.Mod @@ -64,83 +64,75 @@ MODULE ulmResources; TYPE StateChange* = SHORTINT; (* terminated..communicationResumed *) State = SHORTINT; (* alive, unreferenced, or alive *) - (* whether objects are stopped or not is maintained separately *) + (* whether objects are stopped or not is maintained separately *) Event* = POINTER TO EventRec; (* notification of state changes *) EventRec* = - RECORD - (Events.EventRec) - change*: StateChange; (* new state *) - resource*: Resource; - END; + RECORD + (Events.EventRec) + change*: StateChange; (* new state *) + resource*: Resource; + END; TYPE Key* = POINTER TO KeyRec; KeyRec* = - RECORD - (Objects.ObjectRec) - valid: BOOLEAN; - resource: Resource; - END; + RECORD + (Objects.ObjectRec) + valid: BOOLEAN; + resource: Resource; + END; TYPE List = POINTER TO ListRec; ListRec = - RECORD - resource: Resource; - next: List; - END; + RECORD + resource: Resource; + next: List; + END; Discipline = POINTER TO DisciplineRec; DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - state: State; (* alive, unreferenced, or terminated *) - stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *) - refcnt: LONGINT; (* # of Attach - # of Detach *) - eventType: Events.EventType; (* may be NIL *) - dependants: List; (* list of resources which depends on us *) - dependsOn: Resource; (* we depend on this resource *) - key: Key; (* attach key for dependsOn *) - END; + RECORD + (Disciplines.DisciplineRec) + state: State; (* alive, unreferenced, or terminated *) + stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *) + refcnt: LONGINT; (* # of Attach - # of Detach *) + eventType: Events.EventType; (* may be NIL *) + dependants: List; (* list of resources which depends on us *) + dependsOn: Resource; (* we depend on this resource *) + key: Key; (* attach key for dependsOn *) + END; VAR discID: Disciplines.Identifier; (* === private procedures ============================================ *) PROCEDURE GetDisc(resource: Resource; VAR disc: Discipline); + VAR d: Disciplines.Discipline; BEGIN - (*IF ~Disciplines.Seek(resource, discID, disc) THEN*) - (* this line causes error - err 123 type of actual parameter is not identical with that of formal VAR-parameter - because Discipline defined in this module is an extention of the same type in module Disciplines - Disciplines.Seek expects Disciplines.Discipline, not the extended type. - voc (ofront, OP2, as well as oo2c) behaves right by not allowing this, while Ulm's Oberon system - accepts this. - So we introduce here a workaround, which makes usage of this module unsafe; - - noch - *) - IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - NEW(disc); disc.id := discID; - disc.state := alive; disc.refcnt := 0; - disc.eventType := NIL; - disc.dependants := NIL; disc.dependsOn := NIL; - Disciplines.Add(resource, disc); + IF Disciplines.Seek(resource, discID, d) THEN + disc := d(Discipline) + ELSE + NEW(disc); disc.id := discID; + disc.state := alive; disc.refcnt := 0; + disc.eventType := NIL; + disc.dependants := NIL; disc.dependsOn := NIL; + Disciplines.Add(resource, disc); END; END GetDisc; PROCEDURE GenEvent(resource: Resource; change: StateChange); VAR - disc: Discipline; - event: Event; + disc: Discipline; + event: Event; BEGIN GetDisc(resource, disc); IF disc.eventType # NIL THEN - NEW(event); - event.type := disc.eventType; - event.message := "Resources: state change notification"; - event.change := change; - event.resource := resource; - Events.Raise(event); + NEW(event); + event.type := disc.eventType; + event.message := "Resources: state change notification"; + event.change := change; + event.resource := resource; + Events.Raise(event); END; END GenEvent; @@ -149,24 +141,24 @@ MODULE ulmResources; PROCEDURE Unlink(dependant, resource: Resource); (* undo DependsOn operation *) VAR - dependantDisc, resourceDisc: Discipline; - prev, member: List; + dependantDisc, resourceDisc: Discipline; + prev, member: List; BEGIN GetDisc(resource, resourceDisc); IF resourceDisc.state = terminated THEN - (* no necessity for clean up *) - RETURN + (* no necessity for clean up *) + RETURN END; GetDisc(dependant, dependantDisc); prev := NIL; member := resourceDisc.dependants; WHILE member.resource # dependant DO - prev := member; member := member.next; + prev := member; member := member.next; END; IF prev = NIL THEN - resourceDisc.dependants := member.next; + resourceDisc.dependants := member.next; ELSE - prev.next := member.next; + prev.next := member.next; END; (* Detach reference from dependant to resource *) @@ -176,28 +168,29 @@ MODULE ulmResources; PROCEDURE InternalNotify(resource: Resource; change: StateChange); VAR - disc: Discipline; - event: Event; - dependant: List; + disc: Discipline; + event: Event; + dependant: List; BEGIN GetDisc(resource, disc); CASE change OF | communicationResumed: disc.stopped := FALSE; | communicationStopped: disc.stopped := TRUE; | terminated: disc.stopped := FALSE; disc.state := terminated; + ELSE (* Explicitly ignore unhandled values of change *) END; GenEvent(resource, change); (* notify all dependants *) dependant := disc.dependants; WHILE dependant # NIL DO - InternalNotify(dependant.resource, change); - dependant := dependant.next; + InternalNotify(dependant.resource, change); + dependant := dependant.next; END; (* remove dependency relation in case of termination, if present *) IF (change = terminated) & (disc.dependsOn # NIL) THEN - Unlink(resource, disc.dependsOn); + Unlink(resource, disc.dependsOn); END; END InternalNotify; @@ -205,16 +198,16 @@ MODULE ulmResources; PROCEDURE TakeInterest*(resource: Resource; VAR eventType: Events.EventType); (* return resource specific event type for state notifications; - eventType is guaranteed to be # NIL even if - the given resource is already terminated + eventType is guaranteed to be # NIL even if + the given resource is already terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); IF disc.eventType = NIL THEN - Events.Define(disc.eventType); - Events.Ignore(disc.eventType); + Events.Define(disc.eventType); + Events.Ignore(disc.eventType); END; eventType := disc.eventType; END TakeInterest; @@ -222,93 +215,93 @@ MODULE ulmResources; PROCEDURE Attach*(resource: Resource; VAR key: Key); (* mark the resource as being used until Detach gets called *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); IF disc.state IN {terminated, unreferenced} THEN - key := NIL; + key := NIL; ELSE - INC(disc.refcnt); NEW(key); key.valid := TRUE; - key.resource := resource; + INC(disc.refcnt); NEW(key); key.valid := TRUE; + key.resource := resource; END; END Attach; PROCEDURE Detach*(resource: Resource; key: Key); (* mark the resource as unused; the returned key of Attach must - be given -- this allows to check for proper balances - of Attach/Detach calls; - the last Detach operation causes a state change to unreferenced + be given -- this allows to check for proper balances + of Attach/Detach calls; + the last Detach operation causes a state change to unreferenced *) VAR - disc: Discipline; + disc: Discipline; BEGIN IF (key # NIL) & key.valid & (key.resource = resource) THEN - GetDisc(resource, disc); - IF disc.state # terminated THEN - key.valid := FALSE; DEC(disc.refcnt); - IF disc.refcnt = 0 THEN - GenEvent(resource, unreferenced); - disc.state := unreferenced; - IF disc.dependsOn # NIL THEN - Unlink(resource, disc.dependsOn); - END; - END; - END; + GetDisc(resource, disc); + IF disc.state # terminated THEN + key.valid := FALSE; DEC(disc.refcnt); + IF disc.refcnt = 0 THEN + GenEvent(resource, unreferenced); + disc.state := unreferenced; + IF disc.dependsOn # NIL THEN + Unlink(resource, disc.dependsOn); + END; + END; + END; END; END Detach; PROCEDURE Notify*(resource: Resource; change: StateChange); (* notify all interested parties about the new state; - only valid state changes are accepted: - - Notify doesn't accept any changes after termination - - unreferenced is generated conditionally by Detach only - - communicationResumed is valid after communicationStopped only - valid notifications are propagated to all dependants (see below); + only valid state changes are accepted: + - Notify doesn't accept any changes after termination + - unreferenced is generated conditionally by Detach only + - communicationResumed is valid after communicationStopped only + valid notifications are propagated to all dependants (see below); *) VAR - disc: Discipline; - event: Event; - dependant: List; + disc: Discipline; + event: Event; + dependant: List; BEGIN IF change # unreferenced THEN - GetDisc(resource, disc); - IF (disc.state # terminated) & (disc.state # change) & - ((change # communicationResumed) OR disc.stopped) THEN - InternalNotify(resource, change); - END; + GetDisc(resource, disc); + IF (disc.state # terminated) & (disc.state # change) & + ((change # communicationResumed) OR disc.stopped) THEN + InternalNotify(resource, change); + END; END; END Notify; PROCEDURE DependsOn*(dependant, resource: Resource); (* states that `dependant' depends entirely on `resource' -- - this is usually the case if operations on `dependant' - are delegated to `resource'; - only one call of DependsOn may be given per `dependant' while - several DependsOn for one resource are valid; - DependsOn calls implicitly Attach for resource and - detaches if the dependant becomes unreferenced; - all other state changes propagate from `resource' to - `dependant' + this is usually the case if operations on `dependant' + are delegated to `resource'; + only one call of DependsOn may be given per `dependant' while + several DependsOn for one resource are valid; + DependsOn calls implicitly Attach for resource and + detaches if the dependant becomes unreferenced; + all other state changes propagate from `resource' to + `dependant' *) VAR - dependantDisc, resourceDisc: Discipline; - member: List; + dependantDisc, resourceDisc: Discipline; + member: List; BEGIN GetDisc(resource, resourceDisc); IF resourceDisc.state <= unreferenced THEN - (* do not create a relationship to dead or unreferenced objects - but propagate a termination immediately to dependant - *) - IF resourceDisc.state = terminated THEN - Notify(dependant, resourceDisc.state); - END; - RETURN + (* do not create a relationship to dead or unreferenced objects + but propagate a termination immediately to dependant + *) + IF resourceDisc.state = terminated THEN + Notify(dependant, resourceDisc.state); + END; + RETURN END; GetDisc(dependant, dependantDisc); IF dependantDisc.dependsOn # NIL THEN - (* don't accept changes *) - RETURN + (* don't accept changes *) + RETURN END; dependantDisc.dependsOn := resource; @@ -320,10 +313,10 @@ MODULE ulmResources; PROCEDURE Alive*(resource: Resource) : BOOLEAN; (* returns TRUE if the resource is not yet terminated - and ready for communication (i.e. not communicationStopped) + and ready for communication (i.e. not communicationStopped) *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN ~disc.stopped & (disc.state IN {alive, unreferenced}) @@ -331,10 +324,10 @@ MODULE ulmResources; PROCEDURE Stopped*(resource: Resource) : BOOLEAN; (* returns TRUE if the object is currently not responsive - and not yet terminated + and not yet terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN disc.stopped @@ -343,7 +336,7 @@ MODULE ulmResources; PROCEDURE Terminated*(resource: Resource) : BOOLEAN; (* returns TRUE if the resource is terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN disc.state = terminated diff --git a/src/lib/ulm/armv6j_hardfp/ulmSYSTEM.Mod b/src/library/ulm/ulmSYSTEM.Mod similarity index 59% rename from src/lib/ulm/armv6j_hardfp/ulmSYSTEM.Mod rename to src/library/ulm/ulmSYSTEM.Mod index 814c0607..f4efb7d5 100644 --- a/src/lib/ulm/armv6j_hardfp/ulmSYSTEM.Mod +++ b/src/library/ulm/ulmSYSTEM.Mod @@ -1,46 +1,44 @@ MODULE ulmSYSTEM; -IMPORT SYSTEM, Unix, Sys := ulmSys; +IMPORT SYSTEM, Platform, Sys := ulmSys; TYPE pchar = POINTER TO ARRAY 1 OF CHAR; pstring = POINTER TO ARRAY 1024 OF CHAR; - pstatus = POINTER TO Unix.Status; + (* pstatus = POINTER TO Platform.Status; *) TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) pbytearray* = POINTER TO bytearray; TYPE longrealarray* = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) - plongrealarray* = POINTER TO bytearray; + plongrealarray* = POINTER TO longrealarray; PROCEDURE LongToByteArr* ( l : LONGINT; VAR bar : bytearray); (* noch *) VAR b : SYSTEM.BYTE; - p : pbytearray; + adr : SYSTEM.ADDRESS; i : LONGINT; BEGIN - p := SYSTEM.VAL(pbytearray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGINT) -1 DO - b := p^[i]; bar[i] := b; - END + adr := SYSTEM.ADR(l); + i := 0; + REPEAT + SYSTEM.GET(adr + i, b); + bar[i] := b; + INC(i) + UNTIL i = SIZE(LONGINT) END LongToByteArr; PROCEDURE LRealToByteArr* ( l : LONGREAL; VAR lar : longrealarray); (* noch *) VAR b : SYSTEM.BYTE; - p : plongrealarray; + adr: SYSTEM.ADDRESS; i : LONGINT; BEGIN - p := SYSTEM.VAL(plongrealarray, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGREAL) -1 DO - b := p^[i]; lar[i] := b; - END + adr := SYSTEM.ADR(l); + i := 0; + REPEAT + SYSTEM.GET(adr + i, b); + lar[i] := b; + INC(i) + UNTIL i = SIZE(LONGREAL); END LRealToByteArr; -(* - PROCEDURE -Write(adr, n: LONGINT): LONGINT - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; -*) - PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *) VAR oldflag : BOOLEAN; BEGIN @@ -49,24 +47,27 @@ TYPE pchar = POINTER TO ARRAY 1 OF CHAR; RETURN oldflag; END TAS; +(* PROCEDURE UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *) - arg1, arg2, arg3: LONGINT) : BOOLEAN; + arg1, arg2, arg3: LONGINT) : BOOLEAN; VAR - n : LONGINT; - ch : CHAR; - pch : pchar; - pstr : pstring; - pst : pstatus; + n: LONGINT; + ch: CHAR; + pch: pchar; + pstr: pstring; + h: Platform.FileHandle; + (* pst : pstatus; *) BEGIN - + IF syscall = Sys.read THEN - d0 := Unix.Read(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + d0 := Platform.Read(arg1, arg2, arg3, n); + IF d0 >= 0 THEN d0 := n END; + RETURN d0 >= 0; (*NEW(pch); pch := SYSTEM.VAL(pchar, arg2); ch := pch^[0]; n := read(ch); - IF n # 1 THEN + IF n # 1 THEN ch := 0X; RETURN FALSE ELSE @@ -75,48 +76,52 @@ TYPE pchar = POINTER TO ARRAY 1 OF CHAR; END; *) ELSIF syscall = Sys.write THEN - d0 := Unix.Write(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Write(arg1, arg2, arg3) = 0; (*NEW(pch); pch := SYSTEM.VAL(pchar, arg2); n := Write(SYSTEM.VAL(LONGINT, pch), 1); IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END *) - ELSIF syscall = Sys.open THEN - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Open(pstr^, SYSTEM.VAL(SET, arg3), SYSTEM.VAL(SET, arg2)); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + ELSIF syscall = Sys.open THEN + pstr := SYSTEM.VAL(pstring, arg1); + IF SYSTEM.VAL(SET, arg3) * {0,1} # {} THEN + RETURN Platform.OldRW(pstr^, d0) = 0 + ELSE + RETURN Platform.OldRO(pstr^, d0) = 0 + END ELSIF syscall = Sys.close THEN - d0 := Unix.Close(arg1); - IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Close(arg1) = 0 ELSIF syscall = Sys.lseek THEN - d0 := Unix.Lseek(arg1, arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Seek(arg1, arg2, SYSTEM.VAL(INTEGER, arg3)) = 0 + (* ELSIF syscall = Sys.ioctl THEN - d0 := Unix.Ioctl(arg1, arg2, arg3); + d0 := Platform.Ioctl(arg1, arg2, arg3); RETURN d0 >= 0; ELSIF syscall = Sys.fcntl THEN - d0 := Unix.Fcntl (arg1, arg2, arg3); + d0 := Platform.Fcntl (arg1, arg2, arg3); RETURN d0 >= 0; ELSIF syscall = Sys.dup THEN - d0 := Unix.Dup(arg1); + d0 := Platform.Dup(arg1); RETURN d0 > 0; ELSIF syscall = Sys.pipe THEN - d0 := Unix.Pipe(arg1); + d0 := Platform.Pipe(arg1); RETURN d0 >= 0; ELSIF syscall = Sys.newstat THEN pst := SYSTEM.VAL(pstatus, arg2); pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Stat(pstr^, pst^); + d0 := Platform.Stat(pstr^, pst^); RETURN d0 >= 0 ELSIF syscall = Sys.newfstat THEN pst := SYSTEM.VAL(pstatus, arg2); - d0 := Unix.Fstat(arg1, pst^); + d0 := Platform.Fstat(arg1, pst^); RETURN d0 >= 0; + *) + ELSE + HALT(99); END END UNIXCALL; - +*) PROCEDURE UNIXFORK(VAR pid: LONGINT) : BOOLEAN; BEGIN @@ -129,9 +134,9 @@ TYPE pchar = POINTER TO ARRAY 1 OF CHAR; END UNIXSIGNAL; - PROCEDURE WMOVE*(from, to, n : LONGINT); - VAR l : LONGINT; + PROCEDURE WMOVE*(from, to, n : SYSTEM.ADDRESS); BEGIN SYSTEM.MOVE(from, to, n); END WMOVE; + END ulmSYSTEM. diff --git a/src/library/ulm/ulmScales.Mod b/src/library/ulm/ulmScales.Mod new file mode 100644 index 00000000..25af6eac --- /dev/null +++ b/src/library/ulm/ulmScales.Mod @@ -0,0 +1,446 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Scales.om,v $ + Revision 1.3 2004/09/03 09:31:53 borchert + bug fixes: Services.Init added in CreateOperand + Scales.Measure changed to Measure + + Revision 1.2 1995/01/16 21:40:39 borchert + - assertions of Assertions converted into real assertions + - fixes due to changed if of PersistentObjects + + Revision 1.1 1994/02/22 20:10:03 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmScales; + + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM, Types := ulmTypes; + + TYPE + Scale* = POINTER TO ScaleRec; + Family* = POINTER TO FamilyRec; + FamilyRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + reference: Scale; + END; + + TYPE + Unit* = POINTER TO UnitRec; + UnitList = POINTER TO UnitListRec; + UnitListRec = + RECORD + unit: Unit; + next: UnitList; + END; + Interface* = POINTER TO InterfaceRec; + ScaleRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + if: Interface; + family: Family; + head, tail: UnitList; + nextUnit: UnitList; + END; + + CONST + unitNameLength* = 32; + TYPE + UnitName* = ARRAY unitNameLength OF CHAR; + UnitRec* = RECORD + (Disciplines.ObjectRec) + name: UnitName; + scale: Scale; + END; + + CONST + undefined = 0; absolute* = 1; relative* = 2; + TYPE + Measure* = POINTER TO MeasureRec; + MeasureRec* = + RECORD + (Operations.OperandRec) + scale: Scale; + type: Types.Int8; (* absolute or relative? *) + END; + VAR + measureType: Services.Type; + + TYPE + Value* = Types.Int32; + + CONST + add* = Operations.add; sub* = Operations.sub; + TYPE + Operation* = Types.Int8; (* add or sub *) + TYPE + CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN); + GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value); + SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value); + AssignProc* = PROCEDURE (target: Measure; source: Measure); + OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure); + CompareProc* = PROCEDURE (op1, op2: Measure) : Types.Int32; + ConvertProc* = PROCEDURE (from, to: Measure); + + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; + getvalue*: GetValueProc; + setvalue*: SetValueProc; + assign*: AssignProc; + op*: OperatorProc; + compare*: CompareProc; + (* the conversion routines are only to be provided + if the scaling system belongs to a family + *) + scaleToReference*: ConvertProc; + referenceToScale*: ConvertProc; + END; + + VAR + invalidOperation*: Events.EventType; + (* operation cannot be performed for the given combination + of types (absolute or relative) + *) + incompatibleScales*: Events.EventType; + (* the scales of the operands do not belong to the same family *) + badCombination*: Events.EventType; + (* SetValue or GetValue: + given measure and unit do not belong to the same scaling system + *) + + (* our interface to Operations *) + opif: Operations.Interface; + opcaps: Operations.CapabilitySet; + + (* ======= private procedures ===================================== *) + + PROCEDURE DummyConversion(from, to: Measure); + BEGIN + from.scale.if.assign(to, from); + END DummyConversion; + + (* ======== exported procedures ==================================== *) + + PROCEDURE InitFamily*(family: Family; reference: Scale); + BEGIN + family.reference := reference; + (* the reference scale becomes now a member of the family *) + reference.family := family; + reference.if.scaleToReference := DummyConversion; + reference.if.referenceToScale := DummyConversion; + END InitFamily; + + PROCEDURE Init*(scale: Scale; family: Family; if: Interface); + (* reference scales are to be initialized with family = NIL *) + BEGIN + scale.if := if; + scale.family := family; + scale.head := NIL; scale.tail := NIL; + scale.nextUnit := NIL; + END Init; + + PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName); + VAR + listp: UnitList; + BEGIN + unit.name := name; + unit.scale := scale; + NEW(listp); listp.unit := unit; listp.next := NIL; + IF scale.head # NIL THEN + scale.tail.next := listp; + ELSE + scale.head := listp; + END; + scale.tail := listp; + END InitUnit; + + PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: Types.Int8); + BEGIN + scale.if.create(scale, measure, type = absolute); + Operations.Init(measure, opif, opcaps); + measure.scale := scale; + measure.type := type; + END CreateMeasure; + + PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure); + (* init measure to the origin of the given system *) + BEGIN + CreateMeasure(scale, measure, absolute); + END CreateAbsMeasure; + + PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure); + (* init relative measure to 0 *) + BEGIN + CreateMeasure(scale, measure, relative); + END CreateRelMeasure; + + PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure); + (* convert measure to the given scale which must belong + to the same family as the original scale of measure + *) + VAR + newMeasure: Measure; + refMeasure: Measure; + reference: Scale; + BEGIN + IF scale = measure.scale THEN + (* trivial case -- nothing is to be done *) + RETURN + END; + (* check that both scales belong to the same family *) + ASSERT((scale.family # NIL) & (scale.family = measure.scale.family)); + CreateMeasure(scale, newMeasure, measure.type); + reference := scale.family.reference; + CreateMeasure(reference, refMeasure, measure.type); + measure.scale.if.scaleToReference(measure, refMeasure); + scale.if.referenceToScale(refMeasure, newMeasure); + measure := newMeasure; + END ConvertMeasure; + + PROCEDURE GetReference*(family: Family; VAR reference: Scale); + BEGIN + reference := family.reference; + END GetReference; + + PROCEDURE GetFamily*(scale: Scale; VAR family: Family); + BEGIN + family := scale.family; + END GetFamily; + + PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale); + BEGIN + scale := unit.scale; + END GetScaleOfUnit; + + PROCEDURE GetScale*(measure: Measure; VAR scale: Scale); + BEGIN + scale := measure.scale; + END GetScale; + + PROCEDURE TraverseUnits*(scale: Scale); + BEGIN + scale.nextUnit := scale.head; + END TraverseUnits; + + PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN; + BEGIN + IF scale.nextUnit # NIL THEN + unit := scale.nextUnit.unit; + scale.nextUnit := scale.nextUnit.next; + RETURN TRUE + ELSE + RETURN FALSE + END; + END NextUnit; + + PROCEDURE GetName*(unit: Unit; VAR name: UnitName); + BEGIN + name := unit.name; + END GetName; + + PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.getvalue(measure, unit, value); + END GetValue; + + PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.setvalue(measure, unit, value); + END SetValue; + + PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = absolute + END IsAbsolute; + + PROCEDURE IsRelative*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = relative + END IsRelative; + + PROCEDURE MeasureType*(measure: Measure) : Types.Int8; + BEGIN + RETURN measure.type + END MeasureType; + + (* ======== interface procedures for Operations ================= *) + + PROCEDURE CreateOperand(VAR op: Operations.Operand); + (* at this time we don't know anything about the + associated scale -- so we've have to delay this decision + *) + VAR + measure: Measure; + BEGIN + NEW(measure); + measure.type := undefined; + measure.scale := NIL; + Services.Init(measure, measureType); + op := measure; + Operations.Init(op, opif, {Operations.add..Operations.cmp}); + END CreateOperand; + + PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand); + BEGIN + (*WITH source: Measure DO WITH target: Measure DO*) + WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *) + (* target is already initialized but possibly to a dummy operand + by CreateOperand + *) + IF target(Measure).type = undefined THEN (* type guard introduced *) + (* init target with the scale of source *) + CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *) + END; + IF target(Measure).scale # source.scale THEN + (* adapt scale type from source -- + this could lead to a type guard failure if + target is not of the appropiate type + *) + CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); + END; + IF target(Measure).type # source.type THEN + (* adapt measure type from source *) + CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type); + END; + source.scale.if.assign(SYS.VAL(Measure, target), source); + END; END; + END Assign; + + PROCEDURE CheckCompatibility(op1, op2: Operations.Operand; + VAR m1, m2: Measure); + (* is needed by Op and Compare: + both operands are checked to be members of the same family; + if they have different scales of the same family a + conversion is done; + *) + VAR + scale1, scale2: Scale; + BEGIN + WITH op1: Measure DO WITH op2: Measure DO + scale1 := op1.scale; scale2 := op2.scale; + IF scale1 # scale2 THEN + ASSERT((scale1.family # NIL) & (scale1.family = scale2.family)); + (* convert both operands to the reference scale *) + CreateMeasure(scale1.family.reference, m1, op1.type); + scale1.if.scaleToReference(op1, m1); + CreateMeasure(scale2.family.reference, m2, op2.type); + scale2.if.scaleToReference(op2, m2); + ELSE + m1 := op1; + m2 := op2; + END; + END; END; + END CheckCompatibility; + + PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand; + VAR result: Operations.Operand); + VAR + restype: Types.Int8; (* type of result -- set by CheckTypes *) + m1, m2: Measure; + + PROCEDURE CheckTypes(VAR restype: Types.Int8); + (* check operands for correct typing; + sets restype to the correct result type; + *) + VAR ok: BOOLEAN; + BEGIN + (*WITH op1: Measure DO WITH op2: Measure DO*) + IF op1 IS Measure THEN IF op2 IS Measure THEN + CASE op OF + | Operations.add: (* only abs + abs is invalid *) + ok := (op1(Measure).type = relative) OR + (op2(Measure).type = relative); + IF op1(Measure).type = op2(Measure).type THEN + (* both are relative *) + restype := relative; + ELSE + (* exactly one absolute type is involved *) + restype := absolute; + END; + | Operations.sub: (* only rel - abs is invalid *) + ok := op1(Measure).type <= op2(Measure).type; + IF op1(Measure).type # op2(Measure).type THEN + (* abs - rel *) + restype := absolute; + ELSE + (* abs - abs or rel - rel *) + restype := relative; + END; + ELSE + END; + ASSERT(ok); (* invalid operation *) + END; END; + END CheckTypes; + + BEGIN (* Op *) + (* result is already of type Measure; this is guaranteed by Operations *) + IF result IS Measure THEN + CheckTypes(restype); + CheckCompatibility(op1, op2, m1, m2); + CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype); + m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result)); + END; + END Op; + + PROCEDURE Compare(op1, op2: Operations.Operand) : Types.Int32; + VAR + m1, m2: Measure; + BEGIN + CheckCompatibility(op1, op2, m1, m2); + ASSERT(m1.type = m2.type); + CheckCompatibility(op1, op2, m1, m2); + RETURN m1.scale.if.compare(m1, m2) + END Compare; + + PROCEDURE InitInterface; + BEGIN + NEW(opif); + opif.create := CreateOperand; + opif.assign := Assign; + opif.op := Op; + opif.compare := Compare; + opcaps := {Operations.add, Operations.sub, Operations.cmp}; + END InitInterface; + +BEGIN + InitInterface; + PersistentObjects.RegisterType(measureType, + "Scales.Measure", "Operations.Operand", NIL); +END ulmScales. diff --git a/src/library/ulm/ulmServices.Mod b/src/library/ulm/ulmServices.Mod new file mode 100644 index 00000000..73b80aad --- /dev/null +++ b/src/library/ulm/ulmServices.Mod @@ -0,0 +1,520 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Services.om,v $ + Revision 1.2 2004/09/03 09:34:24 borchert + cache results of LoadService to avoid further attempts + + Revision 1.1 1995/03/03 09:32:15 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmServices; + + IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects, Types := ulmTypes; + + TYPE + Type* = POINTER TO TypeRec; + ServiceList = POINTER TO ServiceListRec; + Service* = POINTER TO ServiceRec; + Object* = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (Disciplines.ObjectRec) + type: Type; + installed: ServiceList; (* set of installed services *) + END; + + InstallProc = PROCEDURE (object: Object; service: Service); + + ServiceRec* = + RECORD + (Disciplines.ObjectRec) + name: ARRAY 64 OF CHAR; + next: Service; + END; + + ServiceListRec = + RECORD + service: Service; + type: Type; + install: InstallProc; + next: ServiceList; + END; + + VAR + services: Service; + (* list of services -- needed to support Seek *) + + TYPE + LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN; + LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN; + LoaderInterface* = POINTER TO LoaderInterfaceRec; + LoaderInterfaceRec* = + RECORD + loadModule*: LoadModuleProc; + loadService*: LoadServiceProc; + END; + VAR + loaderIF: LoaderInterface; + + (* ==== name tables ================================================== *) + + CONST + bufsize = 512; (* length of a name buffer in bytes *) + tabsize = 1171; + TYPE + BufferPosition = Types.Int32; + Length = Types.Int32; + HashValue = Types.Int32; + Buffer = ARRAY bufsize OF CHAR; + NameList = POINTER TO NameListRec; + NameListRec = + RECORD + buffer: Buffer; + next: NameList; + END; + VAR + currentBuf: NameList; currentPos: BufferPosition; + TYPE + TypeRec* = + RECORD + (Disciplines.ObjectRec) + baseType: Type; + services: ServiceList; + cachedservices: ServiceList; (* of base types *) + (* table management *) + hashval: HashValue; + length: Length; + begin: NameList; + pos: BufferPosition; + next: Type; (* next type with same hash value *) + END; + BucketTable = ARRAY tabsize OF Type; + VAR + bucket: BucketTable; + + (* ==== name table management ======================================== *) + + PROCEDURE Hash(name: ARRAY OF CHAR; length: Types.Int32) : HashValue; + CONST + shift = 4; + VAR + index: Types.Int32; + val: Types.Int32; + ch: CHAR; + ordval: Types.Int32; + BEGIN + index := 0; val := length; + WHILE index < length DO + ch := name[index]; + IF ch >= " " THEN + ordval := ORD(ch) - ORD(" "); + ELSE + ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch); + END; + val := ASH(val, shift) + ordval; + INC(index); + END; + val := val MOD tabsize; + RETURN SHORT(val) + END Hash; + + PROCEDURE CreateBuf(VAR buf: NameList); + BEGIN + NEW(buf); buf.next := NIL; + IF currentBuf # NIL THEN + currentBuf.next := buf; + END; + currentBuf := buf; + currentPos := 0; + END CreateBuf; + + PROCEDURE StringLength(string: ARRAY OF CHAR) : Types.Int32; + VAR + index: Types.Int32; + BEGIN + index := 0; + WHILE (index < LEN(string)) & (string[index] # 0X) DO + INC(index); + END; + RETURN index + END StringLength; + + PROCEDURE InitName(name: Type; string: ARRAY OF CHAR); + VAR + index, length: Types.Int32; + firstbuf, buf: NameList; + startpos: BufferPosition; + BEGIN + IF currentBuf = NIL THEN + CreateBuf(buf); + ELSE + buf := currentBuf; + END; + + firstbuf := buf; startpos := currentPos; + index := 0; + WHILE (index < LEN(string)) & (string[index] # 0X) DO + IF currentPos = bufsize THEN + CreateBuf(buf); + END; + buf.buffer[currentPos] := string[index]; INC(currentPos); + INC(index); + END; + length := index; + + name.hashval := Hash(string, length); + name.length := length; + name.begin := firstbuf; + name.pos := startpos; + name.next := bucket[name.hashval]; + bucket[name.hashval] := name; + END InitName; + + PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN; + (* precondition: both have the same length *) + VAR + index: Types.Int32; + buf: NameList; + pos: Types.Int32; + BEGIN + buf := name.begin; pos := name.pos; + index := 0; + WHILE index < name.length DO + IF pos = bufsize THEN + buf := buf.next; pos := 0; + END; + IF string[index] # buf.buffer[pos] THEN + RETURN FALSE + END; + INC(pos); + INC(index); + END; + RETURN TRUE + END EqualName; + + PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN; + VAR + length: Types.Int32; + hashval: HashValue; + p: Type; + BEGIN + length := StringLength(string); + hashval := Hash(string, length); + p := bucket[hashval]; + WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO + p := p.next; + END; + name := p; + RETURN p # NIL + END SeekName; + + PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR); + VAR + index: Types.Int32; + buf: NameList; + pos: Types.Int32; + BEGIN + buf := name.begin; pos := name.pos; + index := 0; + WHILE (index + 1 < LEN(string)) & (index < name.length) DO + IF pos = bufsize THEN + buf := buf.next; pos := 0; + END; + string[index] := buf.buffer[pos]; + INC(pos); + INC(index); + END; + string[index] := 0X; + END ExtractName; + + PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN; + BEGIN + IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN + RETURN loaderIF.loadModule(module) + ELSE + RETURN FALSE + END; + END LoadModule; + + PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN; + BEGIN + IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN + RETURN loaderIF.loadService(service, for) + ELSE + RETURN FALSE + END; + END LoadService; + + PROCEDURE MemberOf(list: ServiceList; service: Service; + VAR member: ServiceList) : BOOLEAN; + VAR + p: ServiceList; + BEGIN + p := list; + WHILE (p # NIL) & (p.service # service) DO + p := p.next; + END; + member := p; + RETURN p # NIL + END MemberOf; + + PROCEDURE SeekService(type: Type; service: Service; + VAR member: ServiceList; + VAR baseType: Type) : BOOLEAN; + + VAR + btype: Type; + cachedservice: ServiceList; + + PROCEDURE Seek(type: Type; service: Service; + VAR member: ServiceList) : BOOLEAN; + VAR + typeName: ARRAY 512 OF CHAR; + BEGIN + IF MemberOf(type.services, service, member) OR + MemberOf(type.cachedservices, service, member) THEN + RETURN TRUE + END; + ExtractName(type, typeName); + RETURN LoadService(service.name, typeName) & + MemberOf(type.services, service, member) + END Seek; + + BEGIN (* SeekService *) + btype := type; + WHILE (btype # NIL) & ~Seek(btype, service, member) DO + btype := btype.baseType; + END; + IF (member # NIL) & (btype # type) THEN + (* cache result to avoid further tries to load + a more fitting variant dynamically + *) + NEW(cachedservice); + cachedservice.service := service; + cachedservice.type := member.type; + cachedservice.install := member.install; + cachedservice.next := type.cachedservices; + type.cachedservices := cachedservice; + baseType := member.type; + RETURN TRUE + END; + IF member = NIL THEN + RETURN FALSE + ELSE + baseType := member.type; + RETURN TRUE + END; + END SeekService; + + PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); + (* get the name of the module where 'name' was defined *) + VAR + index: Types.Int32; + BEGIN + index := 0; + WHILE (name[index] # ".") & (name[index] # 0X) & + (index < LEN(module)-1) DO + module[index] := name[index]; INC(index); + END; + module[index] := 0X; + END GetModule; + + (* ==== exported procedures ========================================== *) + + PROCEDURE InitLoader*(if: LoaderInterface); + BEGIN + ASSERT((loaderIF = NIL) & (if # NIL)); + loaderIF := if; + END InitLoader; + + PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR); + VAR + baseType: Type; + otherType: Type; + ok: BOOLEAN; + BEGIN + IF baseName = "" THEN + baseType := NIL; + ELSE + ok := SeekName(baseName, baseType); ASSERT(ok); + END; + ASSERT(~SeekName(name, otherType)); + InitName(type, name); + type.baseType := baseType; + type.services := NIL; + type.cachedservices := NIL; + END InitType; + + PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR); + BEGIN + NEW(type); InitType(type, name, baseName); + END CreateType; + + PROCEDURE Init*(object: Object; type: Type); + BEGIN + ASSERT(type # NIL); + ASSERT(object.type = NIL); + object.type := type; + object.installed := NIL; + END Init; + + PROCEDURE GetType*(object: Object; VAR type: Type); + BEGIN + type := object.type; + END GetType; + + PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR); + BEGIN + ExtractName(type, name); + END GetTypeName; + + PROCEDURE GetBaseType*(type: Type; VAR baseType: Type); + BEGIN + baseType := type.baseType; + END GetBaseType; + + PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN; + BEGIN + ASSERT(baseType # NIL); + WHILE (type # NIL) & (type # baseType) DO + type := type.baseType; + END; + RETURN type = baseType + END IsExtensionOf; + + PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type); + VAR + module: ARRAY 64 OF CHAR; + BEGIN + IF ~SeekName(name, type) THEN + (* try to load the associated module *) + GetModule(name, module); + IF ~LoadModule(module) OR ~SeekName(name, type) THEN + type := NIL; + END; + END; + END SeekType; + + PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service); + BEGIN + service := services; + WHILE (service # NIL) & (service.name # name) DO + service := service.next; + END; + + (* try to load a module named after `name', if not successful *) + IF (service = NIL) & LoadModule(name) THEN + service := services; + WHILE (service # NIL) & (service.name # name) DO + service := service.next; + END; + END; + END Seek; + + PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR); + + PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN; + VAR + service: Service; + BEGIN + service := services; + WHILE (service # NIL) & (service.name # name) DO + service := service.next; + END; + RETURN service # NIL + END Created; + + BEGIN + ASSERT(~Created(name)); + NEW(service); + COPY(name, service.name); + service.next := services; services := service; + END Create; + + PROCEDURE Define*(type: Type; service: Service; install: InstallProc); + VAR + member: ServiceList; + BEGIN + ASSERT(service # NIL); + (* protect against multiple definitions: *) + ASSERT(~MemberOf(type.services, service, member)); + + NEW(member); member.service := service; + member.install := install; member.type := type; + member.next := type.services; type.services := member; + END Define; + + PROCEDURE Install*(object: Object; service: Service) : BOOLEAN; + VAR + member, installed: ServiceList; + baseType: Type; + BEGIN + IF object.type = NIL THEN RETURN FALSE END; + IF ~SeekService(object.type, service, member, baseType) THEN + (* service not supported for this object type *) + RETURN FALSE + END; + IF ~MemberOf(object.installed, service, installed) THEN + (* install services only once *) + IF member.install # NIL THEN + member.install(object, service); + END; + NEW(installed); + installed.service := service; + installed.next := object.installed; + object.installed := installed; + END; + RETURN TRUE + END Install; + + PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN; + VAR + member: ServiceList; + baseType: Type; + BEGIN + RETURN (object.type # NIL) & + SeekService(object.type, service, member, baseType) + END Supported; + + PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN; + VAR + member: ServiceList; + BEGIN + RETURN MemberOf(object.installed, service, member) + END Installed; + + PROCEDURE GetSupportedBaseType*(object: Object; service: Service; + VAR baseType: Type); + VAR + member: ServiceList; + BEGIN + IF ~SeekService(object.type, service, member, baseType) THEN + baseType := NIL; + END; + END GetSupportedBaseType; + +BEGIN + currentBuf := NIL; currentPos := 0; loaderIF := NIL; +END ulmServices. diff --git a/src/lib/ulm/ulmSets.Mod b/src/library/ulm/ulmSets.Mod similarity index 61% rename from src/lib/ulm/ulmSets.Mod rename to src/library/ulm/ulmSets.Mod index d70d21e9..a1dcd4df 100644 --- a/src/lib/ulm/ulmSets.Mod +++ b/src/library/ulm/ulmSets.Mod @@ -35,42 +35,43 @@ *) MODULE ulmSets; +IMPORT Types := ulmTypes; CONST - setsize* = MAX(SET) + 1; + setsize* = MAX(Types.Set) + 1; TYPE - CharSet* = ARRAY ORD(MAX(CHAR)) + 1 DIV setsize OF SET; + CharSet* = ARRAY (ORD(MAX(CHAR)) + 1) DIV setsize OF Types.Set; - PROCEDURE InitSet*(VAR set: ARRAY OF SET); - VAR i: LONGINT; + PROCEDURE InitSet*(VAR set: ARRAY OF Types.Set); + VAR i: Types.Int32; BEGIN i := 0; WHILE i < LEN(set) DO - set[i] := {}; INC(i); + set[i] := {}; INC(i); END; END InitSet; - PROCEDURE Complement*(VAR set: ARRAY OF SET); - VAR i: LONGINT; + PROCEDURE Complement*(VAR set: ARRAY OF Types.Set); + VAR i: Types.Int32; BEGIN i := 0; WHILE i < LEN(set) DO - set[i] := - set[i]; INC(i); + set[i] := - set[i]; INC(i); END; END Complement; - PROCEDURE In*(VAR set: ARRAY OF SET; i: LONGINT) : BOOLEAN; + PROCEDURE In*(VAR set: ARRAY OF Types.Set; i: Types.Int32) : BOOLEAN; BEGIN RETURN (i MOD setsize) IN set[i DIV setsize] END In; - PROCEDURE Incl*(VAR set: ARRAY OF SET; i: LONGINT); + PROCEDURE Incl*(VAR set: ARRAY OF Types.Set; i: Types.Int32); BEGIN INCL(set[i DIV setsize], i MOD setsize); END Incl; - PROCEDURE Excl*(VAR set: ARRAY OF SET; i: LONGINT); + PROCEDURE Excl*(VAR set: ARRAY OF Types.Set; i: Types.Int32); BEGIN EXCL(set[i DIV setsize], i MOD setsize); END Excl; @@ -90,117 +91,117 @@ MODULE ulmSets; EXCL(charset[ORD(ch) DIV setsize], ORD(ch) MOD setsize); END ExclChar; - PROCEDURE Intersection*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET); + PROCEDURE Intersection*(set1, set2: ARRAY OF Types.Set; VAR result: ARRAY OF Types.Set); VAR - index: INTEGER; + index: Types.Int32; BEGIN ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2))); index := 0; WHILE index < LEN(result) DO - result[index] := set1[index] * set2[index]; - INC(index); + result[index] := set1[index] * set2[index]; + INC(index); END; END Intersection; - PROCEDURE SymDifference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET); + PROCEDURE SymDifference*(set1, set2: ARRAY OF Types.Set; VAR result: ARRAY OF Types.Set); VAR - index: INTEGER; + index: Types.Int32; BEGIN ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2))); index := 0; WHILE index < LEN(result) DO - result[index] := set1[index] / set2[index]; - INC(index); + result[index] := set1[index] / set2[index]; + INC(index); END; END SymDifference; - PROCEDURE Union*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET); + PROCEDURE Union*(set1, set2: ARRAY OF Types.Set; VAR result: ARRAY OF Types.Set); VAR - index: INTEGER; + index: Types.Int32; BEGIN ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2))); index := 0; WHILE index < LEN(result) DO - result[index] := set1[index] + set2[index]; - INC(index); + result[index] := set1[index] + set2[index]; + INC(index); END; END Union; - PROCEDURE Difference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET); + PROCEDURE Difference*(set1, set2: ARRAY OF Types.Set; VAR result: ARRAY OF Types.Set); VAR - index: INTEGER; + index: Types.Int32; BEGIN ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2))); index := 0; WHILE index < LEN(result) DO - result[index] := set1[index] - set2[index]; - INC(index); + result[index] := set1[index] - set2[index]; + INC(index); END; END Difference; - PROCEDURE Equal*(set1, set2: ARRAY OF SET) : BOOLEAN; + PROCEDURE Equal*(set1, set2: ARRAY OF Types.Set) : BOOLEAN; VAR - index: INTEGER; + index: Types.Int32; BEGIN index := 0; WHILE (index < LEN(set1)) & (index < LEN(set2)) DO - IF set1[index] # set2[index] THEN - RETURN FALSE - END; - INC(index); + IF set1[index] # set2[index] THEN + RETURN FALSE + END; + INC(index); END; WHILE index < LEN(set1) DO - IF set1[index] # {} THEN - RETURN FALSE - END; - INC(index); + IF set1[index] # {} THEN + RETURN FALSE + END; + INC(index); END; WHILE index < LEN(set2) DO - IF set2[index] # {} THEN - RETURN FALSE - END; - INC(index); + IF set2[index] # {} THEN + RETURN FALSE + END; + INC(index); END; RETURN TRUE END Equal; - PROCEDURE Subset*(set1, set2: ARRAY OF SET) : BOOLEAN; + PROCEDURE Subset*(set1, set2: ARRAY OF Types.Set) : BOOLEAN; VAR - index: INTEGER; + index: Types.Int32; BEGIN index := 0; WHILE (index < LEN(set1)) & (index < LEN(set2)) DO - IF set1[index] - set2[index] # {} THEN - RETURN FALSE - END; - INC(index); + IF set1[index] - set2[index] # {} THEN + RETURN FALSE + END; + INC(index); END; WHILE index < LEN(set1) DO - IF set1[index] # {} THEN - RETURN FALSE - END; - INC(index); + IF set1[index] # {} THEN + RETURN FALSE + END; + INC(index); END; RETURN TRUE END Subset; - PROCEDURE Card*(set: ARRAY OF SET) : INTEGER; + PROCEDURE Card*(set: ARRAY OF Types.Set) : Types.Int32; VAR - index: INTEGER; - i: INTEGER; - card: INTEGER; + index: Types.Int32; + i: Types.Int32; + card: Types.Int32; BEGIN card := 0; index := 0; WHILE index < LEN(set) DO - i := 0; - WHILE i <= MAX(SET) DO - IF i IN set[index] THEN - INC(card); - END; - INC(i); - END; - INC(index); + i := 0; + WHILE i <= MAX(Types.Set) DO + IF i IN set[index] THEN + INC(card); + END; + INC(i); + END; + INC(index); END; RETURN card END Card; diff --git a/src/lib/ulm/ulmStreamConditions.Mod b/src/library/ulm/ulmStreamConditions.Mod similarity index 99% rename from src/lib/ulm/ulmStreamConditions.Mod rename to src/library/ulm/ulmStreamConditions.Mod index 794b3cb1..9e7f5712 100644 --- a/src/lib/ulm/ulmStreamConditions.Mod +++ b/src/library/ulm/ulmStreamConditions.Mod @@ -115,6 +115,7 @@ MODULE ulmStreamConditions; | write: IF Streams.OutputWillBeBuffered(condition.stream) THEN RETURN TRUE END; + ELSE END; msg.operation := condition.operation; msg.errors := errors; diff --git a/src/library/ulm/ulmStreamDisciplines.Mod b/src/library/ulm/ulmStreamDisciplines.Mod new file mode 100644 index 00000000..32f56bfe --- /dev/null +++ b/src/library/ulm/ulmStreamDisciplines.Mod @@ -0,0 +1,249 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: StreamDisci.om,v $ + Revision 1.2 1994/07/04 14:53:25 borchert + parameter for indentation width added + + Revision 1.1 1994/02/22 20:10:34 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 10/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmStreamDisciplines; + + (* definition of general-purpose disciplines for streams *) + + IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM, Types := ulmTypes; + + TYPE + LineTerminator* = ARRAY 4 OF CHAR; + VAR + badfieldsepset*: Events.EventType; + + TYPE + StreamDiscipline = POINTER TO StreamDisciplineRec; + StreamDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + lineterm: LineTerminator; + fieldseps: Sets.CharSet; + fieldsep: CHAR; (* one of them *) + whitespace: Sets.CharSet; + indentwidth: Types.Int32; + END; + + VAR + id: Disciplines.Identifier; + (* default values *) + defaultFieldSeps: Sets.CharSet; + defaultFieldSep: CHAR; + defaultLineTerm: LineTerminator; + defaultWhiteSpace: Sets.CharSet; + defaultIndentWidth: Types.Int32; + + PROCEDURE InitDiscipline(VAR disc: Disciplines.Discipline); + VAR + sdisc: StreamDiscipline; + BEGIN + NEW(sdisc); sdisc.id := id; + sdisc.fieldseps := defaultFieldSeps; + sdisc.fieldsep := defaultFieldSep; + sdisc.lineterm := defaultLineTerm; + sdisc.whitespace := defaultWhiteSpace; + sdisc.indentwidth := defaultIndentWidth; + disc := sdisc + END InitDiscipline; + + PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).lineterm := lineterm; + Disciplines.Add(s, disc); + END SetLineTerm; + + PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator); + (* default line terminator is ASCII.nl *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + lineterm := disc(StreamDiscipline).lineterm; + ELSE + lineterm := defaultLineTerm; + END; + END GetLineTerm; + + PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet); + (* cardinality of fieldsepset must be >= 1 *) + VAR + disc: Disciplines.Discipline; + ch: CHAR; found: BOOLEAN; + fieldsep: CHAR; + event: Events.Event; + BEGIN + ch := 0X; + LOOP (* seek for the first element inside fieldsepset *) + IF Sets.CharIn(fieldsepset, ch) THEN + found := TRUE; fieldsep := ch; EXIT + END; + IF ch = MAX(CHAR) THEN + found := FALSE; EXIT + END; + ch := CHR(ORD(ch) + 1); + END; + IF ~found THEN + NEW(event); + event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset"; + event.type := badfieldsepset; + Events.Raise(event); + RETURN + END; + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).fieldseps := fieldsepset; + disc(StreamDiscipline).fieldsep := fieldsep; + Disciplines.Add(s, disc); + END SetFieldSepSet; + + PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet); + (* default field separators are ASCII.tab and ASCII.sp *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + fieldsepset := disc(StreamDiscipline).fieldseps; + ELSE + fieldsepset := defaultFieldSeps; + END; + END GetFieldSepSet; + + PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + Sets.InclChar(disc(StreamDiscipline).fieldseps, fieldsep); + disc(StreamDiscipline).fieldsep := fieldsep; + Disciplines.Add(s, disc); + END SetFieldSep; + + PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR); + (* default field separator is ASCII.tab; + if a set of field separators has been given via SetFieldSepSet, + one of them is returned + *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + fieldsep := disc(StreamDiscipline).fieldsep; + ELSE + fieldsep := defaultFieldSep; + END; + END GetFieldSep; + + PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet); + (* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + whitespace := disc(StreamDiscipline).whitespace; + ELSE + whitespace := defaultWhiteSpace; + END; + END GetWhiteSpace; + + PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).whitespace := whitespace; + Disciplines.Add(s, disc); + END SetWhiteSpace; + + PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: Types.Int32); + VAR + disc: Disciplines.Discipline; + BEGIN + IF indentwidth >= 0 THEN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).indentwidth := indentwidth; + Disciplines.Add(s, disc); + END; + END SetIndentationWidth; + + PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: Types.Int32); + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + indentwidth := disc(StreamDiscipline).indentwidth; + ELSE + indentwidth := defaultIndentWidth; + END; + END GetIndentationWidth; + + PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: Types.Int32); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + IF disc(StreamDiscipline).indentwidth + incr >= 0 THEN + INC(disc(StreamDiscipline).indentwidth, incr);; + END; + Disciplines.Add(s, disc); + END IncrIndentationWidth; + +BEGIN + Events.Define(badfieldsepset); + + id := Disciplines.Unique(); + Sets.InitSet(defaultFieldSeps); + Sets.InclChar(defaultFieldSeps, ASCII.tab); + Sets.InclChar(defaultFieldSeps, ASCII.sp); + defaultFieldSep := ASCII.tab; + defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X; + Sets.InitSet(defaultWhiteSpace); + Sets.InclChar(defaultWhiteSpace, ASCII.tab); + Sets.InclChar(defaultWhiteSpace, ASCII.sp); + Sets.InclChar(defaultWhiteSpace, ASCII.np); + Sets.InclChar(defaultWhiteSpace, ASCII.nl); + defaultIndentWidth := 0; +END ulmStreamDisciplines. diff --git a/src/library/ulm/ulmStreams.Mod b/src/library/ulm/ulmStreams.Mod new file mode 100644 index 00000000..37f25dfd --- /dev/null +++ b/src/library/ulm/ulmStreams.Mod @@ -0,0 +1,2150 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-2001 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Streams.om,v 1.13 2005/02/14 23:36:35 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Streams.om,v $ + Revision 1.13 2005/02/14 23:36:35 borchert + bug fix: WritePart called InternalFlush without considering + that s.pos may be implicitly changed + (this assumption was wrong since revision 1.11) + + Revision 1.12 2004/05/20 09:52:43 borchert + performance improvements: + - WritePart and Write take now the buffer by reference + - ReadByteFromBuf replaced by ReadBytesFromBuf + (contributed by Christian Ehrhardt) + + Revision 1.11 2001/05/03 15:17:58 borchert + InternalFlush adapted for unidirectional pipelines to avoid + unintentional flushes due to buffer boundaries + + Revision 1.10 2000/04/25 21:41:47 borchert + Streams.ReadPart loops now for unbuffered streams to collect input + until cnt is reached + + Revision 1.9 1998/03/31 11:13:05 borchert + bug fix: NotificationHandler just reacted on Resources.unreferenced + but not on Resources.terminated + + Revision 1.8 1998/03/24 22:58:28 borchert + bug fix in Copy: left was computed incorrectly in case of + copies with fixed length (# -1) + + Revision 1.7 1997/04/02 07:50:05 borchert + Copy replaced by a slightly more efficient variant + + Revision 1.6 1996/09/18 07:43:51 borchert + qualified references to own module (i.e. Streams.XXX) removed + + Revision 1.5 1996/01/04 16:43:57 borchert + some bug fixes in the updates of read and write regions + + Revision 1.4 1995/10/11 09:46:41 borchert + - closeEvent re-introduced (because it gets raised *before* + the actual close) + - bug fix: s.write was diminished in ReadPart but the write region + not properly adjusted + - bug fix: InternalSeek was setting s.left to negative values in + a special case + + Revision 1.3 1995/04/18 12:17:12 borchert + - Streams.Stream is now an extension of Services.Object + - Library variant of assertions replaced by ASSERT + - support of Resources added + - EnableClose, PreventClose & closeEvent removed + + Revision 1.2 1994/07/05 12:45:57 borchert + some minor bug fixes & enhancements: + - ReadPacket added + - streams which don't require cleanup are now subject to the GC + even if Close will never be called for them + - line buffered streams w/o bufio/addrio capability fill now buffer + up to the next line terminator only instead of trying to fill the + whole buffer + - ReadPart didn't set count correctly in all cases + - Touch calls now the flush interface procedure + + Revision 1.1 1994/02/22 20:10:45 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 6/89 + Major Revision: AFB 1/92: bufpool + ---------------------------------------------------------------------------- +*) + +MODULE ulmStreams; + + IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Resources := ulmResources, + Services := ulmServices, SYS := ulmSYSTEM, SYSTEM, Types := ulmTypes; + + CONST + (* 3rd parameter of Seek *) + (* Whence = (fromStart, fromPos, fromEnd); *) + fromStart* = 0; fromPos* = 1; fromEnd* = 2; + + (* capabilities of a stream *) + (* Capability = (read, write, addrio, bufio, seek, tell, trunc, close, + holes, handler); + *) + read* = 0; write* = 1; addrio* = 2; bufio* = 3; seek* = 4; tell* = 5; + trunc* = 6; flush* = 7; close* = 8; holes* = 9; handler* = 10; + + (* BufMode = (nobuf, linebuf, onebuf, bufpool); *) + nobuf* = 0; linebuf* = 1; onebuf* = 2; bufpool* = 3; + + (* ErrorCode = (NoHandlerDefined, CannotRead, CannotSeek, CloseFailed, + NotLineBuffered, SeekFailed, TellFailed, BadWhence, + CannotTell, WriteFailed, CannotWrite, ReadFailed, + Unbuffered, BadParameters, CannotTrunc, TruncFailed, + NestedCall, FlushFailed); + *) + NoHandlerDefined* = 0; (* no handler defined *) + CannotRead* = 1; (* stream is write only *) + CannotSeek* = 2; (* stream is not capable of seeking *) + CloseFailed* = 3; (* Flush or Close failed *) + NotLineBuffered* = 4; (* LineTerm must not be called *) + SeekFailed* = 5; (* seek operation failed *) + TellFailed* = 6; (* tell operation failed *) + BadWhence* = 7; (* whence value out of [fromStart..fromEnd] *) + CannotTell* = 8; (* stream does not have a current position *) + WriteFailed* = 9; (* write error *) + CannotWrite* = 10; (* stream is read only *) + ReadFailed* = 11; (* read error *) + Unbuffered* = 12; (* operation isn't valid for unbuff'd streams *) + BadParameters* = 13; (* e.g. wrong count or offset values *) + CannotTrunc* = 14; (* stream is not capable of truncating *) + TruncFailed* = 15; (* trunc operation failed *) + NestedCall* = 16; (* nested stream operation *) + FlushFailed* = 17; (* flush operation failed *) + errorcodes* = 18; (* number of error codes *) + + (* === private constants ======================================= *) + bufsize = 8192; (* should be the file system block size *) + defaulttermch = 0AX; (* default line terminator (for linebuf) *) + + TYPE + Address* = Types.Address; + Count* = Types.Count; + Byte* = Types.Byte; + Whence* = Types.Int8; (* Whence = (fromStart, fromPos, fromEnd); *) + CapabilitySet* = Types.Set; (* OF Capability; *) + BufMode* = Types.Int8; + ErrorCode* = Types.Int8; + Stream* = POINTER TO StreamRec; + Message* = RECORD (Objects.ObjectRec) END; + + (* the buffering system: + + buffers are always on bufsize-boundaries + + ok: the other components are defined + pos: file position of cont[0] (pos MOD bufsize = 0) + cont: valid data: cont[rbegin]..cont[rend-1] (read-region) + written data: cont[wbegin]..cont[wend-1] (write-region) + + both regions are maintained (even for non-rw streams) + *) + Buffer = POINTER TO BufferRec; + BufferRec = + RECORD + ok: BOOLEAN; (* TRUE if other components are valid *) + pos: Count; (* file position which corresponds to cont[0] *) + rbegin: Count; (* read-region: starting index *) + rend: Count; (* read-region: ending index *) + wbegin: Count; (* write-region: starting index of dirty region *) + wend: Count; (* write-region: ending index *) + cont: ARRAY bufsize OF Byte; (* buffer contents *) + nextfree: Buffer; (* only needed for released buffers *) + (* components for buffers which are members of a buffer pool *) + prevh, nexth: Buffer; (* next buffer with same the hash value *) + preva, nexta: Buffer; (* sorted list of buffers (access time) *) + END; + + CONST + hashtabsize = 128; (* size of bucket table *) + TYPE + BucketTable = ARRAY hashtabsize OF Buffer; + BufferPool = POINTER TO BufferPoolRec; + BufferPoolRec = + RECORD + maxbuf: Types.Int32; (* maximal number of buffers to be used *) + nbuf: Types.Int32; (* number of buffers in use *) + bucket: BucketTable; + (* list of all buffers sorted after the last access time; + tail points to the buffer most recently accessed + *) + head, tail: Buffer; + END; + + TYPE + AddrIOProc* = PROCEDURE (s: Stream; ptr: Address; cnt: Count) : Count; + BufIOProc* = PROCEDURE (s: Stream; VAR buf: ARRAY OF Byte; + off, cnt: Count) : Count; + SeekProc* = PROCEDURE (s: Stream; cnt: Count; whence: Whence) : BOOLEAN; + TellProc* = PROCEDURE (s: Stream; VAR cnt: Count) : BOOLEAN; + ReadProc* = PROCEDURE (s: Stream; VAR byte: Byte) : BOOLEAN; + WriteProc* = PROCEDURE (s: Stream; byte: Byte) : BOOLEAN; + TruncProc* = PROCEDURE (s: Stream; cnt: Count) : BOOLEAN; + FlushProc* = PROCEDURE (s: Stream) : BOOLEAN; + CloseProc* = PROCEDURE (s: Stream) : BOOLEAN; + HandlerProc* = PROCEDURE (s: Stream; VAR msg: Message); + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + addrread*: AddrIOProc; (* read, addrio *) + addrwrite*: AddrIOProc; (* write, addrio *) + bufread*: BufIOProc; (* read, bufio *) + bufwrite*: BufIOProc; (* write, bufio *) + read*: ReadProc; (* read *) + write*: WriteProc; (* write *) + seek*: SeekProc; (* seek *) + tell*: TellProc; (* tell *) + trunc*: TruncProc; (* trunc *) + flush*: FlushProc; (* flush *) + close*: CloseProc; (* close *) + handler*: HandlerProc; (* handler *) + END; + + StreamRec* = + RECORD + (Services.ObjectRec) + (* following components are set after i/o-operations *) + count*: Count; (* resulting count of last operation *) + errors*: Types.Int32; (* incremented for each error; may be set to 0 *) + error*: BOOLEAN; (* last operation successful? *) + lasterror*: ErrorCode; (* error code of last error *) + eof*: BOOLEAN; (* last read-operation with count=0 returned *) + (* === private part ============================================ *) + prev, next: Stream; (* list of open streams *) + if: Interface; caps: CapabilitySet; + bufmode: BufMode; (* buffering mode *) + bidirect: BOOLEAN; (* bidirectional buffering? *) + termch: Byte; (* flush on termch (linebuf only) *) + inlist: BOOLEAN; (* member of the list of opened streams? *) + tiedStream: Stream; (* to be flushed before read operations *) + buf: Buffer; (* current buffer; = NIL for unbuffered streams *) + wbuf: Buffer; (* buffer for writing (only if bidirect = TRUE) *) + bufpool: BufferPool; (* only if bufmode = bufpool *) + validpos: BOOLEAN; (* pos valid? *) + pos: Count; (* current position in stream *) + maxpos: Count; (* maximal position until now (only if buf # NIL) *) + left: Count; (* number of bytes left in buf (after pos) *) + write: Count; (* number of bytes which can be written in buf *) + rpos: Count; (* current position of if.tell *) + wextensible: BOOLEAN; (* write region extensible? *) + eofFound: BOOLEAN; (* eof seen yet? temporary use only *) + lock: BOOLEAN; (* avoid recursive operations *) + flushEvent: Events.EventType; (* valid if # NIL *) + closeEvent: Events.EventType; (* valid if # NIL *) + END; + VAR + type: Services.Type; + + TYPE + (* each error causes an event; + the error number is stored in event.errorcode; + the associated text can be taken from event.message + *) + Event* = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + stream*: Stream; + errorcode*: ErrorCode; + END; + + VAR + null*: Stream; (* accepts any output; does not return input *) + (* these streams are set by other modules; + after initialization of Streams they equal `null'; + so, connections with the standard UNIX streams must be + done by other modules + *) + stdin*, stdout*, stderr*: Stream; + errormsg*: ARRAY errorcodes OF Events.Message; + error*: Events.EventType; + + (* === private variables ========================================== *) + + opened: Stream; (* list of opened streams *) + (* this list has been reduced to the set of streams which + need to be cleaned up explicitly; + all other streams are subject to the garbage collection + even if Close has never been called for them + *) + freelist: Buffer; (* list of free buffers *) + nullif: Interface; (* interface of null-devices *) + + (* === private procedures ========================================= *) + + PROCEDURE NewStream(s: Stream); + BEGIN + IF s.inlist THEN + s.prev := NIL; + s.next := opened; + IF opened # NIL THEN + opened.prev := s; + END; + opened := s; + END; + END NewStream; + + PROCEDURE OldStream(s: Stream); + BEGIN + IF s.inlist THEN + IF s.prev # NIL THEN + s.prev.next := s.next; + ELSE + opened := s.next; + END; + IF s.next # NIL THEN + s.next.prev := s.prev; + END; + END; + END OldStream; + + PROCEDURE NewBuffer(VAR b: Buffer); + BEGIN + IF freelist # NIL THEN + b := freelist; + freelist := freelist.nextfree; + ELSE + NEW(b); + END; + b.nextfree := NIL; + b.ok := FALSE; + END NewBuffer; + + PROCEDURE OldBuffer(VAR b: Buffer); + BEGIN + b.nextfree := freelist; + freelist := b; + b := NIL; + END OldBuffer; + + PROCEDURE Error(s: Stream; code: ErrorCode); + VAR + event: Event; + BEGIN + IF s # NIL THEN + INC(s.errors); + s.error := TRUE; + s.lasterror := code; + + (* generate error event *) + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.stream := s; + event.errorcode := code; + RelatedEvents.Raise(s, event); + END; + END Error; + + PROCEDURE ^ InternalFlush(s: Stream) : BOOLEAN; + + (* ===== management of buffer pool ================================== *) + + PROCEDURE InitBufPool(s: Stream); + VAR + index: Types.Int32; + BEGIN + s.bufpool.maxbuf := 16; (* default size *) + s.bufpool.nbuf := 0; (* currently, no buffers are allocated *) + s.bufpool.head := NIL; s.bufpool.tail := NIL; + index := 0; + WHILE index < hashtabsize DO + s.bufpool.bucket[index] := NIL; + INC(index); + END; + END InitBufPool; + + PROCEDURE HashValue(pos: Count) : Types.Int32; + (* HashValue returns a hash value for pos *) + BEGIN + RETURN SHORT(pos DIV bufsize) MOD hashtabsize + END HashValue; + + PROCEDURE FindBuffer(s: Stream; pos: Count; VAR buf: Buffer) : BOOLEAN; + VAR + index: Types.Int32; + bp: Buffer; + BEGIN + index := HashValue(pos); + bp := s.bufpool.bucket[index]; + WHILE bp # NIL DO + IF bp.pos = pos THEN + buf := bp; RETURN TRUE + END; + bp := bp.nexth; (* next buffer with same hash value *) + END; + buf := NIL; + RETURN FALSE + END FindBuffer; + + PROCEDURE GetBuffer(s: Stream); + (* look for buffer for s.pos and make it to the current buffer; + set s.left and s.write in dependance of s.pos + *) + VAR + buf: Buffer; + pos: Count; (* buffer boundary for s.pos *) + posindex: Count; (* buf[posindex] corresponds to s.pos *) + index: Types.Int32; (* index into bucket table of the buffer pool *) + + PROCEDURE InitBuf(buf: Buffer); + VAR + index: Types.Int32; (* of bucket table *) + BEGIN + buf.ok := TRUE; + buf.pos := pos; + buf.rbegin := posindex; buf.rend := posindex; s.left := 0; + buf.wbegin := posindex; buf.wend := posindex; + s.write := bufsize - posindex; + buf.nextfree := NIL; + + (* insert buf into hash list *) + index := HashValue(pos); + buf.prevh := NIL; + buf.nexth := s.bufpool.bucket[index]; + IF buf.nexth # NIL THEN + buf.nexth.prevh := buf; + END; + s.bufpool.bucket[index] := buf; + + (* buf is already at the end of the sorted list if we + re-use an old buffer + *) + IF s.bufpool.tail # buf THEN + (* append buf to the sorted list *) + buf.nexta := NIL; + IF s.bufpool.tail = NIL THEN + s.bufpool.head := buf; + buf.preva := NIL; + ELSE + s.bufpool.tail.nexta := buf; + buf.preva := s.bufpool.tail; + END; + s.bufpool.tail := buf; + END; + END InitBuf; + + PROCEDURE UseBuffer(s: Stream; buf: Buffer); + (* make buf to the current buffer of s *) + BEGIN + IF s.buf # buf THEN + (* remove buf from sorted list *) + IF buf.preva # NIL THEN + buf.preva.nexta := buf.nexta; + ELSE + s.bufpool.head := buf.nexta; + END; + IF buf.nexta # NIL THEN + buf.nexta.preva := buf.preva; + ELSE + s.bufpool.tail := buf.preva; + END; + + (* append buf to sorted list *) + buf.nexta := NIL; + IF s.bufpool.tail = NIL THEN + s.bufpool.head := buf; + buf.preva := NIL; + ELSE + s.bufpool.tail.nexta := buf; + buf.preva := s.bufpool.tail; + END; + s.bufpool.tail := buf; + + (* set current buf of s to buf *) + s.buf := buf; + + (* update s.left and s.write *) + IF buf.rbegin = buf.rend THEN + buf.rbegin := posindex; buf.rend := posindex; s.left := 0; + ELSIF (posindex >= buf.rbegin) & (posindex < buf.rend) THEN + s.left := buf.rend - posindex; + ELSE + s.left := 0; + END; + IF buf.wbegin = buf.wend THEN + buf.wbegin := posindex; buf.wend := posindex; + s.write := bufsize - posindex; + ELSIF (posindex >= buf.wbegin) & (posindex < buf.wend) THEN + s.write := bufsize - posindex; + ELSE + s.write := 0; + END; + END; + END UseBuffer; + + BEGIN (* GetBuffer *) + posindex := s.pos MOD bufsize; + pos := s.pos - posindex; + + IF ~s.buf.ok THEN + (* init first allocated buffer which has not been used until now *) + InitBuf(s.buf); + INC(s.bufpool.nbuf); + ELSIF s.buf.pos # pos THEN + IF FindBuffer(s, pos, buf) THEN + UseBuffer(s, buf); + ELSE + IF s.bufpool.nbuf >= s.bufpool.maxbuf THEN + (* re-use already allocated buffer *) + buf := s.bufpool.head; + UseBuffer(s, buf); + IF buf.wbegin # buf.wend THEN + IF ~InternalFlush(s) THEN END; + END; + + (* remove buf from hash list *) + IF buf.prevh # NIL THEN + buf.prevh.nexth := buf.nexth; + ELSE + index := HashValue(buf.pos); + s.bufpool.bucket[index] := buf.nexth; + END; + IF buf.nexth # NIL THEN + buf.nexth.prevh := buf.prevh; + END; + + InitBuf(buf); + ELSE + (* allocate and initialize new buffer *) + NewBuffer(buf); + InitBuf(buf); + INC(s.bufpool.nbuf); + END; + s.buf := buf; + END; + END; + END GetBuffer; + + PROCEDURE FlushBufPool(s: Stream) : BOOLEAN; + VAR + buf: Buffer; + ok: BOOLEAN; + BEGIN + ok := TRUE; + IF s.bufpool.nbuf > 0 THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + s.buf := buf; + ok := InternalFlush(s) & ok; + buf := buf.nexta; + END; + END; + RETURN ok + END FlushBufPool; + + PROCEDURE ReleaseBufPool(s: Stream); + (* precondition: all buffers are flushed *) + VAR + buf: Buffer; + BEGIN + IF s.bufpool.nbuf > 0 THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + s.buf := buf; + OldBuffer(s.buf); + buf := buf.nexta; + END; + END; + NewBuffer(s.buf); + InitBufPool(s); + END ReleaseBufPool; + + (* ================================================================== *) + + PROCEDURE GetBufMode*(s: Stream) : BufMode; + BEGIN + RETURN s.bufmode + END GetBufMode; + + PROCEDURE LineTerm*(s: Stream; termch: Byte); + (* set line terminator of `s' (linebuf) to `termch' *) + BEGIN + s.error := FALSE; + IF s.bufmode = linebuf THEN + s.termch := termch; + ELSE + Error(s, NotLineBuffered); + END; + END LineTerm; + + PROCEDURE Tie*(in, out: Stream); + (* PRE: `in' is an line buffered input stream, + `out' an output stream, + and `in' # `out'; + causes `out' to be flushed before reading from `in'; + `out' may be NIL to undo the effect + *) + BEGIN + in.error := FALSE; + IF in.bufmode # linebuf THEN + Error(in, NotLineBuffered); RETURN + END; + IF (in = out) OR ~(read IN in.caps) OR + (out # NIL) & ~(write IN out.caps) THEN + Error(in, BadParameters); RETURN + END; + in.tiedStream := out; + END Tie; + + PROCEDURE SetBufferPoolSize*(s: Stream; nbuf: Types.Int32); + BEGIN + s.error := FALSE; + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN + END; + IF (s.bufmode = bufpool) & (nbuf >= 1) THEN + s.bufpool.maxbuf := nbuf; + END; + s.lock := FALSE; + END SetBufferPoolSize; + + PROCEDURE GetBufferPoolSize*(s: Stream; VAR nbuf: Types.Int32); + BEGIN + s.error := FALSE; + CASE s.bufmode OF + | nobuf: nbuf := 0; + | linebuf: nbuf := 1; + | onebuf: nbuf := 1; + | bufpool: nbuf := s.bufpool.maxbuf; + ELSE (* Explicitly ignore unhandled values of s.bufmode *) + END; + END GetBufferPoolSize; + + PROCEDURE Capabilities*(s: Stream) : CapabilitySet; + BEGIN + s.error := FALSE; + RETURN s.caps + END Capabilities; + + PROCEDURE GetFlushEvent*(s: Stream; VAR type: Events.EventType); + (* `type' will be raised BEFORE every flush operation *) + BEGIN + s.error := FALSE; + IF s.flushEvent = NIL THEN + Events.Define(s.flushEvent); + END; + type := s.flushEvent; + END GetFlushEvent; + + PROCEDURE GetCloseEvent*(s: Stream; VAR type: Events.EventType); + (* `type' will be raised BEFORE the stream gets closed; + that means write operations etc. are legal + *) + BEGIN + s.error := FALSE; + IF s.closeEvent = NIL THEN + Events.Define(s.closeEvent); + END; + type := s.closeEvent; + END GetCloseEvent; + + PROCEDURE Close*(s: Stream) : BOOLEAN; + VAR + event: Event; + type: Events.EventType; + otherStream: Stream; + BEGIN + s.error := FALSE; + + IF (s.closeEvent # NIL) & ~SYS.TAS(s.lock) THEN + type := s.closeEvent; s.closeEvent := NIL; + s.lock := FALSE; + Events.SetPriority(type, Events.GetPriority() + 1); + NEW(event); + event.type := type; + event.message := "close event of Streams"; + event.stream := s; + Events.Raise(event); + END; + + IF ~SYS.TAS(s.lock) THEN + IF write IN s.caps THEN + IF s.bufmode = bufpool THEN + IF ~FlushBufPool(s) THEN END; + ELSE + IF ~InternalFlush(s) THEN END; + END; + END; + IF close IN s.caps THEN + IF ~s.if.close(s) THEN + Error(s, CloseFailed); + END; + END; + IF s.buf # NIL THEN + IF s.bufmode = bufpool THEN + ReleaseBufPool(s); + END; + OldBuffer(s.buf); + END; + OldStream(s); + + (* check if this stream has been tied to another stream *) + otherStream := opened; + WHILE otherStream # NIL DO + IF otherStream.tiedStream = s THEN + otherStream.tiedStream := NIL; (* undo tie operation *) + END; + otherStream := otherStream.next; + END; + (* s.lock remains TRUE to prevent further operations *) + Resources.Notify(s, Resources.terminated); + RETURN ~s.error + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Close; + + PROCEDURE Release*(s: Stream); + BEGIN + IF ~Close(s) THEN END; + END Release; + + PROCEDURE CloseAll*; + BEGIN + WHILE opened # NIL DO + (* that's no endless loop; see Close/OldStream *) + Release(opened); + END; + END CloseAll; + + PROCEDURE NotificationHandler(event: Events.Event); + VAR + s: Stream; + BEGIN + IF ~(event IS Resources.Event) THEN RETURN END; + WITH event: Resources.Event DO + IF ~(event.resource IS Stream) THEN RETURN END; + s := event.resource(Stream); + IF event.change IN {Resources.unreferenced, Resources.terminated} THEN + IF ~s.lock THEN + Release(s); + END; + END; + END; + END NotificationHandler; + + PROCEDURE Init*(s: Stream; if: Interface; caps: CapabilitySet; + bufmode: BufMode); + + VAR + eventType: Events.EventType; + type: Services.Type; + + PROCEDURE InitBidirectionalBuffering(s: Stream); + BEGIN + s.validpos := TRUE; + s.pos := 0; + NewBuffer(s.wbuf); + s.buf.ok := TRUE; s.buf.rbegin := 0; s.buf.rend := 0; s.buf.pos := 0; + s.wbuf.ok := TRUE; s.wbuf.wbegin := 0; s.wbuf.wend := 0; + s.wbuf.pos := 0; + s.left := 0; s.write := bufsize; + END InitBidirectionalBuffering; + + BEGIN + ASSERT((s # NIL) & (if # NIL) & ({read, write} * caps # {})); + Services.GetType(s, type); ASSERT(type # NIL); + s.inlist := (close IN caps) OR (bufmode # nobuf) & (write IN caps); + NewStream(s); + (* initialize public part *) + s.count := 0; + s.errors := 0; + s.error := FALSE; + s.lasterror := 0; + s.eof := FALSE; + (* private part *) + s.if := if; s.caps := caps; + s.bufmode := bufmode; + s.validpos := FALSE; + s.left := 0; s.write := 0; + s.tiedStream := NIL; + IF bufmode IN {linebuf, onebuf, bufpool} THEN + NewBuffer(s.buf); + IF (bufmode = bufpool) & ~(seek IN caps) THEN + bufmode := onebuf; + END; + CASE bufmode OF + | linebuf: s.termch := defaulttermch; + | bufpool: NEW(s.bufpool); InitBufPool(s); + ELSE + END; + s.maxpos := 0; + s.wextensible := {read, write, seek, tell, holes} * caps = + {read, write, seek, tell}; + s.bidirect := {read, write, seek, tell, trunc} * caps = {read, write}; + IF s.bidirect THEN + InitBidirectionalBuffering(s); + ELSE + s.wbuf := NIL; + END; + ELSE + s.buf := NIL; + s.wbuf := NIL; + s.wextensible := FALSE; + s.bidirect := FALSE; + END; + s.flushEvent := NIL; + s.closeEvent := NIL; + Resources.TakeInterest(s, eventType); + Events.Handler(eventType, NotificationHandler); + s.lock := FALSE; + END Init; + + PROCEDURE Send*(s: Stream; VAR message: Message); + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF handler IN s.caps THEN + s.if.handler(s, message); + ELSE + Error(s, NoHandlerDefined); + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + END Send; + + (* === private i/o procedures ================================= *) + + PROCEDURE ValidPos(s: Stream); + BEGIN + IF ~s.validpos THEN + IF tell IN s.caps THEN + IF ~s.if.tell(s, s.pos) OR (s.pos < 0) THEN + Error(s, TellFailed); + s.pos := 0; + END; + ELSE + s.pos := 0; + END; + s.rpos := s.pos; + s.validpos := TRUE; + s.left := 0; + s.write := 0; + END; + END ValidPos; + + PROCEDURE InitBuf(s: Stream); + BEGIN + IF s.bufmode = bufpool THEN + GetBuffer(s); + ELSE + s.buf.pos := s.pos - s.pos MOD bufsize; + s.buf.wbegin := s.pos MOD bufsize; + s.write := bufsize - s.buf.wbegin; + s.buf.wend := s.buf.wbegin; + s.buf.rbegin := s.buf.wbegin; + s.buf.rend := s.buf.wbegin; + s.left := 0; + s.buf.ok := TRUE; + END; + END InitBuf; + + PROCEDURE FillBuf(s: Stream) : BOOLEAN; + (* return FALSE on EOF or errors *) + VAR + offset, count: Count; + posindex: Count; (* s.pos MOD bufsize *) + + PROCEDURE Fill(s: Stream; VAR offset, count: Count) : BOOLEAN; + (* try to fill buf.cont[offset]..buf.cont[offset+count-1]; + return FALSE on EOF; + Fill always extends a read region: + s.buf.rend is set to offset + the number of bytes read + *) + VAR + linetermseen: BOOLEAN; + byte: Byte; + BEGIN + IF s.eofFound THEN + RETURN FALSE + END; + IF addrio IN s.caps THEN + s.buf.rend := s.if.addrread(s, SYSTEM.ADR(s.buf.cont[offset]), count) + + offset; + ELSIF bufio IN s.caps THEN + s.buf.rend := s.if.bufread(s, s.buf.cont, offset, count) + offset; + ELSIF s.bufmode = linebuf THEN + s.buf.rend := offset; linetermseen := FALSE; + WHILE ~linetermseen & (s.buf.rend < offset+count) & + s.if.read(s, byte) DO + s.buf.cont[s.buf.rend] := byte; INC(s.buf.rend); + linetermseen := byte = s.termch; + END; + s.eofFound := ~linetermseen & + (s.buf.rend < offset+count); (* s.if.read failed? *) + ELSE + s.buf.rend := offset; + WHILE (s.buf.rend < offset+count) & + s.if.read(s, s.buf.cont[s.buf.rend]) DO + INC(s.buf.rend); + END; + s.eofFound := s.buf.rend < offset+count; (* s.if.read failed? *) + END; + (* negative counts of addrread or bufread indicate read errors *) + IF s.buf.rend < offset THEN + (* note error and recover s.buf.rend *) + Error(s, ReadFailed); + s.buf.rend := offset; + END; + INC(s.rpos, s.buf.rend - offset); + IF s.buf.rend > offset THEN + DEC(count, s.buf.rend - offset); + offset := s.buf.rend; + RETURN TRUE + ELSE + s.eofFound := TRUE; + RETURN FALSE + END; + END Fill; + + BEGIN (* FillBuf *) + ValidPos(s); + posindex := s.pos MOD bufsize; + s.eofFound := FALSE; + + (* flush associated output streams (line buffered streams only) *) + IF s.bufmode = linebuf THEN + IF write IN s.caps THEN + IF ~InternalFlush(s) THEN END; + END; + IF (s.tiedStream # NIL) & ~SYS.TAS(s.tiedStream.lock) THEN + IF ~InternalFlush(s.tiedStream) THEN END; + s.tiedStream.lock := FALSE; + END; + END; + + (* get a valid buffer and set + offset and count to the buffer range which is to be filled; + on default, we want to fill the whole buffer + *) + offset := 0; count := bufsize; (* default *) + IF ~s.buf.ok THEN + InitBuf(s); + ELSIF s.bidirect THEN + s.buf.rbegin := 0; s.buf.rend := 0; s.pos := 0; posindex := 0; + ELSE + IF s.bufmode = bufpool THEN + GetBuffer(s); + IF s.left > 0 THEN + (* buffer is already filled *) + s.eof := FALSE; RETURN TRUE + END; + ELSIF s.buf.pos # s.pos - posindex THEN + (* reuse filled buffer *) + IF write IN s.caps THEN + IF ~InternalFlush(s) THEN END; + END; + InitBuf(s); + END; + IF s.buf.rbegin # s.buf.rend THEN + IF (write IN s.caps) & + (s.buf.wbegin <= posindex) & (s.buf.wend > posindex) THEN + (* set read region to write region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.wend - posindex; + s.eof := FALSE; RETURN TRUE + ELSIF s.buf.rend = posindex THEN + (* stream position equals end of read region *) + offset := s.buf.rend; count := bufsize - offset; + END; + END; + + (* take care of the write region by limiting count; + note that s.pos does *not* point into the write region; + this is guaranteed by WritePart and other operations + which would have extended the read region in such a case + *) + IF (write IN s.caps) & (s.buf.wbegin # s.buf.wend) THEN + IF s.buf.wbegin >= offset THEN + IF s.buf.wbegin > posindex THEN + (* write-region behind current position *) + count := s.buf.wbegin - offset; + ELSE + (* write-region before current position *) + offset := s.buf.wend; count := bufsize - offset; + END; + END; + IF (s.buf.pos + s.buf.wbegin = s.rpos) & ~(seek IN s.caps) THEN + (* flush if the start of write region corresponds to real + file position and we are not able to change the position + *) + IF ~InternalFlush(s) THEN END; + END; + END; + END; + + (* set the real position to the position we want to read from *) + IF ~s.bidirect & (s.buf.pos + offset # s.rpos) THEN + IF (seek IN s.caps) & s.if.seek(s, s.buf.pos+offset, fromStart) THEN + s.rpos := s.buf.pos + offset; + ELSIF s.pos = s.rpos THEN + DEC(count, posindex - offset); + offset := posindex; + ELSIF seek IN s.caps THEN + Error(s, SeekFailed); RETURN FALSE + ELSE + Error(s, CannotSeek); RETURN FALSE + END; + END; + + (* try to fill buf[offset..offset+count-1]; + and set s.buf.rbegin & s.buf.rend to the new read region + *) + IF s.buf.rend # offset THEN + (* forget old read region if we cannot extend it *) + s.buf.rbegin := offset; s.buf.rend := offset; + END; + WHILE Fill(s, offset, count) & (posindex >= s.buf.rend) DO END; + + IF posindex >= s.buf.rend THEN + (* read operation failed *) + IF (s.pos > s.rpos) & + (seek IN s.caps) & s.if.seek(s, s.pos, fromStart) THEN + s.rpos := s.pos; + (* second try: we were not able to fill the whole buffer + but perhaps we are able to read what we were requested for + *) + DEC(count, posindex - offset); + offset := posindex; + s.buf.rbegin := offset; s.buf.rend := offset; + s.eofFound := FALSE; (* retry it *) + s.eof := ~Fill(s, offset, count); + ELSE + s.eof := TRUE; + END; + ELSE + s.eof := FALSE; + END; + + IF s.eof THEN + s.left := 0; + ELSE + s.left := s.buf.rend - posindex; + END; + + RETURN ~s.eof + END FillBuf; + + + (* ==== i/o operations ============================================== *) + + PROCEDURE ReadPart*(s: Stream; VAR buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* fill buf[off..off+cnt-1] *) + + VAR + pos: Count; + partcnt: Count; + + PROCEDURE ReadBytesFromBuf(s: Stream; + VAR to: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + VAR + bytes, max, spos: Count; + BEGIN + IF s.left = 0 THEN + IF s.eofFound OR ~FillBuf(s) THEN RETURN FALSE END; + END; + spos := s.pos MOD bufsize; + max := s.left; + IF max > cnt THEN + max := cnt; + END; + bytes := 0; + WHILE bytes < max DO + to[off] := s.buf.cont[spos]; + INC(off); INC(spos); INC(bytes); + END; + INC(s.pos, bytes); DEC(s.left, bytes); INC(s.count, bytes); + IF ~s.bidirect THEN + IF s.write >= bytes THEN + DEC(s.write, bytes); + ELSE + s.write := 0; + END; + END; + RETURN TRUE + END ReadBytesFromBuf; + + BEGIN (* ReadPart *) + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + RETURN FALSE + END; + s.error := FALSE; s.count := 0; + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); RETURN FALSE + ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); RETURN FALSE + END; + IF cnt = 0 THEN s.lock := FALSE; RETURN TRUE END; + IF s.buf # NIL THEN + s.eofFound := FALSE; + WHILE (s.count < cnt) & + ReadBytesFromBuf(s, buf, s.count + off, cnt - s.count) DO + (* s.count is already incremented by ReadBytesFromBuf *) + END; + (* extend write region, if necessary *) + IF ~s.bidirect THEN + pos := s.pos MOD bufsize; + IF (s.write > 0) & (s.buf.wend < pos) THEN + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; + END; + s.buf.wend := pos; + END; + END; + ELSE + IF addrio IN s.caps THEN + s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), cnt); + IF (s.count > 0) & (s.count < cnt) THEN + LOOP + partcnt := s.if.addrread(s, + SYSTEM.ADR(buf[off + s.count]), cnt - s.count); + IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; + ASSERT(partcnt <= cnt - s.count); + INC(s.count, partcnt); + IF s.count = cnt THEN EXIT END; + END; + END; + ELSIF bufio IN s.caps THEN + s.count := s.if.bufread(s, buf, off, cnt); + IF (s.count > 0) & (s.count < cnt) THEN + LOOP + partcnt := s.if.bufread(s, buf, off + s.count, cnt - s.count); + IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; + ASSERT(partcnt <= cnt - s.count); + INC(s.count, partcnt); + IF s.count = cnt THEN EXIT END; + END; + END; + ELSE + s.count := 0; + WHILE (s.count < cnt) & s.if.read(s, buf[s.count+off]) DO + INC(s.count); + END; + END; + IF s.count < 0 THEN + s.count := 0; + Error(s, ReadFailed); + ELSE + s.eof := s.count = 0; + END; + END; + s.lock := FALSE; + RETURN s.count = cnt + END ReadPart; + + PROCEDURE Read*(s: Stream; VAR buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN ReadPart(s, buf, 0, LEN(buf)) + END Read; + + PROCEDURE ReadByte*(s: Stream; VAR byte: Byte) : BOOLEAN; + VAR + ok: BOOLEAN; + pos: Count; + BEGIN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN FALSE + END; + s.error := FALSE; + IF s.left = 0 THEN + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN FALSE + END; + IF s.buf # NIL THEN + IF ~FillBuf(s) THEN + (* FillBuf sets s.eof *) + s.lock := FALSE; + s.count := 0; + RETURN FALSE + END; + ELSE + ok := s.if.read(s, byte); + IF ok THEN + s.count := 1; + ELSE + s.count := 0; + END; + s.eof := ~ok; + s.lock := FALSE; + RETURN ok + END; + END; + (* s.left > 0 *) + s.count := 1; + byte := s.buf.cont[s.pos MOD bufsize]; + INC(s.pos); DEC(s.left); + IF ~s.bidirect & (s.write # 0) THEN + DEC(s.write); + pos := s.pos MOD bufsize; + IF s.buf.wend < pos THEN + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; + END; + s.buf.wend := pos; + END; + END; + (* s.eof has been set by FillBuf *) + s.lock := FALSE; + RETURN TRUE + END ReadByte; + + PROCEDURE ReadPacket*(s: Stream; VAR buf: ARRAY OF Byte; + off, maxcnt: Count) : Count; + (* fill buf[off..] with next packet *) + BEGIN + IF s.left > 0 THEN + IF maxcnt > s.left THEN + maxcnt := s.left; + END; + IF ReadPart(s, buf, off, maxcnt) THEN END; + RETURN s.count + END; + + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + s.count := 0; + RETURN 0 + END; + s.error := FALSE; s.count := 0; + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN 0 + ELSIF (off < 0) OR (off+maxcnt > LEN(buf)) OR (maxcnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); s.count := 0; RETURN 0 + END; + IF maxcnt = 0 THEN s.lock := FALSE; RETURN 0 END; + + IF s.buf # NIL THEN + (* s.left = 0 *) + IF ~FillBuf(s) THEN + (* FillBuf sets s.eof *) + s.lock := FALSE; + RETURN 0 + END; + s.lock := FALSE; + IF maxcnt > s.left THEN + maxcnt := s.left; + END; + IF ReadPart(s, buf, off, maxcnt) THEN END; + RETURN s.count + END; + + (* s.buf = NIL *) + IF addrio IN s.caps THEN + s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), maxcnt); + ELSIF bufio IN s.caps THEN + s.count := s.if.bufread(s, buf, off, maxcnt); + ELSE + s.count := 0; + WHILE (s.count < maxcnt) & s.if.read(s, buf[s.count+off]) DO + INC(s.count); + END; + END; + IF s.count < 0 THEN + s.count := 0; + Error(s, ReadFailed); + ELSE + s.eof := s.count = 0; + END; + s.lock := FALSE; + RETURN s.count + END ReadPacket; + + PROCEDURE WritePart*(s: Stream; + (* read-only *) VAR buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* write buf[off..off+cnt-1] to s *) + VAR + posindex: Count; + + PROCEDURE NewBuffer(s: Stream) : BOOLEAN; + (* flush and get new buffer *) + BEGIN + IF s.pos - posindex # s.buf.pos THEN + IF s.bufmode # bufpool THEN + IF ~InternalFlush(s) THEN RETURN FALSE END; + END; + InitBuf(s); + IF s.write # 0 THEN RETURN TRUE END; + END; + IF s.buf.wbegin = s.buf.wend THEN + (* nothing written into this buffer until now *) + s.buf.wbegin := posindex; s.buf.wend := posindex; + s.write := bufsize - posindex; + ELSIF s.wextensible & (s.buf.rbegin # s.buf.rend) THEN + (* check if the write region may be extended + over parts of the read region + *) + IF s.buf.wend < posindex THEN + (* write region before current position *) + IF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend >= posindex) THEN + s.buf.wend := posindex; + s.write := bufsize - posindex; + END; + ELSE (* s.wbegin > posindex *) + (* write region after current position *) + IF (s.buf.rbegin <= posindex) & (s.buf.rend >= s.buf.wbegin) THEN + s.buf.wbegin := posindex; + s.write := bufsize - posindex; + END; + END; + END; + IF (* still *) s.write = 0 THEN + (* Flush necessary *) + IF ~InternalFlush(s) THEN RETURN FALSE END; + s.buf.wbegin := posindex; s.buf.wend := posindex; + s.write := bufsize - posindex; + END; + RETURN TRUE + END NewBuffer; + + PROCEDURE UpdateReadRegion(s: Stream); + BEGIN + (* update s.left and extend read region, if possible *) + IF s.buf.rbegin = s.buf.rend THEN + (* set read region to write region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.rend - posindex; + ELSIF (s.buf.rbegin < s.buf.wbegin) & (s.buf.rend >= s.buf.wbegin) THEN + (* forward extension of read region possible *) + IF s.buf.rend < s.buf.wend THEN + s.buf.rend := s.buf.wend; + END; + s.left := s.buf.rend - posindex; + ELSIF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend > s.buf.wend) THEN + (* backward extension of read region possible *) + IF s.buf.rbegin > s.buf.wbegin THEN + s.buf.rbegin := s.buf.wend; + END; + s.left := s.buf.rend - posindex; + ELSE + (* posindex does not fall into [s.buf.rbegin..s.buf.rend-1] *) + s.left := 0; + END; + IF s.pos = s.buf.pos + bufsize THEN + s.left := 0; + END; + END UpdateReadRegion; + + BEGIN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN FALSE + END; + s.error := FALSE; s.count := 0; + IF ~(write IN s.caps) THEN + s.lock := FALSE; Error(s, CannotWrite); RETURN FALSE + ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); RETURN FALSE + ELSIF cnt = 0 THEN + s.lock := FALSE; RETURN TRUE + END; + + IF s.buf # NIL THEN + IF s.bidirect THEN + WHILE s.count < cnt DO + IF (s.write = 0) & ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + s.wbuf.cont[s.wbuf.wend] := buf[off + s.count]; + INC(s.wbuf.wend); INC(s.count); DEC(s.write); + IF (s.bufmode = linebuf) & + (buf[s.count+off-1] = s.termch) THEN + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + END; + END; + ELSE + ValidPos(s); + posindex := s.pos MOD bufsize; + IF ~s.buf.ok THEN + InitBuf(s); + END; + + (* copy from buf to s.buf *) + WHILE s.count < cnt DO + IF s.write = 0 THEN + posindex := s.pos MOD bufsize; + IF s.count > 0 THEN + UpdateReadRegion(s); + END; + IF ~NewBuffer(s) THEN + s.lock := FALSE; RETURN FALSE + END; + END; + s.buf.cont[posindex] := buf[off + s.count]; + IF s.buf.wend = posindex THEN + INC(s.buf.wend); + END; + INC(s.count); INC(s.pos); DEC(s.write); INC(posindex); + IF (s.bufmode = linebuf) & + (buf[s.count+off-1] = s.termch) THEN + UpdateReadRegion(s); + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + (* s.pos can be changed by InternalFlush *) + posindex := s.pos MOD bufsize; + END; + END; + UpdateReadRegion(s); + END; + ELSE (* unbuffered stream *) + IF addrio IN s.caps THEN + s.count := s.if.addrwrite(s, SYSTEM.ADR(buf[off]), cnt); + ELSIF bufio IN s.caps THEN + s.count := s.if.bufwrite(s, buf, off, cnt); + ELSE + s.count := 0; + WHILE (s.count < cnt) & s.if.write(s, buf[off+s.count]) DO + INC(s.count); + END; + END; + IF s.count # cnt THEN + Error(s, WriteFailed); + END; + END; + s.lock := FALSE; + RETURN s.count = cnt + END WritePart; + + PROCEDURE Write*(s: Stream; + (* read-only *) VAR buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN WritePart(s, buf, 0, LEN(buf)) + END Write; + + PROCEDURE WritePartC*(s: Stream; buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* write buf[off..off+cnt-1] to s *) + BEGIN + RETURN WritePart(s, buf, off, cnt) + END WritePartC; + + PROCEDURE WriteC*(s: Stream; buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN WritePart(s, buf, 0, LEN(buf)) + END WriteC; + + PROCEDURE WriteByte*(s: Stream; byte: Byte) : BOOLEAN; + VAR + posindex: Count; + BEGIN + IF (s.write > 0) & ~SYS.TAS(s.lock) THEN + s.error := FALSE; s.count := 1; + + IF s.bidirect THEN + s.wbuf.cont[s.wbuf.wend] := byte; INC(s.wbuf.wend); DEC(s.write); + ELSE + (* put byte into s.buf *) + posindex := s.pos MOD bufsize; + s.buf.cont[posindex] := byte; + IF s.buf.wend = posindex THEN + INC(s.buf.wend); + END; + DEC(s.write); + + (* update s.buf.rend and s.left, if necessary *) + IF s.buf.rend = posindex THEN + INC(s.buf.rend); + END; + IF s.left # 0 THEN + DEC(s.left); + ELSIF s.buf.rbegin = s.buf.rend THEN + (* set read-region to write-region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.wend - posindex; + END; + + INC(s.pos); + END; + + IF (s.bufmode = linebuf) & (byte = s.termch) THEN + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + IF ~s.bidirect THEN + s.buf.wbegin := s.pos MOD bufsize; + END; + END; + + s.lock := FALSE; RETURN TRUE + ELSE + RETURN WritePart(s, byte, 0, 1) + END; + END WriteByte; + + PROCEDURE InternalSeek(s: Stream; offset: Count; whence: Whence) : BOOLEAN; + VAR + oldpos: Count; pos: Count; + BEGIN + s.error := FALSE; + IF s.bidirect THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF s.buf = NIL THEN + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + ELSE + IF ~s.validpos & (seek IN s.caps) THEN + IF (write IN s.caps) & ~InternalFlush(s) THEN END; + IF ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + IF whence = fromStart THEN + s.validpos := TRUE; + s.pos := offset; s.rpos := offset; + END; + ELSE + ValidPos(s); oldpos := s.pos; + IF s.pos > s.maxpos THEN + s.maxpos := s.pos; + END; + CASE whence OF + | fromStart: IF offset < 0 THEN + Error(s, SeekFailed); RETURN FALSE + END; + s.pos := offset; + | fromPos: IF s.pos + offset < 0 THEN + Error(s, SeekFailed); RETURN FALSE + END; + INC(s.pos, offset); + | fromEnd: IF (write IN s.caps) & ~InternalFlush(s) THEN END; + IF ~(seek IN s.caps) OR + ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + s.validpos := FALSE; ValidPos(s); + ELSE + Error(s, BadWhence); RETURN FALSE + END; + IF ~(holes IN s.caps) & (s.pos > s.maxpos) THEN + (* if holes are not permitted + we need to check the new position + *) + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF s.if.seek(s, s.pos, fromStart) THEN + s.rpos := s.pos; s.maxpos := s.pos; + ELSE + Error(s, SeekFailed); RETURN FALSE + END; + END; + IF s.buf.ok & (s.pos # oldpos) THEN + (* set s.left and s.write *) + IF (s.pos < s.buf.pos) OR (s.pos >= s.buf.pos + bufsize) THEN + s.left := 0; s.write := 0; + ELSE + pos := s.pos MOD bufsize; + IF s.buf.rbegin = s.buf.rend THEN + s.buf.rbegin := pos; s.buf.rend := pos; + END; + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; s.buf.wend := pos; + END; + IF s.pos > oldpos THEN + IF (pos >= s.buf.rbegin) & (pos < s.buf.rend) THEN + s.left := s.buf.rend - pos; + ELSE + s.left := 0; + END; + IF (pos >= s.buf.wbegin) & (pos <= s.buf.wend) THEN + s.write := bufsize - pos; + ELSE + s.write := 0; + END; + IF s.wextensible & + (s.write < s.left) & (s.buf.wbegin # s.buf.wend) THEN + (* s.write = 0 (else s.write >= s.left); + try to extend write-region to avoid + an unnecessary flush operation + *) + IF (s.buf.wbegin < pos) & + (s.buf.wend >= s.buf.rbegin) THEN + (* write-region is followed by read-region *) + s.buf.wend := pos; s.write := bufsize - pos; + ELSIF (pos < s.buf.wbegin) & + (s.buf.wbegin >= s.buf.rend) THEN + (* read-region is followed by write-region *) + s.buf.wbegin := pos; s.write := bufsize - pos; + END; + END; + ELSE (* s.pos < oldpos *) + IF (pos < s.buf.rbegin) OR (pos > s.buf.rend) THEN + s.left := 0; + ELSE + s.left := s.buf.rend - pos; + END; + IF (pos < s.buf.wbegin) OR (pos > s.buf.wend) THEN + s.write := 0; + ELSE + s.write := bufsize - pos; + END; + END; + END; + END; + END; + END; + IF s.left > 0 THEN + s.eof := FALSE; + END; + RETURN TRUE + END InternalSeek; + + PROCEDURE Seek*(s: Stream; offset: Count; whence: Whence) : BOOLEAN; + VAR + rval: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + rval := InternalSeek(s, offset, whence); + s.lock := FALSE; + RETURN rval + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Seek; + + PROCEDURE Tell*(s: Stream; VAR offset: Count) : BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF tell IN s.caps THEN + IF s.buf # NIL THEN + IF s.validpos THEN + offset := s.pos; + ELSIF s.if.tell(s, s.rpos) THEN + s.validpos := TRUE; + s.pos := s.rpos; + offset := s.pos; + ELSE + s.lock := FALSE; + Error(s, TellFailed); + END; + ELSIF ~s.if.tell(s, offset) THEN + s.lock := FALSE; + Error(s, TellFailed); + END; + ELSE + s.lock := FALSE; + Error(s, CannotTell); + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + RETURN ~s.error + END Tell; + + PROCEDURE GetPos*(s: Stream; VAR offset: Count); + (* IF ~Tell(s, offset) THEN offset := internal position END; *) + BEGIN + IF ~Tell(s, offset) THEN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + ELSE + ValidPos(s); + offset := s.pos; + s.lock := FALSE; + END; + END; + END GetPos; + + PROCEDURE SetPos*(s: Stream; offset: Count); + (* IF ~Seek(s, offset, fromStart) THEN END; *) + BEGIN + IF ~Seek(s, offset, fromStart) THEN END; + END SetPos; + + PROCEDURE ^ Touch*(s: Stream); + + PROCEDURE Trunc*(s: Stream; length: Count) : BOOLEAN; + (* truncate `s' to a total length of `length'; + following holds if holes are permitted: + (1) the current position remains unchanged + (2) the contents between `length' and + the current position is undefined + this call fails if holes are not permitted and the + current position is beyond `length' + *) + VAR + ok: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF (trunc IN s.caps) & (length >= 0) THEN + s.error := FALSE; ok := TRUE; + IF s.buf # NIL THEN + ValidPos(s); + IF ~(holes IN s.caps) & (s.pos > length) THEN + ok := FALSE; + ELSIF (s.bufmode = bufpool) OR s.buf.ok & + (s.buf.pos DIV bufsize >= length DIV bufsize) THEN + Touch(s); + END; + END; + IF ~ok OR ~s.if.trunc(s, length) THEN + s.lock := FALSE; Error(s, TruncFailed); + END; + ELSE + s.lock := FALSE; Error(s, CannotTrunc); + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + RETURN ~s.error + END Trunc; + + PROCEDURE Back*(s: Stream) : BOOLEAN; + (* undo last read operation (one byte); + because of the delayed buffer filling + Back is always successful for buffered streams + immediately after read-operations + *) + VAR + rval: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF read IN s.caps THEN + IF seek IN s.caps THEN + (* fails if s.pos = 0 *) + rval := InternalSeek(s, -1, 1) + ELSIF s.bidirect & s.buf.ok THEN + IF s.pos > 0 THEN + DEC(s.pos); INC(s.left); + rval := TRUE; + ELSE + rval := FALSE; + END; + ELSIF (s.buf # NIL) & s.buf.ok THEN + rval := InternalSeek(s, -1, 1) & (s.left > 0) + ELSE + rval := FALSE + END; + ELSE + s.lock := FALSE; Error(s, CannotRead); + rval := FALSE + END; + s.lock := FALSE; + RETURN rval + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Back; + + PROCEDURE Insert*(s: Stream; byte: Byte) : BOOLEAN; + (* return `byte' on next read-operation *) + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF read IN s.caps THEN + IF s.buf # NIL THEN + (* seek in buffer possible? *) + IF s.bidirect THEN + IF s.pos > 0 THEN + DEC(s.pos); s.buf.cont[s.pos] := byte; + RETURN TRUE + ELSE + RETURN FALSE + END; + ELSIF s.buf.ok & + (s.pos > s.buf.pos+s.buf.rbegin) & + (s.pos < s.buf.pos+s.buf.rend) & + InternalSeek(s, -1, 1) THEN + s.buf.cont[s.pos MOD bufsize] := byte; + s.lock := FALSE; + RETURN TRUE + ELSE + s.lock := FALSE; + RETURN FALSE + END; + ELSE + s.lock := FALSE; Error(s, Unbuffered); RETURN FALSE + END; + ELSE + s.lock := FALSE; Error(s, CannotRead); RETURN FALSE + END; + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Insert; + + PROCEDURE InternalFlush(s: Stream) : BOOLEAN; + + PROCEDURE Write(s: Stream; buf: Buffer) : BOOLEAN; + + VAR + count: Count; + BEGIN + IF addrio IN s.caps THEN + count := s.if.addrwrite(s, SYSTEM.ADR(buf.cont[buf.wbegin]), + buf.wend-buf.wbegin); + ELSIF bufio IN s.caps THEN + count := s.if.bufwrite(s, buf.cont, + buf.wbegin, buf.wend-buf.wbegin); + ELSIF s.if.write(s, buf.cont[buf.wbegin]) THEN + count := 1; + ELSE + count := 0; + END; + IF count < 0 THEN + count := 0; + END; + INC(buf.wbegin, count); INC(s.rpos, count); + RETURN count > 0 + END Write; + + PROCEDURE FlushEvent; + VAR + event: Event; + BEGIN + IF s.flushEvent # NIL THEN + NEW(event); + event.type := s.flushEvent; + event.message := "flush event of Streams"; + event.stream := s; + Events.Raise(event); + END; + END FlushEvent; + + BEGIN + s.error := FALSE; + IF (write IN s.caps) & (s.buf # NIL) & s.buf.ok THEN + IF s.bidirect & (s.wbuf.wend > s.wbuf.wbegin) THEN + FlushEvent; + WHILE (s.wbuf.wend > s.wbuf.wbegin) & Write(s, s.wbuf) DO END; + IF s.wbuf.wend > s.wbuf.wbegin THEN + s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; + Error(s, WriteFailed); RETURN FALSE + END; + s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; + ELSIF ~s.bidirect & (s.buf.wend > s.buf.wbegin) THEN + FlushEvent; + ValidPos(s); + IF s.buf.pos + s.buf.wbegin # s.rpos THEN + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); + (* write in this case at the current position + else there is no easy way to write anyhow + *) + ELSIF ~s.if.seek(s, s.buf.pos + s.buf.wbegin, fromStart) THEN + s.buf.wend := s.buf.wbegin; s.write := 0; + Error(s, SeekFailed); RETURN FALSE + END; + s.rpos := s.buf.pos + s.buf.wbegin; + END; + WHILE (s.buf.wend > s.buf.wbegin) & Write(s, s.buf) DO END; + IF s.buf.wend > s.buf.wbegin THEN + s.buf.wend := s.buf.wbegin; s.write := bufsize - s.buf.wbegin; + Error(s, WriteFailed); RETURN FALSE + END; + IF {seek, tell, trunc} * s.caps = {} THEN + (* unidirectional pipeline; reset s.pos to avoid + unintentional flushes due to buffer boundaries + *) + s.pos := 0; s.rpos := 0; s.buf.pos := 0; + s.buf.wbegin := 0; s.buf.wend := 0; s.write := bufsize; + ELSE + IF (s.pos >= s.buf.pos) & (s.pos < s.buf.pos + bufsize) THEN + s.buf.wbegin := s.pos MOD bufsize; + s.buf.wend := s.buf.wbegin; + s.write := bufsize - s.buf.wbegin; + ELSE + s.write := 0; + END; + END; + END; + END; + RETURN TRUE + END InternalFlush; + + PROCEDURE Flush*(s: Stream) : BOOLEAN; + VAR + ok: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF s.bufmode = bufpool THEN + ok := FlushBufPool(s); + ELSE + ok := InternalFlush(s); + END; + IF ok & (flush IN s.caps) THEN + ok := s.if.flush(s); + IF ~ok THEN + Error(s, FlushFailed); + END; + END; + s.lock := FALSE; + RETURN ok + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Flush; + + PROCEDURE InputInBuffer*(s: Stream) : BOOLEAN; + (* returns TRUE if the next byte to be read is buffered *) + VAR + buf: Buffer; + pos: Count; + BEGIN + IF s.bufmode = bufpool THEN + IF ~s.buf.ok THEN RETURN FALSE END; + pos := s.pos - s.pos MOD bufsize; + IF s.buf.pos # pos THEN + IF ~FindBuffer(s, pos, buf) THEN + RETURN FALSE + END; + pos := s.pos - buf.pos; + RETURN (pos >= buf.rbegin) & (pos < buf.rend) + END; + ELSIF s.bidirect THEN + RETURN s.left > 0 + END; + pos := s.pos MOD bufsize; + RETURN (read IN s.caps) & (s.buf # NIL) & s.buf.ok & + ((s.left > 0) OR + (write IN s.caps) & (s.buf.wbegin <= pos) & (s.buf.wend > pos)) + END InputInBuffer; + + PROCEDURE OutputInBuffer*(s: Stream) : BOOLEAN; + (* returns TRUE if Flush would lead to a write-operation *) + VAR + buf: Buffer; + BEGIN + IF s.bufmode = bufpool THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + IF buf.wbegin # buf.wend THEN RETURN TRUE END; + buf := buf.nexta; + END; + RETURN FALSE + ELSIF s.bidirect THEN + RETURN s.wbuf.wend > s.wbuf.wbegin + ELSE + RETURN (write IN s.caps) & (s.buf # NIL) & s.buf.ok & + (s.buf.wend > s.buf.wbegin) + END; + END OutputInBuffer; + + PROCEDURE OutputWillBeBuffered*(s: Stream) : BOOLEAN; + (* returns TRUE if the next written byte will be buffered *) + VAR + buf: Buffer; + pos: Count; + BEGIN + IF s.bufmode = bufpool THEN + IF s.bufpool.nbuf < s.bufpool.maxbuf THEN RETURN TRUE END; + pos := s.pos - s.pos MOD bufsize; + IF s.buf.pos # pos THEN + IF ~FindBuffer(s, pos, buf) THEN RETURN FALSE END; + IF s.buf.wbegin = s.buf.wend THEN RETURN TRUE END; + pos := s.pos - buf.pos; + RETURN (pos >= buf.wbegin) & (pos <= buf.wend) OR + (buf.wbegin > 0) & (pos + 1 = buf.wbegin) + END; + ELSIF s.bidirect THEN + RETURN s.write > 0 + END; + RETURN (write IN s.caps) & (s.buf # NIL) & + ((s.write > 0) OR ~s.buf.ok) + END OutputWillBeBuffered; + + PROCEDURE Touch*(s: Stream); + (* forget any buffer contents *) + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF write IN s.caps THEN + IF s.bufmode = bufpool THEN + IF ~FlushBufPool(s) THEN END; + ReleaseBufPool(s); + ELSE + IF ~InternalFlush(s) THEN END; + END; + END; + IF flush IN s.caps THEN + IF ~s.if.flush(s) THEN + Error(s, FlushFailed); + END; + END; + IF s.bidirect THEN + s.buf.rbegin := 0; s.buf.rend := 0; s.left := 0; + ELSE + s.validpos := FALSE; + IF s.buf # NIL THEN + s.buf.ok := FALSE; + s.left := 0; + s.write := 0; + s.eofFound := FALSE; + END; + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + END Touch; + + PROCEDURE Copy*(source, dest: Stream; maxcnt: Count) : BOOLEAN; + (* more efficient variants are possible *) + VAR + left, count, copied, read, written: Count; + buffer: ARRAY bufsize OF Byte; + ok: BOOLEAN; + BEGIN + IF maxcnt >= 0 THEN + read := 0; written := 0; ok := TRUE; + left := maxcnt; + LOOP + IF left = 0 THEN + EXIT + END; + ASSERT(left > 0); + IF left > bufsize THEN + count := bufsize; + ELSE + count := left; + END; + + ok := ReadPacket(source, buffer, 0, count) > 0; + ASSERT(source.count <= count); + INC(read, source.count); + IF ~ok THEN EXIT END; + + ok := WritePart(dest, buffer, 0, source.count); + ASSERT(dest.count <= source.count); + INC(written, dest.count); + IF ~ok THEN EXIT END; + + DEC(left, dest.count); + END; + source.count := read; dest.count := written; + RETURN ok + ELSE + copied := 0; + WHILE (ReadPacket(source, buffer, 0, bufsize) > 0) & + WritePart(dest, buffer, 0, source.count) DO + INC(copied, source.count); + END; + source.count := copied; dest.count := copied; + RETURN ~source.error & ~dest.error + END; + END Copy; + + (* === nulldev procedures ========================================== *) + + PROCEDURE NulldevRead(s: Stream; VAR byte: Byte) : BOOLEAN; + BEGIN + byte := 0X; + RETURN FALSE + END NulldevRead; + + PROCEDURE NulldevWrite(s: Stream; byte: Byte) : BOOLEAN; + BEGIN + RETURN TRUE + END NulldevWrite; + + PROCEDURE InitNullIf(VAR nullif: Interface); + BEGIN + NEW(nullif); + nullif.read := NulldevRead; + nullif.write := NulldevWrite; + END InitNullIf; + + PROCEDURE OpenNulldev(VAR s: Stream); + BEGIN + NEW(s); + Services.Init(s, type); + Init(s, nullif, {read, write}, nobuf); + END OpenNulldev; + + PROCEDURE ExitHandler(event: Events.Event); + (* flush all streams on exit; + we do not close them to allow output by other exit event handlers + *) + VAR s: Stream; + BEGIN + s := opened; + WHILE s # NIL DO + IF (s.bufmode # nobuf) & (write IN s.caps) THEN + IF ~Flush(s) THEN END; + END; + s := s.next; + END; + END ExitHandler; + + PROCEDURE FreeHandler(event: Events.Event); + (* set all free lists to NIL to return the associated storage + to the garbage collector + *) + BEGIN + freelist := NIL; + END FreeHandler; + +BEGIN + Services.CreateType(type, "Streams.Stream", ""); + + errormsg[NoHandlerDefined] := "no handler defined"; + errormsg[CannotRead] := "not opened for reading"; + errormsg[CannotSeek] := "not capable of seeking"; + errormsg[CloseFailed] := "close operation failed"; + errormsg[NotLineBuffered] := "stream is not line buffered"; + errormsg[SeekFailed] := "seek operation failed"; + errormsg[TellFailed] := "tell operation failed"; + errormsg[BadWhence] := "bad value of whence parameter"; + errormsg[CannotTell] := "not capable of telling current position"; + errormsg[WriteFailed] := "write operation failed"; + errormsg[CannotWrite] := "not opened for writing"; + errormsg[ReadFailed] := "read operation failed"; + errormsg[Unbuffered] := "operation is not valid for unbuffered streams"; + errormsg[BadParameters] := "bad parameter values"; + errormsg[CannotTrunc] := "not capable of truncating"; + errormsg[TruncFailed] := "trunc operation failed"; + errormsg[NestedCall] := "nested stream operation"; + errormsg[FlushFailed] := "flush operation failed"; + + Events.Define(error); Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); + + opened := NIL; + InitNullIf(nullif); + OpenNulldev(null); stdin := null; stdout := null; stderr := null; + + Events.Handler(Process.termination, ExitHandler); + Events.Handler(Process.startOfGarbageCollection, FreeHandler); +END ulmStreams. diff --git a/src/lib/ulm/ulmStrings.Mod b/src/library/ulm/ulmStrings.Mod similarity index 96% rename from src/lib/ulm/ulmStrings.Mod rename to src/library/ulm/ulmStrings.Mod index 19b64395..56785bf9 100644 --- a/src/lib/ulm/ulmStrings.Mod +++ b/src/library/ulm/ulmStrings.Mod @@ -64,7 +64,7 @@ MODULE ulmStrings; posOutside* = 3; (* trunc failure: position beyond trunc pos *) errorcodes* = 4; TYPE - ErrorCode* = SHORTINT; + ErrorCode* = Types.Int8; Event* = POINTER TO EventRec; EventRec* = RECORD @@ -91,13 +91,13 @@ MODULE ulmStrings; (* ======= string to stream operations =========================== *) PROCEDURE WritePart*(stream: Streams.Stream; string: ARRAY OF CHAR; - sourceIndex: LONGINT); + sourceIndex: Types.Int32); (* seek to position 0 of `stream' and copy string[sourceIndex..] to it; the file pointer of `stream' is left on position 0 *) VAR - index: LONGINT; + index: Types.Int32; BEGIN IF ~Streams.Seek(stream, 0, Streams.fromStart) OR ~Streams.Trunc(stream, 0) THEN @@ -122,12 +122,12 @@ MODULE ulmStrings; (* ======= stream to string operations =========================== *) - PROCEDURE ReadPart*(VAR string: ARRAY OF CHAR; destIndex: LONGINT; + PROCEDURE ReadPart*(VAR string: ARRAY OF CHAR; destIndex: Types.Int32; stream: Streams.Stream); (* like `Read' but fill string[destIndex..] *) VAR - len: LONGINT; - endIndex: LONGINT; + len: Types.Int32; + endIndex: Types.Int32; BEGIN len := LEN(string); IF Streams.Seek(stream, 0, Streams.fromStart) & (destIndex < len) THEN @@ -160,8 +160,8 @@ MODULE ulmStrings; PROCEDURE Copy*(VAR destination: ARRAY OF CHAR; source: ARRAY OF CHAR); VAR - index: LONGINT; - minlen: LONGINT; + index: Types.Int32; + minlen: Types.Int32; BEGIN minlen := LEN(destination); IF minlen > LEN(source) THEN @@ -180,8 +180,8 @@ MODULE ulmStrings; destination[index] := 0X; END Copy; - PROCEDURE PartCopy*(VAR destination: ARRAY OF CHAR; destIndex: LONGINT; - source: ARRAY OF CHAR; sourceIndex: LONGINT); + PROCEDURE PartCopy*(VAR destination: ARRAY OF CHAR; destIndex: Types.Int32; + source: ARRAY OF CHAR; sourceIndex: Types.Int32); (* copy source[sourceIndex..] to destination[destIndex..] *) BEGIN WHILE (destIndex+1 < LEN(destination)) & @@ -195,10 +195,10 @@ MODULE ulmStrings; END; END PartCopy; - PROCEDURE Len*(string: ARRAY OF CHAR) : LONGINT; + PROCEDURE Len*(string: ARRAY OF CHAR) : Types.Int32; (* returns the number of characters (without terminating 0X) *) VAR - len: LONGINT; + len: Types.Int32; BEGIN len := 0; WHILE (len < LEN(string)) & (string[len] # 0X) DO @@ -316,7 +316,7 @@ MODULE ulmStrings; PROCEDURE Flush(s: Streams.Stream) : BOOLEAN; VAR - len: LONGINT; + len: Types.Int32; ch: CHAR; BEGIN WITH s: Stream DO diff --git a/src/lib/ulm/ulmSys.Mod b/src/library/ulm/ulmSys.Mod similarity index 100% rename from src/lib/ulm/ulmSys.Mod rename to src/library/ulm/ulmSys.Mod diff --git a/src/lib/ulm/x86/ulmSysConversions.Mod b/src/library/ulm/ulmSysConversions.Mod similarity index 83% rename from src/lib/ulm/x86/ulmSysConversions.Mod rename to src/library/ulm/ulmSysConversions.Mod index f8ea3fbb..babdab5d 100644 --- a/src/lib/ulm/x86/ulmSysConversions.Mod +++ b/src/library/ulm/ulmSysConversions.Mod @@ -38,7 +38,7 @@ MODULE ulmSysConversions; (* convert Oberon records to/from C structures *) IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts; + SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts, Types := ulmTypes; TYPE Address* = SysTypes.Address; @@ -66,10 +66,10 @@ MODULE ulmSysConversions; b: SYS.BYTE B: BOOLEAN c: CHAR - s: SHORTINT - i: INTEGER - l: LONGINT - S: SET + s: Types.Int8 + i: Types.Int32 + l: Types.Int32 + S: Types.Set C data types: @@ -90,10 +90,10 @@ MODULE ulmSysConversions; Rec = RECORD - a, b: INTEGER; + a, b: Types.Int32; c: CHAR; - s: SET; - f: ARRAY 3 OF INTEGER; + s: Types.Set; + f: ARRAY 3 OF Types.Int32; END; to @@ -118,7 +118,7 @@ MODULE ulmSysConversions; unsigned = 0; (* suppress sign extension *) boolean = 1; (* convert anything # 0 to 1 *) TYPE - Flags = SET; + Flags = Types.Set; Event* = POINTER TO EventRec; EventRec* = RECORD @@ -134,9 +134,9 @@ MODULE ulmSysConversions; (* 1: Oberon type 2: C type *) - type1, type2: CHAR; length: INTEGER; left: INTEGER; + type1, type2: CHAR; length: Types.Int32; left: Types.Int32; offset1, offset2: Address; - size1, size2: Address; elementsleft: INTEGER; flags: Flags; + size1, size2: Address; elementsleft: Types.Int32; flags: Flags; END; Format* = POINTER TO FormatRec; @@ -192,7 +192,7 @@ MODULE ulmSysConversions; RETURN (ch >= "0") & (ch <= "9") END IsDigit; - PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER); + PROCEDURE ReadInt(cv: ConvStream; VAR i: Types.Int32); BEGIN i := 0; REPEAT @@ -219,10 +219,10 @@ MODULE ulmSysConversions; PROCEDURE ScanConv(cv: ConvStream; VAR type1, type2: CHAR; - VAR length: INTEGER) : BOOLEAN; + VAR length: Types.Int32) : BOOLEAN; VAR - i: INTEGER; - factor: INTEGER; + i: Types.Int32; + factor: Types.Int32; BEGIN IF cv.left > 0 THEN type1 := cv.type1; @@ -274,8 +274,8 @@ MODULE ulmSysConversions; PROCEDURE Align(VAR offset: Address; boundary: Address); BEGIN - IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN - offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary)); + IF SYS.VAL (Types.Int32, offset) MOD SYS.VAL (Types.Int32, boundary) # 0 THEN + offset := SYS.VAL (Types.Int32, offset) + (SYS.VAL (Types.Int32, boundary) - SYS.VAL (Types.Int32, offset) MOD SYS.VAL (Types.Int32, boundary)); END; END Align; @@ -285,28 +285,28 @@ MODULE ulmSysConversions; VAR flags: Flags) : BOOLEAN; VAR type1, type2: CHAR; - length: INTEGER; + length: Types.Int32; align: BOOLEAN; - boundary: INTEGER; + boundary: Types.Int32; BEGIN IF cv.elementsleft > 0 THEN DEC(cv.elementsleft); (* Oberon type *) IF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); + Align(cv.offset1, SIZE(Types.Int32)); END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; + offset1 := cv.offset1; cv.offset1 := SYS.VAL (Types.Int32, cv.offset1) + size1; size1 := cv.size1; size2 := cv.size2; flags := cv.flags; IF (size1 > 0) & (cv.elementsleft = 0) THEN - Align(cv.offset1, SIZE(INTEGER)); + Align(cv.offset1, SIZE(Types.Int32)); END; (* C type *) IF size2 > 1 THEN Align(cv.offset2, 2); END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); + offset2 := cv.offset2; cv.offset2 := SYS.VAL (Types.Int32, cv.offset2) + SYS.VAL (Types.Int32, size2); RETURN TRUE END; @@ -318,41 +318,41 @@ MODULE ulmSysConversions; | "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned); | "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean); | "c": size1 := SIZE(CHAR); INCL(flags, unsigned); - | "s": size1 := SIZE(SHORTINT); - | "i": size1 := SIZE(INTEGER); - | "l": size1 := SIZE(LONGINT); - | "S": size1 := SIZE(SET); INCL(flags, unsigned); + | "s": size1 := SIZE(Types.Int8); + | "i": size1 := SIZE(Types.Int32); + | "l": size1 := SIZE(Types.Int32); + | "S": size1 := SIZE(Types.Set); INCL(flags, unsigned); | "-": size1 := 0; ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE END; IF size1 > 0 THEN IF length > 0 THEN - Align(cv.offset1, SIZE(INTEGER)); + Align(cv.offset1, SIZE(Types.Int32)); ELSIF size1 > SIZE(SYS.BYTE) THEN - Align(cv.offset1, SIZE(INTEGER)); + Align(cv.offset1, SIZE(Types.Int32)); END; END; - offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1; + offset1 := cv.offset1; cv.offset1 := SYS.VAL (Types.Int32, cv.offset1) + size1; (* C type *) CASE type2 OF - | "a": size2 := 4; INCL(flags, unsigned); (* char* *) - | "c": size2 := 1; (* /* signed */ char *) - | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) - | "s": size2 := 2; (* short int *) - | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) - | "i": size2 := 4; (* int *) - | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "l": size2 := 4; (* long int *) - | "L": size2 := 4; INCL(flags, unsigned); (* long int *) - | "-": size2 := 0; + | "a": size2 := SIZE(Address); INCL(flags, unsigned); (* char* *) + | "c": size2 := 1; (* /* signed */ char *) + | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) + | "s": size2 := 2; (* short int *) + | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) + | "i": size2 := 4; (* int *) + | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) + | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) + | "l": size2 := 8; (* long int *) + | "L": size2 := 8; INCL(flags, unsigned); (* long int *) + | "-": size2 := 0; ELSE Error(cv, "bad C type specifier"); RETURN FALSE END; IF size2 > 1 THEN Align(cv.offset2, size2); END; - offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2); + offset2 := cv.offset2; cv.offset2 := SYS.VAL (Types.Int32, cv.offset2) + SYS.VAL (Types.Int32, size2); cv.size1 := size1; cv.size2 := size2; IF length > 0 THEN @@ -371,7 +371,7 @@ MODULE ulmSysConversions; Pointer = POINTER TO Bytes; VAR dest, source: Pointer; - dindex, sindex: INTEGER; + dindex, sindex: Types.Int32; nonzero: BOOLEAN; fill : CHAR; BEGIN @@ -383,7 +383,7 @@ MODULE ulmSysConversions; nonzero := FALSE; WHILE ssize > 0 DO nonzero := nonzero OR (source[sindex] # 0X); - INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1; + INC(sindex); ssize := SYS.VAL (Types.Int32, ssize) - 1; END; IF dsize > 0 THEN IF nonzero THEN @@ -395,12 +395,12 @@ MODULE ulmSysConversions; END; WHILE dsize > 0 DO dest[dindex] := 0X; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); + dsize := SYS.VAL (Types.Int32, dsize) - 1; INC(dindex); END; ELSE WHILE (dsize > 0) & (ssize > 0) DO dest[dindex] := source[sindex]; - ssize := SYS.VAL (INTEGER, ssize) - 1; + ssize := SYS.VAL (Types.Int32, ssize) - 1; dsize := dsize - 1; INC(dindex); INC(sindex); END; @@ -415,7 +415,7 @@ MODULE ulmSysConversions; END; WHILE dsize > 0 DO dest[dindex] := fill; - dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex); + dsize := SYS.VAL (Types.Int32, dsize) - 1; INC(dindex); END; END; END; @@ -475,7 +475,7 @@ MODULE ulmSysConversions; WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END; Close(cv); size := offset1 + size1; - Align(size, SIZE(INTEGER)); + Align(size, SIZE(Types.Int32)); RETURN size END OberonSize; diff --git a/src/lib/ulm/ulmSysErrors.Mod b/src/library/ulm/ulmSysErrors.Mod similarity index 96% rename from src/lib/ulm/ulmSysErrors.Mod rename to src/library/ulm/ulmSysErrors.Mod index 0e81818d..ce535744 100644 --- a/src/lib/ulm/ulmSysErrors.Mod +++ b/src/library/ulm/ulmSysErrors.Mod @@ -1,6 +1,6 @@ MODULE ulmSysErrors; - IMPORT Errors := ulmErrors, Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, Sys := ulmSys; + IMPORT Errors := ulmErrors, Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, Sys := ulmSys, Types := ulmTypes; CONST perm* = 1; @@ -138,8 +138,8 @@ MODULE ulmSysErrors; EventRec* = RECORD (Events.EventRec) - errno*: (*INTEGER*)LONGINT; - syscall*: (*INTEGER*)LONGINT; (* number of system call *) + errno*: (*Types.Int32*)Types.Int32; + syscall*: (*Types.Int32*)Types.Int32; (* number of system call *) text*: ARRAY textlen OF CHAR; END; @@ -150,7 +150,7 @@ MODULE ulmSysErrors; syserror*: ARRAY ncodes OF Events.EventType; PROCEDURE Raise*(errors: RelatedEvents.Object; - errno, syscall: (*INTEGER*)LONGINT; text: ARRAY OF CHAR); (* in ulm's system INTEGER and LONGINT have the same size *) + errno, syscall: (*Types.Int32*)Types.Int32; text: ARRAY OF CHAR); (* in ulm's system Types.Int32 and Types.Int32 have the same size *) (* raises the events syserrors and syserrors[syscall]; `text' contains additional information (e.g. filenames); further, the syserrors[syscall] event is passed to @@ -192,9 +192,9 @@ MODULE ulmSysErrors; IF ~Streams.WriteByte(s, ch) THEN END; END Write; - PROCEDURE WriteInt(intval: LONGINT); + PROCEDURE WriteInt(intval: Types.Int32); VAR - rest: LONGINT; + rest: Types.Int32; BEGIN rest := intval DIV 10; IF rest > 0 THEN @@ -231,7 +231,7 @@ MODULE ulmSysErrors; PROCEDURE InitEvents; VAR - errno: INTEGER; + errno: Types.Int32; BEGIN syserror[0] := NIL; errno := 1; @@ -447,11 +447,11 @@ BEGIN message[netdown] := "Network is down"; name[netunreach] := "ENETUNREACH"; message[netunreach] := "Network is unreachable"; - name[netreset] := "ENETRESET"; + name[netreset] := "ENETRETypes.Set"; message[netreset] := "Network dropped connection because of reset"; name[connaborted] := "ECONNABORTED"; message[connaborted] := "Software caused connection abort"; - name[connreset] := "ECONNRESET"; + name[connreset] := "ECONNRETypes.Set"; message[connreset] := "Connection reset by peer"; name[nobufs] := "ENOBUFS"; message[nobufs] := "No buffer space available"; diff --git a/src/library/ulm/ulmSysIO.Mod b/src/library/ulm/ulmSysIO.Mod new file mode 100644 index 00000000..3274efda --- /dev/null +++ b/src/library/ulm/ulmSysIO.Mod @@ -0,0 +1,356 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: SysIO.om,v 1.1 1994/02/23 07:59:15 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: SysIO.om,v $ + Revision 1.1 1994/02/23 07:59:15 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 6/89 + ---------------------------------------------------------------------------- +*) + +MODULE ulmSysIO; + + IMPORT RelatedEvents := ulmRelatedEvents, + Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, + SysErrors := ulmSysErrors, SysTypes := ulmSysTypes, + Platform, Types := ulmTypes; + + CONST + (* file control options: arguments of Fcntl and Open *) + rdonly* = {}; + wronly* = { 0 }; + rdwr* = { 1 }; + append* = { 10 }; + ndelay* = { 11 }; (* O_NONBLOCK that works like former O_NDELAY *) + creat* = { 6 }; + trunc* = { 9 }; + excl* = { 7 }; + noctty* = { 8 }; + sync* = { 12 }; + fasync* = { 13 }; + direct* = { 14 }; + largefile* = { 15 }; + directory* = { 16 }; + nofollow* = { 17 }; + + (* Whence = (fromStart, fromPos, fromEnd); *) + fromStart* = 0; + fromPos* = 1; + fromEnd* = 2; + + (* file descriptor flags *) + closeonexec* = { 0 }; + + (* Fcntl requests *) + dupfd* = 0; (* duplicate file descriptor *) + getfd* = 1; (* get file desc flags (close-on-exec) *) + setfd* = 2; (* set file desc flags (close-on-exec) *) + getfl* = 3; (* get file flags *) + setfl* = 4; (* set file flags (ndelay, append) *) + getlk* = 5; (* get file lock *) + setlk* = 6; (* set file lock *) + setlkw* = 7; (* set file lock and wait *) + setown* = 8; (* set owner (async IO) *) + getown* = 9; (* get owner (async IO) *) + setsig* = 10; (* set SIGIO replacement *) + getsig* = 11; (* get SIGIO replacement *) + + TYPE + File* = SysTypes.File; (* file descriptor *) + Address* = SysTypes.Address; + Count* = SysTypes.Count; + Protection* = Types.Int32; + Whence* = Types.Int32; + + PROCEDURE OpenCreat*(VAR fd: File; + filename: ARRAY OF CHAR; options: Types.Set; + protection: Protection; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + (* the filename must be 0X-terminated *) + VAR + error: Platform.ErrorCode; + BEGIN + interrupted := FALSE; + LOOP + IF options * creat # {} THEN error := Platform.New(filename, fd) + ELSIF options * (rdwr+wronly) # {} THEN error := Platform.OldRW(filename, fd) + ELSE error := Platform.OldRO(filename, fd) END; + IF error = 0 THEN RETURN TRUE + ELSE + IF Platform.Interrupted(error) THEN + interrupted := TRUE; + END; + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.open, filename); + RETURN FALSE + END; + END; + END; + END OpenCreat; + + PROCEDURE Open*(VAR fd: File; + filename: ARRAY OF CHAR; options: Types.Set; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + (* the filename must be 0X-terminated *) + BEGIN + RETURN OpenCreat(fd, filename, options, 0, errors, retry, interrupted) + END Open; + + PROCEDURE Close*(fd: File; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + VAR + error: Platform.ErrorCode; + BEGIN + interrupted := FALSE; + LOOP + error := Platform.Close(fd); + IF error = 0 THEN RETURN TRUE + ELSE + IF Platform.Interrupted(error) THEN + interrupted := TRUE; + END; + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.close, ""); + RETURN FALSE + END; + END; + END; + END Close; + + PROCEDURE Read*(fd: File; buf: Address; cnt: Count; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; + (* return value of 0: EOF + -1: I/O error + >0: number of bytes read + *) + VAR + error: Platform.ErrorCode; + bytesread: Count; + BEGIN + interrupted := FALSE; + LOOP + error := Platform.Read(fd, buf, cnt, bytesread); + IF error = 0 THEN RETURN bytesread + ELSE + IF Platform.Interrupted(error) THEN + interrupted := TRUE; + END; + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.read, ""); + RETURN -1 + END; + END; + END; + END Read; + + PROCEDURE Write*(fd: File; buf: Address; cnt: Count; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; + (* return value of -1: I/O error + >=0: number of bytes written + *) + VAR + error: Platform.ErrorCode; + byteswritten: Count; + BEGIN + interrupted := FALSE; + LOOP + error := Platform.Write(fd, buf, cnt); + IF error = 0 THEN RETURN cnt (* todo: Upfate Platform.Write to return actual length written. *) + ELSE + IF Platform.Interrupted(error) THEN + interrupted := TRUE; + END; + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.write, ""); + RETURN -1 + END; + END; + END; + END Write; + + PROCEDURE Seek*(fd: File; offset: Count; whence: Whence; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + error: Platform.ErrorCode; relativity: Types.Int16; + BEGIN + CASE whence OF + |fromPos: relativity := Platform.SeekCur + |fromEnd: relativity := Platform.SeekEnd + ELSE relativity := Platform.SeekSet + END; + error := Platform.Seek(fd, offset, relativity); + IF error = 0 THEN RETURN TRUE + ELSE + SysErrors.Raise(errors, error, Sys.lseek, ""); + RETURN FALSE + END; + END Seek; + +(* + + PROCEDURE Tell*(fd: File; VAR offset: Count; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + d0, d1: Types.Int32; + BEGIN + IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, 0, fromPos) THEN + offset := d0; + RETURN TRUE + ELSE + SysErrors.Raise(errors, d0, Sys.lseek, ""); + RETURN FALSE + END; + END Tell; + + PROCEDURE Isatty*(fd: File) : BOOLEAN; + CONST + sizeofStructTermIO = 18; + tcgeta = 00005405H; + VAR + d0, d1: Types.Int32; + buf: ARRAY 32 OF SYS.BYTE; (* Should be more than sufficient *) + BEGIN + (* following system call fails for non-tty's *) + RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf)) + END Isatty; + PROCEDURE Fcntl*(fd: File; request: Types.Int32; VAR arg: Types.Int32; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + VAR + d0, d1: Types.Int32; + BEGIN + interrupted := FALSE; + LOOP + IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, arg) THEN + arg := d0; + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE + END; + END; + END; + END Fcntl; + + PROCEDURE FcntlSet*(fd: File; request: Types.Int32; flags: Types.Set; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + VAR + d0, d1: Types.Int32; + BEGIN + interrupted := FALSE; + LOOP + IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, SYS.VAL(Types.Int32, flags)) THEN + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE + END; + END; + END; + END FcntlSet; + + PROCEDURE FcntlGet*(fd: File; request: Types.Int32; VAR flags: Types.Set; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + d0, d1: Types.Int32; + BEGIN + IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, 0) THEN + ulmSYSTEM.WMOVE(SYS.ADR(d0), SYS.ADR(flags), 1); + RETURN TRUE + ELSE + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE + END; + END FcntlGet; + + PROCEDURE Dup*(fd: File; VAR newfd: File; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + d0, d1: Types.Int32; + a0, a1: Types.Int32; + BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) + IF ulmSYSTEM.UNIXCALL(Sys.dup, d0, d1, fd, a0, a1) THEN + newfd := d0; + RETURN TRUE + ELSE + SysErrors.Raise(errors, d0, Sys.dup, ""); + RETURN FALSE + END; + END Dup; + + PROCEDURE Dup2*(fd, newfd: File; errors: RelatedEvents.Object) : BOOLEAN; + VAR + d0, d1: Types.Int32; + a0, a1: Types.Int32; + fd2: File; + interrupted: BOOLEAN; + BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) + fd2 := newfd; + (* handmade close to avoid unnecessary events *) + IF ~ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, newfd, a0, a1) THEN END; + IF Fcntl(fd, dupfd, fd2, errors, TRUE, interrupted) THEN + IF fd2 = newfd THEN + RETURN TRUE + ELSE + RETURN Close(fd2, errors, TRUE, interrupted) & FALSE + END; + ELSE + RETURN FALSE + END; + END Dup2; + + PROCEDURE Pipe*(VAR readfd, writefd: File; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + d0, d1: Types.Int32; + a0, a1: Types.Int32; + fds : ARRAY 2 OF (*File*)Types.Int32; (* it needs int pipefd[2], and int is 4 bytes long on x86_64 -- noch *) + BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) + IF ulmSYSTEM.UNIXCALL(Sys.pipe, d0, d1, SYS.ADR (fds), a0, a1) THEN + readfd := fds[0]; writefd := fds[1]; + RETURN TRUE + ELSE + SysErrors.Raise(errors, d0, Sys.pipe, ""); + RETURN FALSE + END; + END Pipe; +*) + +END ulmSysIO. diff --git a/src/library/ulm/ulmSysStat.Mod b/src/library/ulm/ulmSysStat.Mod new file mode 100644 index 00000000..addb33f2 --- /dev/null +++ b/src/library/ulm/ulmSysStat.Mod @@ -0,0 +1,189 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: SysStat.om,v $ + Revision 1.3 2000/11/12 13:02:09 borchert + door file type added + + Revision 1.2 2000/11/12 12:48:07 borchert + - conversion adapted to Solaris 2.x + - Lstat added + + Revision 1.1 1994/02/23 08:00:48 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 9/89 + ---------------------------------------------------------------------------- +*) + +MODULE ulmSysStat; + + (* examine inode: stat(2) and fstat(2) *) + + IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors, + SysTypes := ulmSysTypes, Types := ulmTypes; + + CONST + (* file mode: + bit 0 = 1<<0 bit 31 = 1<<31 + + user group other + 3 1 1111 11 + 1 ... 6 5432 109 876 543 210 + +--------+------+-----+-----+-----+-----+ + | unused | type | sst | rwx | rwx | rwx | + +--------+------+-----+-----+-----+-----+ + *) + + type* = {12..15}; + prot* = {0..8}; + + (* file types; example: (stat.mode * type = dir) *) + reg* = {15}; (* regular *) + dir* = {14}; (* directory *) + chr* = {13}; (* character special *) + fifo* = {12}; (* fifo *) + blk* = {13..14}; (* block special *) + symlink* = {13, 15}; (* symbolic link *) + socket* = {14, 15}; (* socket *) + + (* special *) + setuid* = 11; (* set user id on execution *) + setgid* = 10; (* set group id on execution *) + savetext* = 9; (* save swapped text even after use *) + + (* protection *) + uread* = 8; (* read permission owner *) + uwrite* = 7; (* write permission owner *) + uexec* = 6; (* execute/search permission owner *) + gread* = 5; (* read permission group *) + gwrite* = 4; (* write permission group *) + gexec* = 3; (* execute/search permission group *) + oread* = 2; (* read permission other *) + owrite* = 1; (* write permission other *) + oexec* = 0; (* execute/search permission other *) + + (* example for "r-xr-x---": (read + exec) * (owner + group) *) + owner* = {uread, uwrite, uexec}; + group* = {gread, gwrite, gexec}; + other* = {oread, owrite, oexec}; + read* = {uread, gread, oread}; + write* = {uwrite, gwrite, owrite}; + exec* = {uexec, gexec, oexec}; + rwx* = prot; + + TYPE + StatRec* = RECORD (* result of stat(2) and fstat(2) *) + device*: SysTypes.Device; (* ID of device containing a directory entry + for this file *) + inode*: SysTypes.Inode; (* inode number *) + mode*: Types.Set; (* file mode; see mknod(2) *) + nlinks*: Types.Int32; (* number of links *) + uid*: Types.Int32; (* user id of the file's owner *) + gid*: Types.Int32; (* group id of the file's group *) + rdev*: SysTypes.Device; (* ID of device. this entry is defined only for + character special or block special files *) + size*: SysTypes.Offset; (* file size in bytes *) + + (* Blocks and blksize are not available on all platforms. + blksize*: Types.Int32; (* preferred blocksize *) + blocks*: Types.Int32; (* # of blocks allocated *) + *) + + atime*: SysTypes.Time; (* time of last access *) + mtime*: SysTypes.Time; (* time of last data modification *) + ctime*: SysTypes.Time; (* time of last file status change *) + END; + + + PROCEDURE -Aincludesysstat '#include '; + PROCEDURE -Aerrno '#include '; + + PROCEDURE -structstats "struct stat s"; + PROCEDURE -statdev(): Types.Int32 "(INT32)s.st_dev"; + PROCEDURE -statino(): Types.Int32 "(INT32)s.st_ino"; + PROCEDURE -statmode(): Types.Int32 "(INT32)s.st_mode"; + PROCEDURE -statnlink(): Types.Int32 "(INT32)s.st_nlink"; + PROCEDURE -statuid(): Types.Int32 "(INT32)s.st_uid"; + PROCEDURE -statgid(): Types.Int32 "(INT32)s.st_gid"; + PROCEDURE -statrdev(): Types.Int32 "(INT32)s.st_rdev"; + PROCEDURE -statsize(): Types.Int32 "(INT32)s.st_size"; + PROCEDURE -statatime(): Types.Int32 "(INT32)s.st_atime"; + PROCEDURE -statmtime(): Types.Int32 "(INT32)s.st_mtime"; + PROCEDURE -statctime(): Types.Int32 "(INT32)s.st_ctime"; + + (* Blocks and blksize are not available on all platforms. + PROCEDURE -statblksize(): Types.Int32 "(Types.Int32)s.st_blksize"; + PROCEDURE -statblocks(): Types.Int32 "(Types.Int32)s.st_blocks"; + *) + + PROCEDURE -fstat(fd: Types.Int32): Types.Int32 "fstat(fd, &s)"; + PROCEDURE -stat (n: ARRAY OF CHAR): Types.Int32 "stat((char*)n, &s)"; + + PROCEDURE -err(): Types.Int32 "errno"; + + PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; errors: RelatedEvents.Object): BOOLEAN; + BEGIN + structstats; + IF stat(path) < 0 THEN SysErrors.Raise(errors, err(), Sys.newstat, path); RETURN FALSE END; + buf.device := SYS.VAL(SysTypes.Device, statdev()); + buf.inode := SYS.VAL(SysTypes.Inode, statino()); + buf.mode := SYS.VAL(Types.Set, statmode()); + buf.nlinks := statnlink(); + buf.uid := statuid(); + buf.gid := statgid(); + buf.rdev := SYS.VAL(SysTypes.Device, statrdev()); + buf.size := SYS.VAL(SysTypes.Offset, statsize()); + (* Blocks and blksize are not available on all platforms. + buf.blksize := statblksize(); + buf.blocks := statblocks(); + *) + buf.atime := SYS.VAL(SysTypes.Time, statatime()); + buf.mtime := SYS.VAL(SysTypes.Time, statmtime()); + buf.ctime := SYS.VAL(SysTypes.Time, statctime()); + RETURN TRUE; + END Stat; + + PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; errors: RelatedEvents.Object): BOOLEAN; + BEGIN + structstats; + IF fstat(SYS.VAL(Types.Int32, fd)) < 0 THEN SysErrors.Raise(errors, err(), Sys.newfstat, ""); RETURN FALSE END; + buf.device := SYS.VAL(SysTypes.Device, statdev()); + buf.inode := SYS.VAL(SysTypes.Inode, statino()); + buf.mode := SYS.VAL(Types.Set, statmode()); + buf.nlinks := statnlink(); + buf.uid := statuid(); + buf.gid := statgid(); + buf.rdev := SYS.VAL(SysTypes.Device, statrdev()); + buf.size := SYS.VAL(SysTypes.Offset, statsize()); + (* Blocks and blksize are not available on all platforms. + buf.blksize := statblksize(); + buf.blocks := statblocks(); + *) + buf.atime := SYS.VAL(SysTypes.Time, statatime()); + buf.mtime := SYS.VAL(SysTypes.Time, statmtime()); + buf.ctime := SYS.VAL(SysTypes.Time, statctime()); + RETURN TRUE; + END Fstat; + + +END ulmSysStat. diff --git a/src/lib/ulm/x86/ulmSysTypes.Mod b/src/library/ulm/ulmSysTypes.Mod similarity index 87% rename from src/lib/ulm/x86/ulmSysTypes.Mod rename to src/library/ulm/ulmSysTypes.Mod index 174140e7..c757a5dc 100644 --- a/src/lib/ulm/x86/ulmSysTypes.Mod +++ b/src/library/ulm/ulmSysTypes.Mod @@ -30,7 +30,7 @@ MODULE ulmSysTypes; - IMPORT Types := ulmTypes; + IMPORT Types := ulmTypes, Platform; TYPE Address* = Types.Address; @@ -39,17 +39,17 @@ MODULE ulmSysTypes; Size* = Types.Size; Byte* = Types.Byte; - File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *) - Offset* = LONGINT; - Device* = LONGINT; - Inode* = LONGINT; - Time* = LONGINT; + File* = Platform.FileHandle; + Offset* = Types.Int32; + Device* = Types.Int32; + Inode* = Types.Int32; + Time* = Types.Int32; - Word* = INTEGER; (* must have the size of C's int-type *) + Word* = Types.Int32; (* must have the size of C's int-type *) (* Note: linux supports wait4 but not waitid, i.e. these * constants aren't needed. *) - (* + (* CONST (* possible values of the idtype parameter (4 bytes), see @@ -64,7 +64,7 @@ MODULE ulmSysTypes; idAll = 7; (* all processes *) idLwpid = 8; (* an LWP identifier *) TYPE - IdType = INTEGER; (* idPid .. idLwpid *) + IdType = Types.Int32; (* idPid .. idLwpid *) *) END ulmSysTypes. diff --git a/src/library/ulm/ulmTCrypt.Mod b/src/library/ulm/ulmTCrypt.Mod new file mode 100644 index 00000000..f31decda --- /dev/null +++ b/src/library/ulm/ulmTCrypt.Mod @@ -0,0 +1,1771 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: TCrypt.om,v 1.1 1997/04/02 11:54:02 borchert Exp borchert $ + ---------------------------------------------------------------------------- + $Log: TCrypt.om,v $ + Revision 1.1 1997/04/02 11:54:02 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmTCrypt; (* Michael Szczuka *) + + (* Trautner's association method for key exchange *) + + IMPORT + AsymmetricCiphers := ulmAsymmetricCiphers, BlockCiphers := ulmBlockCiphers, + Ciphers := ulmCiphers, Conclusions := ulmConclusions, + Events := ulmEvents, NetIO := ulmNetIO, + PersistentObjects := ulmPersistentObjects, Random := ulmRandomGenerators, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, + Streams := ulmStreams, SYS := SYSTEM, + Types := ulmTypes; + + CONST + M = 16; (* size of an element of CC(M) [ring of Circular Convolution] *) + MaxVar = 8; (* number of variables of a polynomial *) + MaxNrExp = 4; (* maxiumum number of different exponts used during + initialisaton *) + Dim = 2; (* dimension of the linear recursion *) + Rounds = 16; (* length of the linear recursion in rounds *) + LastRounds = 4; (* use the last LastRounds polynomial vectors as + the composed function eta *) + reg = 1; sing = 2; random = 3; + LIST = TRUE; NOLIST = FALSE; + MaxTerms = 1000; + + CONST + writeSetFailed = 0; + readSetFailed = 1; + notRegular = 2; + errorcodes = 3; + + TYPE + (* an element out of CC(M) *) + CCMElement = Types.Set; + Exponent = ARRAY MaxVar OF Types.Int8; + + TYPE + (* a polynomial with coefficients out of CC(M) *) + Polynom = POINTER TO PolynomRec; + PolynomRec = RECORD + koeff : CCMElement; + exp : Exponent; + next : Polynom; + END; + + TYPE + VektorCCM = ARRAY Dim OF CCMElement; + VektorPolynom = ARRAY Dim OF Polynom; + MatCCM = ARRAY Dim, Dim OF CCMElement; + MatPolynom = ARRAY Dim, Dim OF Polynom; + ListCCM = ARRAY Rounds OF CCMElement; + ListPolynom = ARRAY Rounds OF Polynom; + ChainCCM = ARRAY Rounds OF VektorCCM; + ChainPolynom = ARRAY Rounds OF VektorPolynom; + (* to increase the performance of the algorithm there shouldn't be too + many different exponents to start with *) + ListExp = ARRAY MaxNrExp OF Exponent; + + TYPE + (* this type is the input of the TCrypt method *) + TCryptInput = POINTER TO TCryptInputRec; + TCryptInputRec = RECORD + arg : ARRAY MaxVar OF CCMElement; + END; + + TYPE + (* result type after encryption with the public key *) + TCryptTmp = POINTER TO TCryptTmpRec; + TCryptTmpRec = RECORD + numerator : ChainCCM; + denominator : ListCCM; + END; + + TYPE + (* result type of the algorithm *) + TCryptRes = POINTER TO TCryptResRec; + TCryptResRec = RECORD + arg : ARRAY LastRounds OF VektorCCM; + END; + + TYPE + (* this type represents the public function f resp. phi *) + Phi = POINTER TO PhiRec; + PhiRec = RECORD + num : ChainPolynom; + denom : ListPolynom; + END; + + TYPE + (* the private/secret function g resp. psi consisting of an inital matrix + and a permutation *) + Psi = POINTER TO PsiRec; + PsiRec = RECORD + (* although the inital matrix consists only of elements out of CC(M) + this generalization is useful since all other matrces consist of + polynomials *) + initialmatrix : MatCCM; + (* correcting factors *) + korrNum : ChainCCM; + korrDenom : ListCCM; + END; + + (* the public function h resp. eta being the composition of f/phi + and g/psi *) + TYPE + Eta = POINTER TO EtaRec; + EtaRec = RECORD + p : ARRAY LastRounds OF VektorPolynom; + END; + + TYPE + (* the declaration of a basic type which PublicCipher and PrivateCipher + are descendents from seems a good idea ... at least to me :) *) + Cipher* = POINTER TO CipherRec; + CipherRec* = RECORD (AsymmetricCiphers.CipherRec) END; + (* the specific format of a public key for Trautner's technique *) + PublicCipher = POINTER TO PublicCipherRec; + PublicCipherRec = RECORD + (CipherRec) + phi : Phi; + eta : Eta; + END; + (* the specific format of a key for Trautner's technique *) + PrivateCipher = POINTER TO PrivateCipherRec; + PrivateCipherRec = RECORD + (CipherRec) + phi : Phi; + psi : Psi; + eta : Eta; + END; + + TYPE + ErrorEvent = POINTER TO ErrorEventRec; + ErrorEventRec = RECORD + (Events.EventRec) + errorcode : Types.Int8; + END; + + VAR + pubType, privType, cipherType : Services.Type; + pubIf, privIf, cipherIf : PersistentObjects.Interface; + NullCCM, EinsCCM : CCMElement; (* the zero and unit of CC(M) *) + NullExp : Exponent; (* consists of zero exponents *) + NullExpList : ListExp; (* a pseudo list for CreatePolynom *) + GlobalExpList : ListExp; (* contains the exponents which should be used + when calling CreatePolynom *) + NullPolynom : Polynom; (* the zero polynomial *) + PolFeld : ARRAY MaxTerms OF Polynom; (* used for sorting purposes *) + PreEvalArg : ARRAY M OF TCryptInput; (* precomputed values to speed + up evaluation of a polynomial *) + k : Types.Int8; (* simple counter during initialisation *) + error : Events.EventType; + errormsg : ARRAY errorcodes OF Events.Message; + + + (* ***** error handling ***** *) + + PROCEDURE InitErrorHandling; + BEGIN + Events.Define(error); + errormsg[writeSetFailed] := "couldn't write set"; + errormsg[readSetFailed] := "couldn't read set"; + errormsg[notRegular] := "element isn't regular"; + END InitErrorHandling; + + PROCEDURE Error(s: Streams.Stream; errorcode: Types.Int8); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.message := errormsg[errorcode]; + event.type := error; + event.errorcode := errorcode; + RelatedEvents.Raise(s, event); + END Error; + + (* ***** arithmetic functions for elements out of CC(M) ***** *) + + PROCEDURE RegulaerCCM (x: CCMElement) : BOOLEAN; + (* tests x for regularity [a regular CCMElement contains an odd number of + set bits]; returns TRUE when x is regular, FALSE otherwise *) + VAR + res, i : Types.Int8; + BEGIN + i := 0; + res := 0; + REPEAT (* counting the set bits *) + IF i IN x THEN + INC(res); + END; + INC(i); + UNTIL i>=M; + RETURN ((res MOD 2) = 1); + END RegulaerCCM; + + PROCEDURE EqualCCM (x, y: CCMElement) : BOOLEAN; + (* compares x and y for equality; if x and y are equal TRUE is returned, + FALSE otherwise *) + VAR + i : Types.Int8; + BEGIN + i := 0; + WHILE i < M DO + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + RETURN FALSE; + END; + INC(i); + END; + RETURN TRUE; + END EqualCCM; + + PROCEDURE AddCCM (x, y: CCMElement; VAR z: CCMElement); + (* add x and y in CC(M) *) + VAR + i : Types.Int8; + BEGIN + z := NullCCM; + i := 0; + REPEAT + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + z := z + {i}; + END; + INC(i); + UNTIL i>=M; + END AddCCM; + + PROCEDURE MulCCM (x, y: CCMElement; VAR z: CCMElement); + (* multiply x and y in CC(M) *) + VAR + i, j, diff : Types.Int8; + tmp : Types.Int32; + BEGIN + z := NullCCM; + i := 0; + REPEAT + j := 0; + tmp := 0; + REPEAT + diff := i-j; + IF diff >= 0 THEN + IF (j IN x) & (diff IN y) THEN + INC(tmp); + END; + ELSE + IF (j IN x) & ((M+diff) IN y) THEN + INC(tmp); + END; + END; + INC(j); + UNTIL j>=M; + IF (tmp MOD 2) = 1 THEN + z := z + {i}; + END; + INC(i); + UNTIL i>=M; + END MulCCM; + + PROCEDURE PowerCCM (x: CCMElement; exp: Types.Int32; VAR z: CCMElement); + (* raises x to the power exp in CC(M) *) + VAR + tmp : CCMElement; + BEGIN + (* some special cases first *) + IF exp >= M THEN + IF ~RegulaerCCM(x) THEN + (* x is singular -> result is zero *) + z := NullCCM; + RETURN; + END; + (* x is regular -> compute the modulus of exp mod M and use this + instead of exp *) + exp := exp MOD M; + END; + IF exp = 0 THEN + z := EinsCCM; + RETURN; + END; + IF exp = 1 THEN + z := x; + RETURN; + END; + + (* default case; use a "square and multiply" technique *) + tmp := x; + z := EinsCCM; + REPEAT + IF exp MOD 2 = 1 THEN + MulCCM(z, tmp, z); + END; + exp := exp DIV 2; + MulCCM(tmp, tmp, tmp); + UNTIL exp < 1; + END PowerCCM; + + PROCEDURE CreateCCM (VAR x: CCMElement; mode: Types.Int8); + (* creates a random element out of CC(M) depending on mode which + can be reg, sing or random; + the result is in any case different from the zero *) + VAR + i, SetBits: Types.Int8; + BEGIN + x := NullCCM; + REPEAT + i := 0; + SetBits := 0; + REPEAT + IF Random.Flip() THEN + (* set bit *) + x := x + {i}; + INC(SetBits); + END; + INC(i); + UNTIL i >= (M-1); + UNTIL SetBits > 0; (* at least one bit must be set so that the result + differs from zero *) + + CASE mode OF + random: + IF Random.Flip() THEN + x := x + {M-1}; + END; + | sing: (* singular element - even # of bits *) + IF (SetBits MOD 2) = 1 THEN + x := x + {M-1}; + END; + | reg: (* regular element - odd # of bits *) + IF ((SetBits + 1) MOD 2) = 1 THEN + x := x + {M-1}; + END; + ELSE + END; + END CreateCCM; + + (* ***** arithmetic functions for polynomials over CC(M) ***** *) + + PROCEDURE LengthPolynom(p: Polynom) : Types.Int32; + (* returns the number of terms which make up the polynomial p *) + VAR + i : Types.Int32; + BEGIN + i := 0; + WHILE p # NIL DO + INC(i); + p := p.next; + END; + RETURN i; + END LengthPolynom; + + PROCEDURE RegulaerPolynom (p: Polynom) : BOOLEAN; + (* tests the regularity of a polynomial [a polynomial is regular + iff the # of regular coefficients is odd] *) + VAR + regkoeffs : Types.Int8; + BEGIN + regkoeffs := 0; + WHILE p # NIL DO + IF RegulaerCCM(p.koeff) THEN + (* count # of reg. coefficients *) + INC(regkoeffs); + END; + p := p.next; + END; + RETURN (regkoeffs MOD 2) = 1; + END RegulaerPolynom; + + PROCEDURE CmpExp (exp1, exp2: Exponent) : Types.Int8; + (* compares two exponent vectors and returns 0 on equality, a + positive value if exp1>exp2 and a negative value if exp1 e2 THEN + cmp := 1; diff := TRUE; + END; + END; + INC(i); + UNTIL i >= MaxVar; + + IF sum1 < sum2 THEN + RETURN -2; + END; + IF sum1 > sum2 THEN + RETURN 2; + END; + + RETURN cmp + END CmpExp; + + PROCEDURE ArrangePolynom (VAR p: Polynom); + (* arrange a polynomial according to the order given by CmpExp *) + VAR + r : Polynom; + cnt : Types.Int32; + + PROCEDURE SortPolynom(left, right: Types.Int32); + (* sort the global field PolFeld with the quicksort algorithm *) + VAR + mid : Types.Int32; + + PROCEDURE Partition(l, r: Types.Int32) : Types.Int32; + VAR + koeff : CCMElement; + exp : Exponent; + cmp : Exponent; + i, j : Types.Int32; + BEGIN + cmp := PolFeld[(l+r) DIV 2].exp; + i := l-1; + j := r+1; + LOOP + REPEAT + DEC(j); + UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; + REPEAT + INC(i); + UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; + IF i < j THEN + koeff := PolFeld[i].koeff; + exp := PolFeld[i].exp; + PolFeld[i].koeff := PolFeld[j].koeff; + PolFeld[i].exp := PolFeld[j].exp; + PolFeld[j].koeff := koeff; + PolFeld[j].exp := exp; + ELSE + RETURN j; + END; + END; + END Partition; + + BEGIN + IF left < right THEN + mid := Partition(left, right); + SortPolynom(left, mid); + SortPolynom(mid+1, right); + END; + END SortPolynom; + + BEGIN (* ArrangePolynom *) + IF p = NIL THEN + RETURN; + END; + r := p; + cnt := 0; + WHILE (p # NIL) & (cnt < MaxTerms) DO + PolFeld[cnt] := p; + INC(cnt); + p := p.next; + END; + (* polynomial contains too many terms; this shouldn't happen if all + parameters are set to reasonable values and MaxTerms is high + enough *) + ASSERT(cnt 1 THEN + SortPolynom(0, cnt-1); + END; + p := r; + END ArrangePolynom; + + PROCEDURE CopyPolynom (s: Polynom; VAR t: Polynom); + (* copy the source polynomial s to a new target t *) + VAR + troot : Polynom; + BEGIN + IF s = NIL THEN + t := NIL; + RETURN; + END; + NEW(t); + troot := t; (* save the root of t *) + WHILE s # NIL DO + troot.koeff := s.koeff; + troot.exp := s.exp; + s := s.next; + IF s # NIL THEN + NEW(troot.next); + troot := troot.next; + ELSE + troot.next := NIL; + END; + END; + END CopyPolynom; + + PROCEDURE AddPolynom (p, q: Polynom; VAR r: Polynom); + (* add two polynomial; the polynomials must be sorted by the exponents as + is the result *) + VAR + term1, term2 : Polynom; + last : Polynom; (* the last term of the result *) + tmp : Polynom; + cmpres : Types.Int8; + BEGIN + IF (p = NIL) & (q = NIL) THEN + r := NIL; + RETURN; + END; + NEW(r); + term1 := p; (* term1 runs through all terms of p *) + term2 := q; (* same with term2 for q *) + tmp := r; (* save the root of r *) + last := tmp; + REPEAT + IF (term1 = NIL) OR (term2 = NIL) THEN + IF term2 = NIL THEN + (* no further terms in q *) + WHILE term1 # NIL DO + (* copy the remaining terms of p *) + tmp.koeff := term1.koeff; + tmp.exp := term1.exp; + term1 := term1.next; + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + last := tmp; + NEW(tmp.next); + tmp := tmp.next; + END; + END; + ELSE (* no further terms in p *) + WHILE term2 # NIL DO + tmp.koeff := term2.koeff; + tmp.exp := term2.exp; + term2 := term2.next; + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + last := tmp; + NEW(tmp.next); + tmp := tmp.next; + END; + END; + END; + ELSE (* both p and q still have a term *) + cmpres := CmpExp(term1.exp, term2.exp); + IF cmpres = 0 THEN (* add when exponents are equal *) + AddCCM(term1.koeff, term2.koeff, tmp.koeff); + tmp.exp := term1.exp; + term1 := term1.next; + term2 := term2.next; + ELSE + IF cmpres < 0 THEN (* exp2 > exp1 *) + tmp.koeff := term2.koeff; + tmp.exp := term2.exp; + term2 := term2.next; + ELSE (* exp1 > exp2 *) + tmp.koeff := term1.koeff; + tmp.exp := term1.exp; + term1 := term1.next; + END; + END; + (* zero coefficients = zero terms shouldn't occur in the result *) + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + NEW(tmp.next); + last := tmp; + tmp := tmp.next; + END; + END; + UNTIL (term1 = NIL) & (term2 = NIL); + + (* forget last created term *) + last.next := NIL; + END AddPolynom; + + PROCEDURE MulTerm (p, term: Polynom; VAR r: Polynom); + (* multiply a polynomial with a single term; is used by MulPolynom *) + VAR + tmp : Polynom; + last : Polynom; + + (* add two exponent vetors; addition is modulo M *) + PROCEDURE AddExp (exp1, exp2 : Exponent; VAR res: Exponent); + VAR + i : Types.Int8; + BEGIN + i := 0; + WHILE i 0 DO + IF (exp MOD 2) = 1 THEN + MulPolynom(res, tmp, res); + END; + MulPolynom(tmp, tmp, tmp); + exp := exp DIV 2; + END; + END InvertPolynom; + + PROCEDURE EvalPolynom (p: Polynom; VAR res: CCMElement); + (* evaluate p; a precomputed list of all the powers of the argument can + be found in the global variable PreEvalArg *) + VAR + i : Types.Int8; + pow, prod : CCMElement; + BEGIN + res := NullCCM; + IF p = NIL THEN + RETURN; + END; + WHILE p # NIL DO + prod := PreEvalArg[p.exp[0]].arg[0]; + i := 1; + REPEAT + pow := PreEvalArg[p.exp[i]].arg[i]; + MulCCM(prod, pow, prod); + INC(i); + UNTIL i >= MaxVar; + MulCCM(prod, p.koeff, prod); + AddCCM(res, prod, res); + p := p.next; + END; + END EvalPolynom; + + PROCEDURE CreateExp (VAR exp: Exponent); + (* creates a random vector of exponents *) + VAR + i : Types.Int8; + BEGIN + i := 0; + WHILE i 0 DO + IF (kk MOD 2) = 1 THEN + MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); + END; + INC(ii,ii); + kk := kk DIV 2; + END; + PreEvalArg[k].arg[i] := tmp; + INC(k); + END; + INC(i); + END; + END PreComputeArgs; + + PROCEDURE EvaluatePhi (arg: TCryptInput; data: Phi) : TCryptTmp; + (* evaluate the public function phi (represented by data) with + argument arg *) + VAR + res : TCryptTmp; + r, d : Types.Int8; + BEGIN + NEW(res); + PreComputeArgs(arg); + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + EvalPolynom(data.num[r][d], res.numerator[r][d]); + INC(d); + END; + EvalPolynom(data.denom[r], res.denominator[r]); + INC(r); + END; + RETURN res; + END EvaluatePhi; + + PROCEDURE EvaluatePsi (arg: TCryptTmp; data: Psi) : TCryptRes; + (* evalute the private function psi *) + VAR + res : TCryptRes; + mat, prev : MatCCM; + num, denom, inv : CCMElement; + vek : VektorCCM; + A : ChainCCM; + r, d : Types.Int8; + BEGIN + (* first correct the input with the correlating inverts *) + MulCCM(arg.denominator[0], data.korrDenom[0], denom); + PowerCCM(denom, M-1, inv); + MulCCM(arg.numerator[0][0], data.korrNum[0][0], num); + MulCCM(num, inv, vek[0]); + MulCCM(arg.numerator[0][1], data.korrNum[0][1], num); + MulCCM(num, inv, vek[1]); + MulMatrix(data.initialmatrix, vek, A[0]); + prev := data.initialmatrix; + r := 1; + WHILE r < Rounds DO + (* the matrix for the current round of the recursion must be computed + each round *) + BuildMatrix(mat, prev, A[r-1]); + prev := mat; + MulCCM(arg.denominator[r], data.korrDenom[r], denom); + PowerCCM(denom, M-1, inv); + MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); + MulCCM(num, inv, vek[0]); + MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); + MulCCM(num, inv, vek[1]); + MulMatrix(mat, vek, A[r]); + INC(r); + END; + NEW(res); + r := 0; + WHILE r < LastRounds DO + d := 0; + WHILE d < Dim DO + res.arg[r][d] := A[Rounds-LastRounds+r][d]; + INC(d); + END; + INC(r); + END; + RETURN res; + END EvaluatePsi; + + PROCEDURE EvaluateEta (arg: TCryptInput; data: Eta) : TCryptRes; + (* evaluate the public function eta (composition of phi and psi) *) + VAR + l, d : Types.Int8; + res : TCryptRes; + BEGIN + NEW(res); + PreComputeArgs(arg); + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + EvalPolynom(data.p[l][d], res.arg[l][d]); + INC(d); + END; + INC(l); + END; + RETURN res; + END EvaluateEta; + + PROCEDURE Eof (s: Streams.Stream) : BOOLEAN; + (* returns TRUE if no bytes are left to read from stream s *) + VAR + b : SYS.BYTE; + BEGIN + RETURN ~Streams.ReadByte(s, b) OR ~Streams.Back(s); + END Eof; + + PROCEDURE Encrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: Types.Int32; s: Streams.Stream) : BOOLEAN; + (* interface procedure for Ciphers.Encrypt *) + VAR + i, j : Types.Int8; + ccmarg : TCryptInput; + ccmres : TCryptTmp; + wholeStream : BOOLEAN; + BEGIN + (* check if the whole stream msg shall be encrypted or only a certain + amount of bytes *) + IF length <= 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE + END; + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + IF ~RegulaerCCM(ccmarg.arg[i]) THEN + Error(msg, notRegular); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); + ELSE + ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); + END; + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(i); + END; + DEC(length, MaxVar*(M DIV 8)); + END; + RETURN TRUE; + END Encrypt; + + PROCEDURE Decrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: Types.Int32; s: Streams.Stream) : BOOLEAN; + (* interface procedure for Ciphers.Decrypt *) + VAR + i, j : Types.Int8; + inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; + ccmarg : TCryptTmp; + ccmres : TCryptRes; + wholeStream : BOOLEAN; + BEGIN + IF length < 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE; + END; + WITH key:PrivateCipher DO + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(j); + END; + IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(i); + END; + ccmres := EvaluatePsi(ccmarg, key.psi); + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + INC(i); + END; + DEC (length, Rounds*Dim*(M DIV 8)); + END; + END; + RETURN TRUE; + END Decrypt; + + PROCEDURE ComposedEncrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: Types.Int32; s: Streams.Stream) : BOOLEAN; + (* interface procedure for AsymmetricCiphers.ComposedEncrypt *) + VAR + i, j : Types.Int8; + ccmarg : TCryptInput; + ccmres : TCryptRes; + in, out : ARRAY (M DIV 8) OF SYS.BYTE; + wholeStream : BOOLEAN; + BEGIN + IF length < 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE; + END; + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); + ELSE + ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); + END; + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + INC(i); + END; + DEC (length, MaxVar*(M DIV 8)); + END; + RETURN TRUE; + END ComposedEncrypt; + + PROCEDURE RandomStream (s: Streams.Stream); + (* writes some random elements of CC(M) to the stream s which can then + be used as an input for Trautner's TCRYPT *) + VAR + ccm : CCMElement; + bytes : ARRAY M DIV 8 OF SYS.BYTE; + i : Types.Int32; + BEGIN + i := 0; + WHILE i < MaxVar DO + CreateCCM(ccm, reg); + IF ~NetIO.WriteSet(s, ccm) THEN + Error(s, writeSetFailed); + END; + INC(i); + END; + END RandomStream; + + PROCEDURE PublicCipherCreate (VAR obj: PersistentObjects.Object); + (* constructor for a public cipher *) + VAR + pub : PublicCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; + BEGIN + NEW(pub); NEW(pub.phi); NEW(pub.eta); + PersistentObjects.Init(pub, pubType); + NEW(if); if.encrypt := Encrypt; if.decrypt := NIL; + if.compencrypt := ComposedEncrypt; if.split := NIL; + if.randomStream := RandomStream; + caps := {AsymmetricCiphers.composed}; + AsymmetricCiphers.Init(pub, if, caps, M*MaxVar, M*Dim); + obj := pub; + END PublicCipherCreate; + + PROCEDURE Split (VAR public: AsymmetricCiphers.Cipher; + key: AsymmetricCiphers.Cipher); + (* interface procedure for asymmetric interface *) + VAR + pub: PublicCipher; + obj: PersistentObjects.Object; + BEGIN + WITH key:PrivateCipher DO + PublicCipherCreate(obj); pub := obj(PublicCipher); + pub.phi := key.phi; + pub.eta := key.eta; + public := pub; + END; + END Split; + + PROCEDURE CipherCreate (VAR obj: PersistentObjects.Object); + (* constructor for a private cipher *) + VAR + key : PrivateCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; + BEGIN + NEW(key); NEW(key.phi); NEW(key.psi); NEW(key.eta); + PersistentObjects.Init(key, privType); + NEW(if); if.encrypt := Encrypt; if.decrypt := Decrypt; + if.compencrypt := ComposedEncrypt; if.split := Split; + if.randomStream := RandomStream; + caps := {AsymmetricCiphers.composed, AsymmetricCiphers.isPrivateKey}; + AsymmetricCiphers.Init(key, if, caps, M*MaxVar, M*Dim); + obj := key; + END CipherCreate; + + PROCEDURE Create* (VAR key: Ciphers.Cipher); + (* creates a cipher for the use with Trautner's TCRYPT algorithm *) + VAR + tmpKey : PrivateCipher; + obj : PersistentObjects.Object; + phi : Phi; + psi : Psi; + eta : Eta; + BEGIN + CipherCreate(obj); tmpKey := obj(PrivateCipher); + CreateMaps(tmpKey.phi, tmpKey.psi, tmpKey.eta); + key := tmpKey; + END Create; + + PROCEDURE WritePolynom (s: Streams.Stream; p: Polynom) : BOOLEAN; + (* writes the polynomial p onto the stream s *) + CONST + index = M DIV 8; + VAR + nrOfTerms, i : Types.Int32; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + nrOfTerms := LengthPolynom(p); + IF ~NetIO.WriteInteger(s, nrOfTerms) THEN + RETURN FALSE; + END; + WHILE nrOfTerms > 0 DO + IF ~NetIO.WriteSet(s, p.koeff) THEN + RETURN FALSE; + END; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + p := p.next; + DEC(nrOfTerms); + END; + RETURN TRUE; + END WritePolynom; + + PROCEDURE ReadPolynom (s: Streams.Stream; VAR p: Polynom) : BOOLEAN; + (* reads a polynomial from stream s *) + CONST + index = M DIV 8; + VAR + nrOfTerms, i : Types.Int32; + pol : Polynom; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + IF ~NetIO.ReadInteger(s, nrOfTerms) THEN + RETURN FALSE; + END; + NEW(p); + pol := p; + WHILE nrOfTerms > 0 DO + IF ~NetIO.ReadSet(s, pol.koeff) THEN + RETURN FALSE; + END; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + DEC(nrOfTerms); + IF nrOfTerms > 0 THEN + NEW(pol.next); + pol := pol.next; + END + END; + RETURN TRUE; + END ReadPolynom; + + PROCEDURE PhiWrite (s: Streams.Stream; data: Phi) : BOOLEAN; + (* writes the data structure for the public function phi onto a stream *) + VAR + r, d, k : Types.Int32; + BEGIN + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~WritePolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PhiWrite; + + PROCEDURE PhiRead (s: Streams.Stream; VAR data: Phi) : BOOLEAN; + (* reads the data structure for the public function phi from a stream *) + VAR + r, d, k : Types.Int32; + BEGIN + NEW(data); + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~ReadPolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PhiRead; + + PROCEDURE PsiWrite (s: Streams.Stream; data: Psi) : BOOLEAN; + (* writes the data structure for the private function psi onto a stream *) + CONST + index = M DIV 8; + VAR + dx, dy, r, d : Types.Int32; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + dy := 0; + WHILE dy < Dim DO + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); + END; + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PsiWrite; + + PROCEDURE PsiRead (s: Streams.Stream; VAR data: Psi) : BOOLEAN; + (* reads the data structure for the private function psi from a stream *) + CONST + index = M DIV 8; + VAR + dy, dx, r, d : Types.Int32; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + dy := 0; + WHILE dy < Dim DO + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); + END; + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PsiRead; + + PROCEDURE EtaWrite (s: Streams.Stream; data: Eta) : BOOLEAN; + (* writes the data structure for the public function eta onto a stream *) + VAR + l, d : Types.Int32; + BEGIN + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); + END; + RETURN TRUE; + END EtaWrite; + + PROCEDURE EtaRead (s: Streams.Stream; VAR data: Eta) : BOOLEAN; + (* reads the data structure for the public function eta from a stream *) + VAR + l, d : Types.Int32; + BEGIN + NEW(data); + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); + END; + RETURN TRUE; + END EtaRead; + + PROCEDURE PubWrite (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PublicCipher DO + RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); + END; + END PubWrite; + + PROCEDURE CipherWrite (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PrivateCipher DO + RETURN PhiWrite(s, obj.phi) & + PsiWrite(s, obj.psi) & + EtaWrite(s, obj.eta); + END; + END CipherWrite; + + PROCEDURE PubRead (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PublicCipher DO + IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; + END; + RETURN TRUE; + END PubRead; + + PROCEDURE CipherRead (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PrivateCipher DO + IF ~PhiRead(s, obj.phi) OR + ~PsiRead(s, obj.psi) OR + ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; + END; + RETURN TRUE; + END CipherRead; + +BEGIN + (* init of the zero and unit of CC(M) *) + NullCCM := {}; + EinsCCM := {0}; + + (* init of the zero exponent *) + k := 0; + WHILE k= 0) & (pos <= s.len) THEN s.pos := pos; diff --git a/src/library/ulm/ulmTimeConditions.Mod b/src/library/ulm/ulmTimeConditions.Mod new file mode 100644 index 00000000..0e33c07b --- /dev/null +++ b/src/library/ulm/ulmTimeConditions.Mod @@ -0,0 +1,412 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-2004 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: TimeConditi.om,v 1.5 2004/04/05 16:23:37 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: TimeConditi.om,v $ + Revision 1.5 2004/04/05 16:23:37 borchert + bug fix: Test must not call anything which causes directly or + indirectly WaitFor to be called; hence we schedule + a timer event in all cases where this is possible; + the only exception remains Clocks.system where we + take it for granted that the clock operations are + that simple that they do not lead to WaitFor + (was necessary to get RemoteClocks working again) + + Revision 1.4 2004/02/19 15:23:10 borchert + - Init added to support extensions of TimeConditions.Condition + - using Clocks.Passed instead of Clocks.GetTime in some instances + to reduce the number of system calls needed + - Timers event is only generated now if strictly needed, + i.e. if SendEvent has been called + + Revision 1.3 2001/04/30 15:25:12 borchert + several improvements / bug fixes in context of domain-oriented + condition handling + + Revision 1.2 1995/04/06 14:36:16 borchert + fixes due to changed if & semantics of Conditions + + Revision 1.1 1994/02/22 20:11:18 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 1/92 + ---------------------------------------------------------------------------- +*) + +MODULE ulmTimeConditions; + + IMPORT + Clocks := ulmClocks, Conditions := ulmConditions, Disciplines := ulmDisciplines, + Events := ulmEvents, Op := ulmOperations, Priorities := ulmPriorities, + Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, + Timers := ulmTimers, Times := ulmTimes; + + TYPE + Domain = POINTER TO DomainRec; + DomainRec = + RECORD + (Conditions.DomainRec) + clock: Clocks.Clock; + alarm: Events.EventType; + event: Events.Event; (* event of SendEvent *) + END; + Condition = POINTER TO ConditionRec; + ConditionRec* = + RECORD + (Conditions.ConditionRec) + time: Times.Time; + passed: BOOLEAN; (* becomes TRUE if the time has passed *) + scheduled: BOOLEAN; (* Timer event scheduled? *) + domain: Domain; + END; + + TYPE + (* this discpline will be attached to clocks *) + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + domain: Domain; + END; + VAR + disciplineId: Disciplines.Identifier; + + TYPE + WakeupEvent = POINTER TO WakeupEventRec; + WakeupEventRec = + RECORD + (Events.EventRec) + condition: Condition; + awaked: BOOLEAN; (* set to true by Wakeup event handler *) + END; + + VAR + if: Conditions.Interface; + + PROCEDURE FixTime(VAR time: Times.Time; + currentTime: Times.Time; + clock: Clocks.Clock); + (* convert relative time measures into absolute time specs *) + VAR op: Op.Operand; + BEGIN + IF Scales.IsRelative(time) THEN + Clocks.GetTime(clock, currentTime); + op := time; Op.Add3(op, currentTime, time); time := op(Times.Time) + END; + END FixTime; + + PROCEDURE Wakeup(event: Events.Event); + (* note that we strictly rely on the capability of the + underlying clock to raise this event at the appropriate + time; we are unable to verify it because that could + deadlock us in case of remote clocks + *) + VAR + condevent: Events.Event; (* event requested by SendEvent *) + BEGIN + WITH event: WakeupEvent DO + event.awaked := TRUE; + IF event.condition # NIL THEN + event.condition.passed := TRUE; + event.condition.scheduled := FALSE; + condevent := event.condition.domain.event; + IF condevent # NIL THEN + event.condition.domain.event := NIL; + Events.Raise(condevent); + END; + END; + END; + END Wakeup; + + PROCEDURE ScheduleEvent(condition: Condition); + VAR + wakeup: WakeupEvent; + domain: Domain; + BEGIN + IF ~condition.scheduled THEN + domain := condition.domain; + ASSERT(domain.alarm # NIL); + NEW(wakeup); wakeup.type := domain.alarm; + wakeup.awaked := FALSE; wakeup.condition := condition; + condition.scheduled := TRUE; + Timers.Schedule(domain.clock, condition.time, wakeup); + END; + END ScheduleEvent; + + PROCEDURE Init*(condition: Condition; clock: Clocks.Clock; time: Times.Time); + (* like Create but without NEW *) + VAR + clockDisc: Discipline; + disc: Disciplines.Discipline; + domain: Domain; + desc: Conditions.Description; + priorityOfClock: Priorities.Priority; + currentTime: Times.Time; + BEGIN + IF Disciplines.Seek(clock, disciplineId, disc) THEN + domain := disc(Discipline).domain; + ELSE + (* create new domain *) + NEW(desc); desc.caps := {}; desc.internal := TRUE; + IF clock = Clocks.system THEN + desc.caps := desc.caps + + {Conditions.timelimit, Conditions.timecond}; + END; + IF Clocks.timer IN Clocks.Capabilities(clock) THEN + Clocks.GetPriority(clock, priorityOfClock); + IF priorityOfClock > Priorities.base THEN + desc.caps := desc.caps + {Conditions.select, Conditions.async}; + desc.internal := priorityOfClock < Priorities.interrupts; + END; + END; + NEW(domain); Conditions.InitDomain(domain, if, desc); + domain.clock := clock; + IF Clocks.timer IN Clocks.Capabilities(clock) THEN + Events.Define(domain.alarm); + Events.SetPriority(domain.alarm, priorityOfClock + 1); + Events.Handler(domain.alarm, Wakeup); + ELSE + domain.alarm := NIL; + END; + NEW(clockDisc); clockDisc.id := disciplineId; + clockDisc.domain := domain; + Disciplines.Add(clock, clockDisc); + domain.event := NIL; + END; + Conditions.Init(condition, domain); + FixTime(time, currentTime, clock); condition.time := time; + condition.domain := domain; + condition.passed := Clocks.Passed(clock, time); + condition.scheduled := FALSE; + IF ~condition.passed & + (domain.alarm # NIL) & (clock # Clocks.system) THEN + ScheduleEvent(condition); + END; + END Init; + + PROCEDURE Create*(VAR condition: Conditions.Condition; + clock: Clocks.Clock; time: Times.Time); + (* create and initialize a time condition: + is the current time of the clock greater than or + equal to `time'; + if time is relative then it is taken relative to the current time + *) + VAR + timeCond: Condition; + BEGIN + NEW(timeCond); + Init(timeCond, clock, time); + condition := timeCond; + END Create; + + (* ======== interface procedures ================================ *) + + PROCEDURE GetTime(clock: Clocks.Clock; + VAR currentTime: Times.Time; + errors: RelatedEvents.Object) : BOOLEAN; + (* get the current time of clock and check for errors *) + VAR + oldEvents, newEvents: RelatedEvents.Queue; + BEGIN + RelatedEvents.GetQueue(clock, oldEvents); + Clocks.GetTime(clock, currentTime); + RelatedEvents.GetQueue(clock, newEvents); + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(errors, newEvents); + END; + IF oldEvents # NIL THEN + RelatedEvents.AppendQueue(clock, oldEvents); + END; + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(clock, newEvents); + END; + RETURN newEvents = NIL + END GetTime; + + PROCEDURE Passed(clock: Clocks.Clock; + time: Times.Time; + VAR passed: BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + oldEvents, newEvents: RelatedEvents.Queue; + BEGIN + RelatedEvents.GetQueue(clock, oldEvents); + passed := Clocks.Passed(clock, time); + RelatedEvents.GetQueue(clock, newEvents); + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(errors, newEvents); + END; + IF oldEvents # NIL THEN + RelatedEvents.AppendQueue(clock, oldEvents); + END; + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(clock, newEvents); + END; + RETURN newEvents = NIL + END Passed; + + PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + currentTime: Times.Time; + BEGIN + WITH domain: Domain DO WITH condition: Condition DO + IF condition.passed THEN RETURN TRUE END; + IF condition.domain.event # NIL THEN RETURN FALSE END; + IF condition.scheduled THEN RETURN FALSE END; + IF ~Passed(domain.clock, condition.time, + condition.passed, errors) THEN + condition.passed := TRUE; + RETURN TRUE + END; + RETURN condition.passed + END; END; + END Test; + + PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet; + VAR minTime: Times.Time; + VAR minCond: Condition); + VAR + condition: Conditions.Condition; (* Condition *) + op: Op.Operand; + BEGIN + minTime := NIL; + Conditions.ExamineConditions(conditionSet); + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + IF (minTime = NIL) OR (Op.Compare(condition(Condition).time, minTime) < 0) THEN + minTime := condition(Condition).time; minCond := condition(Condition) + END; + END; + op := minTime; Op.Assign(op, minTime); minTime := op(Times.Time) (* take a copy *) + END GetMinTime; + + PROCEDURE Select(domain: Conditions.Domain; + conditionSet: Conditions.ConditionSet; + time: Times.Time; + VAR setOfTrueConditions: Conditions.ConditionSet; + errors: RelatedEvents.Object; + retry: BOOLEAN; + VAR interrupted: BOOLEAN) : BOOLEAN; + VAR + minTime: Times.Time; + minCond: Condition; + currentTime: Times.Time; (* of Clocks.system *) + condition: Conditions.Condition; (* Condition *) + wakeup: WakeupEvent; + anythingTrue: BOOLEAN; + + PROCEDURE Failure; + (* we are unable to retrieve the time; + so we have to mark all conditions as passed + and to return the whole set + *) + VAR + condition: Conditions.Condition; (* Condition *) + BEGIN + Conditions.CreateSet(setOfTrueConditions); + Conditions.ExamineConditions(conditionSet); + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + condition(Condition).passed := TRUE; + Conditions.Incl(setOfTrueConditions, condition(Condition)); + END; + END Failure; + + BEGIN (* Select *) + WITH domain: Domain DO + GetMinTime(conditionSet, minTime, minCond); + + (* block current process, if necessary *) + interrupted := FALSE; + IF time # NIL THEN + Clocks.GetTime(Clocks.system, currentTime); + FixTime(time, currentTime, Clocks.system); + NEW(wakeup); wakeup.type := domain.alarm; + wakeup.condition := NIL; wakeup.awaked := FALSE; + Timers.Schedule(Clocks.system, time, wakeup); + END; + IF ~GetTime(domain.clock, currentTime, errors) THEN + Failure; RETURN TRUE + END; + + IF ~minCond.passed THEN + LOOP (* goes only into loop if retry = TRUE & we get interrupted *) + Process.Pause; + IF wakeup.awaked THEN EXIT END; + interrupted := ~minCond.passed; + IF ~interrupted THEN EXIT END; + IF ~retry THEN RETURN FALSE END; + END; + END; + + anythingTrue := FALSE; + Conditions.CreateSet(setOfTrueConditions); + Conditions.ExamineConditions(conditionSet); + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + IF condition(Condition).passed THEN + Conditions.Incl(setOfTrueConditions, condition(Condition)); + anythingTrue := TRUE; + END; + END; + RETURN anythingTrue + END; + END Select; + + PROCEDURE SendEvent(domain: Conditions.Domain; + condition: Conditions.Condition; + event: Events.Event; + errors: RelatedEvents.Object) : BOOLEAN; + BEGIN + WITH domain: Domain DO WITH condition: Condition DO + IF condition.passed THEN + RETURN FALSE + ELSE + domain.event := event; + ScheduleEvent(condition); + RETURN TRUE + END; + END; END; + END SendEvent; + + PROCEDURE GetNextTime(domain: Conditions.Domain; + conditionSet: Conditions.ConditionSet; + VAR nextTime: Times.Time; + VAR nextCond: Conditions.Condition; + errors: RelatedEvents.Object); + VAR + condition: Condition; + BEGIN + GetMinTime(conditionSet, nextTime, condition); + nextCond := condition; + END GetNextTime; + + PROCEDURE InitInterface; + BEGIN + NEW(if); + if.test := Test; + if.select := Select; + if.sendevent := SendEvent; + if.gettime := GetNextTime; + END InitInterface; + +BEGIN + disciplineId := Disciplines.Unique(); + InitInterface; +END ulmTimeConditions. diff --git a/src/library/ulm/ulmTimers.Mod b/src/library/ulm/ulmTimers.Mod new file mode 100644 index 00000000..afe160da --- /dev/null +++ b/src/library/ulm/ulmTimers.Mod @@ -0,0 +1,338 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Timers.om,v $ + Revision 1.3 2001/04/30 14:58:18 borchert + bug fix: recursion via Clocks.TimerOn was not possible + + Revision 1.2 1994/07/18 14:21:51 borchert + bug fix: CreateQueue took uninitialized priority variable instead of + queue.priority + + Revision 1.1 1994/02/22 20:11:37 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 1/92 + ---------------------------------------------------------------------------- +*) + +MODULE ulmTimers; + + IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities, + SYS := ulmSYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes, Types := ulmTypes; + + TYPE + Queue = POINTER TO QueueRec; + Timer* = POINTER TO TimerRec; + TimerRec* = + RECORD + (Objects.ObjectRec) + valid: BOOLEAN; (* a valid timer entry? *) + queue: Queue; (* timer belongs to this queue *) + prev, next: Timer; (* double-linked and sorted list *) + time: Times.Time; (* key *) + event: Events.Event; (* raise this event at the given time *) + END; + QueueRec = + RECORD + (Disciplines.ObjectRec) + clock: Clocks.Clock; (* queue of this clock *) + priority: Priorities.Priority; (* priority of the clock *) + checkQueue: Events.EventType; (* check queue on this event *) + head, tail: Timer; (* sorted list of timers *) + lock: BOOLEAN; + END; + TYPE + CheckQueueEvent = POINTER TO CheckQueueEventRec; + CheckQueueEventRec = + RECORD + (Events.EventRec) + queue: Queue; + END; + TYPE + ClockDiscipline = POINTER TO ClockDisciplineRec; + ClockDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + queue: Queue; + END; + VAR + clockDisciplineId: Disciplines.Identifier; + + CONST + invalidTimer* = 0; (* timer is no longer valid *) + queueLocked* = 1; (* the queue is currently locked *) + badClock* = 2; (* clock is unable to maintain a timer *) + errorcodes* = 3; + TYPE + ErrorEvent* = POINTER TO ErrorEventRec; + ErrorEventRec* = + RECORD + (Events.EventRec) + errorcode*: Types.Int8; + END; + VAR + errormsg*: ARRAY errorcodes OF Events.Message; + error*: Events.EventType; + + PROCEDURE InitErrorHandling; + BEGIN + errormsg[invalidTimer] := "invalid timer given to Timers.Remove"; + errormsg[queueLocked] := "the queue is currently locked"; + errormsg[badClock] := "clock is unable to maintain a timer"; + Events.Define(error); Events.SetPriority(error, Priorities.liberrors); + END InitErrorHandling; + + PROCEDURE Error(errors: RelatedEvents.Object; code: Types.Int8); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.errorcode := code; + RelatedEvents.Raise(errors, event); + END Error; + + PROCEDURE CheckQueue(queue: Queue); + VAR + currentTime: Times.Time; + oldTimers: Timer; + p, prev: Timer; + checkQueueEvent: CheckQueueEvent; + nextTimer: Timer; + BEGIN + IF queue.head = NIL THEN queue.lock := FALSE; RETURN END; + + Clocks.GetTime(queue.clock, currentTime); + + (* remove old timers from queue *) + oldTimers := queue.head; + p := queue.head; prev := NIL; + WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO + prev := p; p := p.next; + END; + IF p = NIL THEN + queue.head := NIL; queue.tail := NIL; + ELSE + queue.head := p; + p.prev := NIL; + END; + IF prev = NIL THEN + oldTimers := NIL; + ELSE + prev.next := NIL; + END; + + (* set up next check-queue-event, if necessary *) + nextTimer := queue.head; + queue.lock := FALSE; + (* unlock queue now to allow recursion via Clocks.TimerOn *) + IF nextTimer # NIL THEN + NEW(checkQueueEvent); + checkQueueEvent.type := queue.checkQueue; + checkQueueEvent.message := "check queue of timer"; + checkQueueEvent.queue := queue; + Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent); + ELSE + Clocks.TimerOff(queue.clock); + END; + + (* process old timers *) + p := oldTimers; + WHILE p # NIL DO + p.valid := FALSE; + Events.Raise(p.event); + p := p.next; + END; + END CheckQueue; + + PROCEDURE CatchCheckQueueEvents(event: Events.Event); + BEGIN + WITH event: CheckQueueEvent DO + IF ~SYS.TAS(event.queue.lock) THEN + CheckQueue(event.queue); + (* event.queue.lock := FALSE; (* done by CheckQueue *) *) + END; + END; + END CatchCheckQueueEvents; + + PROCEDURE CreateQueue(errors: RelatedEvents.Object; + VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN; + VAR + clockDiscipline: ClockDiscipline; + BEGIN + IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN + Error(errors, badClock); RETURN FALSE + END; + + NEW(queue); + queue.clock := clock; + queue.head := NIL; queue.tail := NIL; + queue.lock := FALSE; + Events.Define(queue.checkQueue); + Events.Handler(queue.checkQueue, CatchCheckQueueEvents); + Clocks.GetPriority(clock, queue.priority); + IF queue.priority > Priorities.base THEN + Events.SetPriority(queue.checkQueue, queue.priority + 1); + ELSE + queue.priority := Priorities.default; + END; + + NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId; + clockDiscipline.queue := queue; + Disciplines.Add(clock, clockDiscipline); + RETURN TRUE + END CreateQueue; + + PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event; + VAR timer: Timer); + VAR + queue: Queue; + clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *) + p: Timer; + absTime: Times.Time; + op: Op.Operand; + BEGIN + IF Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN + queue := clockDiscipline(ClockDiscipline).queue; + ELSIF ~CreateQueue(clock, queue, clock) THEN + RETURN + END; + + IF SYS.TAS(queue.lock) THEN + Error(clock, queueLocked); RETURN + END; + Events.AssertPriority(queue.priority); + + IF Scales.IsRelative(time) THEN + (* take relative time to be relative to the current time *) + Clocks.GetTime(clock, absTime); + (* Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time); *) + op := absTime; Op.Add2(op, time); absTime := op(Times.Time); + ELSE + (* create a copy of time *) + op := NIL; Op.Assign(op, time); absTime := op(Times.Time); + END; + time := absTime; + NEW(timer); timer.time := time; timer.event := event; + timer.queue := queue; timer.valid := TRUE; + + (* look for the insertion point *) + p := queue.head; + WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO + p := p.next; + END; + + (* insert timer in front of p *) + timer.next := p; + IF p = NIL THEN + (* append timer at the end of the queue *) + timer.prev := queue.tail; + IF queue.tail = NIL THEN + queue.head := timer; + ELSE + queue.tail.next := timer; + END; + queue.tail := timer; + ELSE + timer.prev := p.prev; + timer.next := p; + IF p = queue.head THEN + queue.head := timer; + ELSE + p.prev.next := timer; + END; + p.prev := timer; + END; + + CheckQueue(queue); + (* queue.lock := FALSE; (* done by CheckQueue *) *) + Events.ExitPriority; + END Add; + + PROCEDURE Remove*(timer: Timer); + VAR + queue: Queue; + BEGIN + IF timer.valid THEN + queue := timer.queue; + IF SYS.TAS(queue.lock) THEN + Error(queue.clock, queueLocked); RETURN + END; + Events.AssertPriority(queue.priority); + timer.valid := FALSE; + IF timer.prev = NIL THEN + queue.head := timer.next; + ELSE + timer.prev.next := timer.next; + END; + IF timer.next = NIL THEN + queue.tail := timer.prev; + ELSE + timer.next.prev := timer.prev; + END; + CheckQueue(queue); + (* queue.lock := FALSE; (* done by CheckQueue *) *) + Events.ExitPriority; + ELSE + Error(timer.queue.clock, invalidTimer); + END; + END Remove; + + PROCEDURE Schedule*(clock: Clocks.Clock; + time: Times.Time; event: Events.Event); + VAR + timer: Timer; + BEGIN + Add(clock, time, event, timer); + END Schedule; + + PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN; + VAR + rval: BOOLEAN; + queue: Queue; + clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *) + BEGIN + IF ~Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN + RETURN FALSE + END; + queue := clockDiscipline(ClockDiscipline).queue; + + IF SYS.TAS(queue.lock) THEN + Error(clock, queueLocked); RETURN FALSE + END; + CheckQueue(queue); + IF queue.head # NIL THEN + time := queue.head.time; + rval := TRUE; + ELSE + rval := FALSE + END; + (* queue.lock := FALSE; (* done by CheckQueue *) *) + RETURN rval + END NextEvent; + +BEGIN + InitErrorHandling; + clockDisciplineId := Disciplines.Unique(); +END ulmTimers. diff --git a/src/library/ulm/ulmTimes.Mod b/src/library/ulm/ulmTimes.Mod new file mode 100644 index 00000000..57ecebd7 --- /dev/null +++ b/src/library/ulm/ulmTimes.Mod @@ -0,0 +1,401 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Times.om,v $ + Revision 1.3 2001/04/30 14:54:44 borchert + bug fix: base type is TimeRec instead of Times.TimeRec + (invalid self-reference) + + Revision 1.2 1995/04/07 13:25:07 borchert + fixes due to changed if of PersistentObjects + + Revision 1.1 1994/02/22 20:12:02 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmTimes; + + IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales, + Services := ulmServices, Streams := ulmStreams, Types := ulmTypes; + + CONST + relative* = Scales.relative; + absolute* = Scales.absolute; + TYPE + (* the common base type of all time measures *) + Time* = POINTER TO TimeRec; + TimeRec* = RECORD (Scales.MeasureRec) END; + + CONST + usecsPerSec = 1000000; (* 10^6 *) + TYPE + (* units of the reference implementation: + epoch, second and usec + *) + TimeValueRec* = + RECORD + (Objects.ObjectRec) + (* epoch 0: Jan. 1, 1970; + each epoch has a length of MAX(Scales.Value) + 1 seconds; + epoch may be negative: + -1 is the epoch just before 1970 + *) + epoch*: Scales.Value; + (* seconds and ... *) + second*: Scales.Value; + (* ... microseconds since the beginning of the epoch *) + usec*: Scales.Value; + END; + + (* ==== private datatypes for the reference scale *) + TYPE + ReferenceTime = POINTER TO ReferenceTimeRec; + ReferenceTimeRec = + RECORD + (TimeRec) + timeval: TimeValueRec; + END; + VAR + absType, relType: Services.Type; + CONST + epochUnit = 0; secondUnit = 1; usecUnit = 2; + TYPE + Unit = POINTER TO UnitRec; + UnitRec = + RECORD + (Scales.UnitRec) + index: Types.Int8; (* epochUnit..usecUnit *) + END; + + VAR + scale*: Scales.Scale; (* reference scale *) + family*: Scales.Family; (* family of time scales *) + if: Scales.Interface; + + PROCEDURE Create*(VAR time: Time; type: Types.Int8); + (* type = absolute or relative *) + VAR + m: Scales.Measure; + BEGIN + Scales.CreateMeasure(scale, m, type); + time := m(Time); + END Create; + + PROCEDURE Normalize(VAR timeval: TimeValueRec); + (* make sure that second and usec >= 0 *) + VAR + toomanysecs: Scales.Value; + secs: Scales.Value; + BEGIN + IF timeval.second < 0 THEN + INC(timeval.second, 1); + INC(timeval.second, MAX(Scales.Value)); + DEC(timeval.epoch); + END; + IF timeval.usec < 0 THEN + toomanysecs := timeval.usec DIV usecsPerSec; + IF toomanysecs > timeval.second THEN + timeval.second := - toomanysecs + MAX(Scales.Value) + 1 + + timeval.second; + DEC(timeval.epoch); + ELSE + DEC(timeval.second, toomanysecs); + END; + timeval.usec := timeval.usec MOD usecsPerSec; + ELSIF timeval.usec >= usecsPerSec THEN + secs := timeval.usec DIV usecsPerSec; + IF MAX(Scales.Value) - timeval.second <= secs THEN + INC(timeval.second, secs); + ELSE + timeval.second := secs - (MAX(Scales.Value) - timeval.second); + INC(timeval.epoch); + END; + timeval.usec := timeval.usec MOD usecsPerSec; + END; + END Normalize; + + PROCEDURE SetValue*(time: Time; value: TimeValueRec); + VAR + refTime: Time; + measure: Scales.Measure; + scaleOfTime: Scales.Scale; + BEGIN + Normalize(value); + IF time IS ReferenceTime THEN + WITH time: ReferenceTime DO + time.timeval := value; + END; + ELSE + Create(refTime, Scales.MeasureType(time)); + refTime(ReferenceTime).timeval := value; + Scales.GetScale(time, scaleOfTime); + measure := refTime; + Scales.ConvertMeasure(scaleOfTime, measure); + Operations.Copy(measure, time); + END; + END SetValue; + + PROCEDURE CreateAndSet*(VAR time: Time; type: Types.Int8; + epoch, second, usec: Scales.Value); + VAR + timeval: TimeValueRec; + BEGIN + Create(time, type); + timeval.epoch := epoch; timeval.second := second; timeval.usec := usec; + SetValue(time, timeval); + END CreateAndSet; + + PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec); + VAR mtime: Scales.Measure; + BEGIN + IF ~(time IS ReferenceTime) THEN + Scales.ConvertMeasure(scale, mtime); time := mtime(Time) + END; + value := time(ReferenceTime).timeval; + END GetValue; + + (* ===== interface procedures =================================== *) + + PROCEDURE InternalCreate(scale: Scales.Scale; + VAR measure: Scales.Measure; abs: BOOLEAN); + VAR + time: ReferenceTime; + BEGIN + NEW(time); + time.timeval.epoch := 0; + time.timeval.second := 0; + time.timeval.usec := 0; + IF abs THEN + PersistentObjects.Init(time, absType); + ELSE + PersistentObjects.Init(time, relType); + END; + measure := time; + END InternalCreate; + + PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit; + VAR value: Scales.Value); + BEGIN + WITH measure: ReferenceTime DO WITH unit: Unit DO + CASE unit.index OF + | epochUnit: value := measure.timeval.epoch; + | secondUnit: value := measure.timeval.second; + | usecUnit: value := measure.timeval.usec; + ELSE + END; + END; END; + END InternalGetValue; + + PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit; + value: Scales.Value); + BEGIN + WITH measure: ReferenceTime DO WITH unit: Unit DO + CASE unit.index OF + | epochUnit: measure.timeval.epoch := value; + | secondUnit: measure.timeval.second := value; + | usecUnit: measure.timeval.usec := value; + ELSE + END; + Normalize(measure.timeval); + END; END; + END InternalSetValue; + + PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure); + BEGIN + WITH target: ReferenceTime DO WITH source: ReferenceTime DO + target.timeval := source.timeval; + END; END; + END Assign; + + PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure); + + PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec); + BEGIN + result.epoch := op1.epoch + op2.epoch; + IF op1.second > MAX(Scales.Value) - op2.second THEN + INC(result.epoch); + result.second := op1.second - MAX(Scales.Value) - 1 + + op2.second; + ELSE + result.second := op1.second + op2.second; + END; + result.usec := op1.usec + op2.usec; + IF result.usec > usecsPerSec THEN + DEC(result.usec, usecsPerSec); + IF result.second = MAX(Scales.Value) THEN + result.second := 0; INC(result.epoch); + ELSE + INC(result.second); + END; + END; + END Add; + + PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec); + BEGIN + result.epoch := op1.epoch - op2.epoch; + IF op1.second >= op2.second THEN + result.second := op1.second - op2.second; + ELSE + DEC(result.epoch); + result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second; + END; + result.usec := op1.usec - op2.usec; + IF result.usec < 0 THEN + INC(result.usec, usecsPerSec); + IF result.second = 0 THEN + result.second := MAX(Scales.Value); + DEC(result.epoch); + ELSE + DEC(result.second); + END; + END; + END Sub; + + BEGIN + WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO + WITH result: ReferenceTime DO + CASE op OF + | Scales.add: Add(op1.timeval, op2.timeval, result.timeval); + | Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval); + ELSE + END; + END; + END; END; + END Op; + + PROCEDURE Compare(op1, op2: Scales.Measure) : Types.Int32; + + PROCEDURE ReturnVal(val1, val2: Scales.Value) : Types.Int32; + BEGIN + IF val1 < val2 THEN + RETURN -1 + ELSIF val1 > val2 THEN + RETURN 1 + ELSE + RETURN 0 + END; + END ReturnVal; + + BEGIN + WITH op1: ReferenceTime DO + WITH op2: ReferenceTime DO + IF op1.timeval.epoch # op2.timeval.epoch THEN + RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) + ELSIF op1.timeval.second # op2.timeval.second THEN + RETURN ReturnVal(op1.timeval.second, op2.timeval.second) + ELSE + RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) + END; + END; + END; + RETURN 0; + END Compare; + + (* ========= initialization procedures ========================== *) + + PROCEDURE InitInterface; + VAR + timeType: Services.Type; + BEGIN + NEW(if); + if.create := InternalCreate; + if.getvalue := InternalGetValue; if.setvalue := InternalSetValue; + if.assign := Assign; if.op := Op; if.compare := Compare; + (* conversion procedures are not necessary *) + + PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure", + NIL); + END InitInterface; + + PROCEDURE CreateAbs(VAR object: PersistentObjects.Object); + VAR + measure: Scales.Measure; + BEGIN + Scales.CreateAbsMeasure(scale, measure); + object := measure; + END CreateAbs; + + PROCEDURE CreateRel(VAR object: PersistentObjects.Object); + VAR + measure: Scales.Measure; + BEGIN + Scales.CreateRelMeasure(scale, measure); + object := measure; + END CreateRel; + + PROCEDURE Write(s: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + BEGIN + WITH object: ReferenceTime DO + RETURN NetIO.WriteLongInt(s, object.timeval.epoch) & + NetIO.WriteLongInt(s, object.timeval.second) & + NetIO.WriteLongInt(s, object.timeval.usec) + END; + END Write; + + PROCEDURE Read(s: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + BEGIN + WITH object: ReferenceTime DO + RETURN NetIO.ReadLongInt(s, object.timeval.epoch) & + NetIO.ReadLongInt(s, object.timeval.second) & + NetIO.ReadLongInt(s, object.timeval.usec) + END; + END Read; + + PROCEDURE InitRefScale; + + VAR + poif: PersistentObjects.Interface; + + PROCEDURE InitUnit(unitIndex: Types.Int8; name: Scales.UnitName); + VAR + unit: Unit; + BEGIN + NEW(unit); unit.index := unitIndex; + Scales.InitUnit(scale, unit, name); + END InitUnit; + + BEGIN + NEW(scale); Scales.Init(scale, NIL, if); + InitUnit(epochUnit, "epoch"); + InitUnit(secondUnit, "second"); + InitUnit(usecUnit, "usec"); + + NEW(poif); poif.read := Read; poif.write := Write; + poif.create := CreateAbs; poif.createAndRead := NIL; + PersistentObjects.RegisterType(absType, + "Times.AbsReferenceTime", "Times.Time", poif); + NEW(poif); poif.read := Read; poif.write := Write; + poif.create := CreateRel; poif.createAndRead := NIL; + PersistentObjects.RegisterType(relType, + "Times.RelReferenceTime", "Times.Time", poif); + END InitRefScale; + +BEGIN + InitInterface; + InitRefScale; + NEW(family); Scales.InitFamily(family, scale); +END ulmTimes. diff --git a/src/lib/ulm/armv6j_hardfp/ulmTypes.Mod b/src/library/ulm/ulmTypes.Mod similarity index 63% rename from src/lib/ulm/armv6j_hardfp/ulmTypes.Mod rename to src/library/ulm/ulmTypes.Mod index fe2d6eca..318fcd9d 100644 --- a/src/lib/ulm/armv6j_hardfp/ulmTypes.Mod +++ b/src/library/ulm/ulmTypes.Mod @@ -24,7 +24,7 @@ SetInt type used in msb constant Revision 1.4 2000/12/13 09:51:57 borchert - constants and types for the relationship of INTEGER and SET added + constants and types for the relationship of Types.Int32 and Types.Set added Revision 1.3 1998/09/25 15:23:09 borchert Real32..Real128 added @@ -50,84 +50,81 @@ MODULE ulmTypes; IMPORT SYS := SYSTEM; TYPE - Address* = LONGINT (*SYS.ADDRESS*); - (* ulm compiler can accept - VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) - UntracedAddressDesc* = RECORD[1] END; - Count* = LONGINT; + Address* = SYS.ADDRESS; + UntracedAddress* = POINTER[1] TO UntracedAddressDesc; + UntracedAddressDesc* = RECORD[1] END; + + Count* = SYS.INT32; Size* = Count; Byte* = SYS.BYTE; - IntAddress* = LONGINT; - Int8* = SHORTINT; - Int16* = INTEGER; - Int32* = LONGINT; - Real32* = REAL; + IntAddress* = SYS.INT32; + Int8* = SYS.INT8; + Int16* = SYS.INT16; + Int32* = SYS.INT32; + Real32* = LONGREAL; Real64* = LONGREAL; + Set* = SYS.SET32; CONST bigEndian* = 0; (* SPARC, M68K etc *) littleEndian* = 1; (* Intel 80x86, VAX etc *) byteorder* = littleEndian; (* machine-dependent constant *) TYPE - ByteOrder* = SHORTINT; (* bigEndian or littleEndian *) + ByteOrder* = SYS.INT8; (* bigEndian or littleEndian *) (* following constants and type definitions try to make - conversions from INTEGER to SET and vice versa more portable - to allow for bit operations on INTEGER values + conversions from Types.Int32 to Types.Set and vice versa more portable + to allow for bit operations on Types.Int32 values *) TYPE - SetInt* = LONGINT; (* INTEGER type that corresponds to SET *) - VAR msb* : SET; - msbIsMax*, msbIs0*: SHORTINT; - msbindex*, lsbindex*, nofbits*: LONGINT; + SetInt* = SYS.INT32; (* Types.Int32 type that corresponds to Types.Set *) + VAR + msb*: SYS.SET32; + msbIsMax*, msbIs0*: SYS.INT8; + msbindex*, lsbindex*, nofbits*: SYS.INT32; - PROCEDURE ToInt8*(int: LONGINT) : Int8; + PROCEDURE ToInt8*(int: Int32) : Int8; BEGIN RETURN SHORT(SHORT(int)) END ToInt8; - PROCEDURE ToInt16*(int: LONGINT) : Int16; + PROCEDURE ToInt16*(int: Int32) : Int16; BEGIN RETURN SYS.VAL(Int16, int) END ToInt16; - PROCEDURE ToInt32*(int: LONGINT) : Int32; + PROCEDURE ToInt32*(int: Int32) : Int32; BEGIN RETURN int END ToInt32; - PROCEDURE ToReal32*(real: LONGREAL) : Real32; + PROCEDURE ToReal32*(real: Real64) : Real32; BEGIN RETURN SHORT(real) END ToReal32; - PROCEDURE ToReal64*(real: LONGREAL) : Real64; + PROCEDURE ToReal64*(real: Real64) : Real64; BEGIN - RETURN real + RETURN SHORT(real) END ToReal64; BEGIN - msb := SYS.VAL(SET, MIN(SetInt)); - (* most significant bit, converted to a SET *) + + msb := SYS.VAL(SYS.SET32, MIN(SetInt)); + (* most significant bit, converted to a Types.Set *) (* we expect msbIsMax XOR msbIs0 to be 1; this is checked for by an assertion *) - msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)})); - (* is 1, if msb equals {MAX(SET)} *) - msbIs0 := SYS.VAL(SHORTINT, (msb = {0})); + msbIsMax := SYS.VAL(SYS.INT8, (msb = {MAX(Set)})); + (* is 1, if msb equals {MAX(Set)} *) + msbIs0 := SYS.VAL(SYS.INT8, (msb = {0})); (* is 0, if msb equals {0} *) - msbindex := msbIsMax * MAX(SET); + msbindex := msbIsMax * MAX(Set); (* set element that corresponds to the most-significant-bit *) - lsbindex := MAX(SET) - msbindex; + lsbindex := MAX(Set) - msbindex; (* set element that corresponds to the lowest-significant-bit *) - nofbits := MAX(SET) + 1; - (* number of elements in SETs *) + nofbits := MAX(Set) + 1; + (* number of elements in Sets *) ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1)); END ulmTypes. diff --git a/src/lib/ulm/ulmWrite.Mod b/src/library/ulm/ulmWrite.Mod similarity index 83% rename from src/lib/ulm/ulmWrite.Mod rename to src/library/ulm/ulmWrite.Mod index 0867b2bc..51093cd2 100644 --- a/src/lib/ulm/ulmWrite.Mod +++ b/src/library/ulm/ulmWrite.Mod @@ -33,31 +33,31 @@ MODULE ulmWrite; - IMPORT ASCII := ulmASCII, Print := ulmPrint, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, SYSTEM, SYS := ulmSYSTEM; + IMPORT ASCII := ulmASCII, Print := ulmPrint, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, SYSTEM, SYS := ulmSYSTEM, Types := ulmTypes; (* - TYPE barr = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) + TYPE barr = ARRAY SIZE(Types.Int32) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly Types.Int32 to ARRAY OF BYTE; -- noch *) pbarr = POINTER TO barr; - TYPE lrarr = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) + TYPE lrarr = ARRAY SIZE(Types.Real64) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly Types.Int32 to ARRAY OF BYTE; -- noch *) plrarr = POINTER TO barr; - PROCEDURE LongToByteArr ( l : LONGINT; VAR bar : barr); (* noch *) + PROCEDURE LongToByteArr ( l : Types.Int32; VAR bar : barr); (* noch *) VAR b : SYSTEM.BYTE; p : pbarr; - i : LONGINT; + i : Types.Int32; BEGIN p := SYSTEM.VAL(pbarr, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGINT) -1 DO + FOR i := 0 TO SIZE(Types.Int32) -1 DO b := p^[i]; bar[i] := b; END END LongToByteArr; - PROCEDURE LRealToByteArr ( l : LONGREAL; VAR lar : lrarr); (* noch *) + PROCEDURE LRealToByteArr ( l : Types.Real64; VAR lar : lrarr); (* noch *) VAR b : SYSTEM.BYTE; p : plrarr; - i : LONGINT; + i : Types.Int32; BEGIN p := SYSTEM.VAL(plrarr, SYSTEM.ADR(l)); - FOR i := 0 TO SIZE(LONGREAL) -1 DO + FOR i := 0 TO SIZE(Types.Real64) -1 DO b := p^[i]; lar[i] := b; END END LRealToByteArr; @@ -65,7 +65,7 @@ MODULE ulmWrite; *) - PROCEDURE IntS*(s: Streams.Stream; int: LONGINT; width: LONGINT); + PROCEDURE IntS*(s: Streams.Stream; int: Types.Int32; width: Types.Int32); VAR b, b0 : SYS.bytearray; BEGIN SYS.LongToByteArr(int, b); @@ -73,7 +73,7 @@ MODULE ulmWrite; Print.S2(s, "%*d", b0, b); END IntS; - PROCEDURE RealS*(s: Streams.Stream; real: LONGREAL; width: LONGINT); + PROCEDURE RealS*(s: Streams.Stream; real: Types.Real64; width: Types.Int32); VAR b : SYS.bytearray; lr : SYS.longrealarray; BEGIN SYS.LRealToByteArr(real, lr); @@ -93,11 +93,11 @@ MODULE ulmWrite; PROCEDURE LineS*(s: Streams.Stream; str: ARRAY OF CHAR); VAR - count: LONGINT; + count: Types.Int32; nlOK: BOOLEAN; - cnt: LONGINT; + cnt: Types.Int32; lineterm: StreamDisciplines.LineTerminator; - len: INTEGER; i: INTEGER; + len: Types.Int32; i: Types.Int32; BEGIN cnt := 0; WHILE (cnt < LEN(str)) & (str[cnt] # 0X) DO @@ -141,7 +141,7 @@ MODULE ulmWrite; PROCEDURE LnS*(s: Streams.Stream); VAR lineterm: StreamDisciplines.LineTerminator; - len: INTEGER; + len: Types.Int32; BEGIN StreamDisciplines.GetLineTerm(s, lineterm); IF lineterm[1] = 0X THEN @@ -157,7 +157,7 @@ MODULE ulmWrite; PROCEDURE StringS*(s: Streams.Stream; str: ARRAY OF CHAR); VAR - cnt: LONGINT; + cnt: Types.Int32; BEGIN cnt := 0; WHILE (cnt < LEN(str)) & (str[cnt] # 0X) DO @@ -168,7 +168,7 @@ MODULE ulmWrite; PROCEDURE IndentS*(s: Streams.Stream); VAR - indentwidth: INTEGER; + indentwidth: Types.Int32; BEGIN StreamDisciplines.GetIndentationWidth(s, indentwidth); WHILE (indentwidth > 0) & Streams.WriteByte(s, " ") DO @@ -180,12 +180,12 @@ MODULE ulmWrite; (* procedures writing to Streams.stdout *) - PROCEDURE Int*(int: LONGINT; width: LONGINT); + PROCEDURE Int*(int: Types.Int32; width: Types.Int32); BEGIN IntS(Streams.stdout, int, width); END Int; - PROCEDURE Real*(real: LONGREAL; width: LONGINT); + PROCEDURE Real*(real: Types.Real64; width: Types.Int32); (* write real in exponential format *) BEGIN RealS(Streams.stdout, real, width); diff --git a/src/library/v4/Args.Mod b/src/library/v4/Args.Mod new file mode 100755 index 00000000..c3621116 --- /dev/null +++ b/src/library/v4/Args.Mod @@ -0,0 +1,31 @@ +MODULE Args; (* jt, 8.12.94 *) + + (* command line argument handling for voc (jet backend) *) + + + IMPORT Platform, Modules, SYSTEM; + + TYPE + ArgPtr = POINTER TO ARRAY 1024 OF CHAR; + ArgVec = POINTER TO ARRAY 1024 OF ArgPtr; + + VAR + argc-: INTEGER; + argv-: SYSTEM.ADDRESS; + + +PROCEDURE Get* (n: INTEGER; VAR val: ARRAY OF CHAR); BEGIN Modules.GetArg(n, val) END Get; +PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT); BEGIN Modules.GetIntArg(n, val) END GetInt; +PROCEDURE Pos* (s: ARRAY OF CHAR): INTEGER; BEGIN RETURN Modules.ArgPos(s) END Pos; + +PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); +BEGIN Platform.GetEnv(var, val) END GetEnv; + +PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN; +BEGIN RETURN Platform.getEnv(var, val) END getEnv; + + +BEGIN + argc := Modules.ArgCount; + argv := Modules.ArgVector; +END Args. diff --git a/src/lib/system/freebsd/clang/Console.Mod b/src/library/v4/Console.Mod similarity index 69% rename from src/lib/system/freebsd/clang/Console.Mod rename to src/library/v4/Console.Mod index 93be9373..070ba46b 100644 --- a/src/lib/system/freebsd/clang/Console.Mod +++ b/src/library/v4/Console.Mod @@ -2,23 +2,16 @@ MODULE Console; (* J. Templ, 29-June-96 *) (* output to Unix standard output device based Write system call *) - IMPORT SYSTEM; + IMPORT SYSTEM, Platform; VAR line: ARRAY 128 OF CHAR; pos: INTEGER; - PROCEDURE -includeUnistd() - "#include "; - - PROCEDURE -Write(adr, n: LONGINT) - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; - - PROCEDURE Flush*(); + PROCEDURE Flush*; + VAR error: Platform.ErrorCode; BEGIN - Write(SYSTEM.ADR(line), pos); pos := 0; + error := Platform.Write(Platform.StdOut, SYSTEM.ADR(line), pos); + pos := 0; END Flush; PROCEDURE Char*(ch: CHAR); @@ -34,7 +27,8 @@ MODULE Console; (* J. Templ, 29-June-96 *) WHILE s[i] # 0X DO Char(s[i]); INC(i) END END String; - PROCEDURE Int*(i, n: LONGINT); +(* todo. support int64 properly *) + PROCEDURE Int*(i, n: SYSTEM.INT64); VAR s: ARRAY 32 OF CHAR; i1, k: LONGINT; BEGIN IF i = SYSTEM.LSH(LONG(LONG(1)), SIZE(LONGINT)*8 - 1) THEN @@ -42,7 +36,7 @@ MODULE Console; (* J. Templ, 29-June-96 *) ELSE s := "8463847412"; k := 10 END ELSE - i1 := ABS(i); + i1 := ABS(SYSTEM.VAL(LONGINT,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 ; @@ -52,7 +46,7 @@ MODULE Console; (* J. Templ, 29-June-96 *) END Int; PROCEDURE Ln*; - BEGIN Char(0AX); (* Unix end-of-line *) + BEGIN String(Platform.NL); END Ln; PROCEDURE Bool*(b: BOOLEAN); @@ -60,9 +54,9 @@ MODULE Console; (* J. Templ, 29-June-96 *) END Bool; PROCEDURE Hex*(i: LONGINT); - VAR k, n: LONGINT; + VAR k: INTEGER; n: SYSTEM.INT64; BEGIN - k := -28; + k := 4 - 8 * SIZE(LONGINT); 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 ; @@ -71,17 +65,22 @@ MODULE Console; (* J. Templ, 29-June-96 *) END Hex; PROCEDURE Read*(VAR ch: CHAR); - VAR n: LONGINT; + VAR n: LONGINT; error: Platform.ErrorCode; BEGIN Flush(); - n := read(ch); + error := Platform.ReadBuf(Platform.StdIn, ch, n); 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 ; + i := 0; Read(ch); + WHILE (i < LEN(line) - 1) + & (ch # 0AX) + & (ch # 0X) DO + line[i] := ch; INC(i); Read(ch) + END; + IF (i > 0) & (line[i-1] = 0DX) THEN DEC(i) END; (* Swallow CR before LF *) line[i] := 0X END ReadLine; diff --git a/src/lib/v4/Printer.Mod b/src/library/v4/Printer.Mod similarity index 98% rename from src/lib/v4/Printer.Mod rename to src/library/v4/Printer.Mod index 551db4bc..803b567f 100644 --- a/src/lib/v4/Printer.Mod +++ b/src/library/v4/Printer.Mod @@ -1,6 +1,6 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 *) - IMPORT SYSTEM, Files, Unix, Kernel; + IMPORT SYSTEM, Files, Platform; CONST N = 20; @@ -87,7 +87,7 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 VAR family: ARRAY 7 OF CHAR; BEGIN COPY(fname, family); - Ch(fontR, "/"); Str(fontR, fname); + Ch(fontR, "/"); Str(fontR, fname); IF family = "Syntax" THEN Str(fontR, " DefineSMapFont") ELSE Str(fontR, " DefineMapFont") END; Ln(fontR); Ln(fontR); END SetMappedFont; @@ -161,7 +161,7 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 | 92: Str(fontR, "backslash") | 93: Str(fontR, "bracketright") | 94: Str(fontR, "arrowup") - | 95: Str(fontR, "underscore") + | 95: Str(fontR, "underscore") | 96: Str(fontR, "grave") | 97..122: Ch(fontR, CHR(m)) | 123: Str(fontR, "braceleft") @@ -205,8 +205,8 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 Str(fontR, "% Conversion of the Oberon font "); Str(fontR, fd.name); Ln(fontR); Files.Read(R, ch); IF ch = fontFileId THEN - Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch)); - Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch); + Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch)); + Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch); Files.Read(R, ch); Str(fontR, ", variant: "); Int(fontR, ORD(ch)); Ln(fontR); Files.ReadInt(R, height); Str(fontR, "% height: "); Int(fontR, height); Ln(fontR); Ln(fontR); Files.ReadInt(R, minX); Files.ReadInt(R, maxX); @@ -223,7 +223,7 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 Str(fontR, "/FontMatrix [ 72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0 "); Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0"); Str(fontR, "] def"); Ln(fontR); - Str(fontR, "/FontBBox ["); + Str(fontR, "/FontBBox ["); Int(fontR, minX); Ch(fontR, " "); Int(fontR, minY); Ch(fontR, " "); Int(fontR, maxX); Ch(fontR, " "); @@ -339,7 +339,7 @@ END; Error("file not found", headerFileName) END END Open; - + PROCEDURE UseListFont*(VAR name: ARRAY OF CHAR); BEGIN COPY(name, listFont); curFont := -1 @@ -368,7 +368,7 @@ END; IF fname = listFont THEN fontname := "Courier8.Scn.Fnt" ELSE COPY(fname, fontname) END ; IF (curFont < 0) OR (fontTable[curFont].name # fontname) THEN COPY(fontname, fontTable[fontIndex+1].name); - i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END; + i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END; fNo := 0; WHILE fontTable[fNo].name # fontname DO INC(fNo) END; IF fNo > fontIndex THEN (* DefineFont(fontname); *) fontIndex := fNo END; @@ -394,7 +394,7 @@ END; END; Str(bodyR, ") s"); Ln(bodyR) END ContString; - + PROCEDURE String*(x, y: INTEGER; VAR s, fname: ARRAY OF CHAR); BEGIN Int(bodyR, x); Ch(bodyR, " "); @@ -410,7 +410,7 @@ END; Int(bodyR, col); Str(bodyR, " b"); Ln(bodyR); END ReplPattern; - PROCEDURE Picture*(x, y, w, h, mode: INTEGER; adr: LONGINT); + PROCEDURE Picture*(x, y, w, h, mode: INTEGER; adr: SYSTEM.ADDRESS); VAR n, i, v: INTEGER; ch: CHAR; BEGIN Int(bodyR, x); Ch(bodyR, " "); @@ -517,7 +517,7 @@ END; a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn; w[i] := 1.0; i := 0; WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; - SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); + SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0; WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ; d[i] := d[0] @@ -582,7 +582,7 @@ END; END Spline; PROCEDURE Page*(nofcopies: INTEGER); - BEGIN + BEGIN curR := 0; curG := 0; curB := 0; curFont := -1; INC(pno); ppos := Files.Pos(bodyR); PrintCopies := nofcopies; IF PrintMode[1] # ":" THEN @@ -608,9 +608,6 @@ END; REPEAT ch := s2[j]; s1[i] := ch; INC(i); INC(j) UNTIL ch = 0X END Append; - PROCEDURE -system(cmd: ARRAY OF CHAR) - "system(cmd)"; - PROCEDURE Close*; CONST bufSize = 4*1024; VAR @@ -642,10 +639,10 @@ END; IF PrinterName # "none" THEN Files.Write(printR, 4X) (*force reset postscript*) END ; Files.Register(printF); IF PrinterName # "none" THEN - cmd := "lp -c -s "; + cmd := "lp -c -s "; IF PrinterName # "Pluto" THEN Append(cmd, "-d "); Append(cmd, PrinterName) END ; Append(cmd, " "); Append(cmd, printFileName); - system(cmd); + i := Platform.System(cmd); Files.Delete(printFileName, res); END; Files.Set(bodyR, NIL, 0); diff --git a/src/lib/v4/Sets.Mod b/src/library/v4/Sets.Mod similarity index 100% rename from src/lib/v4/Sets.Mod rename to src/library/v4/Sets.Mod diff --git a/src/par/voc.par.clang.powerpc b/src/par/voc.par.clang.powerpc deleted file mode 100644 index fdc5342a..00000000 --- a/src/par/voc.par.clang.powerpc +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 2 2 -LONGINT 4 4 -SET 4 4 -REAL 4 4 -LONGREAL 8 8 -PTR 4 4 -PROC 4 4 -RECORD 1 1 -ENDIAN 0 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 4 diff --git a/src/par/voc.par.clang.x86_64 b/src/par/voc.par.clang.x86_64 deleted file mode 100644 index bf5ed486..00000000 --- a/src/par/voc.par.clang.x86_64 +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 4 4 -LONGINT 8 8 -SET 8 8 -REAL 4 4 -LONGREAL 8 8 -PTR 8 8 -PROC 8 8 -RECORD 1 1 -ENDIAN 1 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 8 diff --git a/src/par/voc.par.gcc.armv6j_hardfp b/src/par/voc.par.gcc.armv6j_hardfp deleted file mode 100644 index 49740442..00000000 --- a/src/par/voc.par.gcc.armv6j_hardfp +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 2 2 -LONGINT 4 4 -SET 4 4 -REAL 4 4 -LONGREAL 8 8 -PTR 4 4 -PROC 4 4 -RECORD 1 1 -ENDIAN 1 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 4 diff --git a/src/par/voc.par.gcc.powerpc b/src/par/voc.par.gcc.powerpc deleted file mode 100644 index fdc5342a..00000000 --- a/src/par/voc.par.gcc.powerpc +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 2 2 -LONGINT 4 4 -SET 4 4 -REAL 4 4 -LONGREAL 8 8 -PTR 4 4 -PROC 4 4 -RECORD 1 1 -ENDIAN 0 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 4 diff --git a/src/par/voc.par.gcc.x86 b/src/par/voc.par.gcc.x86 deleted file mode 100644 index b6abadc5..00000000 --- a/src/par/voc.par.gcc.x86 +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 2 2 -LONGINT 4 4 -SET 4 4 -REAL 4 4 -LONGREAL 8 4 -PTR 4 4 -PROC 4 4 -RECORD 1 1 -ENDIAN 1 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 4 diff --git a/src/par/voc.par.gcc.x86_64 b/src/par/voc.par.gcc.x86_64 deleted file mode 100644 index bf5ed486..00000000 --- a/src/par/voc.par.gcc.x86_64 +++ /dev/null @@ -1,16 +0,0 @@ -CHAR 1 1 -BOOLEAN 1 1 -SHORTINT 1 1 -INTEGER 4 4 -LONGINT 8 8 -SET 8 8 -REAL 4 4 -LONGREAL 8 8 -PTR 8 8 -PROC 8 8 -RECORD 1 1 -ENDIAN 1 0 -SYSTEM.INT8 1 1 -SYSTEM.INT16 2 2 -SYSTEM.INT32 4 4 -SYSTEM.INT64 8 8 diff --git a/src/runtime/Errors.Txt b/src/runtime/Errors.Txt new file mode 100644 index 00000000..29ed7063 --- /dev/null +++ b/src/runtime/Errors.Txt @@ -0,0 +1,197 @@ +The first line of this file is ignored. +Any line not starting /^ *[0-9]/ is ignored. +There should be only one space between the number and the message text. + +Compiler error messages + 0 undeclared identifier + 1 multiply defined identifier + 2 illegal character in number + 3 illegal character in string + 4 identifier does not match procedure name + 5 comment not closed + + 9 '=' expected + + 12 type definition starts with incorrect symbol + 13 factor starts with incorrect symbol + 14 statement starts with incorrect symbol + 15 declaration followed by incorrect symbol + 16 MODULE expected + + 18 '.' missing + 19 ',' missing + 20 ':' missing + + 22 ')' missing + 23 ']' missing + 24 '}' missing + 25 OF missing + 26 THEN missing + 27 DO missing + 28 TO missing + + 30 '(' missing + + 34 ':=' missing + 35 ',' or OF expected + + 38 identifier expected + 39 ';' missing + + 41 END missing + + 44 UNTIL missing + + 46 EXIT not within loop statement + 47 illegally marked identifier + + 50 expression should be constant + 51 constant not an integer + 52 identifier does not denote a type + 53 identifier does not denote a record type + 54 result type of procedure is not a basic type + 55 procedure call of a function + 56 assignment to non-variable + 57 pointer not bound to record or array type + 58 recursive type definition + 59 illegal open array parameter + 60 wrong type of case label + 61 inadmissible type of case label + 62 case label defined more than once + 63 illegal value of constant + 64 more actual than formal parameters + 65 fewer actual than formal parameters + 66 element types of actual array and formal open array differ + 67 actual parameter corresponding to open array is not an array + 68 control variable must be integer + 69 parameter must be an integer constant + 70 pointer or VAR record required as formal receiver + 71 pointer expected as actual receiver + 72 procedure must be bound to a record of the same scope + 73 procedure must have level 0 + 74 procedure unknown in base type + 75 invalid call of base procedure + 76 this variable (field) is read only + 77 object is not a record + 78 dereferenced object is not a variable + 79 indexed object is not a variable + 80 index expression is not an integer + 81 index out of specified bounds + 82 indexed variable is not an array + 83 undefined record field + 84 dereferenced variable is not a pointer + 85 guard or test type is not an extension of variable type + 86 guard or testtype is not a pointer + 87 guarded or tested variable is neither a pointer nor a VAR-parameter record + 88 open array not allowed as variable, record field or array element + + 92 operand of IN not an integer, or not a set + 93 set element type is not an integer + 94 operand of & is not of type BOOLEAN + 95 operand of OR is not of type BOOLEAN + 96 operand not applicable to (unary) + + 97 operand not applicable to (unary) - + 98 operand of ~ is not of type BOOLEAN + 99 ASSERT fault +100 incompatible operands of dyadic operator +101 operand type inapplicable to * +102 operand type inapplicable to / +103 operand type inapplicable to DIV +104 operand type inapplicable to MOD +105 operand type inapplicable to + +106 operand type inapplicable to - +107 operand type inapplicable to = or # +108 operand type inapplicable to relation +109 overriding method must be exported +110 operand is not a type +111 operand inapplicable to (this) function +112 operand is not a variable +113 incompatible assignment +114 string too long to be assigned +115 parameter doesn't match +116 number of parameters doesn't match +117 result type doesn't match +118 export mark doesn't match with forward declaration +119 redefinition textually precedes procedure bound to base type +120 type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN +121 called object is not a procedure (or is an interrupt procedure) +122 actual VAR-parameter is not a variable +123 type of actual parameter is not identical with that of formal VAR-parameter +124 type of result expression differs from that of procedure +125 type of case expression is neither INTEGER nor CHAR +126 this expression cannot be a type or a procedure +127 illegal use of object +128 unsatisfied forward reference +129 unsatisfied forward procedure +130 WITH clause does not specify a variable +131 LEN not applied to array +132 dimension in LEN too large or negative +135 SYSTEM not imported +150 key inconsistency of imported module +151 incorrect symbol file +152 symbol file of imported module not found +153 object or symbol file not opened (disk full?) +154 recursive import not allowed +155 generation of new symbol file not allowed +156 parameter file not found +157 syntax error in parameter file + +Limitations of implementation +200 not yet implemented +201 lower bound of set range greater than higher bound +202 set element greater than MAX(SET) or less than 0 +203 number too large +204 product too large +205 division by zero +206 sum too large +207 difference too large +208 overflow in arithmetic shift +209 case range too large +213 too many cases in case statement +218 illegal value of parameter (0 <= p < 256) +219 machine registers cannot be accessed +220 illegal value of parameter +221 too many pointers in a record +222 too many global pointers +223 too many record types +224 too many pointer types +225 address of pointer variable too large (move forward in text) +226 too many exported procedures +227 too many imported modules +228 too many exported structures +229 too many nested records for import +230 too many constants (strings) in module +231 too many link table entries (external procedures) +232 too many commands in module +233 record extension hierarchy too high +234 export of recursive type not allowed +240 identifier too long +241 string too long +242 address overflow +244 cyclic type definition not allowed +245 guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable + +Compiler Warnings +301 implicit type cast +306 inappropriate symbol file ignored +307 no ELSE symbol after CASE statement sequence may lead to trap +308 SYSTEM.VAL result includes memory past end of source variable; use SYSTEM.GET +309 you should name this parameter type, or else no actual parameter will match +310 redefining standard predefined type + +Run-time Error Messages + -1 assertion failed, cf. SYSTEM_assert + -2 invalid array index + -3 function procedure without RETURN statement + -4 invalid case in CASE statement + -5 type guard failed + -6 implicit type guard in record assignment failed + -7 invalid case in WITH statement + -8 value out of range + -9 (delayed) interrupt +-10 NIL access +-11 alignment error +-12 zero divide +-13 arithmetic overflow/underflow +-14 invalid function argument +-15 internal error diff --git a/src/runtime/Files.Mod b/src/runtime/Files.Mod new file mode 100644 index 00000000..64236a7d --- /dev/null +++ b/src/runtime/Files.Mod @@ -0,0 +1,763 @@ +MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *) + + IMPORT SYSTEM, Platform, Heap, Strings, Out; + + + CONST + NumBufs = 4; + BufSize = 4096; + NoDesc = -1; + + (* No file states, used when FileDesc.fd = NoDesc *) + open = 0; (* OS File has been opened *) + create = 1; (* OS file needs to be created *) + close = 2; (* Flag used by Files.Register to tell Create to create the + file using it's registerName directly, rather than to + create a temporary file: i.e. since we're closing and all + data is still in buffers bypass writing to temp file and + then renaming and just write directly to final register + name *) + + TYPE + FileName = ARRAY 256 OF CHAR; + File* = POINTER TO FileDesc; + Buffer = POINTER TO BufDesc; + + FileDesc = RECORD + workName: FileName; + registerName: FileName; + tempFile: BOOLEAN; + identity: Platform.FileIdentity; + fd: Platform.FileHandle; + len, pos: LONGINT; + bufs: ARRAY NumBufs OF Buffer; + swapper: INTEGER; + state: INTEGER; + next: POINTER [1] TO FileDesc; + END; + + BufDesc = RECORD + f: File; + chg: BOOLEAN; + org: LONGINT; + size: LONGINT; + data: ARRAY BufSize OF SYSTEM.BYTE + END; + + Rider* = RECORD + res*: LONGINT; (* Residue (byte count not read) at eof of ReadBytes *) + eof*: BOOLEAN; + buf: Buffer; + org: LONGINT; (* File offset of block containing current position *) + offset: LONGINT (* Current position offset within block at org. *) + END; + + + VAR + MaxPathLength-: INTEGER; + MaxNameLength-: INTEGER; + + files: POINTER [1] TO FileDesc; (* List of files backed by an OS file, whether open, registered or temporary. *) + tempno: INTEGER; + HOME: ARRAY 1024 OF CHAR; + SearchPath: POINTER TO ARRAY OF CHAR; + + + PROCEDURE -IdxTrap "__HALT(-1)"; + + PROCEDURE^ Finalize(o: SYSTEM.PTR); + + PROCEDURE Assert(truth: BOOLEAN); + BEGIN + IF ~truth THEN Out.Ln; ASSERT(truth) END + END Assert; + + PROCEDURE Err(s: ARRAY OF CHAR; f: File; errcode: Platform.ErrorCode); + BEGIN + Out.Ln; Out.String("-- "); Out.String(s); Out.String(": "); + IF f # NIL THEN + IF f.registerName # "" THEN Out.String(f.registerName) ELSE Out.String(f.workName) END; + IF f.fd # 0 THEN Out.String(", f.fd = "); Out.Int(f.fd,1) END + END; + IF errcode # 0 THEN Out.String(", errcode = "); Out.Int(errcode, 1) END; + Out.Ln; + HALT(99) + END Err; + + PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR); + VAR i, j, ld, ln: INTEGER; + BEGIN ld := Strings.Length(dir); ln := Strings.Length(name); + WHILE (ld > 0) & (dir[ld-1] = '/') DO DEC(ld) END; + IF ld + ln + 2 > LEN(dest) THEN Err("File name too long", NIL, 0) END; + i := 0; + WHILE i < ld DO dest[i] := dir[i]; INC(i) END; + IF i > 0 THEN dest[i] := '/'; INC(i) END; + j := 0; + WHILE j < ln 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 i, n: INTEGER; + BEGIN + IF finalName[0]='/' THEN COPY(finalName, name) ELSE MakeFileName(Platform.CWD, finalName, name) END; + i := Strings.Length(name)-1; + WHILE (i > 0) & (name[i] # '/') DO DEC(i) END; + IF i+16 >= LEN(name) THEN Err("File name too long", NIL, 0) END; + INC(tempno); n := tempno; + 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 := Platform.PID; + WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END; + name[i] := 0X + END GetTempName; + + (* When registering a file, it may turn out that the name we want to use + is aready in use by another File. E.g. the compiler opens and reads + an existing symbol file if present before creating an updated one. + When this happens on Windows, creation of the new file will be blocked + by the presence of the old one because it is in a open state. Further, + on both Unix and Windows systems we want behaviour to match that of + a real Oberon system, where registering the new file has the effect of + unregistering the old file. To simulate this we need to change the old + Files.File back to a temp file. *) + PROCEDURE Deregister(name: ARRAY OF CHAR); + VAR + identity: Platform.FileIdentity; + osfile: File; + error: Platform.ErrorCode; + BEGIN + IF Platform.IdentifyByName(name, identity) = 0 THEN + (* The name we are registering is an already existing file. *) + osfile := files; + WHILE (osfile # NIL) & ~Platform.SameFile(osfile.identity, identity) DO osfile := osfile.next END; + IF osfile # NIL THEN + (* osfile is the FileDesc corresponding to the file name we are hoping + to register. Turn it into a temporary file. *) + ASSERT(~osfile.tempFile); ASSERT(osfile.fd >= 0); + osfile.registerName := osfile.workName; + GetTempName(osfile.registerName, osfile.workName); + osfile.tempFile := TRUE; + osfile.state := open; + error := Platform.Rename(osfile.registerName, osfile.workName); + IF error # 0 THEN + Err("Couldn't rename previous version of file being registered", osfile, error) + END + END + END + END Deregister; + + + PROCEDURE Create(f: File); + (* Makes sure there is an OS file backing this Oberon file. + Used when more data has been written to an unregistered new file than + buffers can hold, or when registering a new file whose data is all in + buffers. *) + VAR + done: BOOLEAN; + error: Platform.ErrorCode; + err: ARRAY 32 OF CHAR; + BEGIN + IF f.fd = NoDesc THEN + IF f.state = create THEN + (* New file with enough data written to exceed buffers, so we need to + create a temporary file to back it. *) + GetTempName(f.registerName, f.workName); f.tempFile := TRUE + ELSE + ASSERT(f.state = close); + (* New file with all data in buffers being registered. No need for a + temp file, will just write the buffers to the registerName. *) + Deregister(f.registerName); + f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE + END; + error := Platform.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*) + error := Platform.New(f.workName, f.fd); + done := error = 0; + IF done THEN + f.next := files; files := f; (* Link this file into the list of OS backed files. *) + INC(Heap.FileCount); + Heap.RegisterFinalizer(f, Finalize); + f.state := open; + f.pos := 0; + error := Platform.Identify(f.fd, f.identity); + ELSE + IF Platform.NoSuchDirectory(error) THEN err := "no such directory" + ELSIF Platform.TooManyFiles(error) THEN err := "too many files open" + ELSE err := "file not created" + END; + Err(err, f, error) + END + END + END Create; + + PROCEDURE Flush(buf: Buffer); + VAR + error: Platform.ErrorCode; + f: File; + (* identity: Platform.FileIdentity; *) + BEGIN + IF buf.chg THEN f := buf.f; Create(f); + IF buf.org # f.pos THEN + error := Platform.Seek(f.fd, buf.org, Platform.SeekSet); + END; + error := Platform.Write(f.fd, SYSTEM.ADR(buf.data), buf.size); + IF error # 0 THEN Err("error writing file", f, error) END; + f.pos := buf.org + buf.size; + buf.chg := FALSE; + error := Platform.Identify(f.fd, f.identity); (* Update identity with new modification time. *) + IF error # 0 THEN Err("error identifying file", f, error) END; + END + END Flush; + + PROCEDURE Close* (f: File); + VAR + i: LONGINT; error: Platform.ErrorCode; + BEGIN + IF (f.state # create) OR (f.registerName # "") THEN + Create(f); i := 0; + WHILE (i < NumBufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) 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); + (* Extract next individual directory from searchpath starting at pos, + updating pos and returning dir. + Supports ~, ~user and blanks inside path *) + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; + IF SearchPath = NIL THEN + IF pos = 0 THEN + dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *) + END + ELSE + ch := SearchPath[pos]; + WHILE (ch = " ") OR (ch = ";") DO INC(pos); ch := SearchPath[pos] END; + IF ch = "~" THEN + INC(pos); ch := SearchPath[pos]; + 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 := SearchPath[pos] END; + WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END + 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(identity: Platform.FileIdentity): File; + VAR f: File; i: INTEGER; error: Platform.ErrorCode; + BEGIN f := files; + WHILE f # NIL DO + IF Platform.SameFile(identity, f.identity) THEN + IF ~Platform.SameFileTime(identity, f.identity) THEN i := 0; + WHILE i < NumBufs DO + IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END; + INC(i) + END; + f.swapper := -1; f.identity := identity; + error := Platform.Size(f.fd, f.len); + END; + RETURN f + END; + f := f.next + END; + RETURN NIL + END CacheEntry; + + PROCEDURE Old*(name: ARRAY OF CHAR): File; + VAR + f: File; + fd: Platform.FileHandle; + pos: INTEGER; + done: BOOLEAN; + dir, path: ARRAY 256 OF CHAR; + error: Platform.ErrorCode; + identity: Platform.FileIdentity; + BEGIN + (* Out.String("Files.Old "); Out.String(name); Out.Ln; *) + 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 + error := Platform.OldRW(path, fd); done := error = 0; + IF ~done & Platform.TooManyFiles(error) THEN Err("too many files open", f, error) END; + IF ~done & Platform.Inaccessible(error) THEN + error := Platform.OldRO(path, fd); done := error = 0; + END; + IF ~done & ~Platform.Absent(error) THEN + Out.String("Warning: Files.Old "); Out.String(name); + Out.String(" error = "); Out.Int(error, 0); Out.Ln; + END; + IF done THEN + (* Out.String(" fd = "); Out.Int(fd,1); Out.Ln; *) + error := Platform.Identify(fd, identity); + f := CacheEntry(identity); + IF f # NIL THEN + error := Platform.Close(fd); (* fd not needed - we'll be using f.fd. *) + RETURN f + ELSE NEW(f); Heap.RegisterFinalizer(f, Finalize); + f.fd := fd; f.state := open; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*) + error := Platform.Size(fd, f.len); + COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE; + f.identity := identity; + f.next := files; files := f; INC(Heap.FileCount); + 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; identity: Platform.FileIdentity; error: Platform.ErrorCode; + BEGIN i := 0; + WHILE i < NumBufs 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 + error := Platform.Truncate(f.fd, 0); + error := Platform.Seek(f.fd, 0, Platform.SeekSet) + END; + f.pos := 0; f.len := 0; f.swapper := -1; + error := Platform.Identify(f.fd, identity); Platform.SetMTime(f.identity, identity) + END Purge; + + PROCEDURE GetDate* (f: File; VAR t, d: LONGINT); + VAR + identity: Platform.FileIdentity; error: Platform.ErrorCode; + BEGIN + Create(f); error := Platform.Identify(f.fd, identity); + Platform.MTimeAsClock(identity, t, d) + END GetDate; + + PROCEDURE Pos* (VAR r: Rider): LONGINT; + BEGIN + Assert(r.offset <= BufSize); + RETURN r.org + r.offset + END Pos; + + PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT); + VAR org, offset, i, n: LONGINT; buf: Buffer; error: Platform.ErrorCode; + 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 < NumBufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END; + IF i < NumBufs 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 NumBufs; + 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 error := Platform.Seek(f.fd, org, Platform.SeekSet) END; + error := Platform.ReadBuf(f.fd, buf.data, n); + IF error # 0 THEN Err("read from file not done", f, error) END; + f.pos := org + n; + buf.size := n + END; + buf.org := org; buf.chg := FALSE + END + ELSE buf := NIL; org := 0; offset := 0 + END; + Assert(offset <= BufSize); + 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; + Assert(offset <= buf.size); + 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; + + (* wrapper for compatibility with Project Oberon sources *) + PROCEDURE ReadByte*(VAR r: Rider; VAR x: SYSTEM.BYTE); + BEGIN + Read(r, x) + END ReadByte; + + 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; (* Offset within buffer r.buf *) + 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); + Assert(offset <= BufSize) + 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; + Assert(offset <= BufSize); + IF (r.org # buf.org) OR (offset >= BufSize) THEN + Set(r, buf.f, r.org + offset); + buf := r.buf; offset := r.offset + END; + Assert(offset < BufSize); + 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 + Assert(offset <= BufSize); + IF (r.org # buf.org) OR (offset >= BufSize) THEN + Set(r, buf.f, r.org + offset); + buf := r.buf; offset := r.offset + END; + Assert(offset <= BufSize); + 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; + Assert(offset <= BufSize); + 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 + Deregister(name); + res := Platform.Unlink(name) + END Delete; + + PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER); + VAR + fdold, fdnew: Platform.FileHandle; + n: LONGINT; + error, ignore: Platform.ErrorCode; + oldidentity, newidentity: Platform.FileIdentity; + buf: ARRAY 4096 OF CHAR; + BEGIN + error := Platform.IdentifyByName(old, oldidentity); + IF error = 0 THEN + error := Platform.IdentifyByName(new, newidentity); + IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN + Delete(new, error); (* work around stale nfs handles *) + END; + error := Platform.Rename(old, new); + (* Out.String("Platform.Rename error code "); Out.Int(error,1); Out.Ln; *) + (* TODO, if we already have a FileDesc for old, it ought to be updated + with the new workname. *) + IF ~Platform.DifferentFilesystems(error) THEN + res := error; RETURN + ELSE + (* cross device link, move the file *) + error := Platform.OldRO(old, fdold); + IF error # 0 THEN res := 2; RETURN END; + error := Platform.New(new, fdnew); + IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END; + error := Platform.Read(fdold, SYSTEM.ADR(buf), BufSize, n); + WHILE n > 0 DO + error := Platform.Write(fdnew, SYSTEM.ADR(buf), n); + IF error # 0 THEN + ignore := Platform.Close(fdold); + ignore := Platform.Close(fdnew); + Err("cannot move file", NIL, error) + END; + error := Platform.Read(fdold, SYSTEM.ADR(buf), BufSize, n); + END; + ignore := Platform.Close(fdold); + ignore := Platform.Close(fdnew); + IF n = 0 THEN + error := Platform.Unlink(old); res := 0 + ELSE + Err("cannot move file", NIL, error) + END; + END + ELSE + res := 2 (* old file not found *) + END + END Rename; + + PROCEDURE Register* (f: File); + VAR idx, errcode: INTEGER; f1: File; + BEGIN + IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END; + Close(f); + IF f.registerName # "" THEN + Deregister(f.registerName); + Rename(f.workName, f.registerName, errcode); + IF errcode # 0 THEN Err("Couldn't rename temp name as register name", f, errcode) END; + f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE + END + END Register; + + PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER); + BEGIN + res := Platform.Chdir(path); + END ChangeDirectory; + + PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE); + VAR i, j: LONGINT; + BEGIN + IF ~Platform.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); + (* Reads 32 bits as a SET value (even on 64 bit systems. See Oakwood appendix 1.2.5.4 *) + VAR b: ARRAY 4 OF CHAR; l: LONGINT; + BEGIN ReadBytes(R, b, 4); + (* Need to read via a LONGINT to provide correct behaviour for 64 bit sets. *) + l := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H; + x := SYSTEM.VAL(SET, l) + 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 ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + i := 0; REPEAT Read(R, x[i]); INC(i) UNTIL (x[i-1] = 0X) OR (x[i-1] = 0AX); + IF x[i-1] = 0AX THEN DEC(i) END; (* Omit trailing LF *) + IF (i > 0) & (x[i-1] = 0DX) THEN DEC(i) END; (* Also omit preceeding trailing CR if present. *) + x[i] := 0X; (* Guarantee zero termination. *) + END ReadLine; + + PROCEDURE ReadNum*(VAR R: Rider; VAR x: ARRAY OF SYSTEM.BYTE); + VAR s, b: SYSTEM.INT8; q: SYSTEM.INT64; + BEGIN s := 0; q := 0; Read(R, b); + WHILE b < 0 DO INC(q, ASH(b+128, s)); INC(s, 7); Read(R, b) END; + INC(q, ASH(b MOD 64 - b DIV 64 * 64, s)); + Assert(LEN(x) <= 8); + SYSTEM.MOVE(SYSTEM.ADR(q), SYSTEM.ADR(x), LEN(x)) (* Assumes little endian representation of q and x. *) + 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; + y: SYSTEM.SET64; + BEGIN + IF SIZE(SET) = SIZE(INTEGER) THEN + i := SYSTEM.VAL(INTEGER, x); + ELSE + y := x; + i := SYSTEM.VAL(LONGINT, y); + END; + + 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: SYSTEM.INT64); + 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 CloseOSFile(f: File); + (* Close the OS file handle and remove f from 'files' *) + VAR prev: File; error: Platform.ErrorCode; + BEGIN + IF files = f THEN files := f.next + ELSE + prev := files; + WHILE (prev # NIL) & (prev.next # f) DO prev := prev.next END; + IF prev.next # NIL THEN prev.next := f.next END + END; + error := Platform.Close(f.fd); + f.fd := NoDesc; f.state := create; DEC(Heap.FileCount); + END CloseOSFile; + + PROCEDURE Finalize(o: SYSTEM.PTR); + VAR f: File; res: LONGINT; + BEGIN + f := SYSTEM.VAL(File, o); + IF f.fd >= 0 THEN + CloseOSFile(f); + IF f.tempFile THEN res := Platform.Unlink(f.workName) END + END + END Finalize; + + PROCEDURE SetSearchPath*(path: ARRAY OF CHAR); + BEGIN + IF Strings.Length(path) # 0 THEN + NEW(SearchPath, Strings.Length(path)+1); + COPY(path, SearchPath^) + ELSE + SearchPath := NIL + END + END SetSearchPath; + + +BEGIN + tempno := -1; + Heap.FileCount := 0; + HOME := ""; Platform.GetEnv("HOME", HOME); + MaxPathLength := Platform.MaxPathLength(); + MaxNameLength := Platform.MaxNameLength(); +END Files. diff --git a/src/runtime/Heap.Mod b/src/runtime/Heap.Mod new file mode 100644 index 00000000..4c57fa3c --- /dev/null +++ b/src/runtime/Heap.Mod @@ -0,0 +1,635 @@ +MODULE Heap; + + IMPORT S := SYSTEM; (* Cannot import anything else as heap initialization must complete + before any other modules are initialized. *) + + CONST + ModNameLen = 20; + CmdNameLen = 24; + SZA = SIZE(S.ADDRESS); (* Size of address *) + Unit = 4*SZA; (* Smallest possible heap block *) + nofLists = 9; (* Number of freelist entries excluding sentinel *) + heapSize0 = 8000*Unit; (* Startup heap size *) + + (* all blocks look the same: + free blocks describe themselves: size = Unit + tag = &tag++ + ->block size + sentinel = -SZA + next + *) + + (* heap chunks *) + nextChnkOff = S.VAL(S.ADDRESS, 0); (* next heap chunk, sorted ascendingly! *) + endOff = S.VAL(S.ADDRESS, SZA); (* end of heap chunk *) + blkOff = S.VAL(S.ADDRESS, 3*SZA); (* first block in a chunk, starts with tag *) + + (* heap blocks *) + tagOff = S.VAL(S.ADDRESS, 0); (* block starts with tag *) + sizeOff = S.VAL(S.ADDRESS, SZA); (* block size in free block relative to block start *) + sntlOff = S.VAL(S.ADDRESS, 2*SZA); (* pointer offset table sentinel in free block relative to block start *) + nextOff = S.VAL(S.ADDRESS, 3*SZA); (* next pointer in free block relative to block start *) + NoPtrSntl = S.VAL(S.ADDRESS, -SZA); + AddressZero = S.VAL(S.ADDRESS, 0); + + TYPE + ModuleName- = ARRAY ModNameLen OF CHAR; + CmdName- = ARRAY CmdNameLen OF CHAR; + + Module- = POINTER TO ModuleDesc; + Cmd- = POINTER TO CmdDesc; + + EnumProc- = PROCEDURE(P: PROCEDURE(p: S.PTR)); + + ModuleDesc- = RECORD + next-: Module; + name-: ModuleName; + refcnt-: LONGINT; + cmds-: Cmd; + types-: S.ADDRESS; + enumPtrs-: EnumProc; + reserved1, + reserved2: LONGINT + END; + + Command- = PROCEDURE; + + CmdDesc- = RECORD + next-: Cmd; + name-: CmdName; + cmd-: Command + END; + + Finalizer = PROCEDURE(obj: S.PTR); + + FinNode = POINTER TO FinDesc; + FinDesc = RECORD + next: FinNode; + obj: S.ADDRESS; (* weak pointer *) + marked: BOOLEAN; + finalize: Finalizer; + END; + + VAR + (* the list of loaded (=initialization started) modules *) + modules-: S.PTR; (*POINTER [1] TO ModuleDesc;*) + + freeList: ARRAY nofLists + 1 OF S.ADDRESS; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *) + bigBlocks: S.ADDRESS; + allocated*: S.ADDRESS; + firstTry: BOOLEAN; + ldUnit: INTEGER; (* Unit = 2^ldUnit, for unsigned division expressed as logical shift right *) + + + (* extensible heap *) + heap-: S.ADDRESS; (* the sorted list of heap chunks *) + heapMin: S.ADDRESS; (* Range of valid pointer values, used for stack collection *) + heapMax: S.ADDRESS; + heapsize*: S.ADDRESS; (* the sum of all heap chunk sizes *) + heapMinExpand*: S.ADDRESS; (* minimum heap expansion size *) + + (* finalization candidates *) + fin: FinNode; + + (* garbage collector busy flag *) + lockdepth: INTEGER; + interrupted: BOOLEAN; + + (* File system file count monitor *) + FileCount*: INTEGER; + + + PROCEDURE Lock*; + BEGIN + INC(lockdepth); + END Lock; + + PROCEDURE -ModulesHalt(code: LONGINT) "Modules_Halt(code)"; + + PROCEDURE Unlock*; + BEGIN + DEC(lockdepth); + IF interrupted & (lockdepth = 0) THEN + ModulesHalt(-9); + END + END Unlock; + + + PROCEDURE -uLT(x, y: S.ADDRESS): BOOLEAN "((size_t)x < (size_t)y)"; + PROCEDURE -uLE(x, y: S.ADDRESS): BOOLEAN "((size_t)x <= (size_t)y)"; + + (* + 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): S.PTR; + VAR m: Module; + BEGIN + (* REGMOD is called at the start of module initialisation code before that modules + type descriptors have been set up. 'NEW' depends on the Heap modules type + descriptors being ready for use, therefore, just for the Heap module itself, we + must use S.NEW. *) + IF name = "Heap" THEN + S.NEW(m, SIZE(ModuleDesc)) + ELSE + NEW(m) + END; + m.types := 0; m.cmds := NIL; + COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := S.VAL(Module, modules); + modules := m; + RETURN m + END REGMOD; + + PROCEDURE FreeModule*(name: ARRAY OF CHAR): LONGINT; + (* Returns 0 if freed, -1 if not found, refcount if found and refcount > 0. *) + VAR m, p: Module; + BEGIN m := S.VAL(Module, modules); + WHILE (m # NIL) & (m.name # name) DO p := m; m := m.next END; + IF (m # NIL) & (m.refcnt = 0) THEN + IF m = S.VAL(Module, modules) THEN modules := m.next + ELSE p.next := m.next + END; + RETURN 0 + ELSE + IF m = NIL THEN RETURN -1 ELSE RETURN m.refcnt END + END + END FreeModule; + + + PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command); + VAR c: Cmd; + BEGIN + (* REGCMD is called during module initialisation code before that modules + type descriptors have been set up. 'NEW' depends on the Heap modules type + descriptors being ready for use, therefore, just for the commands registered + by the Heap module itself, we must use S.NEW. *) + IF m.name = "Heap" THEN + S.NEW(c, SIZE(CmdDesc)) + ELSE + NEW(c) + END; + COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c + END REGCMD; + + PROCEDURE REGTYP*(m: Module; typ: S.ADDRESS); + BEGIN S.PUT(typ, m.types); m.types := typ + END REGTYP; + + PROCEDURE INCREF*(m: Module); + BEGIN INC(m.refcnt) + END INCREF; + + + PROCEDURE -ExternPlatformOSAllocate "extern ADDRESS Platform_OSAllocate(ADDRESS size);"; + PROCEDURE -OSAllocate(size: S.ADDRESS): S.ADDRESS "Platform_OSAllocate(size)"; + + PROCEDURE NewChunk(blksz: S.ADDRESS): S.ADDRESS; + VAR chnk, blk, end: S.ADDRESS; + BEGIN + chnk := OSAllocate(blksz + blkOff); + IF chnk # 0 THEN + blk := chnk + blkOff; (* Heap chunk consists of a single block *) + end := blk + blksz; + S.PUT(chnk + endOff, end); + S.PUT(blk + tagOff, blk + sizeOff); + S.PUT(blk + sizeOff, blksz); + S.PUT(blk + sntlOff, NoPtrSntl); + S.PUT(blk + nextOff, bigBlocks); + bigBlocks := blk; (* Prepend block to list of big blocks *) + INC(heapsize, blksz); + (* Maintain heap range limits *) + IF uLT(blk + SZA, heapMin) THEN heapMin := blk + SZA END; + IF uLT(heapMax, end) THEN heapMax := end END + END; + RETURN chnk + END NewChunk; + + PROCEDURE ExtendHeap(blksz: S.ADDRESS); + VAR size, chnk, j, next: S.ADDRESS; + BEGIN + ASSERT(blksz MOD Unit = 0); + IF uLT(heapMinExpand, blksz) THEN size := blksz + ELSE size := heapMinExpand (* additional heuristics for avoiding many small heap expansions *) + END; + chnk := NewChunk(size); + IF chnk # 0 THEN + (*sorted insertion*) + IF uLT(chnk, heap) THEN + S.PUT(chnk, heap); heap := chnk + ELSE + j := heap; S.GET(j, next); + WHILE (next # 0) & uLT(next, chnk) DO + j := next; + S.GET(j, next) + END; + S.PUT(chnk, next); S.PUT(j, chnk) + END + ELSIF ~firstTry THEN + (* Heap memory exhausted, i.e. heap is not expanded and NEWREC() will return NIL. + In order to be able to report a trap due to NIL access, there is more + memory needed, which may be available by reducing heapMinExpand. *) + heapMinExpand := Unit + (* ELSE firstTry: ignore failed heap expansion for anti-thrashing heuristics. *) + END + END ExtendHeap; + + PROCEDURE ^GC*(markStack: BOOLEAN); + + PROCEDURE NEWREC*(tag: S.ADDRESS): S.PTR; + VAR + i, i0, di, blksz, restsize, t, adr, end, next, prev: S.ADDRESS; + new: S.PTR; + BEGIN + Lock(); + S.GET(tag, blksz); + + ASSERT(SIZE(S.PTR) = SIZE(S.ADDRESS)); + ASSERT(blksz MOD Unit = 0); + + i0 := S.LSH(blksz, -ldUnit); (*uDIV 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 from freelist[i] *) + S.GET(adr + nextOff, next); + freeList[i] := next; + IF i # i0 THEN (* Split *) + di := i - i0; restsize := di * Unit; end := adr + restsize; + S.PUT(end + sizeOff, blksz); + S.PUT(end + sntlOff, NoPtrSntl); + S.PUT(end, end + sizeOff); + S.PUT(adr + sizeOff, restsize); + S.PUT(adr + nextOff, freeList[di]); + freeList[di] := adr; + INC(adr, restsize) + END + ELSE (* Search in bigBlocks *) + adr := bigBlocks; prev := 0; + LOOP + IF adr = 0 THEN (* Nothing free *) + IF firstTry THEN + GC(TRUE); INC(blksz, Unit); + (* Anti-thrashing heuristics: ensure 1/5 of the heap will not be allocated. *) + t := S.LSH(allocated + blksz, -(2+ldUnit)) (*uDIV 4*Unit*) * (5*Unit) ; (* Minimum preferred heapsize *) + IF uLT(heapsize, t) THEN ExtendHeap(t - heapsize) + (* If there is not enough heap memory then the heap will be expanded below by blksz *) + END; + firstTry := FALSE; new := NEWREC(tag); + IF new = NIL THEN (* Heap is 1/5 free but fragmentation prevented allocation *) + ExtendHeap(blksz); + new := NEWREC(tag) (* Will find a free block if heap has been expanded successfully *) + END; + firstTry := TRUE; + Unlock(); RETURN new + ELSE + Unlock(); RETURN NIL + END + END; + S.GET(adr+sizeOff, t); + IF uLE(blksz, t) THEN EXIT END; + prev := adr; S.GET(adr + nextOff, adr) + END; + restsize := t - blksz; end := adr + restsize; + S.PUT(end + sizeOff, blksz); + S.PUT(end + sntlOff, NoPtrSntl); + S.PUT(end, end + sizeOff); + IF uLT(nofLists * Unit, restsize) THEN (* Resize *) + S.PUT(adr + sizeOff, restsize) + ELSE (* Unlink *) + S.GET(adr + nextOff, next); + IF prev = 0 THEN bigBlocks := next + ELSE S.PUT(prev + nextOff, next); + END; + IF restsize # 0 THEN (* Move *) + di := restsize DIV Unit; + S.PUT(adr + sizeOff, restsize); + S.PUT(adr + nextOff, freeList[di]); + freeList[di] := adr + END + END; + INC(adr, restsize) + END; + i := adr + 4*SZA; end := adr + blksz; + WHILE uLT(i, end) DO (* Deliberately unrolled *) + S.PUT(i, AddressZero); + S.PUT(i + SZA, AddressZero); + S.PUT(i + 2*SZA, AddressZero); + S.PUT(i + 3*SZA, AddressZero); + INC(i, 4*SZA) + END; + S.PUT(adr + nextOff, AddressZero); + S.PUT(adr, tag); + S.PUT(adr + sizeOff, AddressZero); + S.PUT(adr + sntlOff, AddressZero); + INC(allocated, blksz); + Unlock(); + RETURN S.VAL(S.PTR, adr + SZA) + END NEWREC; + + PROCEDURE NEWBLK*(size: S.ADDRESS): S.PTR; + VAR blksz, tag: S.ADDRESS; new: S.PTR; + BEGIN + Lock(); + blksz := (size + (4*SZA + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*) + new := NEWREC(S.ADR(blksz)); + tag := S.VAL(S.ADDRESS, new) + blksz - 3*SZA; + S.PUT(tag - SZA, AddressZero); (*reserved for meta info*) + S.PUT(tag, blksz); + S.PUT(tag + SZA, NoPtrSntl); + S.PUT(S.VAL(S.ADDRESS, new) - SZA, tag); + Unlock(); + RETURN new + END NEWBLK; + + PROCEDURE Mark(q: S.ADDRESS); + VAR p, tag, offset, fld, n, tagbits: S.ADDRESS; + BEGIN + IF q # 0 THEN + S.GET(q - SZA, tagbits); (* Load the tag for the record at q *) + IF ~ODD(tagbits) THEN (* If it has not already been marked *) + S.PUT(q - SZA, tagbits + 1); (* Mark it *) + p := 0; + tag := tagbits + SZA; (* Tag addresses first offset *) + LOOP + S.GET(tag, offset); (* Get next ptr field offset *) + IF offset < 0 THEN (* Sentinel reached: Value is -8*(#fields+1) *) + S.PUT(q - SZA, tag + offset + 1); (* Rotate base ptr into tag *) + IF p = 0 THEN EXIT END; + n := q; q := p; + S.GET(q - SZA, tag); DEC(tag, 1); + S.GET(tag, offset); fld := q + offset; + S.GET(fld, p); S.PUT(fld, S.VAL(S.PTR, n)) + ELSE (* offset references a ptr field *) + fld := q + offset; (* S.ADDRESS the pointer *) + S.GET(fld, n); (* Load the pointer *) + IF n # 0 THEN (* If pointer is not NIL *) + S.GET(n - SZA, tagbits); (* Consider record pointed to by this field *) + IF ~ODD(tagbits) THEN + S.PUT(n - SZA, tagbits + 1); + S.PUT(q - SZA, tag + 1); + S.PUT(fld, S.VAL(S.PTR, p)); + p := q; q := n; + tag := tagbits + END + END + END; + INC(tag, SZA) + END + END + END + END Mark; + + PROCEDURE MarkP(p: S.PTR); (* for compatibility with EnumPtrs in ANSI mode *) + BEGIN + Mark(S.VAL(S.ADDRESS, p)) + END MarkP; + + PROCEDURE Scan; + VAR chnk, adr, end, start, tag, i, size, freesize: S.ADDRESS; + 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; + S.GET(chnk + endOff, end); + WHILE uLT(adr, end) DO + S.GET(adr, tag); + IF ODD(tag) THEN (* Marked *) + IF freesize # 0 THEN + start := adr - freesize; + S.PUT(start, start+SZA); + S.PUT(start+sizeOff, freesize); + S.PUT(start+sntlOff, NoPtrSntl); + i := S.LSH(freesize, -ldUnit) (*uDIV Unit*); + freesize := 0; + IF uLT(i, nofLists) THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start + ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start + END + END; + DEC(tag, 1); + S.PUT(adr, tag); + S.GET(tag, size); + INC(allocated, size); + INC(adr, size) + ELSE (*unmarked*) + S.GET(tag, size); + INC(freesize, size); + INC(adr, size) + END + END; + IF freesize # 0 THEN (* Collect last block *) + start := adr - freesize; + S.PUT(start, start+SZA); + S.PUT(start+sizeOff, freesize); + S.PUT(start+sntlOff, NoPtrSntl); + i := S.LSH(freesize, -ldUnit) (*uDIV Unit*); + freesize := 0; + IF uLT(i, nofLists) THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start + ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start + END + END; + S.GET(chnk, chnk) + END + END Scan; + + PROCEDURE Sift (l, r: LONGINT; VAR a: ARRAY OF S.ADDRESS); + VAR i, j: LONGINT; x: S.ADDRESS; + BEGIN j := l; x := a[j]; + LOOP i := j; j := 2*j + 1; + IF (j < r) & uLT(a[j], a[j+1]) THEN INC(j) END; + IF (j > r) OR uLE(a[j], x) THEN EXIT END; + a[i] := a[j] + END; + a[i] := x + END Sift; + + PROCEDURE HeapSort (n: LONGINT; VAR a: ARRAY OF S.ADDRESS); + VAR l, r: LONGINT; x: S.ADDRESS; + 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 S.ADDRESS); + VAR chnk, end, adr, tag, next, i, ptr, size: S.ADDRESS; + BEGIN + ASSERT(n > 0); + chnk := heap; i := 0; + WHILE chnk # 0 DO + S.GET(chnk + endOff, end); + adr := chnk + blkOff; + WHILE uLT(adr, end) DO + S.GET(adr, tag); + IF ODD(tag) THEN (*already marked*) + S.GET(tag-1, size); INC(adr, size); ptr := adr + SZA; + WHILE uLT(cand[i], ptr) DO INC(i); IF i = n THEN RETURN END END ; + ELSE + S.GET(tag, size); ptr := adr + SZA; INC(adr, size); + WHILE uLT(cand[i], ptr) DO INC(i); IF i = n THEN RETURN END END ; + IF uLT(cand[i], adr) THEN Mark(ptr) END + END ; + IF uLE(end, cand[i]) THEN (*skip rest of this heap chunk*) adr := end END + END ; + S.GET(chnk + nextChnkOff, chnk) + END + END MarkCandidates; + + PROCEDURE CheckFin; + VAR n: FinNode; tag: S.ADDRESS; + BEGIN + n := fin; + WHILE n # NIL DO + S.GET(n.obj - SZA, 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(S.VAL(S.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(S.VAL(S.PTR, n.obj)) + END + END FINALL; + + PROCEDURE -ExternMainStackFrame "extern ADDRESS Modules_MainStackFrame;"; + PROCEDURE -ModulesMainStackFrame(): S.ADDRESS "Modules_MainStackFrame"; + + PROCEDURE MarkStack(n: S.ADDRESS; VAR cand: ARRAY OF S.ADDRESS); + VAR + frame: S.PTR; + nofcand: LONGINT; + inc, sp, p, stack0: S.ADDRESS; + align: RECORD ch: CHAR; p: S.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 := S.ADR(frame); + stack0 := ModulesMainStackFrame(); + (* check for minimum alignment of pointers *) + inc := S.ADR(align.p) - S.ADR(align); + IF uLT(stack0, sp) THEN inc := -inc END; + WHILE sp # stack0 DO + S.GET(sp, p); + IF uLE(heapMin, p) & uLT(p, heapMax) 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: S.ADDRESS; + cand: ARRAY 10000 OF S.ADDRESS; + BEGIN + Lock(); + m := S.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 (* True at first iteration *) + MarkStack(32, cand); EXIT + END + END; + IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 (* use all variables *) + + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15 + + i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN (* Always false *) + RETURN + END; + END; + CheckFin; + Scan; + Finalize; + Unlock() + END GC; + + PROCEDURE RegisterFinalizer*(obj: S.PTR; finalize: Finalizer); + VAR f: FinNode; + BEGIN NEW(f); + f.obj := S.VAL(S.ADDRESS, obj); f.finalize := finalize; f.marked := TRUE; + f.next := fin; fin := f; + END RegisterFinalizer; + + + PROCEDURE -ExternHeapInit "extern void *Heap__init();"; + PROCEDURE -HeapModuleInit 'Heap__init()'; + + PROCEDURE InitHeap*; + (* InitHeap is called by Platform.init before any module bodies have been + initialised, to enable NEW, S.NEW *) + BEGIN + heap := 0; + heapsize := 0; + allocated := 0; + lockdepth := 0; + heapMin := -1; (* all bits set = max unsigned value *) + heapMax := 0; + bigBlocks := 0; + heapMinExpand := heapSize0; + + ASSERT((Unit = 16) OR (Unit = 32)); + IF Unit = 16 THEN ldUnit := 4 ELSE ldUnit := 5 END; + + heap := NewChunk(heapSize0); + S.PUT(heap + nextChnkOff, AddressZero); + + firstTry := TRUE; + freeList[nofLists] := 1; (* Sentinel, # 0 *) + + FileCount := 0; + modules := NIL; + fin := NIL; + interrupted := FALSE; + + HeapModuleInit; + END InitHeap; + +END Heap. diff --git a/src/runtime/In.Mod b/src/runtime/In.Mod new file mode 100644 index 00000000..76ceb1e8 --- /dev/null +++ b/src/runtime/In.Mod @@ -0,0 +1,161 @@ +MODULE In; + +IMPORT Platform, SYSTEM, Strings, Out; + +VAR + Done-: BOOLEAN; + nextch: CHAR; (* Maintains 1 character read ahaead except at end of line. *) + readstate: INTEGER; + +CONST + pending = 0; (* readstate when at start of input or end of line. Implies nextch undefined. *) + ready = 1; (* readstate when nextch is defined and contains next character on current line. *) + eof = 2; (* readstate when at end of file. *) + +PROCEDURE Open*; +VAR error: Platform.ErrorCode; +BEGIN + error := Platform.Seek(Platform.StdIn, 0, Platform.SeekSet); (* Rewind STDIN to beginning of file. *) + readstate := pending; + Done := TRUE; +END Open; + +PROCEDURE ReadChar; +VAR error: Platform.ErrorCode; n: LONGINT; +BEGIN + error := Platform.ReadBuf(Platform.StdIn, nextch, n); + IF (error = 0) & (n = 1) THEN readstate := ready ELSE readstate := eof END +END ReadChar; + +PROCEDURE StartRead; (* Ensure either nextch is valid or we're at EOF. *) +BEGIN Out.Flush; IF readstate = pending THEN ReadChar END; +END StartRead; + +PROCEDURE StartAndSkip; (* Like StartRead, but also skip over blanks, CR, LF, tab. *) +BEGIN StartRead; + WHILE (readstate = ready) & (nextch <= " ") DO ReadChar END +END StartAndSkip; + +PROCEDURE Char*(VAR ch: CHAR); +BEGIN + StartRead; + Done := readstate = ready; + IF Done THEN + ch := nextch; + IF ch = 0AX THEN readstate := pending ELSE ReadChar END + ELSE + ch := 0X + END +END Char; + +PROCEDURE HugeInt*(VAR h: HUGEINT); +VAR + neg, hex, endofnum: BOOLEAN; + decacc, hexacc, digit: HUGEINT; +BEGIN + StartAndSkip; + Done := FALSE; + IF readstate = ready THEN + neg := nextch = '-'; IF neg THEN ReadChar END; + hex := FALSE; + endofnum := FALSE; + decacc := 0; + hexacc := 0; + WHILE (readstate = ready) & ~endofnum DO + digit := -1; + IF (nextch >= "0") & (nextch <= "9") THEN + digit := ORD(nextch) MOD 16 + ELSIF (nextch >= "a") & (nextch <= "f") + OR (nextch >= "A") & (nextch <= "F") THEN + digit := ORD(nextch) MOD 16 + 9; hex := TRUE + END; + IF digit >= 0 THEN + Done := TRUE; + decacc := decacc * 10 + digit; + hexacc := hexacc * 16 + digit; + ReadChar + ELSIF nextch = "H" THEN + hex := TRUE; endofnum := TRUE; ReadChar + ELSE + endofnum := TRUE + END + END; + IF Done THEN + IF hex THEN h := hexacc ELSE h := decacc END; + IF neg THEN h := -h END + ELSE + h := 0 + END + END +END HugeInt; + +PROCEDURE Int*(VAR i: INTEGER); +VAR h: HUGEINT; +BEGIN HugeInt(h); i := SYSTEM.VAL(INTEGER, h) +END Int; + +PROCEDURE LongInt*(VAR i: LONGINT); +VAR h: HUGEINT; +BEGIN HugeInt(h); i := SYSTEM.VAL(LONGINT, h) +END LongInt; + +PROCEDURE Line*(VAR line: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN StartRead; i := 0; Done := readstate = ready; + WHILE (readstate = ready) & (nextch # 0DX) & (nextch # 0AX) & (i < LEN(line)-1) DO + line[i] := nextch; INC(i); ReadChar + END; + line[i] := 0X; + IF (readstate = ready) & (nextch = 0DX) THEN ReadChar END; + IF (readstate = ready) & (nextch = 0AX) THEN readstate := pending END; +END Line; + +PROCEDURE String*(VAR str: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN StartAndSkip; i := 0; + IF (readstate = ready) & (nextch = '"') THEN (* " *) + ReadChar; + WHILE (readstate = ready) + & (i < LEN(str)-1) + & (nextch >= " ") + & (nextch # '"') DO (* " *) + str[i] := nextch; ReadChar; INC(i) + END + END; + Done := (readstate = ready) + & (i < LEN(str)-1) + & (nextch = '"'); (* " *) + IF Done THEN + ReadChar; str[i] := 0X + ELSE + str[0] := 0X + END +END String; + +PROCEDURE Name*(VAR name: ARRAY OF CHAR); (* Read filename. Presumably using shell semantics. *) +BEGIN HALT(99) (* Not implemented *) +END Name; + +PROCEDURE Real*(VAR x: REAL); +VAR + str: ARRAY 16 OF CHAR; +BEGIN + Line(str); + Strings.StrToReal(str, x); +END Real; + +PROCEDURE LongReal*(VAR y: LONGREAL); +VAR + str: ARRAY 16 OF CHAR; +BEGIN + Line(str); + Strings.StrToLongReal(str, y); +END LongReal; + + + +BEGIN + nextch := 0X; + readstate := pending; + Done := TRUE; +END In. diff --git a/src/runtime/Math.Mod b/src/runtime/Math.Mod new file mode 100644 index 00000000..0d1d61f5 --- /dev/null +++ b/src/runtime/Math.Mod @@ -0,0 +1,813 @@ +MODULE Math; + +IMPORT SYSTEM; + +(* Math - Oakwood REAL Mathematics. + Adapted from OOC LowReal.Mod and RealMath.Mod + + Target independent mathematical functions for REAL + (IEEE single - precision) numbers. + + Numerical approximations are taken from "Software Manual for the + Elementary Functions" by Cody & Waite and "Computer Approximations" + by Hart et al. + + Copyright (C) 1995 Michael Griebling + + 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 this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 - 1307 USA +*) + +(* + Real number properties are defined as follows: + + radix - -The whole number value of the radix used to represent the + corresponding read number values. + + places - -The whole number value of the number of radix places used + to store values of the corresponding real number type. + + expoMin - -The whole number value of the exponent minimum. + + expoMax - -The whole number value of the exponent maximum. + + large - -The largest value of the corresponding real number type. + + small - -The smallest positive value of the corresponding real number + type, represented to maximal precision. + + IEC559 - -A Boolean value that is TRUE if and only if the implementation + of the corresponding real number type conforms to IEC 559:1989 + (IEEE 754:1987) in all regards. + + NOTES + 6 -- If `IEC559' is TRUE, the value of `radix' is 2. + 7 -- If LowReal.IEC559 is TRUE, the 32 - bit format of IEC 559:1989 + is used for the type REAL. + 7 -- If LowLong.IEC559 is TRUE, the 64 - bit format of IEC 559:1989 + is used for the type REAL. + + LIA1 - -A Boolean value that is TRUE if and only if the implementation of + the corresponding real number type conforms to ISO/IEC 10967 - 1:199x + (LIA - 1) in all regards: parameters, arithmetic, exceptions, and + notification. + + rounds - -A Boolean value that is TRUE if and only if each operation produces + a result that is one of the values of the corresponding real number + type nearest to the mathematical result. + + gUnderflow - -A Boolean value that is TRUE if and only if there are values of + the corresponding real number type between 0.0 and `small'. + + exception - -A Boolean value that is TRUE if and only if every operation that + attempts to produce a real value out of range raises an exception. + + extend - -A Boolean value that is TRUE if and only if expressions of the + corresponding real number type are computed to higher precision than + the stored values. + + nModes - -The whole number value giving the number of bit positions needed for + the status flags for mode control. + *) + +CONST + pi* = 3.1415926535897932384626433832795028841972; + e* = 2.7182818284590452353602874713526624977572; + + places* = 24; + large* = MAX(REAL); (* 3.40282347E+38. Largest number this package accepts *) +(*small* = 1.17549435E-38; *) (* 2^(-126) *) + small* = 1/8.50705917E37; (* don't know better way; -- noch *) + expoMax* = 127; + expoMin* = 1-expoMax; + expOffset = expoMax; + nMask = {0..22,31}; (* number mask: Sign and mantissa *) + expMask = {23..30}; (* exponent mask: exponent value + 127 *) + + ZERO = 0.0; + HALF = 0.5; + ONE = 1.0; + TWO = 2.0; + TEN = 10.0; + miny = ONE/large; (* Smallest number this package accepts *) + sqrtHalf = 0.70710678118654752440; + Limit = 2.4414062E-4; (* 2 * *( - MantBits/2) *) + eps = 2.9802322E-8; (* 2 * *( - MantBits - 1) *) + piInv = 0.31830988618379067154; (* 1/pi *) + piByTwo = 1.57079632679489661923132; + piByFour = 0.78539816339744830962; + lnv = 0.6931610107421875; (* should be exact *) + vbytwo = 0.13830277879601902638E-4; (* used in sinh/cosh *) + ln2Inv = 1.44269504088896340735992468100189213; + + (* error/exception codes *) + NoError* = 0; IllegalRoot* = 1; IllegalLog* = 2; Overflow* = 3; + IllegalPower* = 4; IllegalLogBase* = 5; IllegalTrig* = 6; IllegalInvTrig* = 7; + HypInvTrigClipped* = 8; IllegalHypInvTrig* = 9; LossOfAccuracy* = 10; Underflow* = 11; + +VAR + ErrorHandler*: PROCEDURE (errno : INTEGER); + err-: INTEGER; + + a1: ARRAY 18 OF REAL; (* lookup table for power function *) + a2: ARRAY 9 OF REAL; (* lookup table for power function *) + em: REAL; (* largest number such that 1 + epsilon > 1.0 *) + LnInfinity: REAL; (* natural log of infinity *) + LnSmall: REAL; (* natural log of very small number *) + SqrtInfinity: REAL; (* square root of infinity *) + TanhMax: REAL; (* maximum Tanh value *) + t: REAL; (* internal variables *) + + +PROCEDURE DefaultErrorHandler(errno : INTEGER); +BEGIN err:=errno END DefaultErrorHandler; + +PROCEDURE ClearError*; +BEGIN err:=0 END ClearError; + + +(* TYPE REAL: 1/sign, 8/exponent, 23/significand *) + +PROCEDURE fraction*(x: REAL): REAL; +(* + The value of the call fraction(x) shall be the significand (or + significant) part of `x'. Hence the following relationship shall + hold: x = scale(fraction(x), exponent(x)). +*) + VAR s: SET; +BEGIN + IF x = ZERO THEN RETURN ZERO + ELSE + s := SYSTEM.VAL(SYSTEM.SET32, x) * nMask + {24..29}; + RETURN SYSTEM.VAL(REAL, s) * 2.0; + END +END fraction; + +PROCEDURE exponent*(x: REAL): INTEGER; +(* + The value of the call exponent(x) shall be the exponent value of `x' + that lies between `expoMin' and `expoMax'. An exception shall occur + and may be raised if `x' is equal to 0.0. + *) +BEGIN + IF x = ZERO THEN RETURN 0 (* NOTE: x=0.0 should raise exception *) + ELSE + RETURN SHORT(SYSTEM.LSH(SYSTEM.VAL(SYSTEM.INT32, x), -23) MOD 256) - 127 + END +END exponent; + +PROCEDURE sign*(x: REAL): REAL; +(* + The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0, + or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or + -1.0 if `x' is equal to 0.0. +*) +BEGIN + IF x < ZERO THEN RETURN -ONE ELSE RETURN ONE END +END sign; + +PROCEDURE scale*(x: REAL; n: INTEGER): REAL; +(* + The value of the call scale(x,n) shall be the value x*radix^n if such + a value exists; otherwise an execption shall occur and may be raised. +*) + VAR exp: LONGINT; lexp: SET; +BEGIN + IF x = ZERO THEN RETURN ZERO END; + exp := exponent(x) + n; (* new exponent *) + IF exp > expoMax THEN RETURN large * sign(x) (* exception raised here *) + ELSIF exp < expoMin THEN RETURN small * sign(x) (* exception here as well *) + END; + lexp := SYSTEM.VAL(SYSTEM.SET32, x) * nMask (* sign and significand *) + + SYSTEM.VAL(SYSTEM.SET32, SYSTEM.LSH(exp+expOffset, 23)); (* shifted exponent bits *) + RETURN SYSTEM.VAL(REAL, lexp) +END scale; + +PROCEDURE ulp*(x: REAL): REAL; +(* + The value of the call ulp(x) shall be the value of the corresponding + real number type equal to a unit in the last place of `x', if such a + value exists; otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN scale(ONE, exponent(x)-places+1) +END ulp; + +PROCEDURE succ*(x: REAL): REAL; +(* + The value of the call succ(x) shall be the next value of the + corresponding real number type greater than `x', if such a type + exists; otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN x+ulp(x)*sign(x) +END succ; + +PROCEDURE pred*(x: REAL): REAL; +(* + The value of the call pred(x) shall be the next value of the + corresponding real number type less than `x', if such a type exists; + otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN x-ulp(x)*sign(x) +END pred; + + +PROCEDURE SinCos (x, y, sign: REAL): REAL; + CONST + ymax = 9099; (* ENTIER(pi * 2* * (MantBits/2)) *) + r1 = -0.1666665668E+0; + r2 = 0.8333025139E-2; + r3 = -0.1980741872E-3; + r4 = 0.2601903036E-5; + VAR + n: LONGINT; xn, f, g: REAL; +BEGIN + IF y >= ymax THEN ErrorHandler(LossOfAccuracy); RETURN ZERO END; + + (* determine the reduced number *) + n := ENTIER(y * piInv + HALF); xn := n; + IF ODD(n) THEN sign := -sign END; + x := ABS(x); + IF x # y THEN xn := xn - HALF END; + + (* fractional part of reduced number *) + f := SHORT(ABS(LONG(x)) - LONG(xn) * pi); + + (* Pre: |f| <= pi/2 *) + IF ABS(f) < Limit THEN RETURN sign * f END; + + (* evaluate polynomial approximation of sin *) + g := f * f; g := (((r4 * g + r3) * g + r2) * g + r1) * g; + g := f + f * g; (* don't use less accurate f(1 + g) *) + RETURN sign * g +END SinCos; + +PROCEDURE div (x, y : LONGINT) : LONGINT; +(* corrected MOD function *) +BEGIN + IF x < 0 THEN + (*ASSERT((x DIV y) = ( - ABS(x) DIV y));*) (* x DIV y should already be correct *) + RETURN -ABS(x) DIV y + ELSE + RETURN x DIV y + END +END div; + + +(* forward declarations *) +PROCEDURE^ arctan2* (xn, xd: REAL): REAL; +PROCEDURE^ sincos* (x: REAL; VAR Sin, Cos: REAL); + +PROCEDURE round* (x: REAL): LONGINT; + (* Returns the value of x rounded to the nearest integer *) +BEGIN + IF x < ZERO THEN RETURN -ENTIER(HALF - x) + ELSE RETURN ENTIER(x + HALF) + END +END round; + +PROCEDURE sqrt* (x: REAL): REAL; + (* Returns the positive square root of x where x >= 0 *) + CONST + P0 = 0.41731; P1 = 0.59016; + VAR + xMant, yEst, z: REAL; xExp: INTEGER; +BEGIN + (* optimize zeros and check for illegal negative roots *) + IF x = ZERO THEN RETURN ZERO END; + IF x < ZERO THEN ErrorHandler(IllegalRoot); x := -x END; + + (* reduce the input number to the range 0.5 <= x <= 1.0 *) + xMant := fraction(x) * HALF; xExp := exponent(x) + 1; + + (* initial estimate of the square root *) + yEst := P0 + P1 * xMant; + + (* perform two newtonian iterations *) + z := (yEst + xMant/yEst); yEst := 0.25 * z + xMant/z; + + (* adjust for odd exponents *) + IF ODD(xExp) THEN yEst := yEst * sqrtHalf; INC(xExp) END; + + (* single Newtonian iteration to produce real number accuracy *) + RETURN scale(yEst, xExp DIV 2) +END sqrt; + +PROCEDURE exp* (x: REAL): REAL; + (* Returns the exponential of x for x < Ln(MAX(REAL)) *) + CONST + ln2 = 0.6931471805599453094172321D0; + P0 = 0.24999999950E+0; P1 = 0.41602886268E-2; Q1 = 0.49987178778E-1; + VAR xn, g, p, q, z: REAL; n: LONGINT; +BEGIN + (* Ensure we detect overflows and return 0 for underflows *) + IF x >= LnInfinity THEN ErrorHandler(Overflow); RETURN large + ELSIF x < LnSmall THEN ErrorHandler(Underflow); RETURN ZERO + ELSIF ABS(x) < eps THEN RETURN ONE + END; + + (* Decompose and scale the number *) + n := round(ln2Inv * x); + xn := n; g := SHORT(LONG(x) - LONG(xn) * ln2); + + (* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *) + z := g * g; p := (P1 * z + P0) * g; q := Q1 * z + HALF; + RETURN scale(HALF + p/(q - p), SHORT(n + 1)) +END exp; + +PROCEDURE ln* (x: REAL): REAL; + (* Returns the natural logarithm of x for x > 0 *) + CONST + c1 = 355.0/512.0; c2 = -2.121944400546905827679E-4; + A0 = -0.5527074855E+0; B0 = -0.6632718214E+1; + VAR f, zn, zd, r, z, w, xn: REAL; n: INTEGER; +BEGIN + (* ensure illegal inputs are trapped and handled *) + IF x <= ZERO THEN ErrorHandler(IllegalLog); RETURN -large END; + + (* reduce the range of the input *) + f := fraction(x) * HALF; n := exponent(x) + 1; + IF f > sqrtHalf THEN zn := (f - HALF) - HALF; zd := f * HALF + HALF + ELSE zn := f - HALF; zd := zn * HALF + HALF; DEC(n) + END; + + (* evaluate rational approximation from "Software Manual for the Elementary Functions" *) + z := zn/zd; w := z * z; r := z + z * (w * A0/(w + B0)); + + (* scale the output *) + xn := n; + RETURN (xn * c2 + r) + xn * c1 +END ln; + +(* The angle in all trigonometric functions is measured in radians *) + +PROCEDURE sin* (x: REAL): REAL; + (* Returns the sine of x for all x *) +BEGIN + IF x < ZERO THEN RETURN SinCos(x, -x, -ONE) + ELSE RETURN SinCos(x, x, ONE) + END +END sin; + +PROCEDURE cos* (x: REAL): REAL; + (* Returns the cosine of x for all x *) +BEGIN + RETURN SinCos(x, ABS(x) + piByTwo, ONE) +END cos; + +PROCEDURE tan* (x: REAL): REAL; + (* Returns the tangent of x where x cannot be an odd multiple of pi/2 *) +CONST + ymax = 6434; (* ENTIER(2 * *(MantBits/2) * pi/2) *) + twoByPi = 0.63661977236758134308; + P1 = -0.958017723E-1; Q1 = -0.429135777E+0; Q2 = 0.971685835E-2; +VAR + n: LONGINT; + y, xn, f, xnum, xden, g: REAL; +BEGIN + (* check for error limits *) + y := ABS(x); + IF y > ymax THEN ErrorHandler(LossOfAccuracy); RETURN ZERO END; + + (* determine n and the fraction f *) + n := round(x * twoByPi); xn := n; + f := SHORT(LONG(x) - LONG(xn) * piByTwo); + + (* check for underflow *) + IF ABS(f) < Limit THEN xnum := f; xden := ONE + ELSE g := f * f; xnum := P1 * g*f + f; xden := (Q2 * g + Q1) * g + HALF + HALF + END; + + (* find the final result *) + IF ODD(n) THEN RETURN xden/( - xnum) + ELSE RETURN xnum/xden + END +END tan; + +PROCEDURE asincos (x: REAL; flag: LONGINT; VAR i: LONGINT; VAR res: REAL); +CONST + P1 = 0.933935835E+0; P2 = -0.504400557E+0; + Q0 = 0.560363004E+1; Q1 = -0.554846723E+1; +VAR + y, g, r: REAL; +BEGIN + y := ABS(x); + IF y > HALF THEN + i := 1 - flag; + IF y > ONE THEN ErrorHandler(IllegalInvTrig); res := large; RETURN END; + + (* reduce the input argument *) + g := (ONE-y) * HALF; r := -sqrt(g); y := r + r; + + (* compute approximation *) + r := ((P2 * g + P1) * g)/((g + Q1) * g + Q0); + res := y + (y * r) + ELSE + i := flag; + IF y < Limit THEN res := y + ELSE + g := y * y; + + (* compute approximation *) + g := ((P2 * g + P1) * g)/((g + Q1) * g + Q0); + res := y + y * g + END + END +END asincos; + +PROCEDURE arcsin* (x: REAL): REAL; + (* Returns the arcsine of x, in the range [ - pi/2, pi/2] where -1 <= x <= 1 *) +VAR + res: REAL; i: LONGINT; +BEGIN + asincos(x, 0, i, res); + IF err # 0 THEN RETURN res END; + + (* adjust result for the correct quadrant *) + IF i = 1 THEN res := piByFour + (piByFour + res) END; + IF x < 0 THEN res := -res END; + RETURN res +END arcsin; + +PROCEDURE arccos* (x: REAL): REAL; + (* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *) +VAR + res: REAL; i: LONGINT; +BEGIN + asincos(x, 1, i, res); + IF err # 0 THEN RETURN res END; + + (* adjust result for the correct quadrant *) + IF x < 0 THEN + IF i = 0 THEN res := piByTwo + (piByTwo + res) + ELSE res := piByFour + (piByFour + res) + END + ELSE + IF i = 1 THEN res := piByFour + (piByFour - res) + ELSE res := -res + END; + END; + RETURN res +END arccos; + +PROCEDURE atan(f: REAL): REAL; +(* internal arctan algorithm *) +CONST + rt32 = 0.26794919243112270647; + rt3 = 1.73205080756887729353; + a = rt3 - ONE; + P0 = -0.4708325141E+0; P1 = -0.5090958253E-1; Q0 = 0.1412500740E+1; + piByThree = 1.04719755119659774615; + piBySix = 0.52359877559829887308; +VAR + n: LONGINT; res, g: REAL; +BEGIN + IF f > ONE THEN f := ONE/f; n := 2 + ELSE n := 0 + END; + + (* check if f should be scaled *) + IF f > rt32 THEN f := (((a * f - HALF) - HALF) + f)/(rt3 + f); INC(n) END; + + (* check for underflow *) + IF ABS(f) < Limit THEN res := f + ELSE + g := f * f; res := (P1 * g + P0) * g/(g + Q0); res := f + f * res + END; + IF n > 1 THEN res := -res END; + CASE n OF + | 1: res := res + piBySix + | 2: res := res + piByTwo + | 3: res := res + piByThree + | ELSE (* do nothing *) + END; + RETURN res +END atan; + +PROCEDURE arctan* (x: REAL): REAL; + (* Returns the arctangent of x, in the range [ - pi/2, pi/2] for all x *) +BEGIN + IF x < 0 THEN RETURN -atan( - x) + ELSE RETURN atan(x) + END +END arctan; + +PROCEDURE power* (base, exp: REAL): REAL; + (* Returns the value of the number base raised to the power exponent + for base > 0 *) + CONST P1 = 0.83357541E-1; K = 0.4426950409; + Q1 = 0.69314675; Q2 = 0.24018510; Q3 = 0.54360383E-1; + OneOver16 = 0.0625; + XMAX = 16 * (expoMax + 1) - 1; + (* XMIN = 16 * expoMin; *) XMIN = -2016; (* to make it easier for voc; -- noch *) + VAR z, g, R, v, u2, u1, w1, w2: REAL; w: LONGREAL; + m, p, i: INTEGER; mp, pp, iw1: LONGINT; +BEGIN + (* handle all possible error conditions *) + IF base <= ZERO THEN + IF base # ZERO THEN ErrorHandler(IllegalPower); base := -base + ELSIF exp > ZERO THEN RETURN ZERO + ELSE ErrorHandler(IllegalPower); RETURN large + END + END; + + (* extract the exponent of base to m and clear exponent of base in g *) + g := fraction(base) * HALF; + m := exponent(base) + 1; + + (* determine p table offset with an unrolled binary search *) + p := 1; + IF g <= a1[9] THEN p := 9 END; + IF g <= a1[p + 4] THEN INC(p, 4) END; + IF g <= a1[p + 2] THEN INC(p, 2) END; + + (* compute scaled z so that |z| <= 0.044 *) + z := ((g - a1[p + 1]) - a2[(p + 1) DIV 2])/(g + a1[p + 1]); z := z + z; + + (* approximation for log2(z) from "Software Manual for the Elementary Functions" *) + v := z * z; R := P1 * v*z; R := R + K * R; u2 := (R + z * K) + z; + u1 := (m * 16 - p) * OneOver16; w := LONG(exp) * (LONG(u1) + LONG(u2)); (* need extra precision *) + + (* calculations below were modified to work properly -- incorrect in cited reference? *) + iw1 := ENTIER(16 * w); w1 := iw1 * OneOver16; w2 := SHORT(w - w1); + + (* check for overflow/underflow *) + IF iw1 > XMAX THEN ErrorHandler(Overflow); RETURN large + ELSIF iw1 < XMIN THEN ErrorHandler(Underflow); RETURN ZERO + END; + + (* final approximation 2 * *w2 - 1 where -0.0625 <= w2 <= 0 *) + IF w2 > ZERO THEN INC(iw1); w2 := w2 - OneOver16 END; + IF iw1 < 0 THEN i := 0 ELSE i := 1 END; + mp := div(iw1, 16) + i; pp := 16 * mp - iw1; + z := ((Q3 * w2 + Q2) * w2 + Q1) * w2; + z := a1[pp + 1] + a1[pp + 1] * z; + RETURN scale(z, SHORT(mp)) +END power; + +PROCEDURE IsRMathException* (): BOOLEAN; + (* Returns TRUE if the current coroutine is in the exceptional execution state + because of the raising of the RealMath exception; otherwise returns FALSE. + *) +BEGIN + RETURN FALSE +END IsRMathException; + + +(* + Following routines are provided as extensions to the ISO standard. + They are either used as the basis of other functions or provide + useful functions which are not part of the ISO standard. + *) + +PROCEDURE log* (x, base: REAL): REAL; +(* log(x,base) is the logarithm of x base 'base'. All positive arguments are + allowed but base > 0 and base # 1 *) +BEGIN + (* log(x, base) = ln(x) / ln(base) *) + IF base <= ZERO THEN ErrorHandler(IllegalLogBase); RETURN -large + ELSE RETURN ln(x)/ln(base) + END +END log; + +PROCEDURE ipower* (x: REAL; base: INTEGER): REAL; +(* ipower(x, base) returns the x to the integer power base where Log2(x) < expoMax *) + VAR Exp: INTEGER; y: REAL; neg: BOOLEAN; + + PROCEDURE Adjust(xadj: REAL): REAL; + BEGIN + IF (x < ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END + END Adjust; + +BEGIN + (* handle all possible error conditions *) + IF base = 0 THEN RETURN ONE (* x * *0 = 1 *) + ELSIF ABS(x) < miny THEN + IF base > 0 THEN RETURN ZERO ELSE ErrorHandler(Overflow); RETURN Adjust(large) END + END; + + (* trap potential overflows and underflows *) + Exp := (exponent(x) + 1) * base; y := LnInfinity * ln2Inv; + IF Exp > y THEN ErrorHandler(Overflow); RETURN Adjust(large) + ELSIF Exp< - y THEN RETURN ZERO + END; + + (* compute x * *base using an optimised algorithm from Knuth, slightly + altered : p442, The Art Of Computer Programming, Vol 2 *) + y := ONE; IF base < 0 THEN neg := TRUE; base := -base ELSE neg:= FALSE END; + LOOP + IF ODD(base) THEN y := y * x END; + base := base DIV 2; IF base = 0 THEN EXIT END; + x := x * x; + END; + IF neg THEN RETURN ONE/y ELSE RETURN y END +END ipower; + +PROCEDURE sincos* (x: REAL; VAR Sin, Cos: REAL); +(* More efficient sin/cos implementation if both values are needed. *) +BEGIN + Sin := sin(x); Cos := sqrt(ONE-Sin * Sin) +END sincos; + +PROCEDURE arctan2* (xn, xd: REAL): REAL; +(* arctan2(xn,xd) is the quadrant - correct arc tangent atan(xn/xd). If the + denominator xd is zero, then the numerator xn must not be zero. All + arguments are legal except xn = xd = 0. *) +VAR + res: REAL; xpdiff: LONGINT; +BEGIN + (* check for error conditions *) + IF xd = ZERO THEN + IF xn = ZERO THEN ErrorHandler(IllegalTrig); RETURN ZERO + ELSIF xn < 0 THEN RETURN -piByTwo + ELSE RETURN piByTwo + END; + ELSE + xpdiff := exponent(xn) - exponent(xd); + IF ABS(xpdiff) >= expoMax - 3 THEN + (* overflow detected *) + IF xn < 0 THEN RETURN -piByTwo + ELSE RETURN piByTwo + END + ELSE + res := ABS(xn/xd); + IF res # ZERO THEN res := atan(res) END; + IF xd < ZERO THEN res := pi - res END; + IF xn < ZERO THEN RETURN -res + ELSE RETURN res + END + END + END +END arctan2; + +PROCEDURE sinh* (x: REAL): REAL; +(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large + that exp(|x|) overflows. *) + CONST P0 = -7.13793159; P1 = -0.190333399; Q0 = -42.8277109; + VAR y, f: REAL; +BEGIN y := ABS(x); + IF y <= ONE THEN (* handle small arguments *) + IF y < Limit THEN RETURN x END; + + (* use approximation from "Software Manual for the Elementary Functions" *) + f := y * y; y := f * ((f * P1 + P0)/(f + Q0)); RETURN x + x * y + ELSIF y > LnInfinity THEN (* handle exp overflows *) + y := y - lnv; + IF y > LnInfinity - lnv + 0.69 THEN ErrorHandler(Overflow); + IF x > ZERO THEN RETURN large ELSE RETURN -large END + ELSE f := exp(y); f := f + f * vbytwo (* don't change to f(1 + vbytwo) *) + END + ELSE f := exp(y); f := (f - ONE/f) * HALF + END; + + (* reach here when 1 < ABS(x) < LnInfinity - lnv + 0.69 *) + IF x > ZERO THEN RETURN f ELSE RETURN -f END +END sinh; + +PROCEDURE cosh* (x: REAL): REAL; +(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large + that exp(|x|) overflows. *) + VAR y, f: REAL; +BEGIN y := ABS(x); + IF y > LnInfinity THEN (* handle exp overflows *) + y := y - lnv; + IF y > LnInfinity - lnv + 0.69 THEN ErrorHandler(Overflow); + IF x > ZERO THEN RETURN large ELSE RETURN -large END + ELSE f := exp(y); RETURN f + f * vbytwo (* don't change to f(1 + vbytwo) *) + END + ELSE f := exp(y); RETURN (f + ONE/f) * HALF + END +END cosh; + +PROCEDURE tanh* (x: REAL): REAL; +(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *) + CONST P0 = -0.8237728127; P1 = -0.3831010665E-2; Q0 = 2.471319654; ln3over2 = 0.5493061443; + BIG = 9.010913347; (* (ln(2) + (t + 1) * ln(B))/2 where t = mantissa bits, B = base *) + VAR f, t: REAL; +BEGIN f := ABS(x); + IF f > BIG THEN t := ONE + ELSIF f > ln3over2 THEN t := ONE - TWO/(exp(TWO * f) + ONE) + ELSIF f < Limit THEN t := f + ELSE (* approximation from "Software Manual for the Elementary Functions" *) + t := f * f; t := t * (P1 * t + P0)/(t + Q0); t := f + f * t + END; + IF x < ZERO THEN RETURN -t ELSE RETURN t END +END tanh; + +PROCEDURE arcsinh* (x: REAL): REAL; +(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *) +BEGIN + IF ABS(x) > SqrtInfinity * HALF THEN ErrorHandler(HypInvTrigClipped); + IF x > ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END; + ELSIF x < ZERO THEN RETURN -ln( - x + sqrt(x * x + ONE)) + ELSE RETURN ln(x + sqrt(x * x + ONE)) + END +END arcsinh; + +PROCEDURE arccosh* (x: REAL): REAL; +(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than + or equal to 1 are legal. *) +BEGIN + IF x < ONE THEN ErrorHandler(IllegalHypInvTrig); RETURN ZERO + ELSIF x > SqrtInfinity * HALF THEN ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity) + ELSE RETURN ln(x + sqrt(x * x - ONE)) + END +END arccosh; + +PROCEDURE arctanh* (x: REAL): REAL; +(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where + em is machine epsilon. Note that |x| must not be so close to 1 that the + result is less accurate than half precision. *) + CONST TanhLimit = 0.999984991; (* Tanh(5.9) *) + VAR t: REAL; +BEGIN t := ABS(x); + IF (t >= ONE) OR (t > (ONE - TWO * em)) THEN ErrorHandler(IllegalHypInvTrig); + IF x < ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END + ELSIF t > TanhLimit THEN ErrorHandler(LossOfAccuracy) + END; + RETURN arcsinh(x/sqrt(ONE - x * x)) +END arctanh; + +PROCEDURE fcmp* (x, y, epsilon: REAL): INTEGER; +(* fcmp: this procedure determines whether `x` and `y` are approximately equal + to a relative accuracy `epsilon`. + References: + The implementation is based on the GNU Scientific Library (GSL). + https://www.gnu.org/software/gsl/doc/html/math.html#approximate-comparison-of-floating-point-numbers +*) +VAR max, exponent0, delta, difference: REAL; +BEGIN + IF ABS(x) > ABS(y) THEN + max := x; + ELSE + max := y; + END; + exponent0 := exponent(max); + delta := 2.0*epsilon*power(2.0, exponent0); + difference := x - y; + IF difference > delta THEN + RETURN 1; + ELSIF difference < -delta THEN + RETURN -1; + ELSE + RETURN 0; (* approximately equal *) + END; +END fcmp; + +PROCEDURE ToREAL(h: HUGEINT): REAL; +BEGIN RETURN SYSTEM.VAL(REAL, h) +END ToREAL; + +BEGIN + ErrorHandler := DefaultErrorHandler; + + (* determine fundamental constants used by hyperbolic trig functions *) + em := ulp(ONE); + LnInfinity := ln(large); + LnSmall := ln(miny); + SqrtInfinity := sqrt(large); + t := pred(ONE)/sqrt(em); + TanhMax := ln(t + sqrt(t * t + ONE)); + + (* initialize tables for the power() function a1[i] = 2 * *((1 - i)/16) *) + a1[1] := ONE; + a1[2] := ToREAL(3F75257DH); + a1[3] := ToREAL(3F6AC0C7H); + a1[4] := ToREAL(3F60CCDFH); + a1[5] := ToREAL(3F5744FDH); + a1[6] := ToREAL(3F4E248CH); + a1[7] := ToREAL(3F45672AH); + a1[8] := ToREAL(3F3D08A4H); + a1[9] := ToREAL(3F3504F3H); + a1[10] := ToREAL(3F2D583FH); + a1[11] := ToREAL(3F25FED7H); + a1[12] := ToREAL(3F1EF532H); + a1[13] := ToREAL(3F1837F0H); + a1[14] := ToREAL(3F11C3D3H); + a1[15] := ToREAL(3F0B95C2H); + a1[16] := ToREAL(3F05AAC3H); + a1[17] := HALF; + + (* a2[i] = 2 * *[(1 - 2i)/16] - a1[2i]; delta resolution *) + a2[1] := ToREAL(31A92436H); + a2[2] := ToREAL(336C2A95H); + a2[3] := ToREAL(31A8FC24H); + a2[4] := ToREAL(331F580CH); + a2[5] := ToREAL(336A42A1H); + a2[6] := ToREAL(32C12342H); + a2[7] := ToREAL(32E75624H); + a2[8] := ToREAL(32CF9890H) +END Math. diff --git a/src/runtime/MathL.Mod b/src/runtime/MathL.Mod new file mode 100644 index 00000000..b1448dc0 --- /dev/null +++ b/src/runtime/MathL.Mod @@ -0,0 +1,748 @@ +MODULE MathL; + +(* MathL - Oakwood LONGREAL Mathematics. + Adapted from OOC LowLReal.Mod and LRealMath.Mod + + Target independent mathematical functions for LONGREAL + (IEEE double-precision) numbers. + + Numerical approximations are taken from "Software Manual for the + Elementary Functions" by Cody & Waite and "Computer Approximations" + by Hart et al. + + Copyright (C) 1996-1998 Michael Griebling + + 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 this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*) +(* + Real number properties are defined as follows: + + radix--The whole number value of the radix used to represent the + corresponding read number values. + + places--The whole number value of the number of radix places used + to store values of the corresponding real number type. + + expoMin--The whole number value of the exponent minimum. + + expoMax--The whole number value of the exponent maximum. + + large--The largest value of the corresponding real number type. + + small--The smallest positive value of the corresponding real number + type, represented to maximal precision. + + IEC559--A Boolean value that is TRUE if and only if the implementation + of the corresponding real number type conforms to IEC 559:1989 + (IEEE 754:1987) in all regards. + + NOTES + 6 -- If `IEC559' is TRUE, the value of `radix' is 2. + 7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989 + is used for the type REAL. + 7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989 + is used for the type REAL. + + LIA1--A Boolean value that is TRUE if and only if the implementation of + the corresponding real number type conforms to ISO/IEC 10967-1:199x + (LIA-1) in all regards: parameters, arithmetic, exceptions, and + notification. + + rounds--A Boolean value that is TRUE if and only if each operation produces + a result that is one of the values of the corresponding real number + type nearest to the mathematical result. + + gUnderflow--A Boolean value that is TRUE if and only if there are values of + the corresponding real number type between 0.0 and `small'. + + exception--A Boolean value that is TRUE if and only if every operation that + attempts to produce a real value out of range raises an exception. + + extend--A Boolean value that is TRUE if and only if expressions of the + corresponding real number type are computed to higher precision than + the stored values. + + nModes--The whole number value giving the number of bit positions needed for + the status flags for mode control. +*) + +IMPORT Math, SYSTEM; + +CONST + pi* = 3.1415926535897932384626433832795028841972D0; + e* = 2.7182818284590452353602874713526624977572D0; + + places* = 53; + large* = MAX(LONGREAL); (*1.7976931348623157D+308;*) (* MAX(LONGREAL) *) +(*small* = 2.2250738585072014D-308; *) + small* = 2.2250738585072014/9.9999999999999981D307(*/10^308)*); + expoMax* = 1023; + expoMin* = 1-expoMax; + expOffset = expoMax; + + ZERO = 0.0D0; + ONE = 1.0D0; + HALF = 0.5D0; + TWO = 2.0D0; + miny = ONE/large; (* Smallest number this package accepts *) + sqrtHalf = 0.70710678118654752440D0; + Limit = 1.0536712D-8; (* 2**(-MantBits/2) *) + eps = 5.5511151D-17; (* 2**(-MantBits-1) *) + piInv = 0.31830988618379067154D0; (* 1/pi *) + piByTwo = 1.57079632679489661923D0; + lnv = 0.6931610107421875D0; (* should be exact *) + vbytwo = 0.13830277879601902638D-4; (* used in sinh/cosh *) + ln2Inv = 1.44269504088896340735992468100189213D0; + +VAR + a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *) + a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *) + em: LONGREAL; (* largest number such that 1 + epsilon > 1.0 *) + LnInfinity: LONGREAL; (* natural log of infinity *) + LnSmall: LONGREAL; (* natural log of very small number *) + SqrtInfinity: LONGREAL; (* square root of infinity *) + TanhMax: LONGREAL; (* maximum Tanh value *) + NumberMask: SYSTEM.SET64; (* Sign and significand, {0..51, 63} *) + ExponentMask: SYSTEM.SET64; (* Exponent part, {53..62} *) + ZeroExponent: SYSTEM.SET64; (* Zero valued exponent {54..61} *) + t: LONGREAL; (* internal variables *) + i: INTEGER; (* For initialisation loops in module body. *) + + + + +(* TYPE LONGREAL: 1/sign, 11/exponent, 52/significand *) + +PROCEDURE fraction*(x: LONGREAL): LONGREAL; +(* + The value of the call fraction(x) shall be the significand (or + significant) part of `x'. Hence the following relationship shall + hold: x = scale(fraction(x), exponent(x)). +*) + VAR s: SYSTEM.SET64; +BEGIN + IF x = ZERO THEN RETURN ZERO + ELSE + s := SYSTEM.VAL(SYSTEM.SET64, x) * NumberMask + ZeroExponent; + RETURN SYSTEM.VAL(LONGREAL, s) * 2.0; + END +END fraction; + +PROCEDURE exponent*(x: LONGREAL): INTEGER; +(* + The value of the call exponent(x) shall be the exponent value of `x' + that lies between `expoMin' and `expoMax'. An exception shall occur + and may be raised if `x' is equal to 0.0. +*) + VAR i: SYSTEM.INT64; +BEGIN + IF x = ZERO THEN RETURN 0 (* NOTE: x=0.0 should raise exception *) + ELSE + i := SYSTEM.LSH(SYSTEM.VAL(SYSTEM.INT64, x), -52) MOD 2048; + RETURN SYSTEM.VAL(INTEGER, i) - 1023 + END +END exponent; + +PROCEDURE sign*(x: LONGREAL): LONGREAL; +(* + The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0, + or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or + -1.0 if `x' is equal to 0.0. +*) +BEGIN + IF x < ZERO THEN RETURN -ONE ELSE RETURN ONE END +END sign; + +PROCEDURE scale*(x: LONGREAL; n: INTEGER): LONGREAL; +(* + The value of the call scale(x,n) shall be the value x*radix^n if such + a value exists; otherwise an execption shall occur and may be raised. +*) + VAR exp: HUGEINT; lexp: SYSTEM.SET64; +BEGIN + IF x = ZERO THEN RETURN ZERO END; + exp := exponent(x) + n; (* new exponent *) + IF exp > expoMax THEN RETURN large * sign(x) (* exception raised here *) + ELSIF exp < expoMin THEN RETURN small * sign(x) (* exception here as well *) + END; + lexp := SYSTEM.VAL(SYSTEM.SET64, x) * NumberMask (* sign and significand *) + + SYSTEM.VAL(SYSTEM.SET64, SYSTEM.LSH(exp + expOffset, 52)); (* shifted exponent bits *) + RETURN SYSTEM.VAL(LONGREAL, lexp) +END scale; + +PROCEDURE ulp*(x: LONGREAL): LONGREAL; +(* + The value of the call ulp(x) shall be the value of the corresponding + real number type equal to a unit in the last place of `x', if such a + value exists; otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN scale(ONE, exponent(x)-places+1) +END ulp; + +PROCEDURE succ*(x: LONGREAL): LONGREAL; +(* + The value of the call succ(x) shall be the next value of the + corresponding real number type greater than `x', if such a type + exists; otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN x+ulp(x)*sign(x) +END succ; + +PROCEDURE pred*(x: LONGREAL): LONGREAL; +(* + The value of the call pred(x) shall be the next value of the + corresponding real number type less than `x', if such a type exists; + otherwise an exception shall occur and may be raised. +*) +BEGIN + RETURN x-ulp(x)*sign(x) +END pred; + + +PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL; + CONST + ymax = 210828714; (* ENTIER(pi*2**(MantBits/2)) *) + c1 = 3.1416015625D0; + c2 = -8.908910206761537356617D-6; + r1 = -0.16666666666666665052D+0; + r2 = 0.83333333333331650314D-2; + r3 = -0.19841269841201840457D-3; + r4 = 0.27557319210152756119D-5; + r5 = -0.25052106798274584544D-7; + r6 = 0.16058936490371589114D-9; + r7 = -0.76429178068910467734D-12; + r8 = 0.27204790957888846175D-14; + VAR + n: LONGINT; xn, f, x1, g: LONGREAL; +BEGIN + IF y >= ymax THEN Math.ErrorHandler(Math.LossOfAccuracy); RETURN ZERO END; + + (* determine the reduced number *) + n := ENTIER(y*piInv + HALF); xn := n; + IF ODD(n) THEN sign := -sign END; + x := ABS(x); + IF x # y THEN xn := xn-HALF END; + + (* fractional part of reduced number *) + x1 := ENTIER(x); + f := ((x1-xn*c1) + (x-x1))-xn*c2; + + (* Pre: |f| <= pi/2 *) + IF ABS(f) < Limit THEN RETURN sign*f END; + + (* evaluate polynomial approximation of sin *) + g := f*f; g := (((((((r8*g + r7)*g + r6)*g + r5)*g + r4)*g + r3)*g + r2)*g + r1)*g; + g := f + f*g; (* don't use less accurate f(1 + g) *) + RETURN sign*g +END SinCos; + +PROCEDURE div (x, y : LONGINT) : LONGINT; +(* corrected MOD function *) +BEGIN + IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END +END div; + + +(* forward declarations *) +PROCEDURE^ arctan2* (xn, xd: LONGREAL): LONGREAL; +PROCEDURE^ sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL); + +PROCEDURE sqrt*(x: LONGREAL): LONGREAL; + (* Returns the positive square root of x where x >= 0 *) + CONST + P0=0.41731; P1=0.59016; + VAR + xMant, yEst, z: LONGREAL; xExp: INTEGER; +BEGIN + (* optimize zeros and check for illegal negative roots *) + IF x=ZERO THEN RETURN ZERO END; + IF x < ZERO THEN Math.ErrorHandler(Math.IllegalRoot); x := -x END; + + (* reduce the input number to the range 0.5 <= x <= 1.0 *) + xMant := fraction(x)*HALF; xExp := exponent(x) + 1; + + (* initial estimate of the square root *) + yEst := P0 + P1*xMant; + + (* perform three newtonian iterations *) + z := (yEst + xMant/yEst); yEst := 0.25*z + xMant/z; + yEst := HALF*(yEst + xMant/yEst); + + (* adjust for odd exponents *) + IF ODD(xExp) THEN yEst := yEst*sqrtHalf; INC(xExp) END; + + (* single Newtonian iteration to produce real number accuracy *) + RETURN scale(yEst, xExp DIV 2) +END sqrt; + +PROCEDURE exp*(x: LONGREAL): LONGREAL; + (* Returns the exponential of x for x < Ln(MAX(REAL) *) + CONST + c1 = 0.693359375D0; + c2 = -2.1219444005469058277D-4; + P0 = 0.249999999999999993D+0; + P1 = 0.694360001511792852D-2; + P2 = 0.165203300268279130D-4; + Q1 = 0.555538666969001188D-1; + Q2 = 0.495862884905441294D-3; + VAR xn, g, p, q, z: LONGREAL; n: INTEGER; +BEGIN + (* Ensure we detect overflows and return 0 for underflows *) + IF x > LnInfinity THEN Math.ErrorHandler(Math.Overflow); RETURN large + ELSIF x < LnSmall THEN RETURN ZERO + ELSIF ABS(x) < eps THEN RETURN ONE + END; + + (* Decompose and scale the number *) + IF x >= ZERO THEN n := SHORT(ENTIER(ln2Inv*x + HALF)) + ELSE n := SHORT(ENTIER(ln2Inv*x-HALF)) + END; + xn := n; g := (x-xn*c1)-xn*c2; + + (* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *) + z := g*g; p := ((P2*z + P1)*z + P0)*g; q := (Q2*z + Q1)*z + HALF; + RETURN scale(HALF + p/(q-p), n + 1) +END exp; + +PROCEDURE ln*(x: LONGREAL): LONGREAL; + (* Returns the natural logarithm of x for x > 0 *) + CONST + c1=355.0D0/512.0D0; c2=-2.121944400546905827679D-4; + P0=-0.64124943423745581147D+2; P1=0.16383943563021534222D+2; P2=-0.78956112887491257267D+0; + Q0=-0.76949932108494879777D+3; Q1=0.31203222091924532844D+3; Q2=-0.35667977739034646171D+2; + VAR f, zn, zd, r, z, w, p, q, xn: LONGREAL; n: INTEGER; +BEGIN + (* ensure illegal inputs are trapped and handled *) + IF x <= ZERO THEN Math.ErrorHandler(Math.IllegalLog); RETURN -large END; + + (* reduce the range of the input *) + f := fraction(x)*HALF; n := exponent(x) + 1; + IF f > sqrtHalf THEN zn := (f-HALF)-HALF; zd := f*HALF + HALF + ELSE zn := f-HALF; zd := zn*HALF + HALF; DEC(n) + END; + + (* evaluate rational approximation from "Software Manual for the Elementary Functions" *) + z := zn/zd; w := z*z; q := ((w + Q2)*w + Q1)*w + Q0; p := w*((P2*w + P1)*w + P0); r := z + z*(p/q); + + (* scale the output *) + xn := n; + RETURN (xn*c2 + r) + xn*c1 +END ln; + + +(* The angle in all trigonometric functions is measured in radians *) + +PROCEDURE sin* (x: LONGREAL): LONGREAL; +BEGIN + IF x < ZERO THEN RETURN SinCos(x, -x, -ONE) + ELSE RETURN SinCos(x, x, ONE) + END +END sin; + +PROCEDURE cos* (x: LONGREAL): LONGREAL; +BEGIN + RETURN SinCos(x, ABS(x) + piByTwo, ONE) +END cos; + +PROCEDURE tan*(x: LONGREAL): LONGREAL; + (* Returns the tangent of x where x cannot be an odd multiple of pi/2 *) + VAR Sin, Cos: LONGREAL; +BEGIN + sincos(x, Sin, Cos); + IF ABS(Cos) < miny THEN Math.ErrorHandler(Math.IllegalTrig); RETURN large + ELSE RETURN Sin/Cos + END +END tan; + +PROCEDURE arcsin*(x: LONGREAL): LONGREAL; + (* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *) +BEGIN + IF ABS(x) > ONE THEN Math.ErrorHandler(Math.IllegalInvTrig); RETURN large + ELSE RETURN arctan2(x, sqrt(ONE-x*x)) + END +END arcsin; + +PROCEDURE arccos*(x: LONGREAL): LONGREAL; + (* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *) +BEGIN + IF ABS(x) > ONE THEN Math.ErrorHandler(Math.IllegalInvTrig); RETURN large + ELSE RETURN arctan2(sqrt(ONE-x*x), x) + END +END arccos; + +PROCEDURE arctan*(x: LONGREAL): LONGREAL; + (* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *) +BEGIN + RETURN arctan2(x, ONE) +END arctan; + +PROCEDURE power*(base, exp: LONGREAL): LONGREAL; + (* Returns the value of the number base raised to the power exponent + for base > 0 *) + CONST + P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1; + P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3; + K=0.44269504088896340736D0; + Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0; + Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2; + Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3; + Q7=0.14928852680595608186D-4; + OneOver16 = 0.0625D0; + XMAX = 16*expoMax - 1; (*XMIN=16*l.expoMin + 1;*) + XMIN = -16351; (* noch *) + VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT; +BEGIN + (* handle all possible error conditions *) + IF ABS(exp) < miny THEN RETURN ONE (* base**0 = 1 *) + ELSIF base < ZERO THEN Math.ErrorHandler(Math.IllegalPower); RETURN -large + ELSIF ABS(base) < miny THEN + IF exp > ZERO THEN RETURN ZERO ELSE Math.ErrorHandler(Math.Overflow); RETURN -large END + END; + + (* extract the exponent of base to m and clear exponent of base in g *) + g := fraction(base)*HALF; m := exponent(base) + 1; + + (* determine p table offset with an unrolled binary search *) + p := 1; + IF g <= a1[9] THEN p := 9 END; + IF g <= a1[p + 4] THEN INC(p, 4) END; + IF g <= a1[p + 2] THEN INC(p, 2) END; + + (* compute scaled z so that |z| <= 0.044 *) + z := ((g-a1[p + 1])-a2[(p + 1) DIV 2])/(g + a1[p + 1]); z := z + z; + + (* approximation for log2(z) from "Software Manual for the Elementary Functions" *) + v := z*z; R := (((P4*v + P3)*v + P2)*v + P1)*v*z; R := R + K*R; u2 := (R + z*K) + z; u1 := (m*16-p)*OneOver16; + + (* generate w with extra precision calculations *) + y1 := ENTIER(16*exp)*OneOver16; y2 := exp-y1; w := u2*exp + u1*y2; + w1 := ENTIER(16*w)*OneOver16; w2 := w-w1; w := w1 + u1*y1; + w1 := ENTIER(16*w)*OneOver16; w2 := w2 + (w-w1); w := ENTIER(16*w2)*OneOver16; + iw1 := ENTIER(16*(w + w1)); w2 := w2-w; + + (* check for overflow/underflow *) + IF iw1 > XMAX THEN Math.ErrorHandler(Math.Overflow); RETURN large + ELSIF iw1 < XMIN THEN RETURN ZERO (* underflow *) + END; + + (* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *) + IF w2 > ZERO THEN INC(iw1); w2 := w2-OneOver16 END; IF iw1 < 0 THEN i := 0 ELSE i := 1 END; + mp := div(iw1, 16) + i; pp := 16*mp-iw1; + z := ((((((Q7*w2 + Q6)*w2 + Q5)*w2 + Q4)*w2 + Q3)*w2 + Q2)*w2 + Q1)*w2; z := a1[pp + 1] + a1[pp + 1]*z; + RETURN scale(z, SHORT(mp)) +END power; + +PROCEDURE round*(x: LONGREAL): LONGINT; + (* Returns the value of x rounded to the nearest integer *) +BEGIN + IF x < ZERO THEN RETURN -ENTIER(HALF-x) + ELSE RETURN ENTIER(x + HALF) + END +END round; + +PROCEDURE IsRMathException*(): BOOLEAN; + (* Returns TRUE if the current coroutine is in the exceptional execution state + because of the raising of the RealMath exception; otherwise returns FALSE. + *) +BEGIN + RETURN FALSE +END IsRMathException; + + +(* + Following routines are provided as extensions to the ISO standard. + They are either used as the basis of other functions or provide + useful functions which are not part of the ISO standard. +*) + +PROCEDURE log* (x, base: LONGREAL): LONGREAL; +(* log(x,base) is the logarithm of x base b. All positive arguments are + allowed but base > 0 and base # 1. *) +BEGIN + (* log(x, base) = log2(x) / log2(base) *) + IF base <= ZERO THEN Math.ErrorHandler(Math.IllegalLogBase); RETURN -large + ELSE RETURN ln(x)/ln(base) + END +END log; + +PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; +(* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *) + VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT; + + PROCEDURE Adjust(xadj: LONGREAL): LONGREAL; + BEGIN + IF (x < ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END + END Adjust; + +BEGIN + (* handle all possible error conditions *) + IF base=0 THEN RETURN ONE (* x**0 = 1 *) + ELSIF ABS(x) < miny THEN + IF base > 0 THEN RETURN ZERO ELSE Math.ErrorHandler(Math.Overflow); RETURN Adjust(large) END + END; + + (* trap potential overflows and underflows *) + Exp := (exponent(x) + 1)*base; y := LnInfinity*ln2Inv; + IF Exp > y THEN Math.ErrorHandler(Math.Overflow); RETURN Adjust(large) + ELSIF Exp < -y THEN RETURN ZERO + END; + + (* compute x**base using an optimised algorithm from Knuth, slightly + altered : p442, The Art Of Computer Programming, Vol 2 *) + y := ONE; IF base < 0 THEN neg := TRUE; base := -base ELSE neg:= FALSE END; + LOOP + IF ODD(base) THEN y := y*x END; + base := base DIV 2; IF base=0 THEN EXIT END; + x := x*x; + END; + IF neg THEN RETURN ONE/y ELSE RETURN y END +END ipower; + +PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL); +(* More efficient sin/cos implementation if both values are needed. *) +BEGIN + Sin := sin(x); Cos := sqrt(ONE-Sin*Sin) +END sincos; + +PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL; +(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the + denominator xd is zero, then the numerator xn must not be zero. All + arguments are legal except xn = xd = 0. *) + CONST + P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3; + P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2; + Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3; + Q2=0.221050883028417680623D+3; Q3=0.3850148650835119501D+2; + PiOver2=pi/2; Sqrt3=1.7320508075688772935D0; + VAR atan, z, z2, p, q: LONGREAL; xnExp, xdExp: INTEGER; Quadrant: SHORTINT; +BEGIN + IF ABS(xd) < miny THEN + IF ABS(xn) < miny THEN Math.ErrorHandler(Math.IllegalInvTrig); atan := ZERO + ELSE Math.ErrorHandler(Math.Overflow); atan := PiOver2 + END + ELSE xnExp := exponent(xn); xdExp := exponent(xd); + IF xnExp-xdExp >= expoMax-3 THEN Math.ErrorHandler(Math.Overflow); atan := PiOver2 + ELSIF xnExp-xdExp < expoMin + 3 THEN atan := ZERO + ELSE + (* ensure division of xn/xd always produces a number < 1 & resolve quadrant *) + IF ABS(xn) > ABS(xd) THEN z := ABS(xd/xn); Quadrant := 2 + ELSE z := ABS(xn/xd); Quadrant := 0 + END; + + (* further reduce range to within 0 to 2-sqrt(3) *) + IF z > TWO-Sqrt3 THEN z := (z*Sqrt3-ONE)/(Sqrt3 + z); INC(Quadrant) END; + + (* approximation from "Computer Approximations" table ARCTN 5075 *) + IF ABS(z) < Limit THEN atan := z (* for small values of z2, return this value *) + ELSE z2 := z*z; p := (((P3*z2 + P2)*z2 + P1)*z2 + P0)*z; q := (((z2 + Q3)*z2 + Q2)*z2 + Q1)*z2 + Q0; atan := p/q; + END; + + (* adjust for z's quadrant *) + IF Quadrant > 1 THEN atan := -atan END; + CASE Quadrant OF + 1: atan := atan + pi/6 + | 2: atan := atan + PiOver2 + | 3: atan := atan + pi/3 + | ELSE (* angle is correct *) + END + END; + + (* map negative xds into the correct quadrant *) + IF xd < ZERO THEN atan := pi-atan END + END; + + (* map negative xns into the correct quadrant *) + IF xn < ZERO THEN atan := -atan END; + RETURN atan +END arctan2; + +PROCEDURE sinh* (x: LONGREAL): LONGREAL; +(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large + that exp(|x|) overflows. *) + CONST + P0=-0.35181283430177117881D+6; P1=-0.11563521196851768270D+5; + P2=-0.16375798202630751372D+3; P3=-0.78966127417357099479D+0; + Q0=-0.21108770058106271242D+7; Q1= 0.36162723109421836460D+5; + Q2=-0.27773523119650701667D+3; + VAR y, f, p, q: LONGREAL; +BEGIN y := ABS(x); + IF y <= ONE THEN (* handle small arguments *) + IF y < Limit THEN RETURN x END; + + (* use approximation from "Software Manual for the Elementary Functions" *) + f := y*y; p := ((P3*f + P2)*f + P1)*f + P0; q := ((f + Q2)*f + Q1)*f + Q0; y := f*(p/q); RETURN x + x*y + ELSIF y > LnInfinity THEN (* handle exp overflows *) + y := y-lnv; + IF y > LnInfinity-lnv + 0.69 THEN Math.ErrorHandler(Math.Overflow); + IF x > ZERO THEN RETURN large ELSE RETURN -large END + ELSE f := exp(y); f := f + f*vbytwo (* don't change to f(1 + vbytwo) *) + END + ELSE f := exp(y); f := (f-ONE/f)*HALF + END; + + (* reach here when 1 < ABS(x) < LnInfinity-lnv + 0.69 *) + IF x > ZERO THEN RETURN f ELSE RETURN -f END +END sinh; + +PROCEDURE cosh* (x: LONGREAL): LONGREAL; +(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large + that exp(|x|) overflows. *) + VAR y, f: LONGREAL; +BEGIN y := ABS(x); + IF y > LnInfinity THEN (* handle exp overflows *) + y := y-lnv; + IF y > LnInfinity-lnv + 0.69 THEN Math.ErrorHandler(Math.Overflow); + IF x > ZERO THEN RETURN large ELSE RETURN -large END + ELSE f := exp(y); RETURN f + f*vbytwo (* don't change to f(1 + vbytwo) *) + END + ELSE f := exp(y); RETURN (f + ONE/f)*HALF + END +END cosh; + +PROCEDURE tanh* (x: LONGREAL): LONGREAL; +(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *) + CONST + P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0; + Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3; + ln3over2=0.54930614433405484570D0; + BIG=19.06154747D0; (* (ln(2) + (t + 1)*ln(B))/2 where t=mantissa bits, B=base *) + VAR f, t: LONGREAL; +BEGIN f := ABS(x); + IF f > BIG THEN t := ONE + ELSIF f > ln3over2 THEN t := ONE-TWO/(exp(TWO*f) + ONE) + ELSIF f < Limit THEN t := f + ELSE (* approximation from "Software Manual for the Elementary Functions" *) + t := f*f; t := t*(((P2*t + P1)*t + P0)/(((t + Q2)*t + Q1)*t + Q0)); t := f + f*t + END; + IF x < ZERO THEN RETURN -t ELSE RETURN t END +END tanh; + +PROCEDURE arcsinh* (x: LONGREAL): LONGREAL; +(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *) +BEGIN + IF ABS(x) > SqrtInfinity*HALF THEN Math.ErrorHandler(Math.HypInvTrigClipped); + IF x > ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END; + ELSIF x < ZERO THEN RETURN -ln(-x + sqrt(x*x + ONE)) + ELSE RETURN ln(x + sqrt(x*x + ONE)) + END +END arcsinh; + +PROCEDURE arccosh* (x: LONGREAL): LONGREAL; +(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than + or equal to 1 are legal. *) +BEGIN + IF x < ONE THEN Math.ErrorHandler(Math.IllegalHypInvTrig); RETURN ZERO + ELSIF x > SqrtInfinity*HALF THEN Math.ErrorHandler(Math.HypInvTrigClipped); RETURN ln(SqrtInfinity) + ELSE RETURN ln(x + sqrt(x*x-ONE)) + END +END arccosh; + +PROCEDURE arctanh* (x: LONGREAL): LONGREAL; +(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where + em is machine epsilon. Note that |x| must not be so close to 1 that the + result is less accurate than half precision. *) + CONST TanhLimit=0.999984991D0; (* Tanh(5.9) *) + VAR t: LONGREAL; +BEGIN t := ABS(x); + IF (t >= ONE) OR (t > (ONE-TWO*em)) THEN Math.ErrorHandler(Math.IllegalHypInvTrig); + IF x < ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END + ELSIF t > TanhLimit THEN Math.ErrorHandler(Math.LossOfAccuracy) + END; + RETURN arcsinh(x/sqrt(ONE-x*x)) +END arctanh; + +PROCEDURE fcmp* (x, y, epsilon: LONGREAL): INTEGER; +(* fcmp: this procedure determines whether `x` and `y` are approximately equal + to a relative accuracy `epsilon`. + References: + The implementation is based on the GNU Scientific Library (GSL). + https://www.gnu.org/software/gsl/doc/html/math.html#approximate-comparison-of-floating-point-numbers +*) +VAR max, exponent0, delta, difference: LONGREAL; +BEGIN + IF ABS(x) > ABS(y) THEN + max := x; + ELSE + max := y; + END; + exponent0 := exponent(max); + delta := 2.0D0*epsilon*power(2.0D0, exponent0); + difference := x - y; + IF difference > delta THEN + RETURN 1; + ELSIF difference < -delta THEN + RETURN -1; + ELSE + RETURN 0; (* approximately equal *) + END; +END fcmp; + +PROCEDURE ToLONGREAL(h: HUGEINT): LONGREAL; +BEGIN RETURN SYSTEM.VAL(LONGREAL, h) +END ToLONGREAL; + +BEGIN + (* Initialise masks. *) + NumberMask := {}; INCL(NumberMask, 63); + FOR i := 0 TO 51 DO INCL(NumberMask, i) END; + ExponentMask := -NumberMask; + ZeroExponent := {}; + FOR i := 53 TO 61 DO INCL(ZeroExponent, i) END; + + (* determine some fundamental constants used by hyperbolic trig functions *) + em := ulp(ONE); + LnInfinity := ln(large); + LnSmall := ln(miny); + SqrtInfinity := sqrt(large); + t := pred(ONE)/sqrt(em); + TanhMax := ln(t + sqrt(t*t + ONE)); + + (* initialize some tables for the power() function a1[i]=2**((1-i)/16) *) + (* disable compiler warnings about 32-bit negative integers *) + (* < * PUSH; Warnings := FALSE * > *) + a1[ 1] := ONE; + a1[ 2] := ToLONGREAL(3FEEA4AFA2A490DAH); + a1[ 3] := ToLONGREAL(3FED5818DCFBA487H); + a1[ 4] := ToLONGREAL(3FEC199BDD85529CH); + a1[ 5] := ToLONGREAL(3FEAE89F995AD3ADH); + a1[ 6] := ToLONGREAL(3FE9C49182A3F090H); + a1[ 7] := ToLONGREAL(3FE8ACE5422AA0DBH); + a1[ 8] := ToLONGREAL(3FE7A11473EB0186H); + a1[ 9] := ToLONGREAL(3FE6A09E667F3BCCH); + a1[10] := ToLONGREAL(3FE5AB07DD485429H); + a1[11] := ToLONGREAL(3FE4BFDAD5362A27H); + a1[12] := ToLONGREAL(3FE3DEA64C123422H); + a1[13] := ToLONGREAL(3FE306FE0A31B715H); + a1[14] := ToLONGREAL(3FE2387A6E756238H); + a1[15] := ToLONGREAL(3FE172B83C7D517AH); + a1[16] := ToLONGREAL(3FE0B5586CF9890FH); + a1[17] := HALF; + + (* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *) + a2[1] := ToLONGREAL(3C90B1EE74320000H); + a2[2] := ToLONGREAL(3C71106589500000H); + a2[3] := ToLONGREAL(3C6C7C46B0700000H); + a2[4] := ToLONGREAL(3C9AFAA2047F0000H); + a2[5] := ToLONGREAL(3C86324C05460000H); + a2[6] := ToLONGREAL(3C7ADA0911F00000H); + a2[7] := ToLONGREAL(3C89B07EB6C80000H); + a2[8] := ToLONGREAL(3C88A62E4ADC0000H); + + (* reenable compiler warnings *) + (* < * POP * > *) +END MathL. + diff --git a/src/runtime/Modules.Mod b/src/runtime/Modules.Mod new file mode 100644 index 00000000..cf398304 --- /dev/null +++ b/src/runtime/Modules.Mod @@ -0,0 +1,331 @@ +MODULE Modules; (* jt 6.1.96 *) + + (* access to list of modules and commands, based on ETH Oberon *) + + + IMPORT SYSTEM, Platform, Heap; (* Note, must import Platform before Heap *) + + CONST + ModNameLen* = 20; + + TYPE + ModuleName* = Heap.ModuleName; + Module* = Heap.Module; + Cmd* = Heap.Cmd; + Command* = Heap.Command; + VAR + res*: INTEGER; + resMsg*: ARRAY 256 OF CHAR; + imported*: ModuleName; + importing*: ModuleName; + + MainStackFrame-: SYSTEM.ADDRESS; + ArgCount-: INTEGER; + ArgVector-: SYSTEM.ADDRESS; + BinaryDir-: ARRAY 1024 OF CHAR; + + +(* Program startup *) + + PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();"; + PROCEDURE -InitHeap "Heap_InitHeap()"; + PROCEDURE -ExternInitModulesInit "extern void *Modules__init(void);"; + PROCEDURE -ModulesInit() "Modules__init()"; + + PROCEDURE Init*(argc: SYSTEM.INT32; argvadr: SYSTEM.ADDRESS); + (* This start code is called by the __INIT macro generated by the compiler + as the C main program. *) + BEGIN + MainStackFrame := argvadr; + ArgCount := SYSTEM.VAL(INTEGER, argc); + SYSTEM.GET(argvadr, ArgVector); + + InitHeap; (* Initialse heap variables needed for compiler generated *__inits *) + ModulesInit(); (* Our own __init code will run Platform__init and Heap__init. *) + END Init; + + + PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR); + TYPE argptr = POINTER TO ARRAY 1024 OF CHAR; + VAR arg: argptr; + BEGIN + IF n < ArgCount THEN + SYSTEM.GET(ArgVector + n*SIZE(SYSTEM.ADDRESS), arg); (* Address of nth argument. *) + COPY(arg^, val); + END + END GetArg; + + PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT); + VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT; + BEGIN + s := ""; GetArg(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 k := -k; DEC(i) END ; + IF i > 0 THEN val := k END + END GetIntArg; + + PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER; + VAR i: INTEGER; arg: ARRAY 256 OF CHAR; + BEGIN + i := 0; GetArg(i, arg); + WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ; + RETURN i + END ArgPos; + + +(* Determine directory from which this executable was loaded *) + + PROCEDURE CharCount(s: ARRAY OF CHAR): INTEGER; + VAR i: INTEGER; + BEGIN + i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END; + RETURN i; + END CharCount; + + PROCEDURE Append(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); + VAR i,j: INTEGER; + BEGIN + i := 0; j := CharCount(d); + WHILE s[i] # 0X DO d[j] := s[i]; INC(i); INC(j) END; + d[j] := 0X; + END Append; + + PROCEDURE AppendPart(c: CHAR; s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); + VAR i,j: INTEGER; + BEGIN + i := 0; j := CharCount(d); + (* Append delimiter c to d only if d is either empty or doesn not + already end in c. *) + IF (j > 0) & (d[j-1] # c) THEN d[j] := c; INC(j) END; + (* Append s to d *) + WHILE s[i] # 0X DO d[j] := s[i]; INC(i); INC(j) END; + d[j] := 0X; + END AppendPart; + + PROCEDURE IsOneOf(c: CHAR; s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + BEGIN + IF c = 0X THEN RETURN FALSE END; + i := 0; WHILE (s[i] # c) & (s[i] # 0X) DO INC(i) END; + RETURN s[i] = c + END IsOneOf; + + PROCEDURE IsAbsolute(d: ARRAY OF CHAR): BOOLEAN; + BEGIN + IF d = '' THEN RETURN FALSE END; + IF IsOneOf(d[0], '/\') THEN RETURN TRUE END; + IF d[1] = ':' THEN RETURN TRUE END; + RETURN FALSE; + END IsAbsolute; + + PROCEDURE Canonify(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); + BEGIN + IF IsAbsolute(s) THEN + COPY(s, d) + ELSE + COPY(Platform.CWD, d); AppendPart('/', s, d); + END; + END Canonify; + + PROCEDURE IsFilePresent(s: ARRAY OF CHAR): BOOLEAN; + VAR identity: Platform.FileIdentity; + BEGIN + (*Out.String("IsFilePresent("); Out.String(s); Out.String(")."); Out.Ln;*) + RETURN Platform.IdentifyByName(s, identity) = 0 + END IsFilePresent; + + PROCEDURE ExtractPart(s: ARRAY OF CHAR; VAR i: INTEGER; p: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); + (* Extracts from s starting at i up to any character in p. + Result string in d. + Returns i skipped passed found string and any number of delimiters from p. + *) + VAR j: INTEGER; + BEGIN + j := 0; + WHILE (s[i] # 0X) & ~IsOneOf(s[i], p) DO + d[j] := s[i]; INC(i); INC(j) + END; + d[j] := 0X; + WHILE IsOneOf(s[i], p) DO INC(i) END + END ExtractPart; + + PROCEDURE Trim(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); + (* Remove redundant '.'s and '/'s. Convert '\'s to '/'. + Note, does not remove 'x/..'. This cannot safely be removed because if + x is a link then 'x/..' means the parent of what x links to rather than + the directory containing link x. + *) + VAR i,j: INTEGER; part: ARRAY 1024 OF CHAR; + BEGIN + i := 0; j := 0; + (* Retain any leading single or pair of '/' (filesystem root or network root). *) + WHILE (i<2) & IsOneOf(s[i], "/\") DO INC(i); d[j] := '/'; INC(j) END; + d[j] := 0X; + (* Append path parts omitting empty or '.' parts. *) + WHILE s[i] # 0X DO + ExtractPart(s, i, "/\", part); + IF (part # '') & (part # '.') THEN AppendPart('/', part, d) END + END; + END Trim; + + PROCEDURE FindBinaryDir(VAR binarydir: ARRAY OF CHAR); + TYPE pathstring = ARRAY 4096 OF CHAR; + VAR + arg0: pathstring; (* The command exactly as passed by the shell *) + pathlist: pathstring; (* The whole PATH environment variable *) + pathdir: pathstring; (* A single directory from the PATH *) + tempstr: pathstring; + i, j, k: INTEGER; + present: BOOLEAN; + BEGIN + IF ArgCount < 1 THEN + (* The caller is misbehaving: Shells and GUIs always pass the command + as ARGV[0]. *) + binarydir[0] := 0X; + RETURN; + END; + + GetArg(0, arg0); (* arg0 is the command binary file name passed by the shell. *) + i := 0; WHILE (arg0[i] # 0X) & (arg0[i] # '/') & (arg0[i] # '\') DO INC(i) END; + IF (arg0[i] = '/') OR (arg0[i] = '\') THEN + (* The argument contains a '/', we expect it to work without reference + to the path. *) + Trim(arg0, tempstr); Canonify(tempstr, binarydir); + present := IsFilePresent(binarydir) + ELSE + (* There are no '/'s in arg0, so search through the path. *) + Platform.GetEnv("PATH", pathlist); + i := 0; present := FALSE; + WHILE (~present) & (pathlist[i] # 0X) DO + ExtractPart(pathlist, i, ":;", pathdir); + AppendPart('/', arg0, pathdir); + Trim(pathdir, tempstr); Canonify(tempstr, binarydir); + present := IsFilePresent(binarydir) + END + END; + + IF present THEN + (* Remove trailing binarydir file name *) + k := CharCount(binarydir); + WHILE (k > 0) & ~IsOneOf(binarydir[k-1], '/\') DO DEC(k) END; + (* Chop off binarydir file name *) + IF k = 0 THEN binarydir[k] := 0X ELSE binarydir[k-1] := 0X END; + ELSE + binarydir[0] := 0X (* Couldn't determine binary directory. *) + END + END FindBinaryDir; + + +(* Module and command lookup by name *) + + PROCEDURE -modules(): Module "(Heap_Module)Heap_modules"; + (*PROCEDURE -setmodules(m: Module) "Heap_modules = m";*) + + PROCEDURE ThisMod* (name: ARRAY OF CHAR): Module; + VAR m: Module; bodyname: ARRAY 64 OF CHAR; body: Command; + BEGIN m := modules(); + WHILE (m # NIL) & (m.name # name) DO m := m.next END ; + IF m # NIL THEN res := 0; resMsg := "" + ELSE res := 1; COPY(name, importing); + resMsg := ' module "'; Append(name, resMsg); Append('" not found', resMsg); + END ; + RETURN m + END ThisMod; + + PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF CHAR): Command; + VAR c: Cmd; + BEGIN c := mod.cmds; + WHILE (c # NIL) & (c.name # name) DO c := c.next END ; + IF c # NIL THEN res := 0; resMsg := ""; RETURN c.cmd + ELSE res := 2; resMsg := ' command "'; COPY(name, importing); + Append(mod.name, resMsg); Append(".", resMsg); Append(name, resMsg); Append('" not found', resMsg); + RETURN NIL + END + END ThisCommand; + + PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN); + VAR m, p: Module; refcount: LONGINT; + BEGIN m := modules(); + IF all THEN + res := 1; resMsg := 'unloading "all" not yet supported' + ELSE + refcount := Heap.FreeModule(name); + IF refcount = 0 THEN + res := 0 + ELSE + IF refcount < 0 THEN resMsg := "module not found" + ELSE resMsg := "clients of this module exist" + END; + res := 1 + END + END + END Free; + + + + (* Run time error reporting. *) + + PROCEDURE errch(c: CHAR); (* Here we favour simplicity over efficiency, so no buffering. *) + VAR e: Platform.ErrorCode; + BEGIN e := Platform.Write(Platform.StdOut, SYSTEM.ADR(c), 1) + END errch; + + PROCEDURE errstring(s: ARRAY OF CHAR); + VAR i: LONGINT; + BEGIN + i := 0; WHILE (i= 10 THEN errint(l DIV 10) END; + errch(CHR(l MOD 10 + 30H)) + END errint; + + PROCEDURE DisplayHaltCode(code: SYSTEM.INT32); + BEGIN + CASE code OF + | -1: errstring("Assertion failure.") + | -2: errstring("Index out of range.") + | -3: errstring("Reached end of function without reaching RETURN.") + | -4: errstring("CASE statement: no matching label and no ELSE.") + | -5: errstring("Type guard failed.") + | -6: errstring("Implicit type guard in record assignment failed.") + | -7: errstring("Invalid case in WITH statement.") + | -8: errstring("Value out of range.") + | -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.") + |-10: errstring("NIL access."); + |-11: errstring("Alignment error."); + |-12: errstring("Divide by zero."); + |-13: errstring("Arithmetic overflow/underflow."); + |-14: errstring("Invalid function argument."); + |-15: errstring("Internal error, e.g. Type descriptor size mismatch.") + |-20: errstring("Too many, or negative number of, elements in dynamic array.") + ELSE + END + END DisplayHaltCode; + + PROCEDURE Halt*(code: SYSTEM.INT32); + BEGIN + Heap.FINALL; + errstring("Terminated by Halt("); errint(code); errstring("). "); + IF code < 0 THEN DisplayHaltCode(code) END; + errstring(Platform.NL); + Platform.Exit(code); + END Halt; + + PROCEDURE AssertFail*(code: SYSTEM.INT32); + BEGIN + Heap.FINALL; + errstring("Assertion failure."); + IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END; + errstring(Platform.NL); + IF code > 0 THEN Platform.Exit(code) ELSE Platform.Exit(-1) END; + END AssertFail; + +BEGIN + FindBinaryDir(BinaryDir); +END Modules. diff --git a/src/runtime/Oberon.Mod b/src/runtime/Oberon.Mod new file mode 100644 index 00000000..c67dcf17 --- /dev/null +++ b/src/runtime/Oberon.Mod @@ -0,0 +1,74 @@ +MODULE Oberon; + +(* this version should not have dependency on graphics -- noch *) + + IMPORT Platform, Modules, Texts, Out; + + TYPE + ParList* = POINTER TO ParRec; + ParRec* = RECORD + (* + vwr*: Viewers.Viewer; + frame*: Display.Frame; + *) + text*: Texts.Text; + pos*: LONGINT + END; + + VAR + Log*: Texts.Text; + Par*: ParList; (*actual parameters*) + OptionChar*: CHAR; + + R: Texts.Reader; + W: Texts.Writer; + + (*clocks*) + +PROCEDURE GetClock* (VAR t, d: LONGINT); +BEGIN Platform.GetClock(t, d) +END GetClock; + +PROCEDURE Time* (): LONGINT; +BEGIN RETURN Platform.Time() +END Time; + +PROCEDURE PopulateParams; + VAR W: Texts.Writer; i: INTEGER; str: ARRAY 256 OF CHAR; +BEGIN + Texts.OpenWriter(W); + i := 1; (* skip program name *) + WHILE i < Modules.ArgCount DO + Modules.GetArg(i, str); Texts.WriteString(W, str); Texts.Write(W, " "); + INC(i) + END; + Texts.Append(Par^.text, W.buf); +END PopulateParams; + +PROCEDURE GetSelection*(VAR text: Texts.Text; VAR beg, end, time: LONGINT); +BEGIN text := NIL; beg := 0; end := 0; time := 0 +END GetSelection; + +(* --- Notifier for echoing to the comsole all text appended to the log. --- *) +PROCEDURE LogNotifier(Log: Texts.Text; op: INTEGER; beg, end: LONGINT); + VAR ch: CHAR; +BEGIN + Texts.OpenReader(R, Log, beg); + WHILE ~R.eot & (beg < end) DO + Texts.Read(R, ch); + IF ch = 0DX THEN Out.Ln ELSE Out.Char(ch) END; + INC(beg) + END +END LogNotifier; + +BEGIN + NEW(Par); + NEW(Par.text); + Par.pos := 0; + OptionChar := '-'; + Texts.Open(Par.text, ""); + PopulateParams; + NEW(Log); + Texts.Open(Log, ""); + Log.notify := LogNotifier; +END Oberon. diff --git a/src/runtime/Out.Mod b/src/runtime/Out.Mod new file mode 100644 index 00000000..8895037c --- /dev/null +++ b/src/runtime/Out.Mod @@ -0,0 +1,247 @@ +MODULE Out; (* DCW Brown. 2016-09-27 *) + (** Module Out provides a set of basic routines + for formatted output of characters, numbers, and strings. + It assumes a standard output stream to which the symbols are written. *) + +IMPORT SYSTEM, Platform, Heap; + +VAR + IsConsole-: BOOLEAN; + + buf: ARRAY 128 OF CHAR; + in: INTEGER; + + + +PROCEDURE Flush*; +VAR error: Platform.ErrorCode; +BEGIN + IF in > 0 THEN error := Platform.Write(Platform.StdOut, SYSTEM.ADR(buf), in) END; + in := 0; +END Flush; +(** Initializes the output stream. In this library does nothing, safe to never use. *) +PROCEDURE Open*; +BEGIN +END Open; +(** Writes the character to the end of the output stream. *) +PROCEDURE Char*(ch: CHAR); +BEGIN + IF in >= LEN(buf) THEN Flush END; + buf[in] := ch; INC(in); + IF ch = 0AX THEN Flush END; +END Char; + +PROCEDURE Length(VAR s: ARRAY OF CHAR): LONGINT; +VAR l: LONGINT; +BEGIN l := 0; WHILE (l < LEN(s)) & (s[l] # 0X) DO INC(l) END; RETURN l +END Length; +(** Writes the null-terminated character sequence str to the end of the output stream (without 0X). *) +PROCEDURE String*(str: ARRAY OF CHAR); + VAR l: LONGINT; error: Platform.ErrorCode; +BEGIN + l := Length(str); + IF in + l > LEN(buf) THEN Flush END; + IF l > LEN(buf) THEN + (* Doesn't fit buf. Bypass buffering. *) + error := Platform.Write(Platform.StdOut, SYSTEM.ADR(str), l) + ELSE + SYSTEM.MOVE(SYSTEM.ADR(str), SYSTEM.ADR(buf[in]), l); INC(in, SHORT(l)); + END +END String; + +(** Writes the integer number x to the end of the output stream. + If the textual representation of x requires m characters, + x is right adjusted in a field of Max(n, m) characters + padded with blanks at the left end. a plus sign is not written. *) +PROCEDURE Int*(x, n: HUGEINT); + CONST zero = ORD('0'); + VAR s: ARRAY 22 OF CHAR; i: INTEGER; negative: BOOLEAN; +BEGIN + negative := x < 0; + IF x = MIN(HUGEINT) THEN + s := "8085774586302733229"; i := 19 + ELSE + IF x < 0 THEN x := - x END; + s[0] := CHR(zero + (x MOD 10)); x := x DIV 10; + i := 1; WHILE x # 0 DO + s[i] := CHR(zero + (x MOD 10)); + x := x DIV 10; + INC(i) + END + END; + IF negative THEN s[i] := '-'; INC(i) END; + WHILE n > i DO Char(' '); DEC(n) END; + WHILE i > 0 DO DEC(i); Char(s[i]) END +END Int; + + +PROCEDURE Hex*(x, n: HUGEINT); +BEGIN + IF n < 1 THEN n := 1 ELSIF n > 16 THEN n := 16 END; + IF x >= 0 THEN + WHILE (n < 16) & (SYSTEM.LSH(x, -4*n) # 0) DO INC(n) END + END; + x := SYSTEM.ROT(x, 4*(16-n)); + WHILE n > 0 DO + x := SYSTEM.ROT(x,4); DEC(n); + IF x MOD 16 < 10 THEN Char(CHR((x MOD 16) + ORD('0'))) + ELSE Char(CHR((x MOD 16) - 10 + ORD('A'))) END + END +END Hex; +(** Writes an end-of-line symbol to the end of the output stream *) +PROCEDURE Ln*; +BEGIN String(Platform.NL); Flush; +END Ln; + + +(* Real and Longreal display *) + +PROCEDURE digit(n: HUGEINT; VAR s: ARRAY OF CHAR; VAR i: INTEGER); +BEGIN + DEC(i); s[i] := CHR(n MOD 10 + 48); +END digit; + +PROCEDURE prepend(t: ARRAY OF CHAR; VAR s: ARRAY OF CHAR; VAR i: INTEGER); + VAR j: INTEGER; l: LONGINT; +BEGIN + l := Length(t); IF l > i THEN l := i END; + DEC(i, SHORT(l)); j := 0; + WHILE j < l DO s[i+j] := t[j]; INC(j) END +END prepend; + + + +PROCEDURE Ten*(e: INTEGER): LONGREAL; +VAR r, power: LONGREAL; +BEGIN r := 1.0D0; power := 1.0D1; + WHILE e > 0 DO + IF ODD(e) THEN r := r*power END; + power := power*power; e := e DIV 2 + END; + RETURN r +END Ten; + +PROCEDURE -Entier64(x: LONGREAL): SYSTEM.INT64 "(INT64)(x)"; + +(** RealP(x, n) writes the long real number x to the end of the output stream using an + exponential form. If the textual representation of x requires m characters (including a + three-digit signed exponent), x is right adjusted in a field of Max(n, m) characters padded + with blanks at the left end. A plus sign of the mantissa is not written. + LONGREAL is 1/sign, 11/exponent, 52/significand *) + +PROCEDURE RealP(x: LONGREAL; n: INTEGER; long: BOOLEAN); + + +VAR + e: INTEGER; (* Exponent field *) + f: HUGEINT; (* Fraction field *) + s: ARRAY 30 OF CHAR; (* Buffer built backwards *) + i: INTEGER; (* Index into s *) + el: INTEGER; (* Exponent length *) + x0: LONGREAL; + nn: BOOLEAN; (* Number negative *) + en: BOOLEAN; (* Exponent negative *) + m: HUGEINT; (* Mantissa digits *) + d: INTEGER; (* Significant digit count to display *) + dr: INTEGER; (* Number of insignificant digits that can be dropped *) + +BEGIN + e := SYSTEM.VAL(INTEGER, (SYSTEM.VAL(HUGEINT, x) DIV 10000000000000H) MOD 800H); + f := SYSTEM.VAL(HUGEINT, x) MOD 10000000000000H; + nn := (SYSTEM.VAL(HUGEINT, x) < 0) & ~((e = 7FFH) & (f # 0)); (* Ignore sign on Nan *) + IF nn THEN DEC(n) END; + + i := LEN(s); + IF e = 7FFH THEN (* NaN / Infinity *) + IF f = 0 THEN prepend("Infinity", s, i) ELSE prepend("NaN", s, i) END + ELSE + (* Calculate number of significant digits caller has proposed space for, and + number of digits to generate. *) + IF long THEN + el := 3; + dr := n-6; (* Leave room for dp and '+D000' *) + IF dr > 17 THEN dr := 17 END; (* Limit to max useful significant digits *) + d := dr; (* Number of digits to generate *) + IF d < 15 THEN d := 15 END (* Generate enough digits to do trailing zero supporession *) + ELSE + el := 2; + dr := n-5; (* Leave room for dp and '+E00' *) + IF dr > 9 THEN dr := 9 END; (* Limit to max useful significant digits *) + d := dr; (* Number of digits to generate *) + IF d < 6 THEN d := 6 END (* Generate enough digits to do trailing zero supporession *) + END; + + IF e = 0 THEN + WHILE el > 0 DO DEC(i); s[i] := "0"; DEC(el) END; + DEC(i); s[i] := "+"; + m := 0; + ELSE + IF nn THEN x := -x END; + + (* Scale e to be an exponent of 10 rather than 2 *) + e := SHORT(LONG(e - 1023) * 77 DIV 256); + IF e >= 0 THEN x := x / Ten(e) ELSE x := Ten(-e) * x END ; + IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END; + + (* Generate the exponent digits *) + en := e < 0; IF en THEN e := - e END; + WHILE el > 0 DO digit(e, s, i); e := e DIV 10; DEC(el) END; + DEC(i); IF en THEN s[i] := "-" ELSE s[i] := "+" END; + + (* Scale x to enough significant digits to reliably test for trailing + zeroes or to the amount of space available, if greater. *) + x0 := Ten(d-1); + x := x0 * x; + x := x + 0.5D0; (* Do not combine with previous line as doing so + introduces a least significant bit difference + between 32 bit and 64 bit builds. *) + IF x >= 10.0D0 * x0 THEN x := 0.1D0 * x; INC(e) END; + m := Entier64(x) + END; + + DEC(i); IF long THEN s[i] := "D" ELSE s[i] := "E" END; + + (* Drop trailing zeroes where caller proposes to use less space *) + IF dr < 2 THEN dr := 2 END; + WHILE (d > dr) & (m MOD 10 = 0) DO m := m DIV 10; DEC(d) END; + + (* Render significant digits *) + WHILE d > 1 DO digit(m, s, i); m := m DIV 10; DEC(d) END; + DEC(i); s[i] := '.'; + digit(m, s, i); + END; + + (* Generate leading padding *) + DEC(n, LEN(s)-i); WHILE n > 0 DO Char(" "); DEC(n) END; + + (* Render prepared number from right end of buffer s *) + IF nn THEN Char("-") END; + WHILE i < LEN(s) DO Char(s[i]); INC(i) END +END RealP; + +(** Writes the real number x to the end of the output stream using an exponential + form. If the textual representation of x requires m characters (including a + two-digit signed exponent), x is right adjusted in a field of Max(n, m) characters + padded with blanks at the left end. A plus sign of the mantissa is not written.*) +PROCEDURE Real*(x: REAL; n: INTEGER); +BEGIN RealP(x, n, FALSE); +END Real; + +(** Writes the long real number x to the end of the output stream using an exponential form. + If the textual representation of x requires m characters (including a three-digit + signed exponent), x is right adjusted in a field of Max(n, m) characters padded + with blanks at the left end. A plus sign of the mantissa is not written. *) +PROCEDURE LongReal*(x: LONGREAL; n: INTEGER); +BEGIN RealP(x, n, TRUE); +END LongReal; + +BEGIN + IsConsole := Platform.IsConsole(Platform.StdOut); + in := 0 + +(** This module originally was designed by Martin Reiser + for the book "Programming in Oberon". + the specification was proposed by H. Moessenbock *) + +END Out. + diff --git a/src/runtime/Platformunix.Mod b/src/runtime/Platformunix.Mod new file mode 100644 index 00000000..bcf11137 --- /dev/null +++ b/src/runtime/Platformunix.Mod @@ -0,0 +1,447 @@ +MODULE Platform; +IMPORT SYSTEM; + +CONST + StdIn- = 0; + StdOut- = 1; + StdErr- = 2; + +TYPE + SignalHandler = PROCEDURE(signal: SYSTEM.INT32); + + ErrorCode* = INTEGER; + FileHandle* = LONGINT; + + FileIdentity* = RECORD + volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *) + index: LONGINT; (* inode on Unix filesystems, file id on NTFS *) + mtime: LONGINT; (* File modification time, value is system dependent *) + END; + +VAR + LittleEndian-: BOOLEAN; + PID-: INTEGER; (* Note: Must be updated by Fork implementation *) + CWD-: ARRAY 256 OF CHAR; + TimeStart: LONGINT; + + SeekSet-: INTEGER; + SeekCur-: INTEGER; + SeekEnd-: INTEGER; + + NL-: ARRAY 3 OF CHAR; (* Platform specific newline representation *) + + + +(* Unix headers to be included *) + +PROCEDURE -Aincludesystime '#include '; (* for gettimeofday *) +PROCEDURE -Aincludetime '#include '; (* for localtime *) +PROCEDURE -Aincludesystypes '#include '; +PROCEDURE -Aincludeunistd '#include '; +PROCEDURE -Aincludesysstat '#include '; +PROCEDURE -Aincludefcntl '#include '; +PROCEDURE -Aincludeerrno '#include '; +PROCEDURE -Astdlib '#include '; +PROCEDURE -Astdio '#include '; +PROCEDURE -Aerrno '#include '; +PROCEDURE -Alimits '#include '; + + + + +(* Error code tests *) + +PROCEDURE -EMFILE(): ErrorCode 'EMFILE'; +PROCEDURE -ENFILE(): ErrorCode 'ENFILE'; +PROCEDURE -ENOENT(): ErrorCode 'ENOENT'; +PROCEDURE -EXDEV(): ErrorCode 'EXDEV'; +PROCEDURE -EACCES(): ErrorCode 'EACCES'; +PROCEDURE -EROFS(): ErrorCode 'EROFS'; +PROCEDURE -EAGAIN(): ErrorCode 'EAGAIN'; +PROCEDURE -ETIMEDOUT(): ErrorCode 'ETIMEDOUT'; +PROCEDURE -ECONNREFUSED(): ErrorCode 'ECONNREFUSED'; +PROCEDURE -ECONNABORTED(): ErrorCode 'ECONNABORTED'; +PROCEDURE -ENETUNREACH(): ErrorCode 'ENETUNREACH'; +PROCEDURE -EHOSTUNREACH(): ErrorCode 'EHOSTUNREACH'; +PROCEDURE -EINTR(): ErrorCode 'EINTR'; + + + +PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = EMFILE()) OR (e = ENFILE()) END TooManyFiles; + +PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ENOENT() END NoSuchDirectory; + +PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EXDEV() END DifferentFilesystems; + +PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible; + +PROCEDURE Absent*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ENOENT() END Absent; + +PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ETIMEDOUT() END TimedOut; + +PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) + OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed; + +PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EINTR() END Interrupted; + + + + +(* Expose file and path name length limits *) + +PROCEDURE -NAMEMAX(): INTEGER 'NAME_MAX'; +PROCEDURE -PATHMAX(): INTEGER 'PATH_MAX'; + +PROCEDURE MaxNameLength*(): INTEGER; BEGIN RETURN NAMEMAX() END MaxNameLength; +PROCEDURE MaxPathLength*(): INTEGER; BEGIN RETURN PATHMAX() END MaxPathLength; + + + + +(* OS memory allocaton *) + +PROCEDURE -allocate (size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(ADDRESS)((void*)malloc((size_t)size))"; +PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate; + +PROCEDURE -free(address: SYSTEM.ADDRESS) "free((void*)address)"; +PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree; + + + + +(* Program arguments and environment access *) + +PROCEDURE -getenv(var: ARRAY OF CHAR): SYSTEM.ADDRESS "getenv((char*)var)"; + +PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN; +TYPE EnvPtr = POINTER TO ARRAY 1024 OF CHAR; +VAR p: EnvPtr; +BEGIN + p := SYSTEM.VAL(EnvPtr, getenv(var)); + IF p # NIL THEN COPY(p^, val) END; + RETURN p # NIL; +END getEnv; + +PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); +BEGIN + IF ~getEnv(var, val) THEN val[0] := 0X END; +END GetEnv; + + + + + + +(* Signals and traps *) + +PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (ADDRESS)h)"; + +PROCEDURE SetInterruptHandler*(handler: SignalHandler); +BEGIN sethandler(2, handler); END SetInterruptHandler; + +PROCEDURE SetQuitHandler*(handler: SignalHandler); +BEGIN sethandler(3, handler); END SetQuitHandler; + +PROCEDURE SetBadInstructionHandler*(handler: SignalHandler); +BEGIN sethandler(4, handler); END SetBadInstructionHandler; + + + + +(* Time of day *) + +PROCEDURE -gettimeval "struct timeval tv; gettimeofday(&tv,0)"; +PROCEDURE -tvsec(): LONGINT "tv.tv_sec"; +PROCEDURE -tvusec(): LONGINT "tv.tv_usec"; +PROCEDURE -sectotm(s: LONGINT) "struct tm *time = localtime((time_t*)&s)"; +PROCEDURE -tmsec(): LONGINT "(LONGINT)time->tm_sec"; +PROCEDURE -tmmin(): LONGINT "(LONGINT)time->tm_min"; +PROCEDURE -tmhour(): LONGINT "(LONGINT)time->tm_hour"; +PROCEDURE -tmmday(): LONGINT "(LONGINT)time->tm_mday"; +PROCEDURE -tmmon(): LONGINT "(LONGINT)time->tm_mon"; +PROCEDURE -tmyear(): LONGINT "(LONGINT)time->tm_year"; + +PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: LONGINT; VAR t, d: LONGINT); +BEGIN + d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da; + t := ASH(ho, 12) + ASH(mi, 6) + se; +END YMDHMStoClock; + +PROCEDURE GetClock*(VAR t, d: LONGINT); +BEGIN + gettimeval; sectotm(tvsec()); + YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d); +END GetClock; + +PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT); +BEGIN + gettimeval; sec := tvsec(); usec := tvusec(); +END GetTimeOfDay; + +PROCEDURE Time*(): LONGINT; +VAR ms: LONGINT; +BEGIN + gettimeval; + ms := (tvusec() DIV 1000) + (tvsec() * 1000); + RETURN (ms - TimeStart) MOD 7FFFFFFFH; +END Time; + + +PROCEDURE -nanosleep(s: LONGINT; ns: LONGINT) "struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem)"; + +PROCEDURE Delay*(ms: LONGINT); +VAR s, ns: LONGINT; +BEGIN + s := ms DIV 1000; + ns := (ms MOD 1000) * 1000000; + nanosleep(s, ns); +END Delay; + + + + +(* System call *) + +PROCEDURE -system(str: ARRAY OF CHAR): INTEGER "system((char*)str)"; +PROCEDURE -err(): INTEGER "errno"; + + +PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER; +BEGIN RETURN system(cmd); END System; + +PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error; + + + + +(* File system *) + +(* Note: Consider also using flags O_SYNC and O_DIRECT as we do buffering *) +PROCEDURE -openrw (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDWR)"; +PROCEDURE -openro (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDONLY)"; +PROCEDURE -opennew(n: ARRAY OF CHAR): INTEGER "open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664)"; + +(* File APIs *) + +PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: INTEGER; +BEGIN + fd := openro(n); + IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END OldRO; + +PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: INTEGER; +BEGIN + fd := openrw(n); + IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END OldRW; + +PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: INTEGER; +BEGIN + fd := opennew(n); + IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END New; + + + +PROCEDURE -closefile(fd: LONGINT): INTEGER "close(fd)"; + +PROCEDURE Close*(h: FileHandle): ErrorCode; +BEGIN + IF closefile(h) < 0 THEN RETURN err() ELSE RETURN 0 END +END Close; + + +PROCEDURE -isatty(fd: LONGINT): INTEGER "isatty(fd)"; + +PROCEDURE IsConsole*(h: FileHandle): BOOLEAN; +BEGIN RETURN isatty(h) # 0 END IsConsole; + + + +PROCEDURE -fstat(fd: LONGINT): INTEGER "fstat(fd, &s)"; +PROCEDURE -stat(n: ARRAY OF CHAR): INTEGER "stat((char*)n, &s)"; +PROCEDURE -structstats "struct stat s"; +PROCEDURE -statdev(): LONGINT "(LONGINT)s.st_dev"; +PROCEDURE -statino(): LONGINT "(LONGINT)s.st_ino"; +PROCEDURE -statmtime(): LONGINT "(LONGINT)s.st_mtime"; +PROCEDURE -statsize(): LONGINT "(ADDRESS)s.st_size"; + +PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode; +BEGIN + structstats; + IF fstat(h) < 0 THEN RETURN err() END; + identity.volume := statdev(); + identity.index := statino(); + identity.mtime := statmtime(); + RETURN 0 +END Identify; + +PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode; +BEGIN + structstats; + IF stat(n) < 0 THEN RETURN err() END; + identity.volume := statdev(); + identity.index := statino(); + identity.mtime := statmtime(); + RETURN 0 +END IdentifyByName; + + +PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN; +BEGIN RETURN (i1.index = i2.index) & (i1.volume = i2.volume) +END SameFile; + +PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN; +BEGIN RETURN i1.mtime = i2.mtime +END SameFileTime; + +PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity); +BEGIN target.mtime := source.mtime; +END SetMTime; + +PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT); +BEGIN + sectotm(i.mtime); + YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d); +END MTimeAsClock; + + +PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode; +BEGIN + structstats; + IF fstat(h) < 0 THEN RETURN err() END; + l := statsize(); + RETURN 0; +END Size; + + + +PROCEDURE -readfile (fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): LONGINT +"(LONGINT)read(fd, (void*)(ADDRESS)(p), l)"; + +PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode; +BEGIN + n := readfile(h, p, l); + IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END +END Read; + +PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode; +BEGIN + n := readfile(h, SYSTEM.ADR(b), LEN(b)); + IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END +END ReadBuf; + + + +PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): SYSTEM.ADDRESS +"write(fd, (void*)(ADDRESS)(p), l)"; + +PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode; + VAR written: SYSTEM.ADDRESS; +BEGIN + written := writefile(h, p, l); + IF written < 0 THEN RETURN err() ELSE RETURN 0 END +END Write; + + + +PROCEDURE -fsync(fd: LONGINT): INTEGER "fsync(fd)"; + +PROCEDURE Sync*(h: FileHandle): ErrorCode; +BEGIN + IF fsync(h) < 0 THEN RETURN err() ELSE RETURN 0 END +END Sync; + + + +PROCEDURE -lseek(fd: LONGINT; o: LONGINT; w: INTEGER): INTEGER "lseek(fd, o, w)"; +PROCEDURE -seekset(): INTEGER "SEEK_SET"; +PROCEDURE -seekcur(): INTEGER "SEEK_CUR"; +PROCEDURE -seekend(): INTEGER "SEEK_END"; + +PROCEDURE Seek*(h: FileHandle; offset: LONGINT; whence: INTEGER): ErrorCode; +BEGIN + IF lseek(h, offset, whence) < 0 THEN RETURN err() ELSE RETURN 0 END +END Seek; + + + +PROCEDURE -ftruncate(fd: LONGINT; l: LONGINT): INTEGER "ftruncate(fd, l)"; + +PROCEDURE Truncate*(h: FileHandle; l: LONGINT): ErrorCode; +BEGIN + IF (ftruncate(h, l) < 0) THEN RETURN err() ELSE RETURN 0 END; +END Truncate; + + + +PROCEDURE -unlink(n: ARRAY OF CHAR): INTEGER "unlink((char*)n)"; + +PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode; +BEGIN + IF unlink(n) < 0 THEN RETURN err() ELSE RETURN 0 END +END Unlink; + + + +PROCEDURE -chdir(n: ARRAY OF CHAR): INTEGER "chdir((char*)n)"; +PROCEDURE -getcwd(VAR cwd: ARRAY OF CHAR): SYSTEM.PTR "getcwd((char*)cwd, cwd__len)"; + +PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode; + VAR r: INTEGER; +BEGIN + IF (chdir(n) >= 0) & (getcwd(CWD) # NIL) THEN RETURN 0 + ELSE RETURN err() END +END Chdir; + + + +PROCEDURE -rename(o,n: ARRAY OF CHAR): INTEGER "rename((char*)o, (char*)n)"; + +PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode; +BEGIN + IF rename(o,n) < 0 THEN RETURN err() ELSE RETURN 0 END +END Rename; + + + + +(* Process termination *) + +PROCEDURE -exit(code: LONGINT) "exit((int)code)"; +PROCEDURE Exit*(code: LONGINT); BEGIN exit(code) END Exit; + + + +PROCEDURE TestLittleEndian; + VAR i: INTEGER; + BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian; + + +PROCEDURE -getpid(): INTEGER "(INTEGER)getpid()"; + +BEGIN + TestLittleEndian; + + TimeStart := 0; TimeStart := Time(); + PID := getpid(); + IF getcwd(CWD) = NIL THEN CWD := "" END; + + SeekSet := seekset(); + SeekCur := seekcur(); + SeekEnd := seekend(); + + NL[0] := 0AX; (* LF *) + NL[1] := 0X; +END Platform. diff --git a/src/runtime/Platformwindows.Mod b/src/runtime/Platformwindows.Mod new file mode 100644 index 00000000..63c90a69 --- /dev/null +++ b/src/runtime/Platformwindows.Mod @@ -0,0 +1,524 @@ +MODULE Platform; +IMPORT SYSTEM; + +(* TODO: + Use Unicode APIs with manual UTF8 conversion and prepend '\\?\' to + file paths in order to get 32768 character path length limit (as + opposed to 256 bytes. *) + + +TYPE + SignalHandler = PROCEDURE(signal: SYSTEM.INT32); + + ErrorCode* = INTEGER; + FileHandle* = SYSTEM.ADDRESS; + + FileIdentity* = RECORD + volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *) + indexhigh: LONGINT; (* inode on Unix filesystems, file id on NTFS *) + indexlow: LONGINT; + mtimehigh: LONGINT; (* File modification time, value is system dependent *) + mtimelow: LONGINT; (* File modification time, value is system dependent *) + END; + +VAR + LittleEndian-: BOOLEAN; + PID-: INTEGER; (* Note: Must be updated by Fork implementation *) + CWD-: ARRAY 4096 OF CHAR; + TimeStart: LONGINT; + + SeekSet-: INTEGER; + SeekCur-: INTEGER; + SeekEnd-: INTEGER; + + StdIn-: FileHandle; + StdOut-: FileHandle; + StdErr-: FileHandle; + + NL-: ARRAY 3 OF CHAR; (* Platform specific newline representation *) + + + +PROCEDURE -AincludeWindowsWrapper '#include "WindowsWrapper.h"'; + + +(* Error code tests *) + +PROCEDURE -ERRORTOOMANYOPENFILES(): ErrorCode 'ERROR_TOO_MANY_OPEN_FILES'; +PROCEDURE -ERRORPATHNOTFOUND(): ErrorCode 'ERROR_PATH_NOT_FOUND'; +PROCEDURE -ERRORFILENOTFOUND(): ErrorCode 'ERROR_FILE_NOT_FOUND'; +PROCEDURE -ERRORNOTSAMEDEVICE(): ErrorCode 'ERROR_NOT_SAME_DEVICE'; +PROCEDURE -ERRORACCESSDENIED(): ErrorCode 'ERROR_ACCESS_DENIED'; +PROCEDURE -ERRORWRITEPROTECT(): ErrorCode 'ERROR_WRITE_PROTECT'; +PROCEDURE -ERRORSHARINGVIOLATION(): ErrorCode 'ERROR_SHARING_VIOLATION'; +PROCEDURE -ERRORNOTREADY(): ErrorCode 'ERROR_NOT_READY'; +PROCEDURE -ETIMEDOUT(): ErrorCode 'WSAETIMEDOUT'; +PROCEDURE -ECONNREFUSED(): ErrorCode 'WSAECONNREFUSED'; +PROCEDURE -ECONNABORTED(): ErrorCode 'WSAECONNABORTED'; +PROCEDURE -ENETUNREACH(): ErrorCode 'WSAENETUNREACH'; +PROCEDURE -EHOSTUNREACH(): ErrorCode 'WSAEHOSTUNREACH'; +PROCEDURE -EINTR(): ErrorCode 'WSAEINTR'; + + + +PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ERRORTOOMANYOPENFILES() END TooManyFiles; + +PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ERRORPATHNOTFOUND() END NoSuchDirectory; + +PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ERRORNOTSAMEDEVICE() END DifferentFilesystems; + +PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN; +BEGIN + RETURN (e = ERRORACCESSDENIED()) OR (e = ERRORWRITEPROTECT()) + OR (e = ERRORNOTREADY()) OR (e = ERRORSHARINGVIOLATION()); +END Inaccessible; + +PROCEDURE Absent*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ERRORFILENOTFOUND()) OR (e = ERRORPATHNOTFOUND()) END Absent; + +PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ETIMEDOUT()) END TimedOut; + +PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) + OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed; + +PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EINTR() END Interrupted; + + + + +(* Expose file and path name length limits (same on Windows) *) + +PROCEDURE -MAXPATH(): INTEGER 'MAX_PATH'; + +PROCEDURE MaxNameLength*(): INTEGER; BEGIN RETURN MAXPATH() END MaxNameLength; +PROCEDURE MaxPathLength*(): INTEGER; BEGIN RETURN MAXPATH() END MaxPathLength; + + + + +(* OS memory allocaton *) + +PROCEDURE -allocate(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))"; +PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate; + +PROCEDURE -free(address: SYSTEM.ADDRESS) "HeapFree(GetProcessHeap(), 0, (void*)address)"; +PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree; + + + + +(* Program arguments and environmet access *) + +PROCEDURE -getenv(name: ARRAY OF CHAR; VAR buf: ARRAY OF CHAR): INTEGER +"(INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len)"; + +PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN; + VAR + buf: ARRAY 4096 OF CHAR; + res: INTEGER; +BEGIN + res := getenv(var, buf); + IF (res > 0) & (res < LEN(buf)) THEN + COPY(buf, val); + RETURN TRUE; + ELSE + RETURN FALSE; + END; +END getEnv; + +PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); +BEGIN + IF ~getEnv(var, val) THEN val[0] := 0X END; +END GetEnv; + + + + + +(* Signals and traps *) + +(* PROCEDURE -signal(sig: LONGINT; func: SignalHandler) "signal(sig, func)"; *) + +(* TODO *) + +(* Ctrl/c handling *) + +PROCEDURE -SetInterruptHandler*(h: SignalHandler) "SystemSetInterruptHandler((ADDRESS)h)"; +PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((ADDRESS)h)"; + +PROCEDURE SetBadInstructionHandler*(handler: SignalHandler); +BEGIN (* TODO *) END SetBadInstructionHandler; + + + + +(* Time of day *) + +PROCEDURE -getLocalTime "SYSTEMTIME st; GetLocalTime(&st)"; +PROCEDURE -stmsec(): INTEGER "(INTEGER)st.wMilliseconds"; +PROCEDURE -stsec(): INTEGER "(INTEGER)st.wSecond"; +PROCEDURE -stmin(): INTEGER "(INTEGER)st.wMinute"; +PROCEDURE -sthour(): INTEGER "(INTEGER)st.wHour"; +PROCEDURE -stmday(): INTEGER "(INTEGER)st.wDay"; +PROCEDURE -stmon(): INTEGER "(INTEGER)st.wMonth"; +PROCEDURE -styear(): INTEGER "(INTEGER)st.wYear"; + +PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: INTEGER; VAR t, d: LONGINT); +BEGIN + d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da; + t := ASH(ho, 12) + ASH(mi, 6) + se; +END YMDHMStoClock; + +PROCEDURE GetClock*(VAR t, d: LONGINT); +BEGIN + getLocalTime; + YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d); +END GetClock; + +PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(UINT32)GetTickCount()"; + +PROCEDURE Time*(): LONGINT; +VAR ms: LONGINT; +BEGIN + ms := GetTickCount(); + RETURN (ms - TimeStart) MOD 7FFFFFFFH; +END Time; + + +PROCEDURE -sleep(ms: LONGINT) "Sleep((DWORD)ms)"; + +PROCEDURE Delay*(ms: LONGINT); +BEGIN + WHILE ms > 30000 DO sleep(30000); ms := ms-30000 END; + IF ms > 0 THEN sleep(ms) END; +END Delay; + + +PROCEDURE -stToFt "FILETIME ft; SystemTimeToFileTime(&st, &ft)"; +PROCEDURE -ftToUli "ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime"; +PROCEDURE -tous1970 "ul.QuadPart = (ul.QuadPart - 116444736000000000ULL)/10LL"; +PROCEDURE -ulSec(): LONGINT "(LONGINT)(ul.QuadPart / 1000000LL)"; +PROCEDURE -uluSec(): LONGINT "(LONGINT)(ul.QuadPart % 1000000LL)"; + +PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT); +BEGIN + getLocalTime; stToFt; ftToUli; tous1970; + sec := ulSec(); usec := uluSec(); +END GetTimeOfDay; + + + +(* System call *) + +PROCEDURE -startupInfo "STARTUPINFO si = {0}; si.cb = sizeof(si);"; +PROCEDURE -processInfo "PROCESS_INFORMATION pi = {0};"; +PROCEDURE -createProcess(str: ARRAY OF CHAR): INTEGER "(INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi)"; +PROCEDURE -waitForProcess(): INTEGER "(INTEGER)WaitForSingleObject(pi.hProcess, INFINITE)"; +PROCEDURE -getExitCodeProcess(VAR exitcode: INTEGER) "GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode);"; +PROCEDURE -cleanupProcess "CloseHandle(pi.hProcess); CloseHandle(pi.hThread);"; +PROCEDURE -err(): INTEGER "(INTEGER)GetLastError()"; + +PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER; +VAR + result: INTEGER; +BEGIN + result := 127; + startupInfo; processInfo; + IF createProcess(cmd) # 0 THEN + IF waitForProcess() = 0 THEN getExitCodeProcess(result) END; + cleanupProcess; + END; + RETURN result * 256; +END System; + +PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error; + + +(* File system *) + +PROCEDURE -invalidHandleValue(): SYSTEM.ADDRESS "((ADDRESS)INVALID_HANDLE_VALUE)"; + +PROCEDURE -openrw (n: ARRAY OF CHAR): FileHandle +"(ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; + +PROCEDURE -openro (n: ARRAY OF CHAR): FileHandle +"(ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; + +PROCEDURE -opennew(n: ARRAY OF CHAR): FileHandle +"(ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)"; + + + + +(* File APIs *) + +PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: FileHandle; +BEGIN + fd := openro(n); + IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END OldRO; + +PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: FileHandle; +BEGIN + fd := openrw(n); + IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END OldRW; + +PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode; +VAR fd: FileHandle; +BEGIN + fd := opennew(n); + IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END; +END New; + + + +PROCEDURE -closeHandle(h: FileHandle): INTEGER "(INTEGER)CloseHandle((HANDLE)h)"; + +PROCEDURE Close*(h: FileHandle): ErrorCode; +BEGIN + IF closeHandle(h) = 0 THEN RETURN err() ELSE RETURN 0 END +END Close; + + + +PROCEDURE -byHandleFileInformation "BY_HANDLE_FILE_INFORMATION bhfi"; +PROCEDURE -getFileInformationByHandle(h: FileHandle): INTEGER "(INTEGER)GetFileInformationByHandle((HANDLE)h, &bhfi)"; +PROCEDURE -bhfiMtimeHigh(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwHighDateTime"; +PROCEDURE -bhfiMtimeLow(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwLowDateTime"; +PROCEDURE -bhfiVsn(): LONGINT "(LONGINT)bhfi.dwVolumeSerialNumber"; +PROCEDURE -bhfiIndexHigh(): LONGINT "(LONGINT)bhfi.nFileIndexHigh"; +PROCEDURE -bhfiIndexLow(): LONGINT "(LONGINT)bhfi.nFileIndexLow"; + + +PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode; +BEGIN + byHandleFileInformation; + IF getFileInformationByHandle(h) = 0 THEN RETURN err() END; + identity.volume := bhfiVsn(); + identity.indexhigh := bhfiIndexHigh(); + identity.indexlow := bhfiIndexLow(); + identity.mtimehigh := bhfiMtimeHigh(); + identity.mtimelow := bhfiMtimeLow(); + RETURN 0 +END Identify; + +PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode; +VAR + h: FileHandle; + e,i: ErrorCode; +BEGIN + e := OldRO(n, h); + IF e # 0 THEN RETURN e END; + e := Identify(h, identity); + i := Close(h); + RETURN e; +END IdentifyByName; + + +PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN; +BEGIN RETURN (i1.indexhigh = i2.indexhigh) & (i1.indexlow = i2.indexlow) & (i1.volume = i2.volume) +END SameFile; + +PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN; +BEGIN RETURN (i1.mtimehigh = i2.mtimehigh) & (i1.mtimelow = i2.mtimelow) +END SameFileTime; + +PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity); +BEGIN target.mtimehigh := source.mtimehigh; target.mtimelow := source.mtimelow; +END SetMTime; + +PROCEDURE -identityToFileTime(i: FileIdentity) +"FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow"; + +PROCEDURE -fileTimeToSysTime +"SYSTEMTIME st; FileTimeToSystemTime(&ft, &st)"; + +PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT); +BEGIN + identityToFileTime(i); fileTimeToSysTime; + YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d); +END MTimeAsClock; + +PROCEDURE -largeInteger "LARGE_INTEGER li"; +PROCEDURE -liLongint(): LONGINT "(LONGINT)li.QuadPart"; +PROCEDURE -getFileSize(h: FileHandle): INTEGER "(INTEGER)GetFileSizeEx((HANDLE)h, &li)"; + +PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode; +BEGIN + largeInteger; + IF getFileSize(h) = 0 THEN RETURN err() END; + l := liLongint(); + RETURN 0; +END Size; + + +PROCEDURE -readfile (fd: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: SYSTEM.INT32): INTEGER +"(INTEGER)ReadFile((HANDLE)fd, (void*)p, (DWORD)l, (DWORD*)n, 0)"; + +PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode; +VAR result: INTEGER; lengthread: SYSTEM.INT32; +BEGIN + result := readfile(h, p, l, lengthread); + IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END +END Read; + +PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode; +VAR result: INTEGER; lengthread: SYSTEM.INT32; +BEGIN + result := readfile(h, SYSTEM.ADR(b), LEN(b), lengthread); + IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END +END ReadBuf; + + + +PROCEDURE -writefile(fd: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: SYSTEM.INT32): INTEGER +"(INTEGER)WriteFile((HANDLE)fd, (void*)(p), (DWORD)l, (DWORD*)n, 0)"; + +PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode; +VAR n: SYSTEM.INT32; +BEGIN + IF writefile(h, p, l, n) = 0 THEN RETURN err() ELSE RETURN 0 END +END Write; + + + +PROCEDURE -flushFileBuffers(h: FileHandle): INTEGER "(INTEGER)FlushFileBuffers((HANDLE)h)"; + +PROCEDURE Sync*(h: FileHandle): ErrorCode; +BEGIN + IF flushFileBuffers(h) = 0 THEN RETURN err() ELSE RETURN 0 END +END Sync; + + + +PROCEDURE -setFilePointerEx(h: FileHandle; o: LONGINT; r: INTEGER; VAR rc: INTEGER) +"li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, li, 0, (DWORD)r)"; + +PROCEDURE -seekset(): INTEGER "FILE_BEGIN"; +PROCEDURE -seekcur(): INTEGER "FILE_CURRENT"; +PROCEDURE -seekend(): INTEGER "FILE_END"; + +PROCEDURE Seek*(h: FileHandle; o: LONGINT; r: INTEGER): ErrorCode; +VAR rc: INTEGER; +BEGIN + largeInteger; + setFilePointerEx(h, o, r, rc); + IF rc = 0 THEN RETURN err() ELSE RETURN 0 END +END Seek; + + + +PROCEDURE -setEndOfFile(h: FileHandle): INTEGER "(INTEGER)SetEndOfFile((HANDLE)h)"; +PROCEDURE -getFilePos(h: FileHandle; VAR r: LONGINT; VAR rc: INTEGER) +"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart"; + +PROCEDURE Truncate*(h: FileHandle; limit: LONGINT): ErrorCode; +VAR rc: INTEGER; oldpos: LONGINT; +BEGIN + largeInteger; + getFilePos(h, oldpos, rc); + IF rc = 0 THEN RETURN err() END; + setFilePointerEx(h, limit, seekset(), rc); + IF rc = 0 THEN RETURN err() END; + IF setEndOfFile(h) = 0 THEN RETURN err() END; + setFilePointerEx(h, oldpos, seekset(), rc); (* Restore original file position *) + IF rc = 0 THEN RETURN err() END; + RETURN 0; +END Truncate; + + + +PROCEDURE -deleteFile(n: ARRAY OF CHAR): INTEGER "(INTEGER)DeleteFile((char*)n)"; + +PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode; +BEGIN + IF deleteFile(n) = 0 THEN RETURN err() ELSE RETURN 0 END +END Unlink; + + +PROCEDURE -setCurrentDirectory(n: ARRAY OF CHAR): INTEGER "(INTEGER)SetCurrentDirectory((char*)n)"; +PROCEDURE -getCurrentDirectory(VAR n: ARRAY OF CHAR) "GetCurrentDirectory(n__len, (char*)n)"; + +PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode; + VAR r: INTEGER; +BEGIN + r := setCurrentDirectory(n); + IF r = 0 THEN RETURN err() END; + getCurrentDirectory(CWD); + RETURN 0; +END Chdir; + + + +PROCEDURE -moveFile(o,n: ARRAY OF CHAR): INTEGER +"(INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING)"; + +PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode; +BEGIN + IF moveFile(o,n) = 0 THEN RETURN err() ELSE RETURN 0 END +END Rename; + + + + +(* Process termination *) + +PROCEDURE -exit(code: LONGINT) "ExitProcess((UINT)code)"; +PROCEDURE Exit*(code: LONGINT); BEGIN exit(code) END Exit; + + +PROCEDURE -GetConsoleMode(h: FileHandle; VAR m: SYSTEM.INT32): BOOLEAN "GetConsoleMode((HANDLE)h, (DWORD*)m)"; +PROCEDURE -SetConsoleMode(h: FileHandle; m: SYSTEM.INT32) "SetConsoleMode((HANDLE)h, (DWORD)m)"; + +PROCEDURE EnableVT100; +CONST VTprocessing = 4; (* ENABLE_VIRTUAL_TERMINAL_PROCESSING: value specified by MSDN *) +VAR mode: SYSTEM.INT32; +BEGIN IF GetConsoleMode(StdOut, mode) THEN SetConsoleMode(StdOut, mode+VTprocessing) END +END EnableVT100; + +PROCEDURE IsConsole*(h: FileHandle): BOOLEAN; +VAR mode: SYSTEM.INT32; +BEGIN RETURN GetConsoleMode(StdOut, mode) +END IsConsole; + + +PROCEDURE TestLittleEndian; + VAR i: INTEGER; + BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian; + + +PROCEDURE -getstdinhandle(): FileHandle "(ADDRESS)GetStdHandle(STD_INPUT_HANDLE)"; +PROCEDURE -getstdouthandle(): FileHandle "(ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE)"; +PROCEDURE -getstderrhandle(): FileHandle "(ADDRESS)GetStdHandle(STD_ERROR_HANDLE)"; +PROCEDURE -getpid(): INTEGER "(INTEGER)GetCurrentProcessId()"; + +BEGIN + TestLittleEndian; + + TimeStart := 0; TimeStart := Time(); + CWD := ""; getCurrentDirectory(CWD); + PID := getpid(); + + SeekSet := seekset(); + SeekCur := seekcur(); + SeekEnd := seekend(); + + StdIn := getstdinhandle(); + StdOut := getstdouthandle(); + StdErr := getstderrhandle(); + + EnableVT100; + + NL[0] := 0DX; (* CR *) + NL[1] := 0AX; (* LF *) + NL[2] := 0X; +END Platform. diff --git a/src/runtime/Reals.Mod b/src/runtime/Reals.Mod new file mode 100644 index 00000000..f9e6617b --- /dev/null +++ b/src/runtime/Reals.Mod @@ -0,0 +1,136 @@ +MODULE Reals; + (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) + (* DCWB 20160817 Made independent of INTEGER size *) + + IMPORT SYSTEM; + + PROCEDURE Ten*(e: INTEGER): REAL; + VAR r, power: LONGREAL; + BEGIN r := 1.0; + power := 10.0; + WHILE e > 0 DO + IF ODD(e) THEN r := r * power END ; + power := power * power; e := e DIV 2 + END ; + RETURN SHORT(r) + END Ten; + + + PROCEDURE TenL*(e: INTEGER): LONGREAL; + VAR r, power: LONGREAL; + BEGIN r := 1.0; + power := 10.0; + LOOP + IF ODD(e) THEN r := r * power END ; + e := e DIV 2; + IF e <= 0 THEN RETURN r END ; + power := power * power + END + END TenL; + + + (* Real number format (IEEE 754) + + TYPE REAL - Single precision / binary32: + 1/sign, 8/exponent, 23/significand + + TYPE LONGREAL - Double precision / binary64: + 1/sign, 11/exponent, 52/significand + + exponent: + stored as exponent value + 127. + + significand (fraction): + excludes leading (most significant) bit which is assumed to be 1. + *) + + + PROCEDURE Expo*(x: REAL): INTEGER; + VAR i: INTEGER; + BEGIN + SYSTEM.GET(SYSTEM.ADR(x)+2, i); + RETURN (i DIV 128) MOD 256 + END Expo; + + PROCEDURE SetExpo*(VAR x: REAL; ex: INTEGER); + VAR c: CHAR; + BEGIN + (* Replace exponent bits within top byte of REAL *) + SYSTEM.GET(SYSTEM.ADR(x)+3, c); + SYSTEM.PUT(SYSTEM.ADR(x)+3, CHR(((ORD(c) DIV 128) * 128) + ((ex DIV 2) MOD 128))); + (* Replace exponent bits within 2nd byte of REAL *) + SYSTEM.GET(SYSTEM.ADR(x)+2, c); + SYSTEM.PUT(SYSTEM.ADR(x)+2, CHR((ORD(c) MOD 128) + ((ex MOD 2) * 128))) + END SetExpo; + + PROCEDURE ExpoL*(x: LONGREAL): INTEGER; + VAR i: INTEGER; + BEGIN + SYSTEM.GET(SYSTEM.ADR(x)+6, i); + RETURN (i DIV 16) MOD 2048 + END ExpoL; + + (* Convert LONGREAL: Write positive integer value of x into array d. + The value is stored backwards, i.e. least significant digit + first. n digits are written, with trailing zeros fill. + On entry x has been scaled to the number of digits required. *) + PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); + VAR i, j, k: LONGINT; + BEGIN + IF x < 0 THEN x := -x END; + k := 0; + + IF (SIZE(LONGINT) < 8) & (n > 9) THEN + (* There are more decimal digits than can be held in a single LONGINT *) + i := ENTIER(x / 1000000000.0D0); (* The 10th and higher digits *) + j := ENTIER(x - (i * 1000000000.0D0)); (* The low 9 digits *) + (* First generate the low 9 digits. *) + IF j < 0 THEN j := 0 END; + WHILE k < 9 DO + d[k] := CHR(j MOD 10 + 48); j := j DIV 10; INC(k) + END; + (* Fall through to generate the upper digits *) + ELSE + (* We can generate all the digits in one go. *) + i := ENTIER(x); + END; + + WHILE k < n DO + d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) + END + END ConvertL; + + + PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); + BEGIN ConvertL(x, n, d) + END Convert; + + PROCEDURE ToHex(i: INTEGER): CHAR; + BEGIN + IF i < 10 THEN RETURN CHR(i+48) + ELSE RETURN CHR(i+55) END + END ToHex; + + PROCEDURE BytesToHex(VAR b, d: ARRAY OF SYSTEM.BYTE); + VAR i: INTEGER; l: LONGINT; by: CHAR; + BEGIN + i := 0; l := LEN(b); + WHILE i < l DO + by := SYSTEM.VAL(CHAR, b[i]); + d[i*2] := ToHex(ORD(by) DIV 16); + d[i*2+1] := ToHex(ORD(by) MOD 16); + INC(i) + END + END BytesToHex; + + (* Convert Hex *) + PROCEDURE ConvertH*(y: REAL; VAR d: ARRAY OF CHAR); + BEGIN BytesToHex(y, d) + END ConvertH; + + (* Convert Hex Long *) + PROCEDURE ConvertHL*(x: LONGREAL; VAR d: ARRAY OF CHAR); + BEGIN BytesToHex(x, d) + END ConvertHL; + +END Reals. diff --git a/src/runtime/SYSTEM.c b/src/runtime/SYSTEM.c new file mode 100644 index 00000000..2952bb66 --- /dev/null +++ b/src/runtime/SYSTEM.c @@ -0,0 +1,227 @@ +/* +* 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" +#include "stdarg.h" +#include + + +// Procedure verions of SYSTEM.H versions used when a multiply accessed +// parameter has side effects. + + + + +INT64 SYSTEM_DIV(INT64 x, INT64 y) +{ + if (x == 0) return 0; + if (x >= 0) + if (y >= 0) {return x/y;} + else {return -((x-y-1)/(-y));} + else + if (y >= 0) {return -((y-x-1)/y);} + else {return (-x)/(-y);} +} + +INT64 SYSTEM_MOD(INT64 x, INT64 y) +{ + if (x == 0) return 0; + if (x >= 0) + if (y >= 0) {return x % y;} + else {return (y+1) + ((x-1) % (-y));} + else + if (y >= 0) {return (y-1) - ((-x-1) % y);} + else {return -((-x) % (-y));} +} + +INT64 SYSTEM_ENTIER(double x) +{ + INT64 y; + if (x >= 0) + return (INT64)x; + else { + y = (INT64)x; + if (y <= x) return y; else return y - 1; + } +} + + + +void SYSTEM_INHERIT(ADDRESS *t, ADDRESS *t0) +{ + t -= __TPROC0OFF; + t0 -= __TPROC0OFF; + while (*t0 != __EOM) {*t = *t0; t--; t0--;} +} + + +void SYSTEM_ENUMP(void *adr, ADDRESS n, void (*P)()) +{ + while (n > 0) { + P((ADDRESS)(*((void**)(adr)))); + adr = ((void**)adr) + 1; + n--; + } +} + +void SYSTEM_ENUMR(void *adr, ADDRESS *typ, ADDRESS size, ADDRESS n, void (*P)()) +{ + ADDRESS *t, off; + typ++; + while (n > 0) { + t = typ; + off = *t; + while (off >= 0) {P(*(ADDRESS*)((char*)adr+off)); t++; off = *t;} + adr = ((char*)adr) + size; + n--; + } +} + +extern void Heap_Lock(); +extern void Heap_Unlock(); + +SYSTEM_PTR SYSTEM_NEWARR(ADDRESS *typ, ADDRESS elemsz, int elemalgn, int nofdim, int nofdyn, ...) +{ + ADDRESS nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; + va_list ap; + va_start(ap, nofdyn); + nofelems = 1; + while (nofdim > 0) { + nofelems = nofelems * va_arg(ap, ADDRESS); nofdim--; + if (nofelems <= 0) __HALT(-20); + } + va_end(ap); + dataoff = nofdyn * sizeof(ADDRESS); + if (elemalgn > sizeof(ADDRESS)) { + n = dataoff % elemalgn; + if (n != 0) dataoff += elemalgn - n; + } + size = dataoff + nofelems * elemsz; + Heap_Lock(); + if (typ == NIL) { + /* element typ does not contain pointers */ + x = Heap_NEWBLK(size); + } + else if (typ == (ADDRESS*)POINTER__typ) { + /* element type is a pointer */ + x = Heap_NEWBLK(size + nofelems * sizeof(ADDRESS)); + p = (ADDRESS*)(ADDRESS)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(ADDRESS); p++; n++;} + *p = - (nofelems + 1) * sizeof(ADDRESS); /* sentinel */ + x[-1] -= nofelems * sizeof(ADDRESS); + } + 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 = Heap_NEWBLK(size + nptr * sizeof(ADDRESS)); + p = (ADDRESS*)(ADDRESS)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(ADDRESS); /* sentinel */ + x[-1] -= nptr * sizeof(ADDRESS); + } + if (nofdyn != 0) { + /* setup len vector for index checks */ + va_start(ap, nofdyn); + p = x; + while (nofdyn > 0) {*p = va_arg(ap, ADDRESS); p++, nofdyn--;} + va_end(ap); + } + Heap_Unlock(); + return x; +} + +typedef void (*SystemSignalHandler)(INT32); // = Platform_SignalHandler + +#ifndef _WIN32 + // Unix signal handling + SystemSignalHandler handler[10] = {0}; // Adjust the array size to include signal 11 + + void segfaultHandler(int signal) { + __HALT(-10); + } + // Revised signal handler to accommodate additional signals like SIGSEGV + void signalHandler(int s) { + if ((s >= 2 && s <= 4) || s == 11) { // Include SIGSEGV (usually signal 11) + if (handler[s-2]) { + handler[s-2](s); + } + } + // Ignore other signals + } + + void SystemSetHandler(int s, ADDRESS h) { + if ((s >= 2 && s <= 4) || s == 11) { + int needtosetsystemhandler = handler[s-2] == 0; + handler[s-2] = (SystemSignalHandler)h; + if (needtosetsystemhandler) { + signal(s, signalHandler); + } + } + } + + void setupAutomaticSegfaultHandler() { + SystemSetHandler(11, (ADDRESS)segfaultHandler); // Register handler for SIGSEGV + } + +#else + // Windows system remains as is since Windows does not use SIGSEGV in the same way + #include "WindowsWrapper.h" + + SystemSignalHandler SystemInterruptHandler = 0; + SystemSignalHandler SystemQuitHandler = 0; + BOOL ConsoleCtrlHandlerSet = FALSE; + + BOOL WINAPI SystemConsoleCtrlHandler(DWORD ctrlType) { + if ((ctrlType == CTRL_C_EVENT) || (ctrlType == CTRL_BREAK_EVENT)) { + if (SystemInterruptHandler) { + SystemInterruptHandler(2); // SIGINT + return TRUE; + } + } else { + if (SystemQuitHandler) { + SystemQuitHandler(3); // SIGQUIT + return TRUE; + } + } + return FALSE; + } + void EnsureConsoleCtrlHandler() { + if (!ConsoleCtrlHandlerSet) { + SetConsoleCtrlHandler(SystemConsoleCtrlHandler, TRUE); + ConsoleCtrlHandlerSet = TRUE; + } + } + + void SystemSetInterruptHandler(ADDRESS h) { + EnsureConsoleCtrlHandler(); + SystemInterruptHandler = (SystemSignalHandler)h; + } + + void SystemSetQuitHandler(ADDRESS h) { + EnsureConsoleCtrlHandler(); + SystemQuitHandler = (SystemSignalHandler)h; + } + +#endif + diff --git a/src/runtime/SYSTEM.h b/src/runtime/SYSTEM.h new file mode 100644 index 00000000..39d594ed --- /dev/null +++ b/src/runtime/SYSTEM.h @@ -0,0 +1,337 @@ +#ifndef SYSTEM__h +#define SYSTEM__h + + +// 64 bit system detection + +#if (__SIZEOF_POINTER__ == 8) || defined (_LP64) || defined(__LP64__) || defined(_WIN64) + #define o__64 +#endif + + +// Declare memcpy in a way compatible with C compilers intrinsic +// built in implementations. + +#if defined (o__64) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + #if defined(__OpenBSD__) + typedef unsigned long size_t; + #else + typedef unsigned int size_t; + #endif +#endif + +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, size_t size); +#if defined _MSC_VER +#define alloca _alloca +#endif +void *alloca(size_t size); + + +// Declare fixed size versions of basic intger types + +#if defined (o__64) && !defined(_WIN64) + // LP64 + typedef long INT64; + typedef unsigned long UINT64; +#else + // ILP32 or LLP64 + typedef long long INT64; + typedef unsigned long long UINT64; +#endif + +typedef int INT32; +typedef unsigned int UINT32; + +typedef short int INT16; +typedef unsigned short int UINT16; + +typedef signed char INT8; +typedef unsigned char UINT8; + + +// The compiler uses 'import' and 'export' which translate to 'extern' and +// nothing respectively. + +#define import extern +#define export + + + +// Known constants + +#define NIL ((void*)0) +#define __MAXEXT 16 +#define POINTER__typ ((ADDRESS*)(1)) // not NIL and not a valid type + + +// Oberon types + +typedef INT8 BOOLEAN; +typedef INT8 SYSTEM_BYTE; +typedef UINT8 CHAR; +typedef float REAL; +typedef double LONGREAL; +typedef void* SYSTEM_PTR; + + + +// 'ADDRESS' is a synonym for an integer of pointer size + +#if defined (o__64) + #define ADDRESS INT64 +#else + #define ADDRESS INT32 +#endif + + + +// ---------------------------------------------------------------------- +// ---------------------------------------------------------------------- + + + +// OS Memory allocation interfaces are in PlatformXXX.Mod + +extern ADDRESS Platform_OSAllocate (ADDRESS size); +extern void Platform_OSFree (ADDRESS addr); + + +// Assertions and Halts + +extern void Modules_Halt(INT32 x); +extern void Modules_AssertFail(INT32 x); + +#define __HALT(x) Modules_Halt((INT32)(x)) +#define __ASSERT(cond, x) if (!(cond)) Modules_AssertFail((INT32)(x)) + + +// Index checking + +static inline INT64 __XF(INT64 i, UINT64 ub) { + if (i < 0 || (UINT64)i >= ub) __HALT(-2); + return i; +} +#define __X(i, ub) (((i) >= 0 && (i) < (ub)) ? (i) : (__HALT(-2),0)) + +// Range checking, and checked SHORT and CHR functions + +static inline INT64 __RF(UINT64 i, UINT64 ub) {if (i >= ub) {__HALT(-8);} return i;} +#define __R(i, ub) (((i)<(ub))?i:(__HALT(-8),0)) +#define __SHORT(x, ub) ((int)((UINT64)(x)+(ub)<(ub)+(ub)?(x):(__HALT(-8),0))) +#define __SHORTF(x, ub) ((int)(__RF((x)+(ub),(ub)+(ub))-(ub))) +#define __CHR(x) ((CHAR)__R(x, 256)) +#define __CHRF(x) ((CHAR)__RF(x, 256)) + + + +// Signal handling in SYSTEM.c + +#ifndef _WIN32 + extern void SystemSetHandler(int s, ADDRESS h); +#else + extern void SystemSetInterruptHandler(ADDRESS h); + extern void SystemSetQuitHandler (ADDRESS h); +#endif + + + +// String comparison + +static inline int __str_cmp(CHAR *x, CHAR *y){ + INT64 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 __STRCMP(a,b) __str_cmp((CHAR*)(a), (CHAR*)(b)) + + + +// Inline string, record and array copy + +#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ + while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} +#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) +#define __DEL(x) + + +/* SYSTEM ops */ + +#define __VAL(t, x) (*(t*)&(x)) + +#define __GET(a, x, t) x=*(t*)(ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(ADDRESS)(a)=x + +#define __LSHL(x, n, s) ((INT##s)((UINT##s)(x)<<(n))) +#define __LSHR(x, n, s) ((INT##s)((UINT##s)(x)>>(n))) +#define __LSH(x, n, s) ((n)>=0? __LSHL(x, n, s): __LSHR(x, -(n), s)) + +#define __ROTL(x, n, s) ((INT##s)((UINT##s)(x)<<(n)|(UINT##s)(x)>>(s-(n)))) +#define __ROTR(x, n, s) ((INT##s)((UINT##s)(x)>>(n)|(UINT##s)(x)<<(s-(n)))) +#define __ROT(x, n, s) ((n)>=0? __ROTL(x, n, s): __ROTR(x, -(n), s)) + +#define __ASHL(x, n) ((INT64)(x)<<(n)) +#define __ASHR(x, n) ((INT64)(x)>>(n)) +#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) +static inline INT64 SYSTEM_ASH(INT64 x, INT64 n) {return __ASH(x,n);} +#define __ASHF(x, n) SYSTEM_ASH((INT64)(x), (INT64)(n)) + +#define __MOVE(s, d, n) memcpy((char*)(ADDRESS)(d),(char*)(ADDRESS)(s),n) + + +extern INT64 SYSTEM_DIV(INT64 x, INT64 y); +#define __DIVF(x, y) SYSTEM_DIV(x, y) +#define __DIV(x, y) (((x)>0 && (y)>0) ? (x)/(y) : __DIVF(x, y)) + + +extern INT64 SYSTEM_MOD(INT64 x, INT64 y); +#define __MODF(x, y) SYSTEM_MOD(x, y) +#define __MOD(x, y) (((x)>0 && (y)>0) ? (x)%(y) : __MODF(x, y)) + + +extern INT64 SYSTEM_ENTIER (double x); +#define __ENTIER(x) SYSTEM_ENTIER(x) + + +#define __ABS(x) (((x)<0)?-(x):(x)) + +static inline INT32 SYSTEM_ABS64(INT64 i) {return i >= 0 ? i : -i;} +static inline INT64 SYSTEM_ABS32(INT32 i) {return i >= 0 ? i : -i;} +#define __ABSF(x) ((sizeof(x) <= 4) ? SYSTEM_ABS32(x) : SYSTEM_ABS64(x)) + +static inline double SYSTEM_ABSD(double i) {return i >= 0.0 ? i : -i;} +#define __ABSFD(x) SYSTEM_ABSD(x) + +#define __CAP(ch) ((CHAR)((ch)&0x5f)) +#define __ODD(x) ((x)&1) + +#define __IN(x, s, size) (((unsigned int)(x))>(x))&1)) +// todo tested versions of SETOF and SETRNG: check that x, l and h fit size +#define __SETOF(x, size) ((UINT##size)1<<(x)) +#define __SETRNG(l, h, size) ((~(UINT##size)0<<(l))&~(UINT##size)0>>(size-1-(h))) + +#define __MASK(x, m) ((x)&~(m)) +#define __BIT(x, n) (*(UINT64*)(x)>>(n)&1) + + + +// Runtime checks + +#define __RETCHK __retchk: __HALT(-3); return 0; +#define __CASECHK __HALT(-4) +#define __WITHCHK __HALT(-7) + + +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(ADDRESS)typ##__typ) +#define __TYPEOF(p) (*(((ADDRESS**)(p))-1)) +#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) + + +#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);*((typ*)p) + + + +// Module entry/registration/exit + +extern void Heap_REGCMD(); +extern SYSTEM_PTR Heap_REGMOD(); +extern void Heap_REGTYP(); +extern void Heap_INCREF(); + +#define __DEFMOD static void *m; if (m!=0) {return m;} +#define __REGCMD(name, cmd) Heap_REGCMD(m, (CHAR*)name, cmd) +#define __REGMOD(name, enum) if (m==0) {m = Heap_REGMOD((CHAR*)name,enum);} +#define __ENDMOD return m +#define __MODULE_IMPORT(name) Heap_INCREF(name##__init()) + + + +// Main module initialisation, registration and finalisation + +extern void Modules_Init(INT32 argc, ADDRESS argv); +extern void Heap_FINALL(); + +extern void setupAutomaticSegfaultHandler(); +#ifndef _WIN32 +#define __INIT(argc, argv) static void *m; setupAutomaticSegfaultHandler(); Modules_Init(argc, (ADDRESS)&argv); +#else +#define __INIT(argc, argv) static void *m; Modules_Init(argc, (ADDRESS)&argv); +#endif +#define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) +#define __FINI Heap_FINALL(); return 0 + + +// Memory allocation + +extern SYSTEM_PTR Heap_NEWBLK (ADDRESS size); +extern SYSTEM_PTR Heap_NEWREC (ADDRESS tag); +extern SYSTEM_PTR SYSTEM_NEWARR(ADDRESS*, ADDRESS, int, int, int, ...); + +#define __SYSNEW(p, len) p = Heap_NEWBLK((ADDRESS)(len)) +#define __NEW(p, t) p = Heap_NEWREC((ADDRESS)t##__typ) +#define __NEWARR SYSTEM_NEWARR + + + +/* Type handling */ + +extern void SYSTEM_INHERIT(ADDRESS *t, ADDRESS *t0); +extern void SYSTEM_ENUMP (void *adr, ADDRESS n, void (*P)()); +extern void SYSTEM_ENUMR (void *adr, ADDRESS *typ, ADDRESS size, ADDRESS n, void (*P)()); + + +#define __TDESC(t, m, n) \ + static struct t##__desc { \ + ADDRESS tproc[m]; /* Proc for each ptr field */ \ + ADDRESS tag; \ + ADDRESS next; /* Module table type list points here */ \ + ADDRESS level; \ + ADDRESS module; \ + char name[24]; \ + ADDRESS basep[__MAXEXT]; /* List of bases this extends */ \ + ADDRESS reserved; \ + ADDRESS blksz; /* xxx_typ points here */ \ + ADDRESS ptr[n+1]; /* Offsets of ptrs up to -ve sentinel */ \ + } t##__desc + +#define __BASEOFF (__MAXEXT+1) // blksz as index to base. +#define __TPROC0OFF (__BASEOFF+24/sizeof(ADDRESS)+5) // blksz as index to tproc IFF m=1. +#define __EOM 1 +#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size +#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (ADDRESS)(n), P) +#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (ADDRESS)(size), (ADDRESS)(n), P) + +#define __INITYP(t, t0, level) \ + t##__typ = (ADDRESS*)&t##__desc.blksz; \ + memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(ADDRESS)); \ + t##__desc.basep[level] = (ADDRESS)t##__typ; \ + t##__desc.module = (ADDRESS)m; \ + if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ + t##__desc.blksz = (t##__desc.blksz+5*sizeof(ADDRESS)-1)/(4*sizeof(ADDRESS))*(4*sizeof(ADDRESS)); \ + Heap_REGTYP(m, (ADDRESS)&t##__desc.next); \ + SYSTEM_INHERIT(t##__typ, t0##__typ) + +// Oberon-2 type bound procedures support +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((ADDRESS)*(typ-(__TPROC0OFF+num))))parlist + + + + +#endif diff --git a/src/lib/v4/Strings.Mod b/src/runtime/Strings.Mod similarity index 70% rename from src/lib/v4/Strings.Mod rename to src/runtime/Strings.Mod index e6fe12ac..89dcaa33 100644 --- a/src/lib/v4/Strings.Mod +++ b/src/runtime/Strings.Mod @@ -28,14 +28,14 @@ Strings.Cap(s) replaces each lower case letter in s by its upper case equivalent. -------------------------------------------------------------*) (* added from trianus v4 *) -MODULE Strings; (*HM 94-06-22 / *) - +MODULE Strings; (*HM 94-06-22 / *) (* noch 2017-06-21 *) +IMPORT Reals; PROCEDURE Length* (s: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; + VAR i: LONGINT; BEGIN - i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END ; - RETURN i + i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END; + IF i <= MAX(INTEGER) THEN RETURN SHORT(i) ELSE RETURN MAX(INTEGER) END END Length; @@ -153,4 +153,74 @@ BEGIN RETURN M(string, pattern, Length(string)-1, Length(pattern)-1) END Match; +PROCEDURE StrToReal*(s: ARRAY OF CHAR; VAR r: REAL); +VAR p, e: INTEGER; y, g: REAL; neg, negE: BOOLEAN; +BEGIN + p := 0; + WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; + IF s[p] = "-" THEN neg := TRUE; INC(p) ELSE neg := FALSE END; + WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; + + y := 0; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + y := y * 10 + (ORD(s[p]) - 30H); + INC(p); + END; + IF s[p] = "." THEN + INC(p); g := 1; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + g := g / 10; y := y + g * (ORD(s[p]) - 30H); + INC(p); + END; + END; + IF (s[p] = "D") OR (s[p] = "E") THEN + INC(p); e := 0; + IF s[p] = "-" THEN negE := TRUE; INC(p) ELSE negE := FALSE END; + WHILE (s[p] = "0") DO INC(p) END; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + e := e * 10 + (ORD(s[p]) - 30H); + INC(p); + END; + IF negE THEN y := y / Reals.Ten(e) + ELSE y := y * Reals.Ten(e) END; + END; + IF neg THEN y := -y END; + r := y; +END StrToReal; + +PROCEDURE StrToLongReal*(s: ARRAY OF CHAR; VAR r: LONGREAL); +VAR p, e: INTEGER; y, g: LONGREAL; neg, negE: BOOLEAN; +BEGIN + p := 0; + WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; + IF s[p] = "-" THEN neg := TRUE; INC(p) ELSE neg := FALSE END; + WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END; + + y := 0; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + y := y * 10 + (ORD(s[p]) - 30H); + INC(p); + END; + IF s[p] = "." THEN + INC(p); g := 1; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + g := g / 10; y := y + g * (ORD(s[p]) - 30H); + INC(p); + END; + END; + IF (s[p] = "D") OR (s[p] = "E") THEN + INC(p); e := 0; + IF s[p] = "-" THEN negE := TRUE; INC(p) ELSE negE := FALSE END; + WHILE (s[p] = "0") DO INC(p) END; + WHILE ("0" <= s[p]) & (s[p] <= "9") DO + e := e * 10 + (ORD(s[p]) - 30H); + INC(p); + END; + IF negE THEN y := y / Reals.Ten(e) + ELSE y := y * Reals.Ten(e) END; + END; + IF neg THEN y := -y END; + r := y; +END StrToLongReal; + END Strings. diff --git a/src/lib/v4/Texts.Mod b/src/runtime/Texts.Mod similarity index 94% rename from src/lib/v4/Texts.Mod rename to src/runtime/Texts.Mod index 2042dcf7..aba83032 100644 --- a/src/lib/v4/Texts.Mod +++ b/src/runtime/Texts.Mod @@ -1,6 +1,6 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *) IMPORT - Files, Modules, Reals; + Files, Modules, Reals, SYSTEM; (*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *) @@ -12,7 +12,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** (**FileMsg.id**) load* = 0; store* = 1; (**Notifier op**) - replace* = 0; insert* = 1; delete* = 2; + replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (**Scanner.class**) Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6; @@ -20,7 +20,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** TYPE FontsFont = POINTER TO FontDesc; - FontDesc = RECORD + FontDesc = RECORD name: ARRAY 32 OF CHAR; END ; @@ -29,7 +29,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** prev, next: Run; len: LONGINT; fnt: FontsFont; - col, voff: SHORTINT; + col, voff: SYSTEM.INT8; ascii: BOOLEAN (* << *) END; @@ -72,8 +72,10 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** head: Run END; + Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); TextDesc* = RECORD len*: LONGINT; + notify*: Notifier; head, cache: Run; corg: LONGINT END; @@ -81,7 +83,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** Reader* = RECORD eot*: BOOLEAN; fnt*: FontsFont; - col*, voff*: SHORTINT; + col*, voff*: SYSTEM.INT8; elem*: Elem; rider: Files.Rider; run: Run; @@ -102,7 +104,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** Writer* = RECORD buf*: Buffer; fnt*: FontsFont; - col*, voff*: SHORTINT; + col*, voff*: SYSTEM.INT8; rider: Files.Rider; file: Files.File END; @@ -112,13 +114,12 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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 @@ -200,7 +201,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; @@ -281,6 +282,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + IF T.notify # NIL THEN T.notify(T, insert, pos, pos+len) END END Insert; PROCEDURE Append* (T: Text; B: Buffer); @@ -288,6 +290,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + IF T.notify # NIL THEN T.notify(T, insert, pos, pos+len) END END Append; PROCEDURE Delete* (T: Text; beg, end: LONGINT); @@ -299,9 +302,10 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** Splice(del.head, un, v, NIL); Merge(T, u, vn); u.next := vn; vn.prev := u; DEC(T.len, end - beg); + IF T.notify # NIL THEN T.notify(T, delete, beg, end) END END Delete; - PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SHORTINT); + PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SYSTEM.INT8); 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; @@ -313,6 +317,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + IF T.notify # NIL THEN T.notify(T, replace, beg, end) END END ChangeLooks; @@ -334,8 +339,8 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** IF u IS Piece THEN Files.Read(R.rider, ch); R.elem := NIL; IF (ch = 0AX) & u(Piece).ascii THEN ch := CR (* << LF to CR *) ELSIF (ch = CR) & u(Piece).ascii THEN (* << CR LF to CR *) - pos := Files.Pos(R.rider); Files.Read(R.rider, nextch); - IF nextch = 0AX THEN INC(R.off) ELSE Files.Set(R.rider, u(Piece).file, pos) END + pos := Files.Pos(R.rider); Files.Read(R.rider, nextch); + IF nextch = 0AX THEN INC(R.off) ELSE Files.Set(R.rider, u(Piece).file, pos) END END ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem) ELSE ch := 0X; R.elem := NIL; R.eot := TRUE @@ -445,7 +450,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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 + 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 ; @@ -457,7 +462,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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 + 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 @@ -500,11 +505,11 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** BEGIN W.fnt := fnt END SetFont; - PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT); + PROCEDURE SetColor* (VAR W: Writer; col: SYSTEM.INT8); BEGIN W.col := col END SetColor; - PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT); + PROCEDURE SetOffset* (VAR W: Writer; voff: SYSTEM.INT8); BEGIN W.voff := voff END SetOffset; @@ -539,12 +544,13 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + PROCEDURE WriteInt* (VAR W: Writer; x, n: SYSTEM.INT64); + VAR + i: INTEGER; x0: SYSTEM.INT64; + a: ARRAY 24 OF CHAR; BEGIN i := 0; IF x < 0 THEN - IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN + IF x = MIN(SYSTEM.INT64) THEN WriteString(W, " -9223372036854775808"); RETURN ELSE DEC(n); x0 := -x END ELSE x0 := x @@ -559,7 +565,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT); VAR i: INTEGER; y: LONGINT; - a: ARRAY 10 OF CHAR; + a: ARRAY 20 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; @@ -663,14 +669,22 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + + (* Scale e to be an exponent of 10 rather than 2 *) 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 ; + IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END; + + (* Scale x to the number of digits requested *) x0 := Reals.TenL(n-1); x := x0*x + 0.5D0; IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ; + + (* Generate the mantissa digits of x *) 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; @@ -703,7 +717,8 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + org, pos, hlen, plen: LONGINT; ecnt, fcnt: SHORTINT; + fno, col, voff: SYSTEM.INT8; f: Files.File; msg: FileMsg; mods, procs: ARRAY 64, 32 OF CHAR; @@ -712,7 +727,7 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + org, ew, eh: LONGINT; eno: SYSTEM.INT8; 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; @@ -744,13 +759,13 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; + (*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; @@ -785,14 +800,15 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** 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; (* << *) + VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fcnt: SHORTINT; ch: CHAR; (* << *) + fno: SYSTEM.INT8; 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; + VAR r1: Files.Rider; org, span: LONGINT; eno: SYSTEM.INT8; 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)); @@ -848,8 +864,9 @@ MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91** u := u.next END; r := msg.r; + IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END 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 diff --git a/src/lib/misc/vt100.Mod b/src/runtime/VT100.Mod similarity index 94% rename from src/lib/misc/vt100.Mod rename to src/runtime/VT100.Mod index 37ab5895..6687ed02 100644 --- a/src/lib/misc/vt100.Mod +++ b/src/runtime/VT100.Mod @@ -1,6 +1,6 @@ -MODULE vt100; +MODULE VT100; -IMPORT Console, Strings; +IMPORT Out, Strings; (* reference http://en.wikipedia.org/wiki/ANSI_escape_code & http://misc.flogisoft.com/bash/tip_colors_and_formatting *) @@ -65,7 +65,7 @@ CONST BLightCyan* = "106m"; BWhite* = "107m"; - VAR + VAR CSI* : ARRAY 5 OF CHAR; tmpstr : ARRAY 32 OF CHAR; @@ -102,7 +102,7 @@ CONST ELSE (* SIZE(LONGINT) = 8 *) b := "-9223372036854775808"; e := 20 - END + END ELSE IF int < 0 THEN (* negative sign *) b[0] := "-"; int := -int; s := 1 @@ -127,7 +127,7 @@ CONST BEGIN COPY(CSI, cmd); Strings.Append (letter, cmd); - Console.String (cmd); + Out.String (cmd); END EscSeq0; PROCEDURE EscSeq (n : INTEGER; letter : ARRAY OF CHAR); @@ -138,7 +138,7 @@ CONST COPY(CSI, cmd); Strings.Append (nstr, cmd); Strings.Append (letter, cmd); - Console.String (cmd); + Out.String (cmd); END EscSeq; PROCEDURE EscSeqSwapped (n : INTEGER; letter : ARRAY OF CHAR); @@ -149,7 +149,7 @@ CONST COPY(CSI, cmd); Strings.Append (letter, cmd); Strings.Append (nstr, cmd); - Console.String (cmd); + Out.String (cmd); END EscSeqSwapped; PROCEDURE EscSeq2(n, m : INTEGER; letter : ARRAY OF CHAR); @@ -164,13 +164,20 @@ CONST Strings.Append (';', cmd); Strings.Append (mstr, cmd); Strings.Append (letter, cmd); - Console.String (cmd); + Out.String (cmd); END EscSeq2; - - -(* Cursor up + PROCEDURE Reset*; + VAR + cmd : ARRAY 6 OF CHAR; + BEGIN + COPY(Escape, cmd); + Strings.Append("c", cmd); + Out.String(cmd); + Out.Ln; + END Reset; +(* Cursor up moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *) PROCEDURE CUU*(n : INTEGER); @@ -187,7 +194,7 @@ CONST END CUD; -(* Cursor forward +(* Cursor forward moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *) PROCEDURE CUF*(n : INTEGER); @@ -195,7 +202,7 @@ CONST EscSeq (n, 'C'); END CUF; -(* Cursor back +(* Cursor back moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *) PROCEDURE CUB*(n : INTEGER); @@ -259,7 +266,7 @@ CONST END SU; (* Scroll Down - Scroll whole page down by n (default 1) lines. New lines are added at the top *) + Scroll whole page down by n (default 1) lines. New lines are added at the top *) PROCEDURE SD*( n : INTEGER); BEGIN EscSeq(n, 'T'); @@ -324,7 +331,7 @@ CONST BEGIN COPY(CSI, tmpstr); Strings.Append(attr, tmpstr); - Console.String(tmpstr); + Out.String(tmpstr); END SetAttr; BEGIN @@ -337,6 +344,6 @@ CONST COPY(CSI, tmpstr); Strings.Append(Green, tmpstr); Strings.Append("hello", tmpstr); - Console.String(tmpstr); Console.Ln; + Out.String(tmpstr); Out.Ln; *) - END vt100. + END VT100. diff --git a/src/runtime/WindowsWrapper.h b/src/runtime/WindowsWrapper.h new file mode 100644 index 00000000..b72c815a --- /dev/null +++ b/src/runtime/WindowsWrapper.h @@ -0,0 +1,10 @@ +// WindowsWrapper.h +// +// Includes Windows.h while avoiding conflicts with Oberon types. + + +#define BOOLEAN _BOOLEAN +#define CHAR _CHAR +#include +#undef BOOLEAN +#undef CHAR diff --git a/src/test/confidence/arrayassignment/aa.mod b/src/test/confidence/arrayassignment/aa.mod new file mode 100644 index 00000000..e5ac2db0 --- /dev/null +++ b/src/test/confidence/arrayassignment/aa.mod @@ -0,0 +1,23 @@ +MODULE aa; +IMPORT Console; + +CONST teststring = "1st 10 ch 2nd 10 ch 3rd 10 ch"; + +VAR + a30: ARRAY 30 OF CHAR; + + a10: ARRAY 10 OF CHAR; + a20: ARRAY 20 OF CHAR; + + buf: ARRAY 64 OF CHAR; + + +BEGIN + a30 := teststring; Console.String("a30: "); Console.String(a30); Console.Ln; + COPY(a30, a20); Console.String("a20: "); Console.String(a20); Console.Ln; + Console.Ln; + COPY(a30, a10); Console.String("a10: "); Console.String(a10); Console.Ln; + Console.String("a20: "); Console.String(a20); Console.Ln; + Console.Ln; + Console.String("Array assignment test complete."); Console.Ln; +END aa. diff --git a/src/test/confidence/arrayassignment/expected b/src/test/confidence/arrayassignment/expected new file mode 100644 index 00000000..753916be --- /dev/null +++ b/src/test/confidence/arrayassignment/expected @@ -0,0 +1,7 @@ +a30: 1st 10 ch 2nd 10 ch 3rd 10 ch +a20: 1st 10 ch 2nd 10 ch + +a10: 1st 10 ch +a20: 1st 10 ch 2nd 10 ch + +Array assignment test complete. diff --git a/src/test/confidence/arrayassignment/old.cygwin.ILP32.gcc.s b/src/test/confidence/arrayassignment/old.cygwin.ILP32.gcc.s new file mode 100644 index 00000000..adf79790 --- /dev/null +++ b/src/test/confidence/arrayassignment/old.cygwin.ILP32.gcc.s @@ -0,0 +1,224 @@ +55 pushl %ebp +89E5 movl %esp, %ebp +83EC10 subl $16, %esp +C745FC00 movl $0, -4(%ebp) +8B55FC movl -4(%ebp), %edx +8B4508 movl 8(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FB movb %al, -5(%ebp) +8B55FC movl -4(%ebp), %edx +8B450C movl 12(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FA movb %al, -6(%ebp) +8345FC01 addl $1, -4(%ebp) +807DFB00 cmpb $0, -5(%ebp) +7508 jne L2 +0FB645FA movzbl -6(%ebp), %eax +F7D8 negl %eax +EB15 jmp L3 +0FB645FB movzbl -5(%ebp), %eax +3A45FA cmpb -6(%ebp), %al +74C9 je L4 +0FB655FB movzbl -5(%ebp), %edx +0FB645FA movzbl -6(%ebp), %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C9 leave +C3 ret +616100 .ascii "aa\0" +6133303A .ascii "a30: \0" +6132303A .ascii "a20: \0" +6131303A .ascii "a10: \0" +000000 .align 4 +41727261 .ascii "Array assignment test complete.\0" +79206173 +7369676E +6D656E74 +20746573 +55 pushl %ebp +89E5 movl %esp, %ebp +83E4F0 andl $-16, %esp +83EC40 subl $64, %esp +E8000000 call ___main +8D550C leal 12(%ebp), %edx +8B4508 movl 8(%ebp), %eax +98 cwtl +89542404 movl %edx, 4(%esp) +890424 movl %eax, (%esp) +E8000000 call _Platform_Init +E8000000 call _Console__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +C7442404 movl $0, 4(%esp) +00000000 +C7042400 movl $LC0, (%esp) +E8000000 call _Heap_REGMOD +A3800000 movl %eax, _m.1612 +C7050000 movl $544502577, _aa_a30 +00003173 +C7050400 movl $1663053873, _aa_a30+4 +00003130 +C7050800 movl $1848778856, _aa_a30+8 +00006820 +C7050C00 movl $808525924, _aa_a30+12 +00006420 +C7051000 movl $543712032, _aa_a30+16 +00002063 +C7051400 movl $543453747, _aa_a30+20 +00003372 +C7051800 movl $1663053873, _aa_a30+24 +00003130 +66C7051C movw $104, _aa_a30+28 +00000068 +C7442404 movl $6, 4(%esp) +06000000 +C7042403 movl $LC1, (%esp) +E8000000 call _Console_String +C7442404 movl $30, 4(%esp) +1E000000 +C7042400 movl $_aa_a30, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +C7442430 movl $_aa_a30, 48(%esp) +00000000 +C744242C movl $_aa_a20, 44(%esp) +2C000000 +C744243C movl $0, 60(%esp) +00000000 +C7442428 movl $19, 40(%esp) +13000000 +EB05 jmp L6 +8344243C addl $1, 60(%esp) +8B44243C movl 60(%esp), %eax +3B442428 cmpl 40(%esp), %eax +7D20 jge L7 +8B54243C movl 60(%esp), %edx +8B44242C movl 44(%esp), %eax +01D0 addl %edx, %eax +8B4C243C movl 60(%esp), %ecx +8B542430 movl 48(%esp), %edx +01CA addl %ecx, %edx +0FB612 movzbl (%edx), %edx +8810 movb %dl, (%eax) +0FB600 movzbl (%eax), %eax +84C0 testb %al, %al +75D1 jne L8 +8B54243C movl 60(%esp), %edx +8B44242C movl 44(%esp), %eax +01D0 addl %edx, %eax +C60000 movb $0, (%eax) +C7442404 movl $6, 4(%esp) +06000000 +C7042409 movl $LC2, (%esp) +E8000000 call _Console_String +C7442404 movl $20, 4(%esp) +14000000 +C704242C movl $_aa_a20, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +C7442424 movl $_aa_a30, 36(%esp) +00000000 +C7442420 movl $_aa_a10, 32(%esp) +20000000 +C7442438 movl $0, 56(%esp) +00000000 +C744241C movl $9, 28(%esp) +09000000 +EB05 jmp L9 +83442438 addl $1, 56(%esp) +8B442438 movl 56(%esp), %eax +3B44241C cmpl 28(%esp), %eax +7D20 jge L10 +8B542438 movl 56(%esp), %edx +8B442420 movl 32(%esp), %eax +01D0 addl %edx, %eax +8B4C2438 movl 56(%esp), %ecx +8B542424 movl 36(%esp), %edx +01CA addl %ecx, %edx +0FB612 movzbl (%edx), %edx +8810 movb %dl, (%eax) +0FB600 movzbl (%eax), %eax +84C0 testb %al, %al +75D1 jne L11 +8B542438 movl 56(%esp), %edx +8B442420 movl 32(%esp), %eax +01D0 addl %edx, %eax +C60000 movb $0, (%eax) +C7442404 movl $6, 4(%esp) +06000000 +C704240F movl $LC3, (%esp) +E8000000 call _Console_String +C7442404 movl $10, 4(%esp) +0A000000 +C7042420 movl $_aa_a10, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +C7442404 movl $6, 4(%esp) +06000000 +C7042409 movl $LC2, (%esp) +E8000000 call _Console_String +C7442404 movl $20, 4(%esp) +14000000 +C704242C movl $_aa_a20, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +C7442418 movl $_aa_a30, 24(%esp) +00000000 +C7442414 movl $_aa_a10, 20(%esp) +20000000 +C7442434 movl $0, 52(%esp) +00000000 +C7442410 movl $9, 16(%esp) +09000000 +EB05 jmp L12 +83442434 addl $1, 52(%esp) +8B442434 movl 52(%esp), %eax +3B442410 cmpl 16(%esp), %eax +7D20 jge L13 +8B542434 movl 52(%esp), %edx +8B442414 movl 20(%esp), %eax +01D0 addl %edx, %eax +8B4C2434 movl 52(%esp), %ecx +8B542418 movl 24(%esp), %edx +01CA addl %ecx, %edx +0FB612 movzbl (%edx), %edx +8810 movb %dl, (%eax) +0FB600 movzbl (%eax), %eax +84C0 testb %al, %al +75D1 jne L14 +8B542434 movl 52(%esp), %edx +8B442414 movl 20(%esp), %eax +01D0 addl %edx, %eax +C60000 movb $0, (%eax) +C7442404 movl $6, 4(%esp) +06000000 +C704240F movl $LC3, (%esp) +E8000000 call _Console_String +C7442404 movl $10, 4(%esp) +0A000000 +C7042420 movl $_aa_a10, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +C7442404 movl $6, 4(%esp) +06000000 +C7042409 movl $LC2, (%esp) +E8000000 call _Console_String +C7442404 movl $20, 4(%esp) +14000000 +C704242C movl $_aa_a20, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +C7442404 movl $32, 4(%esp) +20000000 +C7042418 movl $LC4, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Heap_FINALL +B8000000 movl $0, %eax +C9 leave +C3 ret diff --git a/src/test/confidence/arrayassignment/test.sh b/src/test/confidence/arrayassignment/test.sh new file mode 100755 index 00000000..c4fd00f5 --- /dev/null +++ b/src/test/confidence/arrayassignment/test.sh @@ -0,0 +1,6 @@ +#!/bin/sh +. ../testenv.sh +rm -f aa # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP aa.mod -m +./aa >result +. ../testresult.sh diff --git a/src/test/confidence/hello/expected b/src/test/confidence/hello/expected new file mode 100644 index 00000000..18832d35 --- /dev/null +++ b/src/test/confidence/hello/expected @@ -0,0 +1 @@ +Hello. diff --git a/src/test/confidence/hello/hello.mod b/src/test/confidence/hello/hello.mod new file mode 100644 index 00000000..c87380ff --- /dev/null +++ b/src/test/confidence/hello/hello.mod @@ -0,0 +1,6 @@ +MODULE hello; +IMPORT Console; + +BEGIN + Console.String("Hello."); Console.Ln; +END hello. diff --git a/src/test/confidence/hello/old.cygwin.ILP32.gcc.s b/src/test/confidence/hello/old.cygwin.ILP32.gcc.s new file mode 100644 index 00000000..ab9053fa --- /dev/null +++ b/src/test/confidence/hello/old.cygwin.ILP32.gcc.s @@ -0,0 +1,60 @@ +55 pushl %ebp +89E5 movl %esp, %ebp +83EC10 subl $16, %esp +C745FC00 movl $0, -4(%ebp) +8B55FC movl -4(%ebp), %edx +8B4508 movl 8(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FB movb %al, -5(%ebp) +8B55FC movl -4(%ebp), %edx +8B450C movl 12(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FA movb %al, -6(%ebp) +8345FC01 addl $1, -4(%ebp) +807DFB00 cmpb $0, -5(%ebp) +7508 jne L2 +0FB645FA movzbl -6(%ebp), %eax +F7D8 negl %eax +EB15 jmp L3 +0FB645FB movzbl -5(%ebp), %eax +3A45FA cmpb -6(%ebp), %al +74C9 je L4 +0FB655FB movzbl -5(%ebp), %edx +0FB645FA movzbl -6(%ebp), %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C9 leave +C3 ret +68656C6C .ascii "hello\0" +48656C6C .ascii "Hello.\0" +000000 .text +55 pushl %ebp +89E5 movl %esp, %ebp +83E4F0 andl $-16, %esp +83EC10 subl $16, %esp +E8000000 call ___main +8D550C leal 12(%ebp), %edx +8B4508 movl 8(%ebp), %eax +98 cwtl +89542404 movl %edx, 4(%esp) +890424 movl %eax, (%esp) +E8000000 call _Platform_Init +E8000000 call _Console__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +C7442404 movl $0, 4(%esp) +00000000 +C7042400 movl $LC0, (%esp) +E8000000 call _Heap_REGMOD +A3000000 movl %eax, _m.1608 +C7442404 movl $7, 4(%esp) +07000000 +C7042406 movl $LC1, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Heap_FINALL +B8000000 movl $0, %eax +C9 leave +C3 ret diff --git a/src/test/confidence/hello/test.sh b/src/test/confidence/hello/test.sh new file mode 100755 index 00000000..e49e2b2a --- /dev/null +++ b/src/test/confidence/hello/test.sh @@ -0,0 +1,5 @@ +#!/bin/sh +. ../testenv.sh +$OBECOMP hello.mod -m +./hello >result +. ../testresult.sh diff --git a/src/test/confidence/in/expected b/src/test/confidence/in/expected new file mode 100644 index 00000000..df0db21e --- /dev/null +++ b/src/test/confidence/in/expected @@ -0,0 +1,14 @@ +--- Testing with Oberon 2 variable model --- +chars: Splurdle +integer: 37 +string: "Bert" +line: rest of line +line: another line + + +--- Testing with Component Pascal variable model --- +chars: Splurdle +integer: 37 +string: "Bert" +line: rest of line +line: another line diff --git a/src/test/confidence/in/intest.mod b/src/test/confidence/in/intest.mod new file mode 100644 index 00000000..cb8d2963 --- /dev/null +++ b/src/test/confidence/in/intest.mod @@ -0,0 +1,16 @@ +MODULE intest; +IMPORT Out, In; + +VAR ch: CHAR; i: INTEGER; s: ARRAY 100 OF CHAR; + +BEGIN + In.Char(ch); Out.String("chars: "); + WHILE In.Done & (ch # ".") DO Out.Char(ch); In.Char(ch) END; + Out.Ln; + In.Int(i); IF In.Done THEN Out.String("integer: "); Out.Int(i,1); Out.Ln END; + In.String(s); IF In.Done THEN Out.String('string: "'); Out.String(s); Out.String('"'); Out.Ln END; + In.Line(s); + WHILE In.Done DO + Out.String("line: "); Out.String(s); Out.Ln; In.Line(s) + END +END intest. diff --git a/src/test/confidence/in/test.sh b/src/test/confidence/in/test.sh new file mode 100644 index 00000000..ee738ab4 --- /dev/null +++ b/src/test/confidence/in/test.sh @@ -0,0 +1,16 @@ +#!/bin/sh +. ../testenv.sh +rm -f intest # Remove LSW binary so it doesn't hide Cygwin binary. +echo 'Splurdle.25H "Bert"rest of line'>input +echo another line>>input +$OBECOMP intest.mod -m -O2 +./intest result-O2 +$OBECOMP intest.mod -m -OC +./intest result-OC +echo --- Testing with Oberon 2 variable model --- >result +cat result-O2 >>result +echo "" >>result +echo "" >>result +echo --- Testing with Component Pascal variable model --- >>result +cat result-OC >>result +. ../testresult.sh diff --git a/src/test/confidence/intsyntax/IntSyntax.mod b/src/test/confidence/intsyntax/IntSyntax.mod new file mode 100644 index 00000000..c5ac799c --- /dev/null +++ b/src/test/confidence/intsyntax/IntSyntax.mod @@ -0,0 +1,18 @@ +MODULE IntSyntax; + +(* Test for error messages generated by incompatible integer types *) + +VAR s: SHORTINT; i: INTEGER; l: LONGINT; + +BEGIN + + l := l; (* Good, same types *) + l := i; (* Good, LONGINT longer than INTEGER *) + l := s; (* Good, LONGINT longer than SHORTINT *) + i := s; (* Good, INTEGER longer then SHORTINT *) + + i := l; (* Bad, INTEGER shorter than LONGINT *) + s := l; (* Bad, SHORTINT shorter than LONGINT *) + i := l; (* Bad, SHORTINT shorter than INTEGER *) + +END IntSyntax. \ No newline at end of file diff --git a/src/test/confidence/intsyntax/expected b/src/test/confidence/intsyntax/expected new file mode 100644 index 00000000..ce0633c4 --- /dev/null +++ b/src/test/confidence/intsyntax/expected @@ -0,0 +1,15 @@ +IntSyntax.mod Compiling IntSyntax. + + 14: i := l; (* Bad, INTEGER shorter than LONGINT *) + ^ + pos 340 err 113 incompatible assignment + + 15: s := l; (* Bad, SHORTINT shorter than LONGINT *) + ^ + pos 392 err 113 incompatible assignment + + 16: i := l; (* Bad, SHORTINT shorter than INTEGER *) + ^ + pos 445 err 113 incompatible assignment + +Module compilation failed. diff --git a/src/test/confidence/intsyntax/test.sh b/src/test/confidence/intsyntax/test.sh new file mode 100644 index 00000000..3929cc8c --- /dev/null +++ b/src/test/confidence/intsyntax/test.sh @@ -0,0 +1,5 @@ +#!/bin/sh +. ../testenv.sh +# Generate mixed source and assembly code listing +$OBECOMP IntSyntax.mod -fm >result +. ../testresult.sh diff --git a/src/test/confidence/isptest/expected b/src/test/confidence/isptest/expected new file mode 100644 index 00000000..b5af3090 --- /dev/null +++ b/src/test/confidence/isptest/expected @@ -0,0 +1,1176 @@ +--- Testing with Oberon 2 variable model --- +pos=2 char=O +pos=3 char=D +pos=4 char=U +pos=5 char=L +pos=6 char=E +pos=7 char= +pos=8 char=i +pos=9 char=s +pos=10 char=p +pos=11 char=t +pos=12 char=e +pos=13 char=s +pos=14 char=t +pos=15 char=; +pos=16 char= +pos=17 char= +pos=18 char=I +pos=19 char=M +pos=20 char=P +pos=21 char=O +pos=22 char=R +pos=23 char=T +pos=24 char= +pos=25 char=F +pos=26 char=i +pos=27 char=l +pos=28 char=e +pos=29 char=s +pos=30 char=, +pos=31 char= +pos=32 char=T +pos=33 char=e +pos=34 char=x +pos=35 char=t +pos=36 char=s +pos=37 char=, +pos=38 char= +pos=39 char=O +pos=40 char=u +pos=41 char=t +pos=42 char=, +pos=43 char= +pos=44 char=P +pos=45 char=l +pos=46 char=a +pos=47 char=t +pos=48 char=f +pos=49 char=o +pos=50 char=r +pos=51 char=m +pos=52 char=; +pos=53 char= +pos=54 char= +pos=55 char=C +pos=56 char=O +pos=57 char=N +pos=58 char=S +pos=59 char=T +pos=60 char= +pos=61 char=p +pos=62 char=a +pos=63 char=t +pos=64 char=h +pos=65 char== +pos=66 char=" +pos=67 char=i +pos=68 char=s +pos=69 char=p +pos=70 char=t +pos=71 char=e +pos=72 char=s +pos=73 char=t +pos=74 char=. +pos=75 char=m +pos=76 char=o +pos=77 char=d +pos=78 char=" +pos=79 char=; +pos=80 char= +pos=81 char= +pos=82 char=V +pos=83 char=A +pos=84 char=R +pos=85 char= +pos=86 char= +pos=87 char= +pos=88 char=T +pos=89 char=: +pos=90 char= +pos=91 char=T +pos=92 char=e +pos=93 char=x +pos=94 char=t +pos=95 char=s +pos=96 char=. +pos=97 char=T +pos=98 char=e +pos=99 char=x +pos=100 char=t +pos=101 char=; +pos=102 char= +pos=103 char= +pos=104 char= +pos=105 char=R +pos=106 char=: +pos=107 char= +pos=108 char=T +pos=109 char=e +pos=110 char=x +pos=111 char=t +pos=112 char=s +pos=113 char=. +pos=114 char=R +pos=115 char=e +pos=116 char=a +pos=117 char=d +pos=118 char=e +pos=119 char=r +pos=120 char=; +pos=121 char= +pos=122 char= +pos=123 char= +pos=124 char=c +pos=125 char=h +pos=126 char=: +pos=127 char= +pos=128 char=C +pos=129 char=H +pos=130 char=A +pos=131 char=R +pos=132 char=; +pos=133 char= +pos=134 char= +pos=135 char= +pos=136 char=i +pos=137 char=, +pos=138 char= +pos=139 char=j +pos=140 char=, +pos=141 char= +pos=142 char=k +pos=143 char= +pos=144 char=: +pos=145 char= +pos=146 char=L +pos=147 char=O +pos=148 char=N +pos=149 char=G +pos=150 char=I +pos=151 char=N +pos=152 char=T +pos=153 char=; +pos=154 char= +pos=155 char=B +pos=156 char=E +pos=157 char=G +pos=158 char=I +pos=159 char=N +pos=160 char= +pos=161 char= +pos=162 char= +pos=163 char=N +pos=164 char=E +pos=165 char=W +pos=166 char=( +pos=167 char=T +pos=168 char=) +pos=169 char=; +pos=170 char= +pos=171 char= +pos=172 char= +pos=173 char=I +pos=174 char=F +pos=175 char= +pos=176 char=F +pos=177 char=i +pos=178 char=l +pos=179 char=e +pos=180 char=s +pos=181 char=. +pos=182 char=O +pos=183 char=l +pos=184 char=d +pos=185 char=( +pos=186 char=p +pos=187 char=a +pos=188 char=t +pos=189 char=h +pos=190 char=) +pos=191 char= +pos=192 char=# +pos=193 char= +pos=194 char=N +pos=195 char=I +pos=196 char=L +pos=197 char= +pos=198 char=T +pos=199 char=H +pos=200 char=E +pos=201 char=N +pos=202 char= +pos=203 char= +pos=204 char= +pos=205 char= +pos=206 char= +pos=207 char=T +pos=208 char=e +pos=209 char=x +pos=210 char=t +pos=211 char=s +pos=212 char=. +pos=213 char=O +pos=214 char=p +pos=215 char=e +pos=216 char=n +pos=217 char=( +pos=218 char=T +pos=219 char=, +pos=220 char= +pos=221 char=p +pos=222 char=a +pos=223 char=t +pos=224 char=h +pos=225 char=) +pos=226 char=; +pos=227 char= +pos=228 char= +pos=229 char= +pos=230 char= +pos=231 char= +pos=232 char=T +pos=233 char=e +pos=234 char=x +pos=235 char=t +pos=236 char=s +pos=237 char=. +pos=238 char=O +pos=239 char=p +pos=240 char=e +pos=241 char=n +pos=242 char=R +pos=243 char=e +pos=244 char=a +pos=245 char=d +pos=246 char=e +pos=247 char=r +pos=248 char=( +pos=249 char=R +pos=250 char=, +pos=251 char= +pos=252 char=T +pos=253 char=, +pos=254 char= +pos=255 char=0 +pos=256 char=) +pos=257 char=; +pos=258 char= +pos=259 char=T +pos=260 char=e +pos=261 char=x +pos=262 char=t +pos=263 char=s +pos=264 char=. +pos=265 char=R +pos=266 char=e +pos=267 char=a +pos=268 char=d +pos=269 char=( +pos=270 char=R +pos=271 char=, +pos=272 char= +pos=273 char=c +pos=274 char=h +pos=275 char=) +pos=276 char=; +pos=277 char= +pos=278 char= +pos=279 char= +pos=280 char= +pos=281 char= +pos=282 char=W +pos=283 char=H +pos=284 char=I +pos=285 char=L +pos=286 char=E +pos=287 char= +pos=288 char=~ +pos=289 char=R +pos=290 char=. +pos=291 char=e +pos=292 char=o +pos=293 char=t +pos=294 char= +pos=295 char=D +pos=296 char=O +pos=297 char= +pos=298 char= +pos=299 char= +pos=300 char= +pos=301 char= +pos=302 char= +pos=303 char= +pos=304 char= +pos=305 char=T +pos=306 char=e +pos=307 char=x +pos=308 char=t +pos=309 char=s +pos=310 char=. +pos=311 char=R +pos=312 char=e +pos=313 char=a +pos=314 char=d +pos=315 char=( +pos=316 char=R +pos=317 char=, +pos=318 char= +pos=319 char=c +pos=320 char=h +pos=321 char=) +pos=322 char=; +pos=323 char= +pos=324 char= +pos=325 char= +pos=326 char= +pos=327 char= +pos=328 char= +pos=329 char= +pos=330 char= +pos=331 char=i +pos=332 char= +pos=333 char=: +pos=334 char== +pos=335 char= +pos=336 char=T +pos=337 char=e +pos=338 char=x +pos=339 char=t +pos=340 char=s +pos=341 char=. +pos=342 char=P +pos=343 char=o +pos=344 char=s +pos=345 char=( +pos=346 char=R +pos=347 char=) +pos=348 char=; +pos=349 char= +pos=350 char= +pos=351 char= +pos=352 char= +pos=353 char= +pos=354 char= +pos=355 char= +pos=356 char= +pos=357 char=O +pos=358 char=u +pos=359 char=t +pos=360 char=. +pos=361 char=S +pos=362 char=t +pos=363 char=r +pos=364 char=i +pos=365 char=n +pos=366 char=g +pos=367 char=( +pos=368 char=" +pos=369 char=p +pos=370 char=o +pos=371 char=s +pos=372 char== +pos=373 char=" +pos=374 char=) +pos=375 char=; +pos=376 char= +pos=377 char=O +pos=378 char=u +pos=379 char=t +pos=380 char=. +pos=381 char=I +pos=382 char=n +pos=383 char=t +pos=384 char=( +pos=385 char=i +pos=386 char=, +pos=387 char=0 +pos=388 char=) +pos=389 char=; +pos=390 char= +pos=391 char=O +pos=392 char=u +pos=393 char=t +pos=394 char=. +pos=395 char=S +pos=396 char=t +pos=397 char=r +pos=398 char=i +pos=399 char=n +pos=400 char=g +pos=401 char=( +pos=402 char=" +pos=403 char= +pos=404 char=c +pos=405 char=h +pos=406 char=a +pos=407 char=r +pos=408 char== +pos=409 char=" +pos=410 char=) +pos=411 char=; +pos=412 char= +pos=413 char=O +pos=414 char=u +pos=415 char=t +pos=416 char=. +pos=417 char=C +pos=418 char=h +pos=419 char=a +pos=420 char=r +pos=421 char=( +pos=422 char=c +pos=423 char=h +pos=424 char=) +pos=425 char=; +pos=426 char= +pos=427 char=O +pos=428 char=u +pos=429 char=t +pos=430 char=. +pos=431 char=C +pos=432 char=h +pos=433 char=a +pos=434 char=r +pos=435 char=( +pos=436 char=0 +pos=437 char=A +pos=438 char=X +pos=439 char=) +pos=440 char=; +pos=441 char= +pos=442 char= +pos=443 char= +pos=444 char= +pos=445 char= +pos=446 char= +pos=447 char= +pos=448 char= +pos=449 char=I +pos=450 char=F +pos=451 char= +pos=452 char=i +pos=453 char= +pos=454 char== +pos=455 char= +pos=456 char=2 +pos=457 char=1 +pos=458 char=9 +pos=459 char=0 +pos=460 char=6 +pos=461 char= +pos=462 char=T +pos=463 char=H +pos=464 char=E +pos=465 char=N +pos=466 char= +pos=467 char= +pos=468 char= +pos=469 char= +pos=470 char= +pos=471 char= +pos=472 char= +pos=473 char= +pos=474 char= +pos=475 char= +pos=476 char=O +pos=477 char=u +pos=478 char=t +pos=479 char=. +pos=480 char=S +pos=481 char=t +pos=482 char=r +pos=483 char=i +pos=484 char=n +pos=485 char=g +pos=486 char=( +pos=487 char=" +pos=488 char=2 +pos=489 char=1 +pos=490 char=9 +pos=491 char=0 +pos=492 char=6 +pos=493 char=" +pos=494 char=) +pos=495 char=; +pos=496 char= +pos=497 char=O +pos=498 char=u +pos=499 char=t +pos=500 char=. +pos=501 char=C +pos=502 char=h +pos=503 char=a +pos=504 char=r +pos=505 char=( +pos=506 char=0 +pos=507 char=A +pos=508 char=X +pos=509 char=) +pos=510 char=; +pos=511 char= +pos=512 char= +pos=513 char= +pos=514 char= +pos=515 char= +pos=516 char= +pos=517 char= +pos=518 char= +pos=519 char= +pos=520 char= +pos=521 char=( +pos=522 char=* +pos=523 char=P +pos=524 char=l +pos=525 char=a +pos=526 char=t +pos=527 char=f +pos=528 char=o +pos=529 char=r +pos=530 char=m +pos=531 char=. +pos=532 char=D +pos=533 char=e +pos=534 char=l +pos=535 char=a +pos=536 char=y +pos=537 char=( +pos=538 char=1 +pos=539 char=0 +pos=540 char=0 +pos=541 char=0 +pos=542 char=0 +pos=543 char=) +pos=544 char=; +pos=545 char=* +pos=546 char=) +pos=547 char= +pos=548 char= +pos=549 char= +pos=550 char= +pos=551 char= +pos=552 char= +pos=553 char= +pos=554 char= +pos=555 char=E +pos=556 char=N +pos=557 char=D +pos=558 char=; +pos=559 char= +pos=560 char= +pos=561 char= +pos=562 char= +pos=563 char= +pos=564 char=E +pos=565 char=N +pos=566 char=D +pos=567 char=; +pos=568 char= +pos=569 char= +pos=570 char= +pos=571 char=E +pos=572 char=N +pos=573 char=D +pos=574 char= +pos=575 char=E +pos=576 char=N +pos=577 char=D +pos=578 char= +pos=579 char=i +pos=580 char=s +pos=581 char=p +pos=582 char=t +pos=583 char=e +pos=584 char=s +pos=585 char=t +pos=586 char=. +pos=587 char= + + +--- Testing with Component Pascal variable model --- +pos=2 char=O +pos=3 char=D +pos=4 char=U +pos=5 char=L +pos=6 char=E +pos=7 char= +pos=8 char=i +pos=9 char=s +pos=10 char=p +pos=11 char=t +pos=12 char=e +pos=13 char=s +pos=14 char=t +pos=15 char=; +pos=16 char= +pos=17 char= +pos=18 char=I +pos=19 char=M +pos=20 char=P +pos=21 char=O +pos=22 char=R +pos=23 char=T +pos=24 char= +pos=25 char=F +pos=26 char=i +pos=27 char=l +pos=28 char=e +pos=29 char=s +pos=30 char=, +pos=31 char= +pos=32 char=T +pos=33 char=e +pos=34 char=x +pos=35 char=t +pos=36 char=s +pos=37 char=, +pos=38 char= +pos=39 char=O +pos=40 char=u +pos=41 char=t +pos=42 char=, +pos=43 char= +pos=44 char=P +pos=45 char=l +pos=46 char=a +pos=47 char=t +pos=48 char=f +pos=49 char=o +pos=50 char=r +pos=51 char=m +pos=52 char=; +pos=53 char= +pos=54 char= +pos=55 char=C +pos=56 char=O +pos=57 char=N +pos=58 char=S +pos=59 char=T +pos=60 char= +pos=61 char=p +pos=62 char=a +pos=63 char=t +pos=64 char=h +pos=65 char== +pos=66 char=" +pos=67 char=i +pos=68 char=s +pos=69 char=p +pos=70 char=t +pos=71 char=e +pos=72 char=s +pos=73 char=t +pos=74 char=. +pos=75 char=m +pos=76 char=o +pos=77 char=d +pos=78 char=" +pos=79 char=; +pos=80 char= +pos=81 char= +pos=82 char=V +pos=83 char=A +pos=84 char=R +pos=85 char= +pos=86 char= +pos=87 char= +pos=88 char=T +pos=89 char=: +pos=90 char= +pos=91 char=T +pos=92 char=e +pos=93 char=x +pos=94 char=t +pos=95 char=s +pos=96 char=. +pos=97 char=T +pos=98 char=e +pos=99 char=x +pos=100 char=t +pos=101 char=; +pos=102 char= +pos=103 char= +pos=104 char= +pos=105 char=R +pos=106 char=: +pos=107 char= +pos=108 char=T +pos=109 char=e +pos=110 char=x +pos=111 char=t +pos=112 char=s +pos=113 char=. +pos=114 char=R +pos=115 char=e +pos=116 char=a +pos=117 char=d +pos=118 char=e +pos=119 char=r +pos=120 char=; +pos=121 char= +pos=122 char= +pos=123 char= +pos=124 char=c +pos=125 char=h +pos=126 char=: +pos=127 char= +pos=128 char=C +pos=129 char=H +pos=130 char=A +pos=131 char=R +pos=132 char=; +pos=133 char= +pos=134 char= +pos=135 char= +pos=136 char=i +pos=137 char=, +pos=138 char= +pos=139 char=j +pos=140 char=, +pos=141 char= +pos=142 char=k +pos=143 char= +pos=144 char=: +pos=145 char= +pos=146 char=L +pos=147 char=O +pos=148 char=N +pos=149 char=G +pos=150 char=I +pos=151 char=N +pos=152 char=T +pos=153 char=; +pos=154 char= +pos=155 char=B +pos=156 char=E +pos=157 char=G +pos=158 char=I +pos=159 char=N +pos=160 char= +pos=161 char= +pos=162 char= +pos=163 char=N +pos=164 char=E +pos=165 char=W +pos=166 char=( +pos=167 char=T +pos=168 char=) +pos=169 char=; +pos=170 char= +pos=171 char= +pos=172 char= +pos=173 char=I +pos=174 char=F +pos=175 char= +pos=176 char=F +pos=177 char=i +pos=178 char=l +pos=179 char=e +pos=180 char=s +pos=181 char=. +pos=182 char=O +pos=183 char=l +pos=184 char=d +pos=185 char=( +pos=186 char=p +pos=187 char=a +pos=188 char=t +pos=189 char=h +pos=190 char=) +pos=191 char= +pos=192 char=# +pos=193 char= +pos=194 char=N +pos=195 char=I +pos=196 char=L +pos=197 char= +pos=198 char=T +pos=199 char=H +pos=200 char=E +pos=201 char=N +pos=202 char= +pos=203 char= +pos=204 char= +pos=205 char= +pos=206 char= +pos=207 char=T +pos=208 char=e +pos=209 char=x +pos=210 char=t +pos=211 char=s +pos=212 char=. +pos=213 char=O +pos=214 char=p +pos=215 char=e +pos=216 char=n +pos=217 char=( +pos=218 char=T +pos=219 char=, +pos=220 char= +pos=221 char=p +pos=222 char=a +pos=223 char=t +pos=224 char=h +pos=225 char=) +pos=226 char=; +pos=227 char= +pos=228 char= +pos=229 char= +pos=230 char= +pos=231 char= +pos=232 char=T +pos=233 char=e +pos=234 char=x +pos=235 char=t +pos=236 char=s +pos=237 char=. +pos=238 char=O +pos=239 char=p +pos=240 char=e +pos=241 char=n +pos=242 char=R +pos=243 char=e +pos=244 char=a +pos=245 char=d +pos=246 char=e +pos=247 char=r +pos=248 char=( +pos=249 char=R +pos=250 char=, +pos=251 char= +pos=252 char=T +pos=253 char=, +pos=254 char= +pos=255 char=0 +pos=256 char=) +pos=257 char=; +pos=258 char= +pos=259 char=T +pos=260 char=e +pos=261 char=x +pos=262 char=t +pos=263 char=s +pos=264 char=. +pos=265 char=R +pos=266 char=e +pos=267 char=a +pos=268 char=d +pos=269 char=( +pos=270 char=R +pos=271 char=, +pos=272 char= +pos=273 char=c +pos=274 char=h +pos=275 char=) +pos=276 char=; +pos=277 char= +pos=278 char= +pos=279 char= +pos=280 char= +pos=281 char= +pos=282 char=W +pos=283 char=H +pos=284 char=I +pos=285 char=L +pos=286 char=E +pos=287 char= +pos=288 char=~ +pos=289 char=R +pos=290 char=. +pos=291 char=e +pos=292 char=o +pos=293 char=t +pos=294 char= +pos=295 char=D +pos=296 char=O +pos=297 char= +pos=298 char= +pos=299 char= +pos=300 char= +pos=301 char= +pos=302 char= +pos=303 char= +pos=304 char= +pos=305 char=T +pos=306 char=e +pos=307 char=x +pos=308 char=t +pos=309 char=s +pos=310 char=. +pos=311 char=R +pos=312 char=e +pos=313 char=a +pos=314 char=d +pos=315 char=( +pos=316 char=R +pos=317 char=, +pos=318 char= +pos=319 char=c +pos=320 char=h +pos=321 char=) +pos=322 char=; +pos=323 char= +pos=324 char= +pos=325 char= +pos=326 char= +pos=327 char= +pos=328 char= +pos=329 char= +pos=330 char= +pos=331 char=i +pos=332 char= +pos=333 char=: +pos=334 char== +pos=335 char= +pos=336 char=T +pos=337 char=e +pos=338 char=x +pos=339 char=t +pos=340 char=s +pos=341 char=. +pos=342 char=P +pos=343 char=o +pos=344 char=s +pos=345 char=( +pos=346 char=R +pos=347 char=) +pos=348 char=; +pos=349 char= +pos=350 char= +pos=351 char= +pos=352 char= +pos=353 char= +pos=354 char= +pos=355 char= +pos=356 char= +pos=357 char=O +pos=358 char=u +pos=359 char=t +pos=360 char=. +pos=361 char=S +pos=362 char=t +pos=363 char=r +pos=364 char=i +pos=365 char=n +pos=366 char=g +pos=367 char=( +pos=368 char=" +pos=369 char=p +pos=370 char=o +pos=371 char=s +pos=372 char== +pos=373 char=" +pos=374 char=) +pos=375 char=; +pos=376 char= +pos=377 char=O +pos=378 char=u +pos=379 char=t +pos=380 char=. +pos=381 char=I +pos=382 char=n +pos=383 char=t +pos=384 char=( +pos=385 char=i +pos=386 char=, +pos=387 char=0 +pos=388 char=) +pos=389 char=; +pos=390 char= +pos=391 char=O +pos=392 char=u +pos=393 char=t +pos=394 char=. +pos=395 char=S +pos=396 char=t +pos=397 char=r +pos=398 char=i +pos=399 char=n +pos=400 char=g +pos=401 char=( +pos=402 char=" +pos=403 char= +pos=404 char=c +pos=405 char=h +pos=406 char=a +pos=407 char=r +pos=408 char== +pos=409 char=" +pos=410 char=) +pos=411 char=; +pos=412 char= +pos=413 char=O +pos=414 char=u +pos=415 char=t +pos=416 char=. +pos=417 char=C +pos=418 char=h +pos=419 char=a +pos=420 char=r +pos=421 char=( +pos=422 char=c +pos=423 char=h +pos=424 char=) +pos=425 char=; +pos=426 char= +pos=427 char=O +pos=428 char=u +pos=429 char=t +pos=430 char=. +pos=431 char=C +pos=432 char=h +pos=433 char=a +pos=434 char=r +pos=435 char=( +pos=436 char=0 +pos=437 char=A +pos=438 char=X +pos=439 char=) +pos=440 char=; +pos=441 char= +pos=442 char= +pos=443 char= +pos=444 char= +pos=445 char= +pos=446 char= +pos=447 char= +pos=448 char= +pos=449 char=I +pos=450 char=F +pos=451 char= +pos=452 char=i +pos=453 char= +pos=454 char== +pos=455 char= +pos=456 char=2 +pos=457 char=1 +pos=458 char=9 +pos=459 char=0 +pos=460 char=6 +pos=461 char= +pos=462 char=T +pos=463 char=H +pos=464 char=E +pos=465 char=N +pos=466 char= +pos=467 char= +pos=468 char= +pos=469 char= +pos=470 char= +pos=471 char= +pos=472 char= +pos=473 char= +pos=474 char= +pos=475 char= +pos=476 char=O +pos=477 char=u +pos=478 char=t +pos=479 char=. +pos=480 char=S +pos=481 char=t +pos=482 char=r +pos=483 char=i +pos=484 char=n +pos=485 char=g +pos=486 char=( +pos=487 char=" +pos=488 char=2 +pos=489 char=1 +pos=490 char=9 +pos=491 char=0 +pos=492 char=6 +pos=493 char=" +pos=494 char=) +pos=495 char=; +pos=496 char= +pos=497 char=O +pos=498 char=u +pos=499 char=t +pos=500 char=. +pos=501 char=C +pos=502 char=h +pos=503 char=a +pos=504 char=r +pos=505 char=( +pos=506 char=0 +pos=507 char=A +pos=508 char=X +pos=509 char=) +pos=510 char=; +pos=511 char= +pos=512 char= +pos=513 char= +pos=514 char= +pos=515 char= +pos=516 char= +pos=517 char= +pos=518 char= +pos=519 char= +pos=520 char= +pos=521 char=( +pos=522 char=* +pos=523 char=P +pos=524 char=l +pos=525 char=a +pos=526 char=t +pos=527 char=f +pos=528 char=o +pos=529 char=r +pos=530 char=m +pos=531 char=. +pos=532 char=D +pos=533 char=e +pos=534 char=l +pos=535 char=a +pos=536 char=y +pos=537 char=( +pos=538 char=1 +pos=539 char=0 +pos=540 char=0 +pos=541 char=0 +pos=542 char=0 +pos=543 char=) +pos=544 char=; +pos=545 char=* +pos=546 char=) +pos=547 char= +pos=548 char= +pos=549 char= +pos=550 char= +pos=551 char= +pos=552 char= +pos=553 char= +pos=554 char= +pos=555 char=E +pos=556 char=N +pos=557 char=D +pos=558 char=; +pos=559 char= +pos=560 char= +pos=561 char= +pos=562 char= +pos=563 char= +pos=564 char=E +pos=565 char=N +pos=566 char=D +pos=567 char=; +pos=568 char= +pos=569 char= +pos=570 char= +pos=571 char=E +pos=572 char=N +pos=573 char=D +pos=574 char= +pos=575 char=E +pos=576 char=N +pos=577 char=D +pos=578 char= +pos=579 char=i +pos=580 char=s +pos=581 char=p +pos=582 char=t +pos=583 char=e +pos=584 char=s +pos=585 char=t +pos=586 char=. +pos=587 char= diff --git a/src/test/confidence/isptest/isptest.mod b/src/test/confidence/isptest/isptest.mod new file mode 100644 index 00000000..86fb0fb9 --- /dev/null +++ b/src/test/confidence/isptest/isptest.mod @@ -0,0 +1,27 @@ +MODULE isptest; + +IMPORT Files, Texts, Out, Platform; + +CONST path="isptest.mod"; + +VAR + T: Texts.Text; + R: Texts.Reader; + ch: CHAR; + i, j, k : LONGINT; +BEGIN + NEW(T); + IF Files.Old(path) # NIL THEN + Texts.Open(T, path); + Texts.OpenReader(R, T, 0); Texts.Read(R, ch); + WHILE ~R.eot DO + Texts.Read(R, ch); + i := Texts.Pos(R); + Out.String("pos="); Out.Int(i,0); Out.String(" char="); Out.Char(ch); Out.Char(0AX); + IF i = 21906 THEN + Out.String("21906"); Out.Char(0AX); + (*Platform.Delay(10000);*) + END; + END; + END +END isptest. \ No newline at end of file diff --git a/src/test/confidence/isptest/test.sh b/src/test/confidence/isptest/test.sh new file mode 100644 index 00000000..49e2dfdd --- /dev/null +++ b/src/test/confidence/isptest/test.sh @@ -0,0 +1,13 @@ +#!/bin/sh +. ../testenv.sh +$OBECOMP isptest.mod -m -O2 +./isptest >result-O2 +$OBECOMP isptest.mod -m -OC +./isptest >result-OC +echo --- Testing with Oberon 2 variable model --- >result +cat result-O2 >>result +echo "" >>result +echo "" >>result +echo --- Testing with Component Pascal variable model --- >>result +cat result-OC >>result +. ../testresult.sh diff --git a/src/test/confidence/language/TestLanguage.mod b/src/test/confidence/language/TestLanguage.mod new file mode 100644 index 00000000..7399b006 --- /dev/null +++ b/src/test/confidence/language/TestLanguage.mod @@ -0,0 +1,298 @@ +MODULE TestLanguage; + +IMPORT SYSTEM, Console; + + VAR gz: LONGREAL; + +PROCEDURE TestShiftResult(of, by, actual, expected: LONGINT; msg: ARRAY OF CHAR); +BEGIN + IF actual # expected THEN + Console.String(msg); + Console.String(" of $"); Console.Hex(of); + Console.String(" by "); Console.Int(by,1); + Console.String(" is $"); Console.Hex(actual); + Console.String(" but should be $"); Console.Hex(expected); + Console.Ln; + END +END TestShiftResult; + +PROCEDURE Shift; +VAR c: CHAR; b: SYSTEM.BYTE; s,t,u: SHORTINT; h,i,j,k: INTEGER; l,m,n,r: LONGINT; +(* + Aritmetic shift always returns type LONGINT. Defined as x * 2**n. + LSH and ROT produces results of the same type as the value being shifted. +*) +BEGIN + (* Positive LSH shifts and ROTs without overflow *) + + i := 0; m := 1; + WHILE i < SIZE(LONGINT)*8 DO + l := 1; r := SYSTEM.LSH(l,i); TestShiftResult(l, i, r, m, "LSH"); + l := 1; r := SYSTEM.ROT(l,i); TestShiftResult(l, i, r, m, "ROT(1)"); + m := m * 2; INC(i); + END; + + i := 0; k := 1; + WHILE i < SIZE(INTEGER)*8 DO + j := 1; j := SYSTEM.LSH(j,i); ASSERT(j = k, 23); + j := 1; j := SYSTEM.ROT(j,i); ASSERT(j = k, 24); + k := k * 2; INC(i); + END; + + i := 0; t := 1; + WHILE i < SIZE(SHORTINT)*8 DO + s := 1; s := SYSTEM.LSH(s,i); ASSERT(s = t, 30); + s := 1; s := SYSTEM.ROT(s,i); ASSERT(s = t, 31); + t := t * 2; INC(i); + END; + + (* Negative LSH shifts and ROTs without overflow *) + + i := -1; m := 1; m := SYSTEM.LSH(m, SIZE(LONGINT)*8 - 2); n := m*2; + WHILE i > -SIZE(LONGINT)*8 DO + l := n; l := SYSTEM.LSH(l,i); ASSERT(l = m, 39); + l := n; l := SYSTEM.ROT(l,i); ASSERT(l = m, 40); + m := m DIV 2; DEC(i); + END; + + i := -1; k := 1; k := SYSTEM.LSH(k, SIZE(INTEGER)*8 - 2); h := k*2; + WHILE i > -SIZE(INTEGER)*8 DO + j := h; j := SYSTEM.LSH(j,i); ASSERT(j = k, 46); + j := h; j := SYSTEM.ROT(j,i); ASSERT(j = k, 47); + k := k DIV 2; DEC(i); + END; + + i := -1; t := 1; t := SYSTEM.LSH(t, SIZE(SHORTINT)*8 - 2); u := t*2; + WHILE i > -SIZE(SHORTINT)*8 DO + s := u; s := SYSTEM.LSH(s,i); ASSERT(s = t, 53); + s := u; s := SYSTEM.ROT(s,i); ASSERT(s = t, 54); + t := t DIV 2; DEC(i); + END; + + (* Positive ASHs of a negative number *) + + i := 0; m := 1; m := SYSTEM.LSH(m, SIZE(LONGINT)*8 - 1); n := m; + WHILE i > -SIZE(LONGINT)*8 DO + l := n; l := ASH(l,i); ASSERT(l = m, 62); + m := m DIV 2; DEC(i); + END; + + i := 0; j := 1; j := SYSTEM.LSH(j, SIZE(INTEGER)*8 - 1); k := j; + WHILE i > -SIZE(INTEGER)*8 DO + l := ASH(j,i); ASSERT(l = LONG(k), 68); + k := k DIV 2; DEC(i); + END; + + i := 0; s := 1; s := SYSTEM.LSH(s, SIZE(SHORTINT)*8 - 1); t := s; + WHILE i > -SIZE(SHORTINT)*8 DO + l := ASH(s,i); ASSERT(l = LONG(LONG(t)), 74); + t := t DIV 2; DEC(i); + END; + + (* Positive ASHs of a positive number *) + + i := 0; m := 1; m := SYSTEM.LSH(m, SIZE(LONGINT)*8 - 2); n := m; + WHILE i > 1-SIZE(LONGINT)*8 DO + l := n; l := ASH(l,i); ASSERT(l = m, 82); + m := m DIV 2; DEC(i); + END; + + + (* Positive LSH shifts and ROTs with overflow *) + + i := 1; m := 1; + WHILE i < SIZE(LONGINT)*8 DO + l := MAX(LONGINT); INC(l); r := SYSTEM.LSH(l,i); TestShiftResult(l, i, r, 0, "LSH"); + l := MAX(LONGINT); INC(l); r := SYSTEM.ROT(l,i); TestShiftResult(l, i, r, m, "ROT(2)"); + m := m * 2; INC(i); + END; + + i := 1; k := 1; + WHILE i < SIZE(INTEGER)*8 DO + j := MAX(INTEGER); INC(j); r := SYSTEM.LSH(j,i); TestShiftResult(j, i, r, 0, "LSH"); + j := MAX(INTEGER); INC(j); r := SYSTEM.ROT(j,i); TestShiftResult(j, i, r, k, "ROT(3)"); + k := k * 2; INC(i); + END; + + i := 1; t := 1; + WHILE i < SIZE(SHORTINT)*8 DO + s := MAX(SHORTINT); INC(s); r := SYSTEM.LSH(s,i); TestShiftResult(s, i, r, 0, "LSH"); + s := MAX(SHORTINT); INC(s); r := SYSTEM.ROT(s,i); TestShiftResult(s, i, r, t, "ROT(4)"); + t := t * 2; INC(i); + END; + + (* Negative LSH shifts and ROTs without overflow *) + + i := -1; m := MAX(LONGINT); INC(m); + WHILE i > -SIZE(LONGINT)*8 DO + l := 1; r := SYSTEM.LSH(l,i); TestShiftResult(l, i, r, 0, "LSH"); + l := 1; r := SYSTEM.ROT(l,i); TestShiftResult(l, i, r, m, "ROT"); + m := SYSTEM.LSH(m,-1); (* m := m DIV 2; *) + DEC(i); + END; + + i := -1; k := MAX(INTEGER); INC(k); + WHILE i > -SIZE(INTEGER)*8 DO + j := 1; r := SYSTEM.LSH(j,i); TestShiftResult(j, i, r, 0, "LSH"); + j := 1; r := SYSTEM.ROT(j,i); TestShiftResult(j, i, r, k, "ROT"); + k := SYSTEM.LSH(k,-1); (* k := k DIV 2; *) + DEC(i); + END; + + i := -1; t := MAX(SHORTINT); INC(t); + WHILE i > -SIZE(SHORTINT)*8 DO + s := 1; r := SYSTEM.LSH(s,i); TestShiftResult(s, i, r, 0, "LSH"); + s := 1; r := SYSTEM.ROT(s,i); TestShiftResult(s, i, r, t, "ROT"); + t := SYSTEM.LSH(t,-1); (* t := t DIV 2; *) + DEC(i); + END; + + + (* Also need full tests for CHAR, and poossibly SYSTEM.BYTE. Here's a simple one *) + + c := 1X; c := SYSTEM.LSH(c,2); c := SYSTEM.ROT(c,-2); ASSERT(c=1X, 93); + b := 1; b := SYSTEM.LSH(b,2); b := SYSTEM.ROT(b,-2); ASSERT(SYSTEM.VAL(CHAR,b)=1X, 94); + +END Shift; + + +PROCEDURE TestValue(v,e: LONGINT; name: ARRAY OF CHAR); +BEGIN + IF v # e THEN + Console.String(name); + Console.String(" = "); + Console.Int(v,1); + Console.String(", expected "); + Console.Int(e,1); + Console.Ln; + END +END TestValue; + + +PROCEDURE side(i: INTEGER): INTEGER; BEGIN RETURN i END side; + +PROCEDURE DivMod; + VAR i,j: INTEGER; +BEGIN + j := 2; + i := 4; TestValue(i DIV j, 2, "4 DIV 2"); TestValue(side(i) DIV side(j), 2, "side(4) DIV side(2)"); + i := 5; TestValue(i DIV j, 2, "5 DIV 2"); TestValue(side(i) DIV side(j), 2, "side(5) DIV side(2)"); + i := 6; TestValue(i DIV j, 3, "6 DIV 2"); TestValue(side(i) DIV side(j), 3, "side(6) DIV side(2)"); + i := 7; TestValue(i DIV j, 3, "7 DIV 2"); TestValue(side(i) DIV side(j), 3, "side(7) DIV side(2)"); + i := -4; TestValue(i DIV j, -2, "(-4) DIV 2"); TestValue(side(i) DIV side(j), -2, "side(-4) DIV side(2)"); + i := -5; TestValue(i DIV j, -3, "(-5) DIV 2"); TestValue(side(i) DIV side(j), -3, "side(-5) DIV side(2)"); + i := -6; TestValue(i DIV j, -3, "(-6) DIV 2"); TestValue(side(i) DIV side(j), -3, "side(-6) DIV side(2)"); + i := -7; TestValue(i DIV j, -4, "(-7) DIV 2"); TestValue(side(i) DIV side(j), -4, "side(-7) DIV side(2)"); + + j := -2; + i := 4; TestValue(i DIV j, -2, "4 DIV (-2)"); TestValue(side(i) DIV side(j), -2, "side(4) DIV side(-2)"); + i := 5; TestValue(i DIV j, -3, "5 DIV (-2)"); TestValue(side(i) DIV side(j), -3, "side(5) DIV side(-2)"); + i := 6; TestValue(i DIV j, -3, "6 DIV (-2)"); TestValue(side(i) DIV side(j), -3, "side(6) DIV side(-2)"); + i := 7; TestValue(i DIV j, -4, "7 DIV (-2)"); TestValue(side(i) DIV side(j), -4, "side(7) DIV side(-2)"); + i := -4; TestValue(i DIV j, 2, "(-4) DIV (-2)"); TestValue(side(i) DIV side(j), 2, "side(-4) DIV side(-2)"); + i := -5; TestValue(i DIV j, 2, "(-5) DIV (-2)"); TestValue(side(i) DIV side(j), 2, "side(-5) DIV side(-2)"); + i := -6; TestValue(i DIV j, 3, "(-6) DIV (-2)"); TestValue(side(i) DIV side(j), 3, "side(-6) DIV side(-2)"); + i := -7; TestValue(i DIV j, 3, "(-7) DIV (-2)"); TestValue(side(i) DIV side(j), 3, "side(-7) DIV side(-2)"); + + (* x = (x DIV y) * y + (x MOD y) + => x MOd y = x - ((x DIV y) * y) + *) + + i := 4; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "4 MOD 3"); + i := 5; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "5 MOD 3"); + i := 6; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "6 MOD 3"); + i := 7; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "7 MOD 3"); + + i := -4; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "-4 MOD 3"); + i := -5; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "-5 MOD 3"); + i := -6; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "-6 MOD 3"); + i := -7; j := 3; TestValue(i MOD j, i - ((i DIV j) * j), "-7 MOD 3"); + + i := 4; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "4 MOD -3"); + i := 5; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "5 MOD -3"); + i := 6; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "6 MOD -3"); + i := 7; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "7 MOD -3"); + + i := -4; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "-4 MOD -3"); + i := -5; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "-5 MOD -3"); + i := -6; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "-6 MOD -3"); + i := -7; j := -3; TestValue(i MOD j, i - ((i DIV j) * j), "-7 MOD -3"); +END DivMod; + + + + +PROCEDURE Abs; + VAR + i: INTEGER; + l: LONGINT; + h: SYSTEM.INT64; +BEGIN + i := 5; TestValue(ABS(i), 5, "ABS(INTEGER 5)"); + i := -5; TestValue(ABS(i), 5, "ABS(INTEGER -5)"); + l := 5; TestValue(ABS(l), 5, "ABS(LONGINT 5)"); + l := -5; TestValue(ABS(l), 5, "ABS(LONGINT -5)"); + h := 5; TestValue(SYSTEM.VAL(LONGINT,ABS(h)), 5, "ABS(SYSTEM.INT64 5)"); + h := -5; TestValue(SYSTEM.VAL(LONGINT,ABS(h)), 5, "ABS(SYSTEM.INT64 -5)"); +END Abs; + + + +(* LR does nothing numerically, but is enough to stop the C compiler + optimizing away the LR assignment and ENTIER implementation. *) +PROCEDURE LR(lr: LONGREAL): LONGREAL; BEGIN RETURN lr + gz; END LR; + +PROCEDURE Entier; + VAR lr: LONGREAL; +BEGIN + gz := 0.0; + lr := LR(-0.01); TestValue(ENTIER(lr), -1, "ENTIER(-0.01"); + lr := LR( 0.00); TestValue(ENTIER(lr), 0, "ENTIER(0.00"); + lr := LR( 5.00); TestValue(ENTIER(lr), 5, "ENTIER(5.00"); + lr := LR( 5.50); TestValue(ENTIER(lr), 5, "ENTIER(5.50"); + lr := LR( 5.99); TestValue(ENTIER(lr), 5, "ENTIER(5.99"); + lr := LR(-5.00); TestValue(ENTIER(lr), -5, "ENTIER(-5.00"); + lr := LR(-5.50); TestValue(ENTIER(lr), -6, "ENTIER(-5.50"); + lr := LR(-5.99); TestValue(ENTIER(lr), -6, "ENTIER(-5.99"); +END Entier; + + + + +PROCEDURE IntSize; + VAR l: LONGINT; +BEGIN + TestValue(MIN(SHORTINT), -80H, "MIN(SHORTINT)"); + TestValue(MAX(SHORTINT), 7FH, "MAX(SHORTINT)"); + IF SIZE(INTEGER) = 2 THEN (* 32 bit machine *) + TestValue(MIN(INTEGER), -7FFFH - 1, "MIN(INTEGER)"); + TestValue(MAX(INTEGER), 7FFFH, "MAX(INTEGER)"); + TestValue(MIN(LONGINT), -7FFFFFFFH - 1, "MIN(LONGINT)"); + TestValue(MAX(LONGINT), 7FFFFFFFH, "MAX(LONGINT)"); + ELSIF SIZE(INTEGER) = 4 THEN (* 64 bit machine *) + TestValue(MIN(INTEGER), -7FFFFFFFH - 1, "MIN(INTEGER)"); + TestValue(MAX(INTEGER), 7FFFFFFFH, "MAX(INTEGER)"); + (* Since we need to be compilable on 32 bit machines we cannot use + a 64 bit constant, so use arithmetic. *) + l := 1; l := SYSTEM.LSH(l, 63); l := l-1; (* Generate l = 7FFFFFFFFFFFFFFFH *) + TestValue(MIN(LONGINT), -l - 1, "MIN(LONGINT)"); + TestValue(MAX(LONGINT), l, "MAX(LONGINT)"); + ELSE + Console.String("SIZE(INTEGER) = "); + Console.Int(SIZE(INTEGER),1); + Console.String(", expected 2 or 4."); + Console.Ln; + END; +END IntSize; + + + + +BEGIN + Shift; + DivMod; + IntSize; + Abs; + Entier; + Console.String("Language tests successful."); Console.Ln; +END TestLanguage. diff --git a/src/test/confidence/language/expected b/src/test/confidence/language/expected new file mode 100644 index 00000000..041933c1 --- /dev/null +++ b/src/test/confidence/language/expected @@ -0,0 +1 @@ +Language tests successful. diff --git a/src/test/confidence/language/old.cygwin.ILP32.gcc.s b/src/test/confidence/language/old.cygwin.ILP32.gcc.s new file mode 100644 index 00000000..4e35c971 --- /dev/null +++ b/src/test/confidence/language/old.cygwin.ILP32.gcc.s @@ -0,0 +1,541 @@ +55 pushl %ebp +89E5 movl %esp, %ebp +83EC10 subl $16, %esp +C745FC00 movl $0, -4(%ebp) +8B55FC movl -4(%ebp), %edx +8B4508 movl 8(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FB movb %al, -5(%ebp) +8B55FC movl -4(%ebp), %edx +8B450C movl 12(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FA movb %al, -6(%ebp) +8345FC01 addl $1, -4(%ebp) +807DFB00 cmpb $0, -5(%ebp) +7508 jne L2 +0FB645FA movzbl -6(%ebp), %eax +F7D8 negl %eax +EB15 jmp L3 +0FB645FB movzbl -5(%ebp), %eax +3A45FA cmpb -6(%ebp), %al +74C9 je L4 +0FB655FB movzbl -5(%ebp), %edx +0FB645FA movzbl -6(%ebp), %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C9 leave +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +53 pushl %ebx +83EC34 subl $52, %esp +66C745F4 movw $0, -12(%ebp) +C745EC01 movl $1, -20(%ebp) +E9BE0000 jmp L6 +C745E801 movl $1, -24(%ebp) +66837DF4 cmpw $0, -12(%ebp) +780F js L7 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB0F jmp L8 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3EA shrl %cl, %edx +89D0 movl %edx, %eax +8945E8 movl %eax, -24(%ebp) +8B45E8 movl -24(%ebp), %eax +3B45EC cmpl -20(%ebp), %eax +740C je L9 +C7042410 movl $16, (%esp) +E8000000 call _Platform_AssertFail +C745E801 movl $1, -24(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7827 js L10 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +89D3 movl %edx, %ebx +89C1 movl %eax, %ecx +D3E3 sall %cl, %ebx +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +B9200000 movl $32, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3EA shrl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB21 jmp L11 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89D3 movl %edx, %ebx +89C1 movl %eax, %ecx +D3EB shrl %cl, %ebx +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +83C020 addl $32, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +8945E8 movl %eax, -24(%ebp) +8B45E8 movl -24(%ebp), %eax +3B45EC cmpl -20(%ebp), %eax +740C je L12 +C7042411 movl $17, (%esp) +E8000000 call _Platform_AssertFail +D165EC sall -20(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83C001 addl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $31, -12(%ebp) +0F8E37FF jle L13 +66C745F4 movw $0, -12(%ebp) +66C745F2 movw $1, -14(%ebp) +E9E50000 jmp L14 +66C745E6 movw $1, -26(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7813 js L15 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB13 jmp L16 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +668945E6 movw %ax, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +663B45F2 cmpw -14(%ebp), %ax +740C je L17 +C7042417 movl $23, (%esp) +E8000000 call _Platform_AssertFail +66C745E6 movw $1, -26(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7831 js L18 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +B9100000 movl $16, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB2B jmp L19 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +83C010 addl $16, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +668945E6 movw %ax, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +663B45F2 cmpw -14(%ebp), %ax +740C je L20 +C7042418 movl $24, (%esp) +E8000000 call _Platform_AssertFail +0FBF45F2 movswl -14(%ebp), %eax +01C0 addl %eax, %eax +668945F2 movw %ax, -14(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83C001 addl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $15, -12(%ebp) +0F8E10FF jle L21 +66C745F4 movw $0, -12(%ebp) +C645F701 movb $1, -9(%ebp) +E9DC0000 jmp L22 +C645E501 movb $1, -27(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7813 js L23 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB13 jmp L24 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +8845E5 movb %al, -27(%ebp) +0FB645E5 movzbl -27(%ebp), %eax +3A45F7 cmpb -9(%ebp), %al +740C je L25 +C704241E movl $30, (%esp) +E8000000 call _Platform_AssertFail +C645E501 movb $1, -27(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7831 js L26 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +B9080000 movl $8, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB2B jmp L27 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +83C008 addl $8, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +8845E5 movb %al, -27(%ebp) +0FB645E5 movzbl -27(%ebp), %eax +3A45F7 cmpb -9(%ebp), %al +740C je L28 +C704241F movl $31, (%esp) +E8000000 call _Platform_AssertFail +0FBE45F7 movsbl -9(%ebp), %eax +01C0 addl %eax, %eax +8845F7 movb %al, -9(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83C001 addl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $7, -12(%ebp) +0F8E19FF jle L29 +66C745F4 movw $-1, -12(%ebp) +C745EC01 movl $1, -20(%ebp) +8B45EC movl -20(%ebp), %eax +C1E01E sall $30, %eax +8945EC movl %eax, -20(%ebp) +8B45EC movl -20(%ebp), %eax +01C0 addl %eax, %eax +8945E0 movl %eax, -32(%ebp) +E9BC0000 jmp L30 +8B45E0 movl -32(%ebp), %eax +8945E8 movl %eax, -24(%ebp) +66837DF4 cmpw $0, -12(%ebp) +780F js L31 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB0F jmp L32 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3EA shrl %cl, %edx +89D0 movl %edx, %eax +8945E8 movl %eax, -24(%ebp) +8B45E8 movl -24(%ebp), %eax +3B45EC cmpl -20(%ebp), %eax +740C je L33 +C7042427 movl $39, (%esp) +E8000000 call _Platform_AssertFail +8B45E0 movl -32(%ebp), %eax +8945E8 movl %eax, -24(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7827 js L34 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +89D3 movl %edx, %ebx +89C1 movl %eax, %ecx +D3E3 sall %cl, %ebx +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +B9200000 movl $32, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3EA shrl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB21 jmp L35 +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89D3 movl %edx, %ebx +89C1 movl %eax, %ecx +D3EB shrl %cl, %ebx +8B55E8 movl -24(%ebp), %edx +0FBF45F4 movswl -12(%ebp), %eax +83C020 addl $32, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +8945E8 movl %eax, -24(%ebp) +8B45E8 movl -24(%ebp), %eax +3B45EC cmpl -20(%ebp), %eax +740C je L36 +C7042428 movl $40, (%esp) +E8000000 call _Platform_AssertFail +D17DEC sarl -20(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83E801 subl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $-31, -12(%ebp) +0F8D39FF jge L37 +66C745F4 movw $-1, -12(%ebp) +66C745F2 movw $1, -14(%ebp) +0FB745F2 movzwl -14(%ebp), %eax +0FB7C0 movzwl %ax, %eax +C1E00E sall $14, %eax +668945F2 movw %ax, -14(%ebp) +0FBF45F2 movswl -14(%ebp), %eax +01C0 addl %eax, %eax +668945DE movw %ax, -34(%ebp) +E9E30000 jmp L38 +0FB745DE movzwl -34(%ebp), %eax +668945E6 movw %ax, -26(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7813 js L39 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB13 jmp L40 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +668945E6 movw %ax, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +663B45F2 cmpw -14(%ebp), %ax +740C je L41 +C704242E movl $46, (%esp) +E8000000 call _Platform_AssertFail +0FB745DE movzwl -34(%ebp), %eax +668945E6 movw %ax, -26(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7831 js L42 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +B9100000 movl $16, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB2B jmp L43 +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB745E6 movzwl -26(%ebp), %eax +0FB7D0 movzwl %ax, %edx +0FBF45F4 movswl -12(%ebp), %eax +83C010 addl $16, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +668945E6 movw %ax, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +663B45F2 cmpw -14(%ebp), %ax +740C je L44 +C704242F movl $47, (%esp) +E8000000 call _Platform_AssertFail +66D17DF2 sarw -14(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83E801 subl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $-15, -12(%ebp) +0F8D12FF jge L45 +66C745F4 movw $-1, -12(%ebp) +C645F701 movb $1, -9(%ebp) +0FB645F7 movzbl -9(%ebp), %eax +0FB6C0 movzbl %al, %eax +C1E006 sall $6, %eax +8845F7 movb %al, -9(%ebp) +0FBE45F7 movsbl -9(%ebp), %eax +01C0 addl %eax, %eax +8845DD movb %al, -35(%ebp) +E9DC0000 jmp L46 +0FB645DD movzbl -35(%ebp), %eax +8845E5 movb %al, -27(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7813 js L47 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB13 jmp L48 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +8845E5 movb %al, -27(%ebp) +0FB645E5 movzbl -27(%ebp), %eax +3A45F7 cmpb -9(%ebp), %al +740C je L49 +C7042435 movl $53, (%esp) +E8000000 call _Platform_AssertFail +0FB645DD movzbl -35(%ebp), %eax +8845E5 movb %al, -27(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7831 js L50 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +B9080000 movl $8, %ecx +29C1 subl %eax, %ecx +89C8 movl %ecx, %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +EB2B jmp L51 +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +89C3 movl %eax, %ebx +0FB645E5 movzbl -27(%ebp), %eax +0FB6D0 movzbl %al, %edx +0FBF45F4 movswl -12(%ebp), %eax +83C008 addl $8, %eax +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +09D8 orl %ebx, %eax +8845E5 movb %al, -27(%ebp) +0FB645E5 movzbl -27(%ebp), %eax +3A45F7 cmpb -9(%ebp), %al +740C je L52 +C7042436 movl $54, (%esp) +E8000000 call _Platform_AssertFail +D07DF7 sarb -9(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83E801 subl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $-7, -12(%ebp) +0F8D19FF jge L53 +66C745F4 movw $0, -12(%ebp) +C745EC01 movl $1, -20(%ebp) +8B45EC movl -20(%ebp), %eax +C1E01F sall $31, %eax +8945EC movl %eax, -20(%ebp) +8B45EC movl -20(%ebp), %eax +8945E0 movl %eax, -32(%ebp) +EB50 jmp L54 +8B45E0 movl -32(%ebp), %eax +8945E8 movl %eax, -24(%ebp) +66837DF4 cmpw $0, -12(%ebp) +780F js L55 +0FBF45F4 movswl -12(%ebp), %eax +8B55E8 movl -24(%ebp), %edx +89C1 movl %eax, %ecx +D3E2 sall %cl, %edx +89D0 movl %edx, %eax +EB0F jmp L56 +0FBF45F4 movswl -12(%ebp), %eax +F7D8 negl %eax +8B55E8 movl -24(%ebp), %edx +89C1 movl %eax, %ecx +D3FA sarl %cl, %edx +89D0 movl %edx, %eax +8945E8 movl %eax, -24(%ebp) +8B45E8 movl -24(%ebp), %eax +3B45EC cmpl -20(%ebp), %eax +740C je L57 +C704243E movl $62, (%esp) +E8000000 call _Platform_AssertFail +D17DEC sarl -20(%ebp) +0FB745F4 movzwl -12(%ebp), %eax +83E801 subl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $-31, -12(%ebp) +7DA9 jge L58 +66C745F4 movw $0, -12(%ebp) +66C745E6 movw $1, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +0FB7C0 movzwl %ax, %eax +C1E00F sall $15, %eax +668945E6 movw %ax, -26(%ebp) +0FB745E6 movzwl -26(%ebp), %eax +668945F2 movw %ax, -14(%ebp) diff --git a/src/test/confidence/language/test.sh b/src/test/confidence/language/test.sh new file mode 100755 index 00000000..27b9f951 --- /dev/null +++ b/src/test/confidence/language/test.sh @@ -0,0 +1,7 @@ +#!/bin/sh +. ../testenv.sh +# Generate mixed source and assembly code listing +rm -f TestLanguage # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP TestLanguage.mod -m +./TestLanguage >result +. ../testresult.sh diff --git a/src/test/confidence/language/updateassertions.pl b/src/test/confidence/language/updateassertions.pl new file mode 100644 index 00000000..70b8063f --- /dev/null +++ b/src/test/confidence/language/updateassertions.pl @@ -0,0 +1,16 @@ +#!perl -w +use strict; +use warnings; + +my ($fn) = @ARGV; + +open MOD,$fn // die "Could not open $fn."; +while () { + if (/^(.*)ASSERT\((.*?)(, +[0-9]+)\)(.*$)/) { + print $1, "ASSERT($2, $.)", $4, "\n"; + } else { + print $_; + } +} + +close MOD; diff --git a/src/test/confidence/library/TestLibrary.mod b/src/test/confidence/library/TestLibrary.mod new file mode 100644 index 00000000..32f7c91b --- /dev/null +++ b/src/test/confidence/library/TestLibrary.mod @@ -0,0 +1,99 @@ +MODULE TestLibrary; + +IMPORT SYSTEM, Oberon, Texts, Reals, oocLowReal; + +VAR W: Texts.Writer; + +PROCEDURE tc(c: CHAR); BEGIN Texts.Write(W, c) END tc; +PROCEDURE ts(s: ARRAY OF CHAR); BEGIN Texts.WriteString(W, s) END ts; +PROCEDURE ti(i, n: LONGINT); BEGIN Texts.WriteInt(W, i, n) END ti; +PROCEDURE tr(r: LONGREAL; n: INTEGER); BEGIN Texts.WriteLongReal(W, r, n) END tr; +PROCEDURE tn; BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END tn; + + +PROCEDURE TestConvert(lr: LONGREAL); + VAR str: ARRAY 20 OF CHAR; i: INTEGER; +BEGIN + Reals.ConvertL(lr, 6, str); + i := 6; WHILE i > 0 DO DEC(i); tc(str[i]) END; + tn; +END TestConvert; + +PROCEDURE TestHex(r: REAL); + VAR str: ARRAY 20 OF CHAR; +BEGIN + Reals.ConvertH(r, str); str[8] := 0X; ts(str); tn; +END TestHex; + +PROCEDURE TestSetExpo(r: REAL; i: INTEGER); +BEGIN + ts("r = "); tr(r,10); + ts(", i = "); ti(Reals.Expo(r),1); + Reals.SetExpo(r, i); + ts(" -> r = "); tr(r,10); + ts(", i = "); ti(Reals.Expo(r),1); tn; +END TestSetExpo; + +PROCEDURE TestFractionPart(r: REAL); +BEGIN + ts("r = "); tr(r,14); + ts(", exp = "); ti(Reals.Expo(r),1); + r := oocLowReal.fraction(r); + ts(" -> r = "); tr(r,14); + ts(", exp = "); ti(Reals.Expo(r),1); tn; +END TestFractionPart; + +PROCEDURE RealTests; + VAR + str: ARRAY 20 OF CHAR; + r: REAL; +(* + lr: LONGREAL; +*) +BEGIN + TestConvert(1.0); + TestConvert(1.5); + TestConvert(2.0); + TestConvert(2.99); + TestConvert(3.0); + + TestHex(1.0); + TestHex(1.5); + TestHex(2.0); + TestHex(2.99); + TestHex(3.0); + + ti(Reals.Expo(0.5),1); tn; (* 126 *) + ti(Reals.Expo(1.0),1); tn; (* 127 *) + ti(Reals.Expo(2.0),1); tn; (* 128 *) + ti(Reals.Expo(3.0),1); tn; (* 128 *) + ti(Reals.Expo(4.0),1); tn; (* 129 *) + + TestSetExpo(1.0, 129); + TestSetExpo(-1.0, 129); + TestSetExpo(2.0, 129); + TestSetExpo(-4.0, 129); + TestSetExpo(1.5, 129); + TestSetExpo(-1.5, 129); + + TestFractionPart(1.234); + TestFractionPart(-1.234); + TestFractionPart(32.678); + TestFractionPart(-32.678); + + r := 0.0; + ASSERT(~oocLowReal.IsInfinity(r), 3); ASSERT(~oocLowReal.IsNaN(r), 4); + + r := 0.0; Reals.SetExpo(r, 255); + ASSERT(oocLowReal.IsInfinity(r), 5); ASSERT(~oocLowReal.IsNaN(r), 6); + + r := 0.123; Reals.SetExpo(r, 255); + ASSERT(~oocLowReal.IsInfinity(r), 7); ASSERT(oocLowReal.IsNaN(r), 8); +END RealTests; + + +BEGIN + Texts.OpenWriter(W); + RealTests; + ts("Library tests successful."); tn +END TestLibrary. \ No newline at end of file diff --git a/src/test/confidence/library/expected b/src/test/confidence/library/expected new file mode 100644 index 00000000..3e361735 --- /dev/null +++ b/src/test/confidence/library/expected @@ -0,0 +1,26 @@ +000001 +000001 +000002 +000002 +000003 +0000803F +0000C03F +00000040 +295C3F40 +00004040 +126 +127 +128 +128 +129 +r = 1.0D+000, i = 127 -> r = 4.0D+000, i = 129 +r = -1.0D+000, i = 127 -> r = -4.0D+000, i = 129 +r = 2.0D+000, i = 128 -> r = 4.0D+000, i = 129 +r = -4.0D+000, i = 129 -> r = -4.0D+000, i = 129 +r = 1.5D+000, i = 127 -> r = 6.0D+000, i = 129 +r = -1.5D+000, i = 127 -> r = -6.0D+000, i = 129 +r = 1.23400D+000, exp = 127 -> r = 1.23400D+000, exp = 127 +r = -1.23400D+000, exp = 127 -> r = -1.23400D+000, exp = 127 +r = 3.26780D+001, exp = 132 -> r = 1.02119D+000, exp = 127 +r = -3.26780D+001, exp = 132 -> r = -1.02119D+000, exp = 127 +Library tests successful. diff --git a/src/test/confidence/library/test.sh b/src/test/confidence/library/test.sh new file mode 100644 index 00000000..91780313 --- /dev/null +++ b/src/test/confidence/library/test.sh @@ -0,0 +1,7 @@ +#!/bin/sh +. ../testenv.sh +# Generate mixed source and assembly code listing +rm -f TestLibrary # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP TestLibrary.mod -m +./TestLibrary >result +. ../testresult.sh diff --git a/src/test/confidence/lola/LSB.Mod b/src/test/confidence/lola/LSB.Mod new file mode 100644 index 00000000..2b97d65a --- /dev/null +++ b/src/test/confidence/lola/LSB.Mod @@ -0,0 +1,52 @@ +MODULE LSB; (*Lola System Compiler Base LSBX, 26.9.2015*) + IMPORT Texts, Oberon; + + CONST + bit* = 0; array* = 1; unit* = 2; (*type forms*) + + (*tags in output*) const* = 1; typ* = 2; var* = 3; lit* = 4; sel* = 7; range* = 8; cons* = 9; + repl* = 10; not* = 11; and* = 12; mul* = 13; div* = 14; or* = 15; xor* = 16; add* = 17; sub* = 18; + eql* = 20; neq* = 21; lss* = 22; geq* = 23; leq* = 24; gtr* = 25; + then* = 30; else* = 31; ts* = 32; next* = 33; + + TYPE + Item* = POINTER TO ItemDesc; + Object* = POINTER TO ObjDesc; + Type* = POINTER TO TypeDesc; + ArrayType* = POINTER TO ArrayTypeDesc; + UnitType* = POINTER TO UnitTypeDesc; + + ItemDesc* = RECORD + tag*: INTEGER; + type*: Type; + val*, size*: LONGINT; + a*, b*: Item + END ; + + ObjDesc* = RECORD (ItemDesc) + next*: Object; + name*: ARRAY 32 OF CHAR; + marked*: BOOLEAN + END ; + + TypeDesc* = RECORD len*, size*: LONGINT; typobj*: Object END ; + ArrayTypeDesc* = RECORD (TypeDesc) eltyp*: Type END ; + UnitTypeDesc* = RECORD (TypeDesc) firstobj*: Object END ; + + VAR root*, top*: Object; + bitType*, integer*, string*: Type; + byteType*, wordType*: ArrayType; + modname*: ARRAY 32 OF CHAR; + + PROCEDURE Register*(name: ARRAY OF CHAR; list: Object); + BEGIN (*modname := name*) COPY(name, modname); top := list + END Register; + +BEGIN NEW(bitType); bitType.len := 0; bitType.size := 1; NEW(integer); NEW(string); + NEW(byteType); byteType.len := 8; byteType.size := 8; byteType.eltyp := bitType; + NEW(wordType); wordType.len := 32; wordType.size := 32; wordType.eltyp := bitType; + NEW(root); root.tag := typ; root.name := "WORD"; root.type := wordType; root.next := NIL; + NEW(top); top.tag := typ; top.name := "BYTE"; top.type := byteType; top.next := root; root := top; + NEW(top); top.tag := typ; top.name := "BIT"; top.type := bitType; top.next := root; root := top +END LSB. + diff --git a/src/test/confidence/lola/LSC.Mod b/src/test/confidence/lola/LSC.Mod new file mode 100644 index 00000000..7efad856 --- /dev/null +++ b/src/test/confidence/lola/LSC.Mod @@ -0,0 +1,536 @@ +MODULE LSC; (*Lola System Compiler, NW 8.1.95 / 26.9.2015 for RISC (LSCX)*) + IMPORT Texts, Oberon, LSB, LSS; + + VAR sym: INTEGER; + err: BOOLEAN; (*used at end of Unit*) + top, bot, undef: LSB.Object; + factor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward references*) + expression: PROCEDURE (VAR x: LSB.Item); + Unit: PROCEDURE (VAR locals: LSB.Object); + W: Texts.Writer; + + PROCEDURE Err(n: INTEGER); + BEGIN LSS.Mark("type error"); Texts.WriteInt(W, n, 4); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Err; + + PROCEDURE Log(m: LONGINT): LONGINT; + VAR n: LONGINT; + BEGIN n := 1; + WHILE m > 1 DO m := m DIV 2; INC(n) END ; + RETURN n + END Log; + + PROCEDURE New(tag: INTEGER; a, b: LSB.Item): LSB.Item; + VAR z: LSB.Item; + BEGIN NEW(z); z.tag := tag; z.a := a; z.b := b; z.val := b.val; RETURN z + END New; + + PROCEDURE NewObj(class: INTEGER): LSB.Object; (*insert at end, before BIT*) + VAR new, x: LSB.Object; + BEGIN x := top; + WHILE (x.next # bot) & (x.next.name # LSS.id) DO x := x.next END ; + IF x.next = bot THEN + NEW(new); new.name := LSS.id; new.tag := class; new.next := bot; x.next := new + ELSE LSS.Mark("mult def"); new := x + END ; + RETURN new + END NewObj; + + PROCEDURE ThisObj(id: LSS.Ident): LSB.Object; (*find object with name = identifier last read*) + VAR x: LSB.Object; + BEGIN x := top.next; + WHILE (x # NIL) & (x.name # id) DO x := x.next END ; + IF x = NIL THEN LSS.Mark("undef"); x := undef END ; + RETURN x + END ThisObj; + + PROCEDURE CheckTypes(x, y, z: LSB.Item); (*z.type = result type*) + VAR xtyp, ytyp: LSB.Type; + BEGIN xtyp := x.type; ytyp := y.type; z.type := xtyp; z.size := x.size; z.val := x.val; + IF xtyp = LSB.bitType THEN z.type := xtyp; + IF ytyp = LSB.integer THEN (* b + 0 *) + IF y.val >= 2 THEN Err(20); LSS.Mark("only 0 or 1") END + ELSIF ytyp = LSB.string THEN (* b + {...} *) Err(21) + ELSIF ytyp # LSB.bitType THEN Err(22) + END + ELSIF xtyp IS LSB.ArrayType THEN + IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN + IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN + IF xtyp.size # ytyp.size THEN Err(33) END (* x + y *) + ELSIF ytyp = LSB.integer THEN (* w + 5 *) + IF xtyp.size < Log(y.val) THEN Err(30) END + ELSIF ytyp = LSB.string THEN (*x + {...} *) + IF xtyp.size # y.size THEN Err(31) END + ELSIF ytyp # LSB.bitType THEN Err(34) + END + ELSIF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = ytyp(LSB.ArrayType).eltyp) THEN + IF (xtyp.size # ytyp.size) THEN Err(40) END + ELSE Err(41) + END + ELSIF xtyp = LSB.string THEN + IF ytyp = LSB.bitType THEN (* {...} + b *) Err(12) + ELSIF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* {...} + w *) + IF x.size # ytyp.size THEN Err(13) END + ELSIF ytyp = LSB.integer THEN (* {...} + 5*) + IF x.size < Log(y.val) THEN Err(10) END + ELSIF ytyp = LSB.string THEN (* {...} + {...} *) + IF x.size # y.size THEN Err(11) END ; + ELSE Err(14) + END + ELSIF xtyp = LSB.integer THEN + IF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* 5 + w *) + IF Log(x.val) > ytyp.size THEN Err(3); LSS.Mark("const too large") END + ELSIF ytyp = LSB.bitType THEN (* 5 + b *) + IF x.val >= 2 THEN Err(2) END + ELSIF ytyp = LSB.integer THEN (* 5 + 5 *) + ELSIF ytyp = LSB.string THEN (* 5 + {...} *) + IF Log(x.val) > y.size THEN Err(12) END + ELSE Err(4) + END + END + END CheckTypes; + + PROCEDURE selector(VAR x: LSB.Item); + VAR y, z: LSB.Item; obj: LSB.Object; + eltyp: LSB.Type; len, kind: LONGINT; + BEGIN + WHILE (sym = LSS.lbrak) OR (sym = LSS.period) DO + IF sym = LSS.lbrak THEN + eltyp := x.type(LSB.ArrayType).eltyp; LSS.Get(sym); expression(y); + IF sym = LSS.colon THEN (*range*) + LSS.Get(sym); expression(z); + IF (y.tag = LSB.lit) & (z.tag = LSB.lit) THEN + len := y.val - z.val + 1; y := New(LSB.range, y, z); x := New(LSB.sel, x, y); x.type := LSB.string; x.size := len + END + ELSE kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind + END ; + IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END + ELSE (*sym = LSS.period*) LSS.Get(sym); factor(y); + IF (y.tag = LSB.lit) & (y.val >= x.type.len) THEN LSS.Mark("too large") END ; + eltyp := x.type(LSB.ArrayType).eltyp; kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind + END + END + END selector; + + PROCEDURE elem(VAR x: LSB.Item; VAR len: LONGINT); + VAR y, z: LSB.Item; m, n: LONGINT; + BEGIN expression(x); + IF (x.type = LSB.integer) OR (x.type = LSB.string) THEN m := x.size ELSE m := x.type.size END ; + IF sym = LSS.repl THEN + LSS.Get(sym); + IF sym = LSS.integer THEN + NEW(y); y.tag := LSB.lit; n := LSS.val; y.val := n; y.type := LSB.integer; LSS.Get(sym); + x := New(LSB.repl, x, y) + END + ELSE n := 1 + END ; + len := m*n + END elem; + + PROCEDURE constructor(VAR x: LSB.Item); + VAR y: LSB.Item; n, len: LONGINT; + BEGIN elem(x, len); + WHILE sym = LSS.comma DO + LSS.Get(sym); elem(y, n); INC(len, n); x := New(LSB.cons, x, y); x.val := len + END ; + x.size := len; x.type := LSB.string; + IF sym = LSS.rbrace THEN LSS.Get(sym) ELSE LSS.Mark("rbrace ?") END + END constructor; + + PROCEDURE factor0(VAR x: LSB.Item); + VAR obj: LSB.Object; y, z: LSB.Item; + n, len: LONGINT; t: LSB.ArrayType; + BEGIN + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); LSS.Get(sym); + IF x.tag = LSB.var THEN selector(x) + ELSIF x.tag = LSB.const THEN n := x.b.val; NEW(x); x.tag := LSB.lit; x.val := n; x.type := LSB.integer + ELSE LSS.Mark("bad factor") + END + ELSIF sym = LSS.lparen THEN + LSS.Get(sym); expression(x); + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSIF sym = LSS.integer THEN + NEW(x); x.tag := LSB.lit; x.val := LSS.val; x.type := LSB.integer; LSS.Get(sym); + IF sym = LSS.apo THEN LSS.Get(sym); + IF sym = LSS.integer THEN + len := LSS.val; LSS.Get(sym); + IF len < Log(x.val) THEN LSS.Mark("value too large") END + ELSE LSS.Mark("integer ?"); len := 0 + END ; + x.size := len + ELSE len := 0 + END ; + x.size := len + ELSIF sym = LSS.not THEN + LSS.Get(sym); factor(x); y := New(LSB.not, NIL, x); y.type := x.type; y.size := x.size; x := y + ELSIF sym = LSS.lbrace THEN LSS.Get(sym); constructor(x) + ELSE LSS.Mark("bad factor") + END + END factor0; + + PROCEDURE term(VAR x: LSB.Item); + VAR y, z: LSB.Item; op: INTEGER; + BEGIN factor(x); + WHILE (sym >= LSS.times) & (sym <= LSS.and) DO + IF sym = LSS.and THEN op := LSB.and + ELSIF sym = LSS.times THEN op := LSB.mul + ELSIF sym = LSS.div THEN op := LSB.div + END ; + LSS.Get(sym); factor(y); z := New(op, x, y); CheckTypes(x, y, z); x := z + END + END term; + + PROCEDURE SimpleExpression(VAR x: LSB.Item); + VAR y, z: LSB.Item; op: INTEGER; + BEGIN + IF sym = LSS.minus THEN LSS.Get(sym); term(y); + IF y.tag = LSB.lit THEN x := y; x.val := -y.val + ELSE x := New(LSB.sub, NIL, y); x.type := y.type; x.size := y.size + END + ELSIF sym = LSS.plus THEN LSS.Get(sym); term(x); + ELSE term(x) + END ; + WHILE (sym >= LSS.plus) & (sym <= LSS.xor) DO + IF sym = LSS.or THEN op := LSB.or + ELSIF sym = LSS.xor THEN op := LSB.xor + ELSIF sym = LSS.plus THEN op := LSB.add + ELSIF sym = LSS.minus THEN op := LSB.sub + END ; + LSS.Get(sym); term(y); z := New(op, x, y); CheckTypes(x, y, z); x := z + END + END SimpleExpression; + + PROCEDURE UncondExpression(VAR x: LSB.Item); + VAR y, z: LSB.Item; rel: INTEGER; + BEGIN SimpleExpression(x); + IF (sym >= LSS.eql) & (sym <= LSS.geq) THEN + IF sym = LSS.eql THEN rel := LSB.eql + ELSIF sym = LSS.neq THEN rel := LSB.neq + ELSIF sym = LSS.lss THEN rel := LSB.lss + ELSIF sym = LSS.geq THEN rel := LSB.geq + ELSIF sym = LSS.leq THEN rel := LSB.leq + ELSE rel := LSB.gtr + END ; + LSS.Get(sym); SimpleExpression(y); z := New(rel, x, y); CheckTypes(x, y, z); z.type := LSB.bitType; x := z + END + END UncondExpression; + + PROCEDURE expression0(VAR x: LSB.Item); + VAR y, z, w: LSB.Item; + BEGIN UncondExpression(x); + IF sym = LSS.then THEN + IF x.type # LSB.bitType THEN LSS.Mark("Boolean?") END ; + LSS.Get(sym); expression(y); + IF sym = LSS.colon THEN + LSS.Get(sym); expression(z); w := New(LSB.else, y, z); CheckTypes(y, z, w); + x := New(LSB.then, x, w); x.type := w.type; x.size := w.size + ELSE LSS.Mark("colon ?") + END + END + END expression0; + + PROCEDURE CheckAssign(x, y: LSB.Item); + VAR xtyp, ytyp: LSB.Type; + BEGIN xtyp := x.type; ytyp := y.type; + IF xtyp # ytyp THEN + IF xtyp = LSB.bitType THEN + IF (ytyp # LSB.integer) OR (y.val >= 2) THEN Err(70); END + ELSIF xtyp IS LSB.ArrayType THEN + IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN + IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (*w := w*) + IF xtyp.size # ytyp.size THEN Err(71) END (* x + y *) + ELSIF ytyp = LSB.integer THEN (* w := 5 *) + IF xtyp.size < Log(y.val) THEN Err(72) END + ELSIF ytyp = LSB.string THEN (* w := {...} *) + IF xtyp.size # y.size THEN Err(73) END + ELSE Err(74) + END + ELSE Err(74) + END + END + END + END CheckAssign; + + PROCEDURE Param(fpar: LSB.Object; VAR apar: LSB.Item); + VAR y, z: LSB.Item; + BEGIN expression(y); apar := New(LSB.next, NIL, y); CheckAssign(fpar, y); + IF fpar.val IN {3, 4} THEN (*OUT or INOUT parameter*) + IF ~(y.tag IN {3, 7}) THEN (*actual param is expression?*) LSS.Mark("bad actual param") + ELSIF y.b = NIL THEN y.b := undef + END + END + END Param; + + PROCEDURE Statement; + VAR w, x, y, z, apar, npar: LSB.Item; + unit: LSB.UnitType; fpar: LSB.Object; + BEGIN + IF sym < LSS.ident THEN LSS.Mark("bad factor"); + REPEAT LSS.Get(sym) UNTIL sym >= LSS.ident + END ; + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); z := x; LSS.Get(sym); selector(z); + IF sym = LSS.becomes THEN LSS.Get(sym); + IF x.val >= 5 THEN LSS.Mark("assignment to read-only") END ; + IF (x.b # NIL) & ~(x.type IS LSB.ArrayType) THEN LSS.Mark("mult assign") END ; + expression(y); CheckAssign(z, y); x.b := y; (*tricky*) + IF z # x THEN x.a := z.b; x.val := 1 (*overwriting clk field x.a *) END + ELSIF sym = LSS.lparen THEN LSS.Get(sym); (*unit instantiation*) + IF x.type IS LSB.UnitType THEN + unit := x.type(LSB.UnitType); fpar := unit.firstobj; + IF sym # LSS.rparen THEN + Param(fpar, apar); x.b := apar; fpar := fpar.next; + WHILE sym # LSS.rparen DO + IF sym = LSS.comma THEN LSS.Get(sym) END ; + Param(fpar, npar); + IF fpar.tag >= 3 THEN fpar := fpar.next; apar.a := npar; apar := npar + ELSE LSS.Mark("too many params") + END + END ; + IF fpar.val >= 3 THEN LSS.Mark("too few params") END + END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSE LSS.Mark("not a module") + END + ELSE LSS.Mark("bad statement") + END + ELSIF sym = LSS.ts THEN (*tri-state*) LSS.Get(sym); + IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("( missing") END ; + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); x.b := undef; (*INOUT parameter*) + IF x.val # 5 THEN LSS.Mark("not INOUT") END ; + LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + IF sym = LSS.ident THEN y := ThisObj(LSS.id); CheckAssign(x, y); y.b := undef END ; (*output from gate*) + LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + expression(z); + IF (z.tag = LSB.lit) & (z.val <= 1) THEN z.type := LSB.bitType END ; + CheckAssign(x, z); LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + expression(w); (*control*) + IF w.type # LSB.bitType THEN CheckAssign(x, w) END ; + w := New(LSB.next, z, w); x.b := New(LSB.ts, y, w); + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark(") missing") END + END + END + END Statement; + + PROCEDURE StatSequence; + BEGIN Statement; + WHILE sym <= LSS.semicolon DO + IF sym < LSS.semicolon THEN LSS.Mark("semicolon missing?") END ; + WHILE sym = LSS.semicolon DO LSS.Get(sym) END ; + Statement + END ; + IF sym = LSS.end THEN LSS.Get(sym) ELSE LSS.Mark("END ?") END + END StatSequence; + + (*---------------------------------------------------*) + + (* for variables and registers,, obj.val has the meaning + 0 register + 1 register with imlicit clock "clk" + 2 variable + 3 output parameter + 4 output parameter with register + 5 inout parameter + 6 input parameter *) + + PROCEDURE ConstDeclaration; + VAR obj: LSB.Object; + BEGIN + IF sym = LSS.ident THEN + obj := NewObj(LSB.const); LSS.Get(sym); + IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; + expression(obj.b); obj.type := LSB.integer; + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END + ELSE LSS.Mark("ident ?") + END + END ConstDeclaration; + + PROCEDURE Type0(VAR type: LSB.Type); + VAR obj: LSB.Object; len, size: LONGINT; + eltyp: LSB.Type; arrtyp: LSB.ArrayType; + BEGIN len := 1; + IF sym = LSS.lbrak THEN (*array*) LSS.Get(sym); + IF sym = LSS.integer THEN len := LSS.val; LSS.Get(sym) + ELSIF sym = LSS.ident THEN obj := ThisObj(LSS.id); len := obj.val + END ; + IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END ; + Type0(eltyp); NEW(arrtyp); size := eltyp.size * len; + arrtyp.eltyp := eltyp; type := arrtyp; type.len := len; type.size := size + ELSIF sym = LSS.ident THEN + obj := ThisObj(LSS.id); LSS.Get(sym); + IF obj # NIL THEN + IF obj.tag = LSB.typ THEN type := obj.type ELSE LSS.Mark("not a type"); type := LSB.bitType END + ELSE LSS.Mark("type ?") + END + ELSE type := LSB.bitType; LSS.Mark("ident or [") + END + END Type0; + + PROCEDURE TypeDeclaration; + VAR obj: LSB.Object; utyp: LSB.UnitType; + BEGIN + IF sym = LSS.ident THEN + obj := NewObj(LSB.typ); LSS.Get(sym); + IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; + IF sym = LSS.module THEN + LSS.Get(sym); NEW(utyp); Unit(utyp.firstobj); obj.type := utyp; obj.type.typobj := obj + ELSE Type0(obj.type) + END ; + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END + ELSE LSS.Mark("ident ?") + END + END TypeDeclaration; + + PROCEDURE VarList(kind: INTEGER; clk: LSB.Item); + VAR first, new, obj: LSB.Object; type: LSB.Type; + BEGIN obj := NIL; + WHILE sym = LSS.ident DO + new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; first := new; LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END ; + WHILE sym = LSS.ident DO + new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END + END ; + IF sym = LSS.colon THEN + LSS.Get(sym); Type0(type); obj := first; + WHILE obj # bot DO obj.type := type; obj.a := clk; obj := obj.next END + ELSE LSS.Mark("colon ?") + END ; + IF sym = LSS.semicolon THEN LSS.Get(sym) + ELSIF sym # LSS.rparen THEN LSS.Mark("semicolon or rparen missing") + END + END + END VarList; + + PROCEDURE ParamList; + VAR kind: INTEGER; + BEGIN + IF sym = LSS.in THEN LSS.Get(sym); kind := 6 + ELSIF sym = LSS.out THEN LSS.Get(sym); + IF sym = LSS.reg THEN LSS.Get(sym); kind := 4 ELSE kind := 3 END + ELSIF sym = LSS.inout THEN LSS.Get(sym); kind := 5 + END ; + VarList(kind, NIL) + END ParamList; + + PROCEDURE Traverse(x: LSB.Item); + BEGIN + IF x # NIL THEN + IF x IS LSB.Object THEN + IF (x.tag = LSB.var) & (x.val >= 2) THEN (*not reg*) + IF x(LSB.Object).marked THEN (*loop*) + Texts.WriteString(W, x(LSB.Object).name); Texts.Write(W, " "); err := TRUE + ELSIF x.b # NIL THEN x(LSB.Object).marked := TRUE; Traverse(x.b) + END ; + x(LSB.Object).marked := FALSE + END + ELSE Traverse(x.a); Traverse(x.b) + END + END + END Traverse; + + PROCEDURE Unit0(VAR locals: LSB.Object); + VAR obj, oldtop: LSB.Object; kind: INTEGER; clock: LSB.Item; + BEGIN oldtop := top.next; top.next := LSB.root; (*top is dummy*) + IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("lparen ?") END ; + WHILE (sym = LSS.in) OR (sym = LSS.out) OR (sym = LSS.inout) DO ParamList END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END ; + IF sym = LSS.xor (*arrow*) THEN LSS.Get(sym); locals := top.next + ELSE + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END ; + IF sym = LSS.const THEN LSS.Get(sym); + WHILE sym = LSS.ident DO ConstDeclaration END + END ; + IF sym = LSS.type THEN LSS.Get(sym); + WHILE sym = LSS.ident DO TypeDeclaration END + END ; + WHILE (sym = LSS.var) OR (sym = LSS.reg) DO + IF sym = LSS.var THEN LSS.Get(sym); + WHILE sym = LSS.ident DO VarList(2, NIL) END + ELSE (*reg*) kind := 0; LSS.Get(sym); + IF sym = LSS.lparen THEN (*clock*) + LSS.Get(sym); expression(clock); + IF clock.type # LSB.bitType THEN LSS.Mark("clock must be bitType") END ; + IF (clock IS LSB.Object) & (clock(LSB.Object).name = "clk") THEN kind := 1; clock := NIL END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSE LSS.Mark("lparen expected"); clock := undef + END ; + WHILE sym = LSS.ident DO VarList(kind, clock) END + END + END ; + locals := top.next; + IF sym = LSS.begin THEN LSS.Get(sym); StatSequence END ; + obj := locals; err := FALSE; (*find unassigned variables*) + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & (obj.val < 5) THEN + IF (obj.b = NIL) & (obj.val < 4) THEN Texts.WriteString(W, obj.name); Texts.Write(W, " "); err := TRUE + ELSIF obj.b = undef THEN obj.b := NIL + END + END ; + obj := obj.next + END ; + IF err THEN Texts.WriteString(W, " unassigned"); Texts.WriteLn(W) + ELSE obj := locals; err := FALSE; (*find combinatorial loops*) + WHILE obj # LSB.root DO + IF obj.tag = LSB.var THEN obj.marked := TRUE; Traverse(obj.b); obj.marked := FALSE END ; + obj := obj.next + END ; + IF err THEN Texts.WriteString(W, "in loop"); Texts.WriteLn(W) END + END + END ; + IF err THEN Texts.Append(Oberon.Log, W.buf) END ; + top.next := oldtop + END Unit0; + + PROCEDURE Module(T: Texts.Text; pos: LONGINT); + VAR root: LSB.Object; modname: ARRAY 32 OF CHAR; + BEGIN Texts.WriteString(W, "compiling Lola: "); + bot := LSB.root; top.next := bot; LSS.Init(T, pos); LSS.Get(sym); + IF sym = LSS.module THEN + LSS.Get(sym); + IF sym = LSS.ident THEN + modname := LSS.id; Texts.WriteString(W, LSS.id); LSS.Get(sym); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + ELSE LSS.Mark("ident ?") + END ; + Unit(root); + IF sym = LSS.ident THEN LSS.Get(sym); + IF LSS.id # modname THEN LSS.Mark("no match") END + END ; + IF sym # LSS.period THEN LSS.Mark("period ?") END ; + IF ~LSS.error THEN LSB.Register(modname, root) + ELSE Texts.WriteString(W, "compilation failed"); Texts.WriteLn(W); LSB.Register("", LSB.root) + END + ELSE LSS.Mark("module ?") + END ; + Texts.Append(Oberon.Log, W.buf) + END Module; + + PROCEDURE Compile*; + VAR beg, end, time: LONGINT; + S: Texts.Scanner; T: Texts.Text; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF S.class = Texts.Char THEN + IF S.c = "*" THEN + ELSIF S.c = "@" THEN + Oberon.GetSelection(T, beg, end, time); + IF time >= 0 THEN Module(T, beg) END + END + ELSIF S.class = Texts.Name THEN + NEW(T); Texts.Open(T, S.s); Module(T, 0) + END ; + Oberon.Par.pos := Texts.Pos(S); + Texts.Append(Oberon.Log, W.buf) + END Compile; + +BEGIN Texts.OpenWriter(W); + Texts.WriteString(W, "Lola compiler; NW 6.7.2015"); Texts.WriteLn(W); + NEW(top); bot := LSB.root; NEW(undef); undef.tag := 2; undef.type := LSB.bitType; + Unit := Unit0; factor := factor0; expression := expression0; +END LSC. diff --git a/src/test/confidence/lola/LSS.Mod b/src/test/confidence/lola/LSS.Mod new file mode 100644 index 00000000..809c4e8b --- /dev/null +++ b/src/test/confidence/lola/LSS.Mod @@ -0,0 +1,165 @@ +MODULE LSS; (* NW 16.10.93 / 1.9.2015*) + IMPORT Texts, Oberon; + + CONST IdLen* = 32; NofKeys = 11; + (*symbols*) null = 0; + arrow* = 1; times* = 2; div* = 3; and* = 4; plus* = 5; minus* = 6; or* = 7; xor* = 8; not* = 9; + eql* = 10; neq* = 11; lss* = 12; leq* = 13; gtr* = 14; geq* = 15; + at* = 16; apo* = 17; period* = 18; comma* = 19; colon* = 20; rparen* = 21; rbrak* = 22; rbrace* = 23; + then* = 24; lparen* = 26; lbrak* = 27; lbrace* = 28; repl* = 29; becomes* = 30; + ident* = 31; integer* = 32; ts* = 33; semicolon* = 40; end* = 41; + const* = 51; type* = 52; reg* = 53; var* = 54; out* = 55; inout* = 56; in* = 57; + begin* = 58; module* = 59; eof = 60; + + TYPE Ident* = ARRAY IdLen OF CHAR; + + VAR val*: LONGINT; + id*: Ident; + error*: BOOLEAN; + + ch: CHAR; + errpos: LONGINT; + R: Texts.Reader; + W: Texts.Writer; + key: ARRAY NofKeys OF Ident; + symno: ARRAY NofKeys OF INTEGER; + + PROCEDURE Mark*(msg: ARRAY OF CHAR); + VAR p: LONGINT; + BEGIN p := Texts.Pos(R); + IF p > errpos+2 THEN + Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); + Texts.WriteString(W, " err: "); Texts.WriteString(W, msg); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END ; + errpos := p; error := TRUE + END Mark; + + PROCEDURE identifier(VAR sym: INTEGER); + VAR i: INTEGER; + BEGIN i := 0; + REPEAT + IF i < IdLen THEN id[i] := ch; INC(i) END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z"); + IF ch = "'" THEN + IF i < IdLen THEN id[i] := ch; INC(i) END ; + Texts.Read(R, ch) + END ; + IF i = IdLen THEN Mark("ident too long"); id[IdLen-1] := 0X + ELSE id[i] := 0X + END ; + i := 0; + WHILE (i < NofKeys) & (id # key[i]) DO INC(i) END ; + IF i < NofKeys THEN sym := symno[i] ELSE sym := ident END + END identifier; + + PROCEDURE Number(VAR sym: INTEGER); + VAR i, k, h, n, d: LONGINT; + hex: BOOLEAN; + dig: ARRAY 16 OF LONGINT; + BEGIN sym := integer; i := 0; k := 0; n := 0; hex := FALSE; + REPEAT + IF n < 16 THEN d := ORD(ch)-30H; + IF d >= 10 THEN hex := TRUE ; d := d - 7 END ; + dig[n] := d; INC(n) + ELSE Mark("too many digits"); n := 0 + END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); + IF ch = "H" THEN (*hex*) + REPEAT h := dig[i]; k := k*10H + h; INC(i) (*no overflow check*) + UNTIL i = n; + Texts.Read(R, ch) + ELSE + IF hex THEN Mark("illegal hex digit") END ; + REPEAT k := k*10 + dig[i]; INC(i) UNTIL i = n + END ; + val := k + END Number; + + PROCEDURE comment; + BEGIN Texts.Read(R, ch); + REPEAT + WHILE ~R.eot & (ch # "*") DO + IF ch = "(" THEN Texts.Read(R, ch); + IF ch = "*" THEN comment END + ELSE Texts.Read(R, ch) + END + END ; + WHILE ch = "*" DO Texts.Read(R, ch) END + UNTIL (ch = ")") OR R.eot; + IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END + END comment; + + PROCEDURE Get*(VAR sym: INTEGER); + BEGIN + REPEAT + WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; + IF R.eot THEN sym := eof + ELSIF ch < "A" THEN + IF ch < "0" THEN + IF ch = "!" THEN Texts.Read(R, ch); sym := repl + ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq + ELSIF ch = "$" THEN Texts.Read(R, ch); sym := null + ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and + ELSIF ch = "'" THEN Texts.Read(R, ch); sym := apo + ELSIF ch = "(" THEN Texts.Read(R, ch); + IF ch = "*" THEN sym := null; comment ELSE sym := lparen END + ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen + ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times + ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus + ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma + ELSIF ch = "-" THEN Texts.Read(R, ch); + IF ch = ">" THEN Texts.Read(R, ch); sym := then ELSE sym := minus END + ELSIF ch = "." THEN Texts.Read(R, ch); sym := period + ELSIF ch = "/" THEN Texts.Read(R, ch); sym := div + ELSE sym := null + END + ELSIF ch <= "9" THEN Number(sym) + ELSIF ch = ":" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END + ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon + ELSIF ch = "<" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END + ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql + ELSIF ch = ">" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END + ELSIF ch = "?" THEN Texts.Read(R, ch); sym := then + ELSIF ch = "@" THEN Texts.Read(R, ch); sym := at + ELSE sym := null + END + ELSIF ch <= "Z" THEN identifier(sym) + ELSIF ch < "a" THEN + IF ch = "[" THEN Texts.Read(R, ch); sym := lbrak + ELSIF ch = "]" THEN Texts.Read(R, ch); sym := rbrak + ELSIF ch = "^" THEN Texts.Read(R, ch); sym := xor + ELSE sym := null + END + ELSIF ch <= "z" THEN identifier(sym) + ELSIF ch <= "{" THEN Texts.Read(R, ch); sym := lbrace + ELSIF ch <= "|" THEN Texts.Read(R, ch); sym := or + ELSIF ch <= "}" THEN Texts.Read(R, ch); sym := rbrace + ELSIF ch <= "~" THEN Texts.Read(R, ch); sym := not + ELSE sym := null + END + UNTIL sym # null + END Get; + + PROCEDURE Init*(T: Texts.Text; pos: LONGINT); + BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch) + END Init; + +BEGIN Texts.OpenWriter(W); + key[ 0] := "BEGIN"; symno[0] := begin; + key[ 1] := "CONST"; symno[1] := const; + key[ 2] := "END"; symno[2] := end; + key[3] := "IN"; symno[3] := in; + key[4] := "INOUT"; symno[4] := inout; + key[5] := "MODULE"; symno[5] := module; + key[6] := "OUT"; symno[6] := out; + key[7] := "REG"; symno[7] := reg; + key[8] := "TYPE"; symno[8] := type; + key[9] := "VAR"; symno[9] := var; + key[10] := "TS"; symno[10] := ts +END LSS. diff --git a/src/test/confidence/lola/LSV.Mod b/src/test/confidence/lola/LSV.Mod new file mode 100644 index 00000000..6c87497f --- /dev/null +++ b/src/test/confidence/lola/LSV.Mod @@ -0,0 +1,238 @@ +MODULE LSV; (*Lola System: display Verilog; generate txt-File; NW 31.8.2015*) + IMPORT Files, Texts, Oberon, LSB; + + VAR W: Texts.Writer; + nofgen: INTEGER; + Constructor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward reference*) + F: Files.File; R: Files.Rider; + C: ARRAY 64, 6 OF CHAR; + + PROCEDURE Write(ch: CHAR); + BEGIN Files.Write(R, ch) + END Write; + + PROCEDURE WriteLn; + BEGIN Files.Write(R, 0DX); Files.Write(R, 0AX) + END WriteLn; + + PROCEDURE WriteInt(x: LONGINT); (* x >= 0 *) + VAR i: INTEGER; d: ARRAY 14 OF LONGINT; + BEGIN i := 0; + IF x < 0 THEN Files.Write(R, "-"); x := -x END ; + REPEAT d[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0; + REPEAT DEC(i); Files.Write(R, CHR(d[i] + 30H)) UNTIL i = 0 + END WriteInt; + + PROCEDURE WriteHex(x: LONGINT); (*x >= 0*) + VAR i: INTEGER; d: ARRAY 8 OF LONGINT; + BEGIN i := 0; + REPEAT d[i] := x MOD 10H; x := x DIV 10H; INC(i) UNTIL (x = 0) OR (i = 8); + REPEAT DEC(i); + IF d[i] >= 10 THEN Files.Write(R, CHR(d[i] + 37H)) ELSE Files.Write(R, CHR(d[i] + 30H)) END + UNTIL i = 0 + END WriteHex; + + PROCEDURE WriteString(s: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO Files.Write(R, s[i]); INC(i) END + END WriteString; + + (* ------------------------------- *) + + PROCEDURE Type(typ: LSB.Type); + VAR obj: LSB.Object; + BEGIN + IF typ IS LSB.ArrayType THEN + IF typ(LSB.ArrayType).eltyp # LSB.bitType THEN + Write("["); WriteInt(typ.len - 1); WriteString(":0]"); Type(typ(LSB.ArrayType).eltyp) + END + ELSIF typ IS LSB.UnitType THEN (* obj := typ(LSB.UnitType).firstobj; *) + END + END Type; + + PROCEDURE BitArrLen(typ: LSB.Type); + VAR eltyp: LSB.Type; + BEGIN + IF typ IS LSB.ArrayType THEN + eltyp := typ(LSB.ArrayType).eltyp; + WHILE eltyp IS LSB.ArrayType DO typ := eltyp; eltyp := typ(LSB.ArrayType).eltyp END ; + IF eltyp = LSB.bitType THEN + Write("["); WriteInt(typ.len - 1);WriteString(":0] ") + END + END + END BitArrLen; + + PROCEDURE Expression(x: LSB.Item); + VAR z: LSB.Item; + BEGIN + IF x # NIL THEN + IF x IS LSB.Object THEN WriteString(x(LSB.Object).name) + ELSIF x.tag = LSB.cons THEN + Write("{"); Constructor(x); Write("}") + ELSE + IF x.tag = LSB.repl THEN + Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); + Write("}"); Write("}") + ELSE + IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write("(") END ; + Expression(x.a); + IF x.tag = LSB.sel THEN Write("["); Expression(x.b); Write("]") + ELSIF x.tag = LSB.lit THEN + IF x.size # 0 THEN WriteInt(x.size); Write("'"); Write("h"); WriteHex(x.val) + ELSE WriteInt(x.val) + END + ELSE WriteString(C[x.tag]); Expression(x.b) + END ; + IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write(")") END + END + END + END + END Expression; + + PROCEDURE Elem(VAR x: LSB.Item); + BEGIN + IF x.tag = LSB.repl THEN + Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); WriteString("}}") + ELSE Expression(x) + END + END Elem; + + PROCEDURE Constructor0(VAR x: LSB.Item); + BEGIN + IF x.tag = LSB.cons THEN Constructor(x.a); WriteString(", "); Elem(x.b) ELSE Elem(x) END + END Constructor0; + + PROCEDURE Declaration(obj: LSB.Object); + VAR apar: LSB.Item; typ: LSB.Type; + BEGIN typ := obj.type; + IF obj.type IS LSB.UnitType THEN WriteString("unit ") ELSE Type(obj.type) END ; + IF obj.tag = LSB.var THEN + IF obj.type IS LSB.UnitType THEN + apar := obj.a; WriteLn; Write("["); + WHILE apar # NIL DO Expression(apar.b); apar := apar.a END ; + Write("]") + END + ELSIF obj.tag = LSB.const THEN WriteString(" = "); WriteInt(obj.val) + END + END Declaration; + + PROCEDURE ObjList0(obj: LSB.Object); (*declarations*) + VAR obj1: LSB.Object; param: BOOLEAN; + BEGIN param := TRUE; + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) THEN + IF obj.val <= 1 THEN WriteString("reg ") + ELSIF obj.val = 2 THEN WriteString("wire ") + ELSIF obj.val = 3 THEN WriteString("output ") + ELSIF obj.val = 4 THEN WriteString("output reg ") + ELSIF obj.val = 5 THEN WriteString("inout ") + ELSIF obj.val = 6 THEN WriteString("input ") + ELSE WriteString("??? ") + END ; + BitArrLen(obj.type); WriteString(obj.name); + obj1 := obj.next; + WHILE (obj1 # LSB.top) & (obj1.type = obj.type) & (obj1.val = obj.val) DO + WriteString(", "); obj := obj1; WriteString(obj.name); obj1 := obj.next + END ; + IF param & (obj.val >= 3) & (obj1.val < 3) THEN (*end param list*) param := FALSE; Write(")") + END ; + IF (obj.type # LSB.bitType) & (obj.type(LSB.ArrayType).eltyp # LSB.bitType) THEN Type(obj.type) END ; + IF param THEN Write(",") ELSE Write(";") END ; + WriteLn + ELSIF obj.tag = LSB.const THEN + END ; + obj := obj.next + END + END ObjList0; + + PROCEDURE ActParam(VAR x: LSB.Item; fpar: LSB.Object); + BEGIN Write("."); WriteString(fpar.name); Write("("); Expression(x); Write(")") + END ActParam; + + PROCEDURE ObjList1(obj: LSB.Object); (*assignments to variables*) + VAR apar, x: LSB.Item; fpar: LSB.Object; size: LONGINT; + BEGIN + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) OR (obj.tag = LSB.const) THEN + IF obj.type IS LSB.UnitType THEN + WriteString(obj.type.typobj.name); Write(" "); WriteString(obj.name); + apar := obj.b; fpar := obj.type(LSB.UnitType).firstobj; + Write("("); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next; (*actual param list*) + WHILE apar # NIL DO WriteString(", "); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next END ; + Write(")"); Write(";"); WriteLn + ELSIF (obj.b # NIL) & (obj.val = 5) THEN (*tri-state*) + size := obj.type.size; x := obj.b; + IF x.tag = LSB.ts THEN + IF obj.type = LSB.bitType THEN + WriteString("IOBUF block"); INC(nofgen); WriteInt(nofgen); WriteString(" (.IO("); WriteString(obj.name); + WriteString("), .O("); WriteString(x.a(LSB.Object).name); WriteString("), .I("); x := x.b; + IF x.a.type = LSB.bitType THEN Expression(x.a) ELSE WriteString(x.a(LSB.Object).name) END ; + WriteString("), .T("); + IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name) END ; + WriteString("));") + ELSE (*array type*) + IF nofgen = 0 THEN WriteString("genvar i;"); WriteLn END ; + INC(nofgen); WriteString("generate"); WriteLn; + WriteString("for (i = 0; i < "); WriteInt(size); WriteString("; i = i+1) begin : bufblock"); WriteInt(nofgen); WriteLn; + WriteString("IOBUF block (.IO("); WriteString(obj.name); + WriteString("[i]), .O("); WriteString(x.a(LSB.Object).name); WriteString("[i]), .I("); x := x.b; + WriteString(x.a(LSB.Object).name); WriteString("[i]), .T("); + IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name); WriteString("[i]") END ; + WriteString("));"); WriteLn; WriteString("end"); WriteLn; WriteString("endgenerate") + END ; + WriteLn + END + ELSIF (obj.b # NIL) & (obj.val >= 2) THEN + WriteString("assign "); WriteString(obj.name); + IF (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; + WriteString(" = "); Expression(obj.b); Write(";"); WriteLn + END + ELSIF obj.tag = LSB.typ THEN (*instantiation; actual parameters*) + END ; + obj := obj.next + END + END ObjList1; + + PROCEDURE ObjList2(obj: LSB.Object); (*assignments to registers*) + VAR apar: LSB.Item; kind: LONGINT; clk: LSB.Item; + BEGIN + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) & (obj.val < 2) THEN + WriteString("always @ (posedge "); kind := obj.val; + IF kind = 0 THEN Expression(obj.a) + ELSE (*kind = 1*) WriteString("clk") + END ; + WriteString(") begin "); + REPEAT WriteString(obj.name); + IF (kind = 1) & (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; + WriteString(" <= "); Expression(obj.b); Write(";"); WriteLn; obj := obj.next + UNTIL (obj = LSB.top) OR (obj.val # kind); + WriteString("end"); WriteLn + ELSE obj := obj.next + END + END + END ObjList2; + + PROCEDURE List*; + VAR S: Texts.Scanner; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF (S.class = Texts.Name) OR (S.class = Texts.String) THEN + Texts.WriteString(W, LSB.modname); Texts.WriteString(W, " translating to "); Texts.WriteString(W, S.s); + F := Files.New(S.s); Files.Set(R, F, 0); + WriteString("`timescale 1ns / 1 ps"); WriteLn; nofgen := 0; + WriteString("module "); WriteString(LSB.modname); WriteString("( // translated from Lola"); WriteLn; + ObjList0(LSB.top); ObjList1(LSB.top); ObjList2(LSB.top); + WriteString("endmodule"); WriteLn; + Files.Register(F); Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END List; + +BEGIN Texts.OpenWriter(W); Constructor := Constructor0; + C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR"; + C[LSB.lit] := "LIT"; C[LSB.sel] := "SEL"; C[LSB.range] := ":"; C[LSB.cons] := ","; + C[LSB.or] := " | "; C[LSB.xor] := " ^ "; C[LSB.and] := " & "; C[LSB.not] := "~"; + C[LSB.add] := " + "; C[LSB.sub] := " - "; C[LSB.mul] := " * "; C[LSB.div] := " / "; + C[LSB.eql] := " == "; C[LSB.neq] := " != "; C[LSB.lss] := " < "; C[LSB.geq] := " >= "; C[LSB.leq] := " <= "; C[LSB.gtr] := " > "; + C[LSB.then] := " ? "; C[LSB.else] := " : "; C[LSB.ts] := "TS"; C[LSB.next] := "--" +END LSV. diff --git a/src/test/confidence/lola/RISC5.Lola b/src/test/confidence/lola/RISC5.Lola new file mode 100644 index 00000000..24af46fb --- /dev/null +++ b/src/test/confidence/lola/RISC5.Lola @@ -0,0 +1,214 @@ +MODULE RISC5 (IN clk, rst, stallX: BIT; (*NW 26.10.2015*) + IN inbus, codebus: WORD; + OUT adr: [24] BIT; + rd, wr, ben: BIT; + outbus: WORD); + + CONST StartAdr = 3FF800H'22; + + TYPE PROM := MODULE (IN clk: BIT; + IN adr: [9] BIT; + OUT data: WORD) ^; + + Multiplier := MODULE (IN clk, run, u: BIT; + OUT stall: BIT; + IN x, y: WORD; + OUT z: [64] BIT) ^; + + Divider := MODULE (IN clk, run, u: BIT; + OUT stall: BIT; + IN x, y: WORD; + OUT quot, rem: WORD) ^; + + FPAdder := MODULE (IN clk, run, u, v: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + FPMultiplier := MODULE (IN clk, run: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + FPDivider := MODULE (IN clk, run: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + REG (clk) PC: [22] BIT; (*program counter*) + IR: WORD; (*instruction register*) + N, Z, C, OV: BIT; (*condition flags*) + stall1, PMsel: BIT; + R: [16] WORD; (*data registers*) + H: WORD; (*auxiliary register*) + + VAR PM: PROM; (*mem for boot loader*) + mulUnit: Multiplier; + divUnit: Divider; + faddUnit: FPAdder; + fmulUnit: FPMultiplier; + fdivUnit: FPDivider; + + pcmux, nxpc: [22] BIT; + cond, S: BIT; + sa, sb, sc: BIT; + + ins, pmout: WORD; + p, q, u, v, w: BIT; (*instruction fields*) + op, ira, ira0, irb, irc: [4] BIT; + cc: [3] BIT; + imm: [16] BIT; + off: [20] BIT; + offL: [24] BIT; + + regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD: BIT; + sc1, sc0: [2] BIT; (*shift counts*) + + a0, a1, a2, a3: BIT; + inbusL, outbusB0, outbusB1, outbusB2, outbusB3: BYTE; + inbusH: [24] BIT; + + A, B, C0, C1, aluRes, regmux: WORD; + s1, s2, s3, t1, t2, t3: WORD; (*shifting*) + quotient, remainder: WORD; + product: [64] BIT; + fsum, fprod, fquot: WORD; + + Add, Sub, Mul, Div: BIT; + Fadd, Fsub, Fmul, Fdiv: BIT; + Ldr, Str, Br: BIT; + +BEGIN PM(clk, pcmux[8:0], pmout); + mulUnit (clk, Mul, ~u, stallM, B, C1, product); + divUnit (clk, Div, ~u, stallD, B, C1, quotient, remainder); + faddUnit (clk, Fadd|Fsub, u, v, stallFA, B, {Fsub^C0.31, C0[30:0]}, fsum); + fmulUnit (clk, Fmul, stallFM, B, C0, fprod); + fdivUnit (clk, Fdiv, stallFD, B, C0, fquot); + + ins := PMsel -> pmout : IR; (*current instruction*) + p := ins.31; (*instruction fields*) + q := ins.30; + u := ins.29; + v := ins.28; + w := ins.16; + cc:= ins[26:24]; + ira := ins[27:24]; + irb := ins[23:20]; + op := ins[19:16]; + irc := ins[3:0]; + imm := ins[15:0]; (*reg instr*) + off := ins[19:0]; (*mem instr*) + offL := ins[23:0]; (*branch instr*) + + Add := ~p & (op = 8); + Sub := ~p & (op = 9); + Mul := ~p & (op = 10); + Div := ~p & (op = 11); + Fadd := ~p & (op = 12); + Fsub := ~p & (op = 13); + Fmul := ~p & (op = 14); + Fdiv := ~p & (op = 15); + Ldr := p & ~q & ~u; + Str := p & ~q & u; + Br := p & q; + + (*ALU*) + A := R[ira0]; (*main data path*) + B := R[irb]; + C0 := R[irc]; + C1 := q -> {v!16, imm} : C0 ; + ira0 := Br -> 15'4 : ira; + adr := stallL -> B[23:0] + {0'4, off} : {pcmux, 0'2}; + rd := Ldr & ~stallX & ~stall1; + wr := Str & ~stallX & ~stall1; + ben := p & ~q & v & ~stallX & ~stall1; (*byte enable*) + + sc0 := C1[1:0]; + sc1 := C1[3:2]; + + (*right shifter*) + s1 := (sc0 = 3) -> {(w -> B[2:0] : {B.31 ! 3}), B[31:3]} : + (sc0 = 2) -> {(w -> B[1:0] : {B.31 ! 2}), B[31:2]} : + (sc0 = 1) -> {(w -> B.0 : B.31), B[31:1]} : B; + s2 := (sc1 = 3) -> {(w -> s1[11:0] : {B.31 ! 12}), s1[31:12]} : + (sc1 = 2) -> {(w -> s1[7:0] : {B.31 ! 8}), s1[31:8]} : + (sc1 = 1) -> {(w -> s1[3:0] : {B.31 ! 4}), s1[31:4]} : s1; + s3 := C1.4 -> {(w -> s2[15:0] : {s2.31 ! 16}), s2[31:16]} : s2; + + (*left shifter*) + t1 := (sc0 = 3) -> {B[28:0], 0'3} : + (sc0 = 2) -> {B[29:0], 0'2} : + (sc0 = 1) -> {B[30:0], 0'1} : B; + t2 := (sc1 = 3) -> {t1[19:0], 0'12} : + (sc1 = 2) -> {t1[23:0], 0'8} : + (sc1 = 1) -> {t1[27:0], 0'4} : t1; + t3 := C1.4 -> {t2[15:0], 0'16} : t2; + + aluRes := + ~op.3 -> + (~op.2 -> + (~op.1 -> + (~op.0 -> (*Mov*) + (q -> + (~u -> {v!16 , imm} : {imm, 0'16}) : + (~u -> C0 : (~v -> H : {N, Z, C, OV, 0'20, 58H'8}))) : + t3 ): (*Lsl*) + s3) : (*Asr, Ror*) + (~op.1 -> + (~op.0 -> B & C1 : B & ~C1) : (*And, Ann*) + (~op.0 -> B | C1 : B ^ C1)) ): (*Ior, Xor*) + (~op.2 -> + (~op.1 -> + (~op.0 -> B + C + (u&C) : B - C1 - (u&C)) : (*Add, Sub*) + (~op.0 -> product[31:0] : quotient)) : (*Mul, Div*) + (~op.1 -> + fsum : (*Fad, Fsb*) + (~op.0 -> fprod : fquot))) ; (*Fml, Fdv*) + + regwr := ~p & ~stall | (Ldr & ~stallX & ~stall1) | (Br & cond & v & ~stallX); + a0 := ~adr.1 & ~adr.0; + a1 := ~adr.1 & adr.0; + a2 := adr.1 & ~adr.0; + a3 := adr.1 & adr.0; + inbusL := (~ben | a0) -> inbus[7:0] : a1 -> inbus[15:8] : a2 -> inbus[23:16] : inbus[31:24]; + inbusH := ~ben -> inbus[31:8] : 0'24; + regmux := Ldr -> {inbusH, inbusL} : (Br & v) -> {0'8, nxpc, 0'2} : aluRes ; + + outbusB0 := A[7:0]; + outbusB1 := ben & a1 -> A[7:0] : A[15:8]; + outbusB2 := ben & a2 -> A[7:0] : A[23:16]; + outbusB3 := ben & a3 -> A[7:0] : A[31:24]; + outbus := {outbusB3, outbusB2, outbusB1, outbusB0}; + + (*control unit*) + S := N ^ OV; + nxpc := PC + 1; + cond := ins.27 ^ ( + (cc = 0) & N | (*MI, PL*) + (cc = 1) & Z | (*EQ, NE*) + (cc = 2) & C | (*CS, CC*) + (cc = 3) & OV | (*VS, VC*) + (cc = 4) & (C|Z) | (*LS, HI*) + (cc = 5) & S | (*LT, GE*) + (cc = 6) & (S|Z) | (*LE, GT*) + (cc = 7)); + pcmux := ~rst -> 3FF800H'22 : + stall -> PC : + (Br & cond & u) -> offL[21:0] + nxpc : + (Br & cond & ~u) -> C0[23:2] : nxpc; + + sa := aluRes.31; + sb := B.31; + sc := C1.31; + + stall := stallL | stallM | stallD | stallFA | stallFM | stallFD | stallX; + stallL := (Ldr | Str) & ~stall1; + + (*assignments to registers*) + PC := pcmux; + PMsel := ~rst | (pcmux[21:12] = 03FFH'10); + IR := stall -> IR : codebus; + stall1 := stallX -> stall1 : stallL; + R[ira0] := regwr -> regmux : A; + N := regwr -> regmux.31 : N; + Z := regwr -> (regmux = 0) : Z; + C := Add -> (sb&sc) | (~sa&~sb&sc) | (~sa&sb&~sc&sa) : + Sub -> (~sb&sc) | (sa&~sb&~sc) | (sa&sb&sc) : C; + OV := Add -> (sa&~sb&~sc) | (~sa&sb&sc) : + Sub -> (sa&~sb&sc) | (~sa&sb&~sc) : OV; + H := Mul -> product[63:32] : Div -> remainder : H +END RISC5. diff --git a/src/test/confidence/lola/expected b/src/test/confidence/lola/expected new file mode 100644 index 00000000..12f87669 --- /dev/null +++ b/src/test/confidence/lola/expected @@ -0,0 +1,113 @@ +`timescale 1ns / 1 ps +module RISC5( // translated from Lola +input clk, rst, stallX, +input [31:0] inbus, codebus, +output [23:0] adr, +output rd, wr, ben, +output [31:0] outbus); +reg [21:0] PC; +reg [31:0] IR; +reg N, Z, C, OV, stall1, PMsel; +reg [31:0] R[15:0]; +reg [31:0] H; +wire [21:0] pcmux, nxpc; +wire cond, S, sa, sb, sc; +wire [31:0] ins, pmout; +wire p, q, u, v, w; +wire [3:0] op, ira, ira0, irb, irc; +wire [2:0] cc; +wire [15:0] imm; +wire [19:0] off; +wire [23:0] offL; +wire regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD; +wire [1:0] sc1, sc0; +wire a0, a1, a2, a3; +wire [7:0] inbusL, outbusB0, outbusB1, outbusB2, outbusB3; +wire [23:0] inbusH; +wire [31:0] A, B, C0, C1, aluRes, regmux, s1, s2, s3, t1, t2, t3, quotient, remainder; +wire [63:0] product; +wire [31:0] fsum, fprod, fquot; +wire Add, Sub, Mul, Div, Fadd, Fsub, Fmul, Fdiv, Ldr, Str, Br; +assign adr = stallL ? (B[23:0] + {4'h0, off}) : {pcmux, 2'h0}; +assign rd = ((Ldr & ~stallX) & ~stall1); +assign wr = ((Str & ~stallX) & ~stall1); +assign ben = ((((p & ~q) & v) & ~stallX) & ~stall1); +assign outbus = {outbusB3, outbusB2, outbusB1, outbusB0}; +PROM PM(.clk(clk), .adr(pcmux[8:0]), .data(pmout)); +Multiplier mulUnit(.clk(clk), .run(Mul), .u(~u), .stall(stallM), .x(B), .y(C1), .z(product)); +Divider divUnit(.clk(clk), .run(Div), .u(~u), .stall(stallD), .x(B), .y(C1), .quot(quotient), .rem(remainder)); +FPAdder faddUnit(.clk(clk), .run((Fadd | Fsub)), .u(u), .v(v), .stall(stallFA), .x(B), .y({(Fsub ^ C0[31]), C0[30:0]}), .z(fsum)); +FPMultiplier fmulUnit(.clk(clk), .run(Fmul), .stall(stallFM), .x(B), .y(C0), .z(fprod)); +FPDivider fdivUnit(.clk(clk), .run(Fdiv), .stall(stallFD), .x(B), .y(C0), .z(fquot)); +assign pcmux = ~rst ? 22'h3FF800 : stall ? PC : ((Br & cond) & u) ? (offL[21:0] + nxpc) : ((Br & cond) & ~u) ? C0[23:2] : nxpc; +assign nxpc = (PC + 1); +assign cond = (ins[27] ^ (((((((((cc == 0) & N) | ((cc == 1) & Z)) | ((cc == 2) & C)) | ((cc == 3) & OV)) | ((cc == 4) & (C | Z))) | ((cc == 5) & S)) | ((cc == 6) & (S | Z))) | (cc == 7))); +assign S = (N ^ OV); +assign sa = aluRes[31]; +assign sb = B[31]; +assign sc = C1[31]; +assign ins = PMsel ? pmout : IR; +assign p = ins[31]; +assign q = ins[30]; +assign u = ins[29]; +assign v = ins[28]; +assign w = ins[16]; +assign op = ins[19:16]; +assign ira = ins[27:24]; +assign ira0 = Br ? 4'hF : ira; +assign irb = ins[23:20]; +assign irc = ins[3:0]; +assign cc = ins[26:24]; +assign imm = ins[15:0]; +assign off = ins[19:0]; +assign offL = ins[23:0]; +assign regwr = (((~p & ~stall) | ((Ldr & ~stallX) & ~stall1)) | (((Br & cond) & v) & ~stallX)); +assign stall = ((((((stallL | stallM) | stallD) | stallFA) | stallFM) | stallFD) | stallX); +assign stallL = ((Ldr | Str) & ~stall1); +assign sc1 = C1[3:2]; +assign sc0 = C1[1:0]; +assign a0 = (~adr[1] & ~adr[0]); +assign a1 = (~adr[1] & adr[0]); +assign a2 = (adr[1] & ~adr[0]); +assign a3 = (adr[1] & adr[0]); +assign inbusL = (~ben | a0) ? inbus[7:0] : a1 ? inbus[15:8] : a2 ? inbus[23:16] : inbus[31:24]; +assign outbusB0 = A[7:0]; +assign outbusB1 = (ben & a1) ? A[7:0] : A[15:8]; +assign outbusB2 = (ben & a2) ? A[7:0] : A[23:16]; +assign outbusB3 = (ben & a3) ? A[7:0] : A[31:24]; +assign inbusH = ~ben ? inbus[31:8] : 24'h0; +assign A = R[ira0]; +assign B = R[irb]; +assign C0 = R[irc]; +assign C1 = q ? {{16{v}}, imm} : C0; +assign aluRes = ~op[3] ? ~op[2] ? ~op[1] ? ~op[0] ? q ? ~u ? {{16{v}}, imm} : {imm, 16'h0} : ~u ? C0 : ~v ? H : {N, Z, C, OV, 20'h0, 8'h58} : t3 : s3 : ~op[1] ? ~op[0] ? (B & C1) : (B & ~C1) : ~op[0] ? (B | C1) : (B ^ C1) : ~op[2] ? ~op[1] ? ~op[0] ? ((B + C) + (u & C)) : ((B - C1) - (u & C)) : ~op[0] ? product[31:0] : quotient : ~op[1] ? fsum : ~op[0] ? fprod : fquot; +assign regmux = Ldr ? {inbusH, inbusL} : (Br & v) ? {8'h0, nxpc, 2'h0} : aluRes; +assign s1 = (sc0 == 3) ? {w ? B[2:0] : {3{B[31]}}, B[31:3]} : (sc0 == 2) ? {w ? B[1:0] : {2{B[31]}}, B[31:2]} : (sc0 == 1) ? {w ? B[0] : B[31], B[31:1]} : B; +assign s2 = (sc1 == 3) ? {w ? s1[11:0] : {12{B[31]}}, s1[31:12]} : (sc1 == 2) ? {w ? s1[7:0] : {8{B[31]}}, s1[31:8]} : (sc1 == 1) ? {w ? s1[3:0] : {4{B[31]}}, s1[31:4]} : s1; +assign s3 = C1[4] ? {w ? s2[15:0] : {16{s2[31]}}, s2[31:16]} : s2; +assign t1 = (sc0 == 3) ? {B[28:0], 3'h0} : (sc0 == 2) ? {B[29:0], 2'h0} : (sc0 == 1) ? {B[30:0], 1'h0} : B; +assign t2 = (sc1 == 3) ? {t1[19:0], 12'h0} : (sc1 == 2) ? {t1[23:0], 8'h0} : (sc1 == 1) ? {t1[27:0], 4'h0} : t1; +assign t3 = C1[4] ? {t2[15:0], 16'h0} : t2; +assign Add = (~p & (op == 8)); +assign Sub = (~p & (op == 9)); +assign Mul = (~p & (op == 10)); +assign Div = (~p & (op == 11)); +assign Fadd = (~p & (op == 12)); +assign Fsub = (~p & (op == 13)); +assign Fmul = (~p & (op == 14)); +assign Fdiv = (~p & (op == 15)); +assign Ldr = ((p & ~q) & ~u); +assign Str = ((p & ~q) & u); +assign Br = (p & q); +always @ (posedge clk) begin PC <= pcmux; +IR <= stall ? IR : codebus; +N <= regwr ? regmux[31] : N; +Z <= regwr ? (regmux == 0) : Z; +C <= Add ? (((sb & sc) | ((~sa & ~sb) & sc)) | (((~sa & sb) & ~sc) & sa)) : Sub ? (((~sb & sc) | ((sa & ~sb) & ~sc)) | ((sa & sb) & sc)) : C; +OV <= Add ? (((sa & ~sb) & ~sc) | ((~sa & sb) & sc)) : Sub ? (((sa & ~sb) & sc) | ((~sa & sb) & ~sc)) : OV; +stall1 <= stallX ? stall1 : stallL; +PMsel <= (~rst | (pcmux[21:12] == 10'h3FF)); +R[ira0] <= regwr ? regmux : A; +H <= Mul ? product[63:32] : Div ? remainder : H; +end +endmodule diff --git a/src/test/confidence/lola/lola.Mod b/src/test/confidence/lola/lola.Mod new file mode 100644 index 00000000..8f7faaa3 --- /dev/null +++ b/src/test/confidence/lola/lola.Mod @@ -0,0 +1,12 @@ +MODULE Lola; (* Command line runner for Lola to verilog compilation *) + IMPORT LSB, LSC, LSV, Modules, Console; +BEGIN + IF Modules.ArgCount < 3 THEN + Console.String("Lola - compile lola source to verilog source."); Console.Ln; Console.Ln; + Console.String("usage:"); Console.Ln; Console.Ln; + Console.String(" lola lola-source-file verilog-source-file"); Console.Ln; Console.Ln; + ELSE + LSC.Compile; + IF LSB.modname # "" THEN LSV.List END + END +END Lola. diff --git a/src/test/confidence/lola/old.cygwin.ILP32.gcc.s b/src/test/confidence/lola/old.cygwin.ILP32.gcc.s new file mode 100644 index 00000000..601c26da --- /dev/null +++ b/src/test/confidence/lola/old.cygwin.ILP32.gcc.s @@ -0,0 +1,105 @@ +55 pushl %ebp +89E5 movl %esp, %ebp +83EC10 subl $16, %esp +C745FC00 movl $0, -4(%ebp) +8B55FC movl -4(%ebp), %edx +8B4508 movl 8(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FB movb %al, -5(%ebp) +8B55FC movl -4(%ebp), %edx +8B450C movl 12(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FA movb %al, -6(%ebp) +8345FC01 addl $1, -4(%ebp) +807DFB00 cmpb $0, -5(%ebp) +7508 jne L2 +0FB645FA movzbl -6(%ebp), %eax +F7D8 negl %eax +EB15 jmp L3 +0FB645FB movzbl -5(%ebp), %eax +3A45FA cmpb -6(%ebp), %al +74C9 je L4 +0FB655FB movzbl -5(%ebp), %edx +0FB645FA movzbl -6(%ebp), %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C9 leave +C3 ret +4C6F6C61 .ascii "Lola\0" +000000 .align 4 +4C6F6C61 .ascii "Lola - compile lola source to verilog source.\0" +202D2063 +6F6D7069 +6C65206C +6F6C6120 +75736167 .ascii "usage:\0" +000000 .align 4 +20206C6F .ascii " lola lola-source-file verilog-source-file\0" +6C61206C +6F6C612D +736F7572 +63652D66 +55 pushl %ebp +89E5 movl %esp, %ebp +83E4F0 andl $-16, %esp +83EC10 subl $16, %esp +E8000000 call ___main +8D550C leal 12(%ebp), %edx +8B4508 movl 8(%ebp), %eax +98 cwtl +89542404 movl %edx, 4(%esp) +890424 movl %eax, (%esp) +E8000000 call _Platform_Init +E8000000 call _Console__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _LSB__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _LSC__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _LSV__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _Platform__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +C7442404 movl $0, 4(%esp) +00000000 +C7042400 movl $LC0, (%esp) +E8000000 call _Heap_REGMOD +A3000000 movl %eax, _m.1843 +0FB70500 movzwl _Platform_ArgCount, %eax +6683F802 cmpw $2, %ax +7F5C jg L6 +C7442404 movl $46, 4(%esp) +2E000000 +C7042408 movl $LC1, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +C7442404 movl $7, 4(%esp) +07000000 +C7042436 movl $LC2, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +C7442404 movl $44, 4(%esp) +2C000000 +C7042440 movl $LC3, (%esp) +E8000000 call _Console_String +E8000000 call _Console_Ln +E8000000 call _Console_Ln +EB15 jmp L7 +E8000000 call _LSC_Compile +0FB60500 movzbl _LSB_modname, %eax +84C0 testb %al, %al +7405 je L7 +E8000000 call _LSV_List +E8000000 call _Heap_FINALL +B8000000 movl $0, %eax +C9 leave +C3 ret diff --git a/src/test/confidence/lola/test.sh b/src/test/confidence/lola/test.sh new file mode 100755 index 00000000..3571e536 --- /dev/null +++ b/src/test/confidence/lola/test.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ../testenv.sh +$OBECOMP LSS.Mod +$OBECOMP LSB.Mod +$OBECOMP LSC.Mod +$OBECOMP LSV.Mod +$OBECOMP lola.Mod -m +./Lola RISC5.Lola result +. ../testresult.sh diff --git a/src/test/confidence/math/expected b/src/test/confidence/math/expected new file mode 100644 index 00000000..fb01dc20 --- /dev/null +++ b/src/test/confidence/math/expected @@ -0,0 +1,328 @@ +Math and MathL module tests. + +Math.fraction(9.00000E-01): 1.80000E+00. MathL.fraction(9.00000000000000D-001): 1.80000000000000D+000 +Math.fraction(1.00000E+00): 1.00000E+00. MathL.fraction(1.00000000000000D+000): 1.00000000000000D+000 +Math.fraction(1.40000E+00): 1.40000E+00. MathL.fraction(1.40000000000000D+000): 1.40000000000000D+000 +Math.fraction(1.50000E+00): 1.50000E+00. MathL.fraction(1.50000000000000D+000): 1.50000000000000D+000 +Math.fraction(1.60000E+00): 1.60000E+00. MathL.fraction(1.60000000000000D+000): 1.60000000000000D+000 +Math.fraction(1.90000E+00): 1.90000E+00. MathL.fraction(1.90000000000000D+000): 1.90000000000000D+000 +Math.fraction(2.00000E+00): 1.00000E+00. MathL.fraction(2.00000000000000D+000): 1.00000000000000D+000 +Math.fraction(2.40000E+00): 1.20000E+00. MathL.fraction(2.40000000000000D+000): 1.20000000000000D+000 +Math.fraction(2.50000E+00): 1.25000E+00. MathL.fraction(2.50000000000000D+000): 1.25000000000000D+000 +Math.fraction(3.00000E+00): 1.50000E+00. MathL.fraction(3.00000000000000D+000): 1.50000000000000D+000 +Math.fraction(4.00000E+00): 1.00000E+00. MathL.fraction(4.00000000000000D+000): 1.00000000000000D+000 +Math.fraction(-9.0000E-01): -1.8000E+00. MathL.fraction(-9.0000000000000D-001): -1.8000000000000D+000 +Math.fraction(-1.0000E+00): -1.0000E+00. MathL.fraction(-1.0000000000000D+000): -1.0000000000000D+000 +Math.fraction(-1.4000E+00): -1.4000E+00. MathL.fraction(-1.4000000000000D+000): -1.4000000000000D+000 +Math.fraction(-1.5000E+00): -1.5000E+00. MathL.fraction(-1.5000000000000D+000): -1.5000000000000D+000 +Math.fraction(-1.6000E+00): -1.6000E+00. MathL.fraction(-1.6000000000000D+000): -1.6000000000000D+000 +Math.fraction(-1.9000E+00): -1.9000E+00. MathL.fraction(-1.9000000000000D+000): -1.9000000000000D+000 +Math.fraction(-2.0000E+00): -1.0000E+00. MathL.fraction(-2.0000000000000D+000): -1.0000000000000D+000 +Math.fraction(-2.4000E+00): -1.2000E+00. MathL.fraction(-2.4000000000000D+000): -1.2000000000000D+000 +Math.fraction(-2.5000E+00): -1.2500E+00. MathL.fraction(-2.5000000000000D+000): -1.2500000000000D+000 +Math.fraction(-3.0000E+00): -1.5000E+00. MathL.fraction(-3.0000000000000D+000): -1.5000000000000D+000 +Math.fraction(-4.0000E+00): -1.0000E+00. MathL.fraction(-4.0000000000000D+000): -1.0000000000000D+000 + +Math.round(9.00000E-01): 1. MathL.round(9.00000000000000D-001): 1 +Math.round(1.00000E+00): 1. MathL.round(1.00000000000000D+000): 1 +Math.round(1.40000E+00): 1. MathL.round(1.40000000000000D+000): 1 +Math.round(1.50000E+00): 2. MathL.round(1.50000000000000D+000): 2 +Math.round(1.60000E+00): 2. MathL.round(1.60000000000000D+000): 2 +Math.round(1.90000E+00): 2. MathL.round(1.90000000000000D+000): 2 +Math.round(2.00000E+00): 2. MathL.round(2.00000000000000D+000): 2 +Math.round(2.40000E+00): 2. MathL.round(2.40000000000000D+000): 2 +Math.round(2.50000E+00): 3. MathL.round(2.50000000000000D+000): 3 +Math.round(3.00000E+00): 3. MathL.round(3.00000000000000D+000): 3 +Math.round(4.00000E+00): 4. MathL.round(4.00000000000000D+000): 4 +Math.round(-9.0000E-01): -1. MathL.round(-9.0000000000000D-001): -1 +Math.round(-1.0000E+00): -1. MathL.round(-1.0000000000000D+000): -1 +Math.round(-1.4000E+00): -1. MathL.round(-1.4000000000000D+000): -1 +Math.round(-1.5000E+00): -2. MathL.round(-1.5000000000000D+000): -2 +Math.round(-1.6000E+00): -2. MathL.round(-1.6000000000000D+000): -2 +Math.round(-1.9000E+00): -2. MathL.round(-1.9000000000000D+000): -2 +Math.round(-2.0000E+00): -2. MathL.round(-2.0000000000000D+000): -2 +Math.round(-2.4000E+00): -2. MathL.round(-2.4000000000000D+000): -2 +Math.round(-2.5000E+00): -3. MathL.round(-2.5000000000000D+000): -3 +Math.round(-3.0000E+00): -3. MathL.round(-3.0000000000000D+000): -3 +Math.round(-4.0000E+00): -4. MathL.round(-4.0000000000000D+000): -4 + +Math.sqrt(9.00000E-01): 9.48683E-01. MathL.sqrt(9.00000000000000D-001): 9.48683298050514D-001 +Math.sqrt(1.00000E+00): 1.00000E-01. MathL.sqrt(1.00000000000000D+000): 1.00000000000000D+000 +Math.sqrt(1.40000E+00): 1.18322E+00. MathL.sqrt(1.40000000000000D+000): 1.18321595661992D+000 +Math.sqrt(1.50000E+00): 1.22474E+00. MathL.sqrt(1.50000000000000D+000): 1.22474487139159D+000 +Math.sqrt(1.60000E+00): 1.26491E+00. MathL.sqrt(1.60000000000000D+000): 1.26491106406735D+000 +Math.sqrt(1.90000E+00): 1.37840E+00. MathL.sqrt(1.90000000000000D+000): 1.37840487520902D+000 +Math.sqrt(2.00000E+00): 1.41421E+00. MathL.sqrt(2.00000000000000D+000): 1.41421356237310D+000 +Math.sqrt(2.40000E+00): 1.54919E+00. MathL.sqrt(2.40000000000000D+000): 1.54919333848297D+000 +Math.sqrt(2.50000E+00): 1.58114E+00. MathL.sqrt(2.50000000000000D+000): 1.58113883008419D+000 +Math.sqrt(3.00000E+00): 1.73205E+00. MathL.sqrt(3.00000000000000D+000): 1.73205080756888D+000 +Math.sqrt(4.00000E+00): 2.00000E+00. MathL.sqrt(4.00000000000000D+000): 2.00000000000000D+000 +Math.sqrt(-9.0000E-01): 9.48683E-01. MathL.sqrt(-9.0000000000000D-001): 9.48683298050514D-001 +Math.sqrt(-1.0000E+00): 1.00000E-01. MathL.sqrt(-1.0000000000000D+000): 1.00000000000000D+000 +Math.sqrt(-1.4000E+00): 1.18322E+00. MathL.sqrt(-1.4000000000000D+000): 1.18321595661992D+000 +Math.sqrt(-1.5000E+00): 1.22474E+00. MathL.sqrt(-1.5000000000000D+000): 1.22474487139159D+000 +Math.sqrt(-1.6000E+00): 1.26491E+00. MathL.sqrt(-1.6000000000000D+000): 1.26491106406735D+000 +Math.sqrt(-1.9000E+00): 1.37840E+00. MathL.sqrt(-1.9000000000000D+000): 1.37840487520902D+000 +Math.sqrt(-2.0000E+00): 1.41421E+00. MathL.sqrt(-2.0000000000000D+000): 1.41421356237310D+000 +Math.sqrt(-2.4000E+00): 1.54919E+00. MathL.sqrt(-2.4000000000000D+000): 1.54919333848297D+000 +Math.sqrt(-2.5000E+00): 1.58114E+00. MathL.sqrt(-2.5000000000000D+000): 1.58113883008419D+000 +Math.sqrt(-3.0000E+00): 1.73205E+00. MathL.sqrt(-3.0000000000000D+000): 1.73205080756888D+000 +Math.sqrt(-4.0000E+00): 2.00000E+00. MathL.sqrt(-4.0000000000000D+000): 2.00000000000000D+000 + +Math.ln(9.00000E-01): -1.05361E-01. MathL.ln(9.00000000000000D-001): -1.05360515657826D-001 +Math.ln(1.00000E+00): 0.00000E+00. MathL.ln(1.00000000000000D+000): 0.00000000000000D+000 +Math.ln(1.40000E+00): 3.36472E-01. MathL.ln(1.40000000000000D+000): 3.36472236621213D-001 +Math.ln(1.50000E+00): 4.05465E-01. MathL.ln(1.50000000000000D+000): 4.05465108108164D-001 +Math.ln(1.60000E+00): 4.70004E-01. MathL.ln(1.60000000000000D+000): 4.70003629245736D-001 +Math.ln(1.90000E+00): 6.41854E-01. MathL.ln(1.90000000000000D+000): 6.41853886172395D-001 +Math.ln(2.00000E+00): 6.93147E-01. MathL.ln(2.00000000000000D+000): 6.93147180559945D-001 +Math.ln(2.40000E+00): 8.75469E-01. MathL.ln(2.40000000000000D+000): 8.75468737353900D-001 +Math.ln(2.50000E+00): 9.16291E-01. MathL.ln(2.50000000000000D+000): 9.16290731874155D-001 +Math.ln(3.00000E+00): 1.09861E+00. MathL.ln(3.00000000000000D+000): 1.09861228866811D+000 +Math.ln(4.00000E+00): 1.38629E+00. MathL.ln(4.00000000000000D+000): 1.38629436111989D+000 +Math.ln(-9.0000E-01): -3.40282E+38. MathL.ln(-9.0000000000000D-001): -1.79769296342094D+308 +Math.ln(-1.0000E+00): -3.40282E+38. MathL.ln(-1.0000000000000D+000): -1.79769296342094D+308 +Math.ln(-1.4000E+00): -3.40282E+38. MathL.ln(-1.4000000000000D+000): -1.79769296342094D+308 +Math.ln(-1.5000E+00): -3.40282E+38. MathL.ln(-1.5000000000000D+000): -1.79769296342094D+308 +Math.ln(-1.6000E+00): -3.40282E+38. MathL.ln(-1.6000000000000D+000): -1.79769296342094D+308 +Math.ln(-1.9000E+00): -3.40282E+38. MathL.ln(-1.9000000000000D+000): -1.79769296342094D+308 +Math.ln(-2.0000E+00): -3.40282E+38. MathL.ln(-2.0000000000000D+000): -1.79769296342094D+308 +Math.ln(-2.4000E+00): -3.40282E+38. MathL.ln(-2.4000000000000D+000): -1.79769296342094D+308 +Math.ln(-2.5000E+00): -3.40282E+38. MathL.ln(-2.5000000000000D+000): -1.79769296342094D+308 +Math.ln(-3.0000E+00): -3.40282E+38. MathL.ln(-3.0000000000000D+000): -1.79769296342094D+308 +Math.ln(-4.0000E+00): -3.40282E+38. MathL.ln(-4.0000000000000D+000): -1.79769296342094D+308 + +Math.sin(0.00000E+00): 0.00000E+00. MathL.sin(0.00000000000000D+000): 0.00000000000000D+000 +Math.sin(1.00000E-01): 9.98334E-02. MathL.sin(1.00000000000000D-001): 9.98334166468282D-002 +Math.sin(1.04720E+00): 8.66025E-01. MathL.sin(1.04719755119660D+000): 8.66025403784440D-001 +Math.sin(1.57080E+00): 1.00000E+00. MathL.sin(1.57079632679490D+000): 9.99999999999999D-001 +Math.sin(3.14159E+00): -3.10862E-15. MathL.sin(3.14159265358979D+000): 3.23108679839857D-015 +Math.sin(-1.0472E+00): -8.66025E-01. MathL.sin(-1.0471975511966D+000): -8.6602540378444D-001 +Math.sin(-1.5708E+00): -1.0000E+00. MathL.sin(-1.5707963267949D+000): -9.99999999999999D-001 +Math.sin(-3.14159E+00): 3.10862E-15. MathL.sin(-3.14159265358979D+000): -3.23108679839857D-015 + +Math.cos(0.00000E+00): 1.00000E+00. MathL.cos(0.00000000000000D+000): 9.99999999999999D-001 +Math.cos(1.00000E-01): 9.95004E-01. MathL.cos(1.00000000000000D-001): 9.95004165278025D-001 +Math.cos(1.04720E+00): 5.00000E-01. MathL.cos(1.04719755119660D+000): 4.99999999999998D-001 +Math.cos(1.57080E+00): -1.55431E-15. MathL.cos(1.57079632679490D+000): -3.49148251407644D-015 +Math.cos(3.14159E+00): -1.0000E+00. MathL.cos(3.14159265358979D+000): -9.99999999999999D-001 +Math.cos(-1.0472E+00): 5.00000E-01. MathL.cos(-1.0471975511966D+000): 4.99999999999998D-001 +Math.cos(-1.5708E+00): -1.55431E-15. MathL.cos(-1.5707963267949D+000): -3.49148251407644D-015 +Math.cos(-3.14159E+00): -1.0000E+00. MathL.cos(-3.14159265358979D+000): -9.99999999999999D-001 + +Math.tan(0.00000E+00): 0.00000E+00. MathL.tan(0.00000000000000D+000): 0.00000000000000D+000 +Math.tan(1.00000E-01): 1.00335E-01. MathL.tan(1.00000000000000D-001): 1.00334672085451D-001 +Math.tan(1.04720E+00): 1.73205E+00. MathL.tan(1.04719755119660D+000): 1.73205080756888D+000 +Math.tan(1.57080E+00): 3.00240E+14. MathL.tan(1.57079632679490D+000): 2.02340838177263D+007 +Math.tan(3.14159E+00): -6.66134E-15. MathL.tan(3.14159265358979D+000): 3.23108679839857D-015 +Math.tan(-1.0472E+00): -1.73205E+00. MathL.tan(-1.0471975511966D+000): -1.73205080756888D+000 +Math.tan(-1.5708E+00): -3.0024E+14. MathL.tan(-1.5707963267949D+000): -2.02340838177263D+007 +Math.tan(-3.14159E+00): 6.66134E-15. MathL.tan(-3.14159265358979D+000): -3.23108679839857D-015 + +Math.arcsin(9.00000E-01): -4.51027E-01. MathL.arcsin(9.00000000000000D-001): 1.11976951499864D+000 +Math.arcsin(1.00000E+00): -0.0000E+00. MathL.arcsin(1.00000000000000D+000): 1.57079632679490D+000 +Math.arcsin(1.40000E+00): 3.40282E+38. MathL.arcsin(1.40000000000000D+000): 1.79769296342094D+308 +Math.arcsin(1.50000E+00): 3.40282E+38. MathL.arcsin(1.50000000000000D+000): 1.79769296342094D+308 +Math.arcsin(1.60000E+00): 3.40282E+38. MathL.arcsin(1.60000000000000D+000): 1.79769296342094D+308 +Math.arcsin(1.90000E+00): 3.40282E+38. MathL.arcsin(1.90000000000000D+000): 1.79769296342094D+308 +Math.arcsin(2.00000E+00): 3.40282E+38. MathL.arcsin(2.00000000000000D+000): 1.79769296342094D+308 +Math.arcsin(2.40000E+00): 3.40282E+38. MathL.arcsin(2.40000000000000D+000): 1.79769296342094D+308 +Math.arcsin(2.50000E+00): 3.40282E+38. MathL.arcsin(2.50000000000000D+000): 1.79769296342094D+308 +Math.arcsin(3.00000E+00): 3.40282E+38. MathL.arcsin(3.00000000000000D+000): 1.79769296342094D+308 +Math.arcsin(4.00000E+00): 3.40282E+38. MathL.arcsin(4.00000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-9.0000E-01): -4.51027E-01. MathL.arcsin(-9.0000000000000D-001): -1.11976951499864D+000 +Math.arcsin(-1.0000E+00): -0.0000E+00. MathL.arcsin(-1.0000000000000D+000): -1.5707963267949D+000 +Math.arcsin(-1.4000E+00): 3.40282E+38. MathL.arcsin(-1.4000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-1.5000E+00): 3.40282E+38. MathL.arcsin(-1.5000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-1.6000E+00): 3.40282E+38. MathL.arcsin(-1.6000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-1.9000E+00): 3.40282E+38. MathL.arcsin(-1.9000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-2.0000E+00): 3.40282E+38. MathL.arcsin(-2.0000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-2.4000E+00): 3.40282E+38. MathL.arcsin(-2.4000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-2.5000E+00): 3.40282E+38. MathL.arcsin(-2.5000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-3.0000E+00): 3.40282E+38. MathL.arcsin(-3.0000000000000D+000): 1.79769296342094D+308 +Math.arcsin(-4.0000E+00): 3.40282E+38. MathL.arcsin(-4.0000000000000D+000): 1.79769296342094D+308 + +Math.arccos(9.00000E-01): -4.51027E-01. MathL.arccos(9.00000000000000D-001): 4.51026811796263D-001 +Math.arccos(1.00000E+00): -0.0000E+00. MathL.arccos(1.00000000000000D+000): 0.00000000000000D+000 +Math.arccos(1.40000E+00): 3.40282E+38. MathL.arccos(1.40000000000000D+000): 1.79769296342094D+308 +Math.arccos(1.50000E+00): 3.40282E+38. MathL.arccos(1.50000000000000D+000): 1.79769296342094D+308 +Math.arccos(1.60000E+00): 3.40282E+38. MathL.arccos(1.60000000000000D+000): 1.79769296342094D+308 +Math.arccos(1.90000E+00): 3.40282E+38. MathL.arccos(1.90000000000000D+000): 1.79769296342094D+308 +Math.arccos(2.00000E+00): 3.40282E+38. MathL.arccos(2.00000000000000D+000): 1.79769296342094D+308 +Math.arccos(2.40000E+00): 3.40282E+38. MathL.arccos(2.40000000000000D+000): 1.79769296342094D+308 +Math.arccos(2.50000E+00): 3.40282E+38. MathL.arccos(2.50000000000000D+000): 1.79769296342094D+308 +Math.arccos(3.00000E+00): 3.40282E+38. MathL.arccos(3.00000000000000D+000): 1.79769296342094D+308 +Math.arccos(4.00000E+00): 3.40282E+38. MathL.arccos(4.00000000000000D+000): 1.79769296342094D+308 +Math.arccos(-9.0000E-01): -4.51027E-01. MathL.arccos(-9.0000000000000D-001): 2.69056584179353D+000 +Math.arccos(-1.0000E+00): -0.0000E+00. MathL.arccos(-1.0000000000000D+000): 3.14159265358979D+000 +Math.arccos(-1.4000E+00): 3.40282E+38. MathL.arccos(-1.4000000000000D+000): 1.79769296342094D+308 +Math.arccos(-1.5000E+00): 3.40282E+38. MathL.arccos(-1.5000000000000D+000): 1.79769296342094D+308 +Math.arccos(-1.6000E+00): 3.40282E+38. MathL.arccos(-1.6000000000000D+000): 1.79769296342094D+308 +Math.arccos(-1.9000E+00): 3.40282E+38. MathL.arccos(-1.9000000000000D+000): 1.79769296342094D+308 +Math.arccos(-2.0000E+00): 3.40282E+38. MathL.arccos(-2.0000000000000D+000): 1.79769296342094D+308 +Math.arccos(-2.4000E+00): 3.40282E+38. MathL.arccos(-2.4000000000000D+000): 1.79769296342094D+308 +Math.arccos(-2.5000E+00): 3.40282E+38. MathL.arccos(-2.5000000000000D+000): 1.79769296342094D+308 +Math.arccos(-3.0000E+00): 3.40282E+38. MathL.arccos(-3.0000000000000D+000): 1.79769296342094D+308 +Math.arccos(-4.0000E+00): 3.40282E+38. MathL.arccos(-4.0000000000000D+000): 1.79769296342094D+308 + +Math.arctan(9.00000E-01): 7.32815E-01. MathL.arctan(9.00000000000000D-001): 7.32815101786508D-001 +Math.arctan(1.00000E+00): 7.85398E-01. MathL.arctan(1.00000000000000D+000): 7.85398163397449D-001 +Math.arctan(1.40000E+00): 9.50547E-01. MathL.arctan(1.40000000000000D+000): 9.50546840812077D-001 +Math.arctan(1.50000E+00): 9.82794E-01. MathL.arctan(1.50000000000000D+000): 9.82793723247331D-001 +Math.arctan(1.60000E+00): 1.01220E+00. MathL.arctan(1.60000000000000D+000): 1.01219701145134D+000 +Math.arctan(1.90000E+00): 1.08632E+00. MathL.arctan(1.90000000000000D+000): 1.08631839775788D+000 +Math.arctan(2.00000E+00): 1.10715E+00. MathL.arctan(2.00000000000000D+000): 1.10714871779409D+000 +Math.arctan(2.40000E+00): 1.17601E+00. MathL.arctan(2.40000000000000D+000): 1.17600520709514D+000 +Math.arctan(2.50000E+00): 1.19029E+00. MathL.arctan(2.50000000000000D+000): 1.19028994968253D+000 +Math.arctan(3.00000E+00): 1.24905E+00. MathL.arctan(3.00000000000000D+000): 1.24904577239826D+000 +Math.arctan(4.00000E+00): 1.32582E+00. MathL.arctan(4.00000000000000D+000): 1.32581766366804D+000 +Math.arctan(-9.0000E-01): -7.32815E-01. MathL.arctan(-9.0000000000000D-001): -7.32815101786508D-001 +Math.arctan(-1.0000E+00): -7.85398E-01. MathL.arctan(-1.0000000000000D+000): -7.85398163397449D-001 +Math.arctan(-1.4000E+00): -9.50547E-01. MathL.arctan(-1.4000000000000D+000): -9.50546840812077D-001 +Math.arctan(-1.5000E+00): -9.82794E-01. MathL.arctan(-1.5000000000000D+000): -9.82793723247331D-001 +Math.arctan(-1.6000E+00): -1.0122E+00. MathL.arctan(-1.6000000000000D+000): -1.01219701145134D+000 +Math.arctan(-1.9000E+00): -1.08632E+00. MathL.arctan(-1.9000000000000D+000): -1.08631839775788D+000 +Math.arctan(-2.0000E+00): -1.10715E+00. MathL.arctan(-2.0000000000000D+000): -1.10714871779409D+000 +Math.arctan(-2.4000E+00): -1.17601E+00. MathL.arctan(-2.4000000000000D+000): -1.17600520709514D+000 +Math.arctan(-2.5000E+00): -1.19029E+00. MathL.arctan(-2.5000000000000D+000): -1.19028994968253D+000 +Math.arctan(-3.0000E+00): -1.24905E+00. MathL.arctan(-3.0000000000000D+000): -1.24904577239826D+000 +Math.arctan(-4.0000E+00): -1.32582E+00. MathL.arctan(-4.0000000000000D+000): -1.32581766366804D+000 + +Math.sinh(9.00000E-01): 1.02652E+00. MathL.sinh(9.00000000000000D-001): 1.02651672570818D+000 +Math.sinh(1.00000E+00): 1.17520E+00. MathL.sinh(1.00000000000000D+000): 1.17520119364380D+000 +Math.sinh(1.40000E+00): 1.90430E+00. MathL.sinh(1.40000000000000D+000): 1.90430150145153D+000 +Math.sinh(1.50000E+00): 2.12928E+00. MathL.sinh(1.50000000000000D+000): 2.12927945509482D+000 +Math.sinh(1.60000E+00): 2.37557E+00. MathL.sinh(1.60000000000000D+000): 2.37556795320023D+000 +Math.sinh(1.90000E+00): 3.26816E+00. MathL.sinh(1.90000000000000D+000): 3.26816291152832D+000 +Math.sinh(2.00000E+00): 3.62686E+00. MathL.sinh(2.00000000000000D+000): 3.62686040784702D+000 +Math.sinh(2.40000E+00): 5.46623E+00. MathL.sinh(2.40000000000000D+000): 5.46622921367609D+000 +Math.sinh(2.50000E+00): 6.05020E+00. MathL.sinh(2.50000000000000D+000): 6.05020448103979D+000 +Math.sinh(3.00000E+00): 1.00179E+01. MathL.sinh(3.00000000000000D+000): 1.00178749274099D+001 +Math.sinh(4.00000E+00): 2.72899E+01. MathL.sinh(4.00000000000000D+000): 2.72899171971278D+001 +Math.sinh(-9.0000E-01): -1.02652E+00. MathL.sinh(-9.0000000000000D-001): -1.02651672570818D+000 +Math.sinh(-1.0000E+00): -1.1752E+00. MathL.sinh(-1.0000000000000D+000): -1.1752011936438D+000 +Math.sinh(-1.4000E+00): -1.9043E+00. MathL.sinh(-1.4000000000000D+000): -1.90430150145153D+000 +Math.sinh(-1.5000E+00): -2.12928E+00. MathL.sinh(-1.5000000000000D+000): -2.12927945509482D+000 +Math.sinh(-1.6000E+00): -2.37557E+00. MathL.sinh(-1.6000000000000D+000): -2.37556795320023D+000 +Math.sinh(-1.9000E+00): -3.26816E+00. MathL.sinh(-1.9000000000000D+000): -3.26816291152832D+000 +Math.sinh(-2.0000E+00): -3.62686E+00. MathL.sinh(-2.0000000000000D+000): -3.62686040784702D+000 +Math.sinh(-2.4000E+00): -5.46623E+00. MathL.sinh(-2.4000000000000D+000): -5.46622921367609D+000 +Math.sinh(-2.5000E+00): -6.0502E+00. MathL.sinh(-2.5000000000000D+000): -6.05020448103979D+000 +Math.sinh(-3.0000E+00): -1.00179E+01. MathL.sinh(-3.0000000000000D+000): -1.00178749274099D+001 +Math.sinh(-4.0000E+00): -2.72899E+01. MathL.sinh(-4.0000000000000D+000): -2.72899171971278D+001 + +Math.cosh(9.00000E-01): 1.43309E+00. MathL.cosh(9.00000000000000D-001): 1.43308638544877D+000 +Math.cosh(1.00000E+00): 1.54308E+00. MathL.cosh(1.00000000000000D+000): 1.54308063481524D+000 +Math.cosh(1.40000E+00): 2.15090E+00. MathL.cosh(1.40000000000000D+000): 2.15089846539314D+000 +Math.cosh(1.50000E+00): 2.35241E+00. MathL.cosh(1.50000000000000D+000): 2.35240961524325D+000 +Math.cosh(1.60000E+00): 2.57746E+00. MathL.cosh(1.60000000000000D+000): 2.57746447119489D+000 +Math.cosh(1.90000E+00): 3.41773E+00. MathL.cosh(1.90000000000000D+000): 3.41773153075095D+000 +Math.cosh(2.00000E+00): 3.76220E+00. MathL.cosh(2.00000000000000D+000): 3.76219569108363D+000 +Math.cosh(2.40000E+00): 5.55695E+00. MathL.cosh(2.40000000000000D+000): 5.55694716696551D+000 +Math.cosh(2.50000E+00): 6.13229E+00. MathL.cosh(2.50000000000000D+000): 6.13228947966369D+000 +Math.cosh(3.00000E+00): 1.00677E+01. MathL.cosh(3.00000000000000D+000): 1.00676619957778D+001 +Math.cosh(4.00000E+00): 2.73082E+01. MathL.cosh(4.00000000000000D+000): 2.73082328360165D+001 +Math.cosh(-9.0000E-01): 1.43309E+00. MathL.cosh(-9.0000000000000D-001): 1.43308638544877D+000 +Math.cosh(-1.0000E+00): 1.54308E+00. MathL.cosh(-1.0000000000000D+000): 1.54308063481524D+000 +Math.cosh(-1.4000E+00): 2.15090E+00. MathL.cosh(-1.4000000000000D+000): 2.15089846539314D+000 +Math.cosh(-1.5000E+00): 2.35241E+00. MathL.cosh(-1.5000000000000D+000): 2.35240961524325D+000 +Math.cosh(-1.6000E+00): 2.57746E+00. MathL.cosh(-1.6000000000000D+000): 2.57746447119489D+000 +Math.cosh(-1.9000E+00): 3.41773E+00. MathL.cosh(-1.9000000000000D+000): 3.41773153075095D+000 +Math.cosh(-2.0000E+00): 3.76220E+00. MathL.cosh(-2.0000000000000D+000): 3.76219569108363D+000 +Math.cosh(-2.4000E+00): 5.55695E+00. MathL.cosh(-2.4000000000000D+000): 5.55694716696551D+000 +Math.cosh(-2.5000E+00): 6.13229E+00. MathL.cosh(-2.5000000000000D+000): 6.13228947966369D+000 +Math.cosh(-3.0000E+00): 1.00677E+01. MathL.cosh(-3.0000000000000D+000): 1.00676619957778D+001 +Math.cosh(-4.0000E+00): 2.73082E+01. MathL.cosh(-4.0000000000000D+000): 2.73082328360165D+001 + +Math.tanh(9.00000E-01): 7.16298E-01. MathL.tanh(9.00000000000000D-001): 7.16297870199025D-001 +Math.tanh(1.00000E+00): 7.61594E-01. MathL.tanh(1.00000000000000D+000): 7.61594155955765D-001 +Math.tanh(1.40000E+00): 8.85352E-01. MathL.tanh(1.40000000000000D+000): 8.85351648202263D-001 +Math.tanh(1.50000E+00): 9.05148E-01. MathL.tanh(1.50000000000000D+000): 9.05148253644866D-001 +Math.tanh(1.60000E+00): 9.21669E-01. MathL.tanh(1.60000000000000D+000): 9.21668554406471D-001 +Math.tanh(1.90000E+00): 9.56237E-01. MathL.tanh(1.90000000000000D+000): 9.56237458127739D-001 +Math.tanh(2.00000E+00): 9.64028E-01. MathL.tanh(2.00000000000000D+000): 9.64027580075817D-001 +Math.tanh(2.40000E+00): 9.83675E-01. MathL.tanh(2.40000000000000D+000): 9.83674857693680D-001 +Math.tanh(2.50000E+00): 9.86614E-01. MathL.tanh(2.50000000000000D+000): 9.86614298151430D-001 +Math.tanh(3.00000E+00): 9.95055E-01. MathL.tanh(3.00000000000000D+000): 9.95054753686731D-001 +Math.tanh(4.00000E+00): 9.99329E-01. MathL.tanh(4.00000000000000D+000): 9.99329299739067D-001 +Math.tanh(-9.0000E-01): -7.16298E-01. MathL.tanh(-9.0000000000000D-001): -7.16297870199025D-001 +Math.tanh(-1.0000E+00): -7.61594E-01. MathL.tanh(-1.0000000000000D+000): -7.61594155955765D-001 +Math.tanh(-1.4000E+00): -8.85352E-01. MathL.tanh(-1.4000000000000D+000): -8.85351648202263D-001 +Math.tanh(-1.5000E+00): -9.05148E-01. MathL.tanh(-1.5000000000000D+000): -9.05148253644866D-001 +Math.tanh(-1.6000E+00): -9.21669E-01. MathL.tanh(-1.6000000000000D+000): -9.21668554406471D-001 +Math.tanh(-1.9000E+00): -9.56237E-01. MathL.tanh(-1.9000000000000D+000): -9.56237458127739D-001 +Math.tanh(-2.0000E+00): -9.64028E-01. MathL.tanh(-2.0000000000000D+000): -9.64027580075817D-001 +Math.tanh(-2.4000E+00): -9.83675E-01. MathL.tanh(-2.4000000000000D+000): -9.8367485769368D-001 +Math.tanh(-2.5000E+00): -9.86614E-01. MathL.tanh(-2.5000000000000D+000): -9.8661429815143D-001 +Math.tanh(-3.0000E+00): -9.95055E-01. MathL.tanh(-3.0000000000000D+000): -9.95054753686731D-001 +Math.tanh(-4.0000E+00): -9.99329E-01. MathL.tanh(-4.0000000000000D+000): -9.99329299739067D-001 + +Math.arcsinh(9.00000E-01): 8.08867E-01. MathL.arcsinh(9.00000000000000D-001): 8.08866935652783D-001 +Math.arcsinh(1.00000E+00): 8.81374E-01. MathL.arcsinh(1.00000000000000D+000): 8.81373587019543D-001 +Math.arcsinh(1.40000E+00): 1.13798E+00. MathL.arcsinh(1.40000000000000D+000): 1.13798204629337D+000 +Math.arcsinh(1.50000E+00): 1.19476E+00. MathL.arcsinh(1.50000000000000D+000): 1.19476321728711D+000 +Math.arcsinh(1.60000E+00): 1.24898E+00. MathL.arcsinh(1.60000000000000D+000): 1.24898332790488D+000 +Math.arcsinh(1.90000E+00): 1.39800E+00. MathL.arcsinh(1.90000000000000D+000): 1.39799836511143D+000 +Math.arcsinh(2.00000E+00): 1.44364E+00. MathL.arcsinh(2.00000000000000D+000): 1.44363547517881D+000 +Math.arcsinh(2.40000E+00): 1.60944E+00. MathL.arcsinh(2.40000000000000D+000): 1.60943791243410D+000 +Math.arcsinh(2.50000E+00): 1.64723E+00. MathL.arcsinh(2.50000000000000D+000): 1.64723114637110D+000 +Math.arcsinh(3.00000E+00): 1.81845E+00. MathL.arcsinh(3.00000000000000D+000): 1.81844645923207D+000 +Math.arcsinh(4.00000E+00): 2.09471E+00. MathL.arcsinh(4.00000000000000D+000): 2.09471254726110D+000 +Math.arcsinh(-9.0000E-01): -8.08867E-01. MathL.arcsinh(-9.0000000000000D-001): -8.08866935652783D-001 +Math.arcsinh(-1.0000E+00): -8.81374E-01. MathL.arcsinh(-1.0000000000000D+000): -8.81373587019543D-001 +Math.arcsinh(-1.4000E+00): -1.13798E+00. MathL.arcsinh(-1.4000000000000D+000): -1.13798204629337D+000 +Math.arcsinh(-1.5000E+00): -1.19476E+00. MathL.arcsinh(-1.5000000000000D+000): -1.19476321728711D+000 +Math.arcsinh(-1.6000E+00): -1.24898E+00. MathL.arcsinh(-1.6000000000000D+000): -1.24898332790488D+000 +Math.arcsinh(-1.9000E+00): -1.3980E+00. MathL.arcsinh(-1.9000000000000D+000): -1.39799836511143D+000 +Math.arcsinh(-2.0000E+00): -1.44364E+00. MathL.arcsinh(-2.0000000000000D+000): -1.44363547517881D+000 +Math.arcsinh(-2.4000E+00): -1.60944E+00. MathL.arcsinh(-2.4000000000000D+000): -1.6094379124341D+000 +Math.arcsinh(-2.5000E+00): -1.64723E+00. MathL.arcsinh(-2.5000000000000D+000): -1.6472311463711D+000 +Math.arcsinh(-3.0000E+00): -1.81845E+00. MathL.arcsinh(-3.0000000000000D+000): -1.81844645923207D+000 +Math.arcsinh(-4.0000E+00): -2.09471E+00. MathL.arcsinh(-4.0000000000000D+000): -2.0947125472611D+000 + +Math.arccosh(9.00000E-01): 0.00000E+00. MathL.arccosh(9.00000000000000D-001): 0.00000000000000D+000 +Math.arccosh(1.00000E+00): 0.00000E+00. MathL.arccosh(1.00000000000000D+000): 0.00000000000000D+000 +Math.arccosh(1.40000E+00): 8.67015E-01. MathL.arccosh(1.40000000000000D+000): 8.67014726490565D-001 +Math.arccosh(1.50000E+00): 9.62424E-01. MathL.arccosh(1.50000000000000D+000): 9.62423650119207D-001 +Math.arccosh(1.60000E+00): 1.04697E+00. MathL.arccosh(1.60000000000000D+000): 1.04696791500319D+000 +Math.arccosh(1.90000E+00): 1.25720E+00. MathL.arccosh(1.90000000000000D+000): 1.25719582660038D+000 +Math.arccosh(2.00000E+00): 1.31696E+00. MathL.arccosh(2.00000000000000D+000): 1.31695789692482D+000 +Math.arccosh(2.40000E+00): 1.52208E+00. MathL.arccosh(2.40000000000000D+000): 1.52207936746365D+000 +Math.arccosh(2.50000E+00): 1.56680E+00. MathL.arccosh(2.50000000000000D+000): 1.56679923697241D+000 +Math.arccosh(3.00000E+00): 1.76275E+00. MathL.arccosh(3.00000000000000D+000): 1.76274717403909D+000 +Math.arccosh(4.00000E+00): 2.06344E+00. MathL.arccosh(4.00000000000000D+000): 2.06343706889556D+000 +Math.arccosh(-9.0000E-01): 0.00000E+00. MathL.arccosh(-9.0000000000000D-001): 0.00000000000000D+000 +Math.arccosh(-1.0000E+00): 0.00000E+00. MathL.arccosh(-1.0000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-1.4000E+00): 0.00000E+00. MathL.arccosh(-1.4000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-1.5000E+00): 0.00000E+00. MathL.arccosh(-1.5000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-1.6000E+00): 0.00000E+00. MathL.arccosh(-1.6000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-1.9000E+00): 0.00000E+00. MathL.arccosh(-1.9000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-2.0000E+00): 0.00000E+00. MathL.arccosh(-2.0000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-2.4000E+00): 0.00000E+00. MathL.arccosh(-2.4000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-2.5000E+00): 0.00000E+00. MathL.arccosh(-2.5000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-3.0000E+00): 0.00000E+00. MathL.arccosh(-3.0000000000000D+000): 0.00000000000000D+000 +Math.arccosh(-4.0000E+00): 0.00000E+00. MathL.arccosh(-4.0000000000000D+000): 0.00000000000000D+000 + +Math.arctanh(9.00000E-01): 1.47222E+00. MathL.arctanh(9.00000000000000D-001): 1.47221948958322D+000 +Math.arctanh(1.00000E+00): 8.66434E+00. MathL.arctanh(1.00000000000000D+000): 1.87149738751185D+001 +Math.arctanh(1.40000E+00): 8.66434E+00. MathL.arctanh(1.40000000000000D+000): 1.87149738751185D+001 +Math.arctanh(1.50000E+00): 8.66434E+00. MathL.arctanh(1.50000000000000D+000): 1.87149738751185D+001 +Math.arctanh(1.60000E+00): 8.66434E+00. MathL.arctanh(1.60000000000000D+000): 1.87149738751185D+001 +Math.arctanh(1.90000E+00): 8.66434E+00. MathL.arctanh(1.90000000000000D+000): 1.87149738751185D+001 +Math.arctanh(2.00000E+00): 8.66434E+00. MathL.arctanh(2.00000000000000D+000): 1.87149738751185D+001 +Math.arctanh(2.40000E+00): 8.66434E+00. MathL.arctanh(2.40000000000000D+000): 1.87149738751185D+001 +Math.arctanh(2.50000E+00): 8.66434E+00. MathL.arctanh(2.50000000000000D+000): 1.87149738751185D+001 +Math.arctanh(3.00000E+00): 8.66434E+00. MathL.arctanh(3.00000000000000D+000): 1.87149738751185D+001 +Math.arctanh(4.00000E+00): 8.66434E+00. MathL.arctanh(4.00000000000000D+000): 1.87149738751185D+001 +Math.arctanh(-9.0000E-01): -1.47222E+00. MathL.arctanh(-9.0000000000000D-001): -1.47221948958322D+000 +Math.arctanh(-1.0000E+00): -8.66434E+00. MathL.arctanh(-1.0000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-1.4000E+00): -8.66434E+00. MathL.arctanh(-1.4000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-1.5000E+00): -8.66434E+00. MathL.arctanh(-1.5000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-1.6000E+00): -8.66434E+00. MathL.arctanh(-1.6000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-1.9000E+00): -8.66434E+00. MathL.arctanh(-1.9000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-2.0000E+00): -8.66434E+00. MathL.arctanh(-2.0000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-2.4000E+00): -8.66434E+00. MathL.arctanh(-2.4000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-2.5000E+00): -8.66434E+00. MathL.arctanh(-2.5000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-3.0000E+00): -8.66434E+00. MathL.arctanh(-3.0000000000000D+000): -1.87149738751185D+001 +Math.arctanh(-4.0000E+00): -8.66434E+00. MathL.arctanh(-4.0000000000000D+000): -1.87149738751185D+001 + diff --git a/src/test/confidence/math/mathtest.mod b/src/test/confidence/math/mathtest.mod new file mode 100644 index 00000000..b062c844 --- /dev/null +++ b/src/test/confidence/math/mathtest.mod @@ -0,0 +1,145 @@ +MODULE mathtest; +IMPORT Math, MathL, Out, SYSTEM; + +TYPE + RtoR = PROCEDURE(x: REAL): REAL; + LRtoLR = PROCEDURE(x: LONGREAL): LONGREAL; + RtoLI = PROCEDURE(x: REAL): LONGINT; + LRtoLI = PROCEDURE(x: LONGREAL): LONGINT; + + Values = RECORD + v: ARRAY 100 OF LONGREAL; + n: INTEGER + END; + +VAR + r: REAL; + lr: LONGREAL; + misc: Values; + angles: Values; + + +PROCEDURE wc(c: CHAR); BEGIN Out.Char(c) END wc; +PROCEDURE ws(s: ARRAY OF CHAR); BEGIN Out.String(s) END ws; +PROCEDURE wi(i: HUGEINT); BEGIN Out.Int(i,1) END wi; +PROCEDURE wr(r: REAL); BEGIN Out.Real(r,11) END wr; +PROCEDURE wlr(lr: LONGREAL); BEGIN Out.LongReal(lr,21) END wlr; +PROCEDURE wl; BEGIN Out.Ln END wl; + +PROCEDURE wh(VAR h: ARRAY OF SYSTEM.BYTE); + VAR i: INTEGER; b: SYSTEM.INT8; +BEGIN + i := SHORT(LEN(h)); + WHILE i > 0 DO + DEC(i); b := SYSTEM.VAL(SYSTEM.INT8, h[i]); + IF b DIV 16 MOD 16 < 10 THEN wc(CHR(b DIV 16 MOD 16 + 48)) ELSE wc(CHR(b DIV 16 MOD 16 + 55)) END; + IF b MOD 16 < 10 THEN wc(CHR(b MOD 16 + 48)) ELSE wc(CHR(b MOD 16 + 55)) END; + END +END wh; + +PROCEDURE addvalue(lr: LONGREAL; VAR val: Values); +BEGIN val.v[val.n] := lr; INC(val.n) +END addvalue; + +PROCEDURE MathErrorHandler(error: INTEGER); +BEGIN + ws(" ") +END MathErrorHandler; + +PROCEDURE TestRtoR(s: ARRAY OF CHAR; p: RtoR; lp: LRtoLR; val: Values); + VAR i: INTEGER; r: REAL; +BEGIN + i := 0; + WHILE i < val.n DO + r := SHORT(val.v[i]); + ws("Math."); ws(s); ws("("); wr(r); ws("): "); wr(p(r)); + ws(". MathL."); ws(s); ws("("); wlr(val.v[i]); ws("): "); wlr(lp(val.v[i])); wl; + INC(i) + END; + wl; +END TestRtoR; + +PROCEDURE TestRtoLI(s: ARRAY OF CHAR; p: RtoLI; lp: LRtoLI; val: Values); + VAR i: INTEGER; r: REAL; +BEGIN + i := 0; + WHILE i < val.n DO + r := SHORT(val.v[i]); + ws("Math."); ws(s); ws("("); wr(r); ws("): "); wi(p(r)); + ws(". MathL."); ws(s); ws("("); wlr(val.v[i]); ws("): "); wi(lp(val.v[i])); wl; + INC(i) + END; + wl; +END TestRtoLI; + +PROCEDURE round(lr: LONGREAL); + VAR r: REAL; +BEGIN + r := SHORT(lr); + ws("Math.round("); wr(r); ws("): "); wi(Math.round(r)); + ws(". MathL.round("); wlr(lr); ws("): "); wi(MathL.round(lr)); wl +END round; + +PROCEDURE sqrt(lr: LONGREAL); + VAR r: REAL; +BEGIN + r := SHORT(lr); + ws("Math.sqrt("); wr(r); ws("): "); wr(Math.sqrt(r)); + ws(". MathL.sqrt("); wlr(r); ws("): "); wlr(MathL.sqrt(r)); wl +END sqrt; + + +BEGIN + ws("Math and MathL module tests."); wl; wl; + + misc.n := 0; + addvalue(0.9D0, misc); addvalue(1.0D0, misc); addvalue(1.4D0, misc); addvalue(1.5D0, misc); addvalue(1.6D0, misc); addvalue(1.9D0, misc); + addvalue(2.0D0, misc); addvalue(2.4D0, misc); addvalue(2.5D0, misc); + addvalue(3.0D0, misc); addvalue(4.0D0, misc); + + addvalue(-0.9D0, misc); addvalue(-1.0D0, misc); addvalue(-1.4D0, misc); addvalue(-1.5D0, misc); addvalue(-1.6D0, misc); addvalue(-1.9D0, misc); + addvalue(-2.0D0, misc); addvalue(-2.4D0, misc); addvalue(-2.5D0, misc); + addvalue(-3.0D0, misc); addvalue(-4.0D0, misc); + + angles.n:= 0; + addvalue(0.0D0, angles); addvalue(0.1D0, angles); + addvalue(MathL.pi/3.0D0, angles); addvalue(MathL.pi/2.0D0, angles); addvalue(MathL.pi, angles); + addvalue(-MathL.pi/3.0D0, angles); addvalue(-MathL.pi/2.0D0, angles); addvalue(-MathL.pi, angles); + + TestRtoR("fraction", Math.fraction, MathL.fraction, misc); + TestRtoLI("round", Math.round, MathL.round, misc); + TestRtoR("sqrt", Math.sqrt, MathL.sqrt, misc); +(*TestRtoR("exp", Math.exp, MathL.exp, misc);*) (* bypass exp test as MathL result differs between x86 and x64. *) + TestRtoR("ln", Math.ln, MathL.ln, misc); + TestRtoR("sin", Math.sin, MathL.sin, angles); + TestRtoR("cos", Math.cos, MathL.cos, angles); + TestRtoR("tan", Math.tan, MathL.tan, angles); + TestRtoR("arcsin", Math.arcsin, MathL.arcsin, misc); + TestRtoR("arccos", Math.arccos, MathL.arccos, misc); + TestRtoR("arctan", Math.arctan, MathL.arctan, misc); + TestRtoR("sinh", Math.sinh, MathL.sinh, misc); + TestRtoR("cosh", Math.cosh, MathL.cosh, misc); + TestRtoR("tanh", Math.tanh, MathL.tanh, misc); + TestRtoR("arcsinh", Math.arcsinh, MathL.arcsinh, misc); + TestRtoR("arccosh", Math.arccosh, MathL.arccosh, misc); + TestRtoR("arctanh", Math.arctanh, MathL.arctanh, misc); + + (* todo power, log, ipower, sincos, arctan2 *) + +END mathtest. diff --git a/src/test/confidence/math/test.sh b/src/test/confidence/math/test.sh new file mode 100644 index 00000000..c64bde88 --- /dev/null +++ b/src/test/confidence/math/test.sh @@ -0,0 +1,6 @@ +#!/bin/sh +. ../testenv.sh +rm -f mathtest # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP mathtest.mod -m -OC +./mathtest >result +. ../testresult.sh diff --git a/src/test/confidence/out/expected b/src/test/confidence/out/expected new file mode 100644 index 00000000..dab1e079 --- /dev/null +++ b/src/test/confidence/out/expected @@ -0,0 +1,254 @@ +--- Testing with Oberon 2 variable model --- +Real number hex representation. + 1.0D0: 3FF0000000000000 + 1.1D0: 3FF199999999999A + 2.1D0: 4000CCCCCCCCCCCD +-1.1D0: BFF199999999999A + 1.1D3: 4091300000000000 + 1.1D-3: 3F5205BC01A36E2F + 1.2345678987654321D3: 40934A45874103D8 + 0.0: 0000000000000000 + 0.000123D0: 3F201F31F46ED246 + 1/0.0: 7FF0000000000000 +-1/0.0: FFF0000000000000 + + 1.0E0: 3F800000 + 1.1E0: 3F8CCCCD + 2.1E0: 40066666 +-1.1E0: BF8CCCCD + 1.1E3: 44898000 + 1.1E-3: 3A902DE0 + 1.2345678987654321E3: 449A522C + 0.0: 00000000 + 0.000123E0: 3900F990 + 1/0.0: 7F800000 +-1/0.0: FF800000 + + +Out module tests. +SIZE(INTEGER) = 2 + +Testing LONGREAL. + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.0D+000 + 1.1D0: 1.1D+000 + 2.1D0: 2.1D+000 +-1.1D0: -1.1D+000 + 1.1D3: 1.1D+003 + 1.1D-3: 1.1D-003 + 1.2345678987654321D3: 1.23456789876543D+003 + 0.0: 0.0D+000 + 0.000123D0: 1.23D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.00000D+000 + 1.1D0: 1.10000D+000 + 2.1D0: 2.10000D+000 +-1.1D0: -1.1000D+000 + 1.1D3: 1.10000D+003 + 1.1D-3: 1.10000D-003 + 1.2345678987654321D3: 1.23456789876543D+003 + 0.0: 0.00000D+000 + 0.000123D0: 1.23000D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.0000000000000000D+000 + 1.1D0: 1.1000000000000000D+000 + 2.1D0: 2.1000000000000000D+000 +-1.1D0: -1.1000000000000000D+000 + 1.1D3: 1.1000000000000000D+003 + 1.1D-3: 1.1000000000000000D-003 + 1.2345678987654321D3: 1.2345678987654300D+003 + 0.0: 0.0000000000000000D+000 + 0.000123D0: 1.2300000000000000D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + + +Testing REAL. + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0E0: 1.0E+00 + 1.1E0: 1.1E+00 + 2.1E0: 2.1E+00 +-1.1E0: -1.1E+00 + 1.1E3: 1.1E+03 + 1.1E-3: 1.1E-03 + 1.2345678987654321E3: 1.23457E+03 + 0.0: 0.0E+00 + 0.000123E0: 1.23E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 + 123456789012345678901234567890 + 1.0E0: 1.000000E+00 + 1.1E0: 1.100000E+00 + 2.1E0: 2.100000E+00 +-1.1E0: -1.10000E+00 + 1.1E3: 1.100000E+03 + 1.1E-3: 1.100000E-03 + 1.2345678987654321E3: 1.234568E+03 + 0.0: 0.000000E+00 + 0.000123E0: 1.230000E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0E0: 1.00000000E+00 + 1.1E0: 1.10000002E+00 + 2.1E0: 2.09999990E+00 +-1.1E0: -1.10000002E+00 + 1.1E3: 1.10000000E+03 + 1.1E-3: 1.09999999E-03 + 1.2345678987654321E3: 1.23456787E+03 + 0.0: 0.00000000E+00 + 0.000123E0: 1.23000005E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + + +--- Testing with Component Pascal variable model --- +Real number hex representation. + 1.0D0: 3FF0000000000000 + 1.1D0: 3FF199999999999A + 2.1D0: 4000CCCCCCCCCCCD +-1.1D0: BFF199999999999A + 1.1D3: 4091300000000000 + 1.1D-3: 3F5205BC01A36E2F + 1.2345678987654321D3: 40934A45874103D8 + 0.0: 0000000000000000 + 0.000123D0: 3F201F31F46ED246 + 1/0.0: 7FF0000000000000 +-1/0.0: FFF0000000000000 + + 1.0E0: 3F800000 + 1.1E0: 3F8CCCCD + 2.1E0: 40066666 +-1.1E0: BF8CCCCD + 1.1E3: 44898000 + 1.1E-3: 3A902DE0 + 1.2345678987654321E3: 449A522C + 0.0: 00000000 + 0.000123E0: 3900F990 + 1/0.0: 7F800000 +-1/0.0: FF800000 + + +Out module tests. +SIZE(INTEGER) = 4 + +Testing LONGREAL. + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.0D+000 + 1.1D0: 1.1D+000 + 2.1D0: 2.1D+000 +-1.1D0: -1.1D+000 + 1.1D3: 1.1D+003 + 1.1D-3: 1.1D-003 + 1.2345678987654321D3: 1.23456789876543D+003 + 0.0: 0.0D+000 + 0.000123D0: 1.23D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.00000D+000 + 1.1D0: 1.10000D+000 + 2.1D0: 2.10000D+000 +-1.1D0: -1.1000D+000 + 1.1D3: 1.10000D+003 + 1.1D-3: 1.10000D-003 + 1.2345678987654321D3: 1.23456789876543D+003 + 0.0: 0.00000D+000 + 0.000123D0: 1.23000D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0D0: 1.0000000000000000D+000 + 1.1D0: 1.1000000000000000D+000 + 2.1D0: 2.1000000000000000D+000 +-1.1D0: -1.1000000000000000D+000 + 1.1D3: 1.1000000000000000D+003 + 1.1D-3: 1.1000000000000000D-003 + 1.2345678987654321D3: 1.2345678987654300D+003 + 0.0: 0.0000000000000000D+000 + 0.000123D0: 1.2300000000000000D-004 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + + +Testing REAL. + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0E0: 1.0E+00 + 1.1E0: 1.1E+00 + 2.1E0: 2.1E+00 +-1.1E0: -1.1E+00 + 1.1E3: 1.1E+03 + 1.1E-3: 1.1E-03 + 1.2345678987654321E3: 1.23457E+03 + 0.0: 0.0E+00 + 0.000123E0: 1.23E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 + 123456789012345678901234567890 + 1.0E0: 1.000000E+00 + 1.1E0: 1.100000E+00 + 2.1E0: 2.100000E+00 +-1.1E0: -1.10000E+00 + 1.1E3: 1.100000E+03 + 1.1E-3: 1.100000E-03 + 1.2345678987654321E3: 1.234568E+03 + 0.0: 0.000000E+00 + 0.000123E0: 1.230000E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + + 1 2 3 4 + 1234567890123456789012345678901234567890 + 1.0E0: 1.00000000E+00 + 1.1E0: 1.10000002E+00 + 2.1E0: 2.09999990E+00 +-1.1E0: -1.10000002E+00 + 1.1E3: 1.10000000E+03 + 1.1E-3: 1.09999999E-03 + 1.2345678987654321E3: 1.23456787E+03 + 0.0: 0.00000000E+00 + 0.000123E0: 1.23000005E-04 + 1/0.0: Infinity +-1/0.0: -Infinity + 0.0/0.0: NaN + diff --git a/src/test/confidence/out/outtest.mod b/src/test/confidence/out/outtest.mod new file mode 100644 index 00000000..aa1997cb --- /dev/null +++ b/src/test/confidence/out/outtest.mod @@ -0,0 +1,183 @@ +MODULE outtest; + +IMPORT Out, SYSTEM; + +VAR + r: REAL; + lr: LONGREAL; + cw: SYSTEM.INT16; + +PROCEDURE wc(c: CHAR); BEGIN Out.Char(c) END wc; +PROCEDURE ws(s: ARRAY OF CHAR); BEGIN Out.String(s) END ws; +PROCEDURE wi(i: HUGEINT); BEGIN Out.Int(i,1) END wi; +PROCEDURE wl; BEGIN Out.Ln END wl; + +PROCEDURE wh(VAR h: ARRAY OF SYSTEM.BYTE); + VAR i: INTEGER; b: SYSTEM.INT8; +BEGIN + i := SHORT(LEN(h)); + WHILE i > 0 DO + DEC(i); b := SYSTEM.VAL(SYSTEM.INT8, h[i]); + IF b DIV 16 MOD 16 < 10 THEN wc(CHR(b DIV 16 MOD 16 + 48)) ELSE wc(CHR(b DIV 16 MOD 16 + 55)) END; + IF b MOD 16 < 10 THEN wc(CHR(b MOD 16 + 48)) ELSE wc(CHR(b MOD 16 + 55)) END; + END +END wh; + + +(* +PROCEDURE -GetFpcw() '__asm__ __volatile__ ("fnstcw %0" : "=m" (outtest_cw))'; +*) + + + +BEGIN + (* + ws("Floating point control word: "); GetFpcw; wh(cw); wl; + wl; + *) + + ws("Real number hex representation."); wl; + lr := 1.0D0; ws(" 1.0D0: "); wh(lr); wl; + lr := 1.1D0; ws(" 1.1D0: "); wh(lr); wl; + lr := 2.1D0; ws(" 2.1D0: "); wh(lr); wl; + lr := -1.1D0; ws("-1.1D0: "); wh(lr); wl; + lr := 1.1D3; ws(" 1.1D3: "); wh(lr); wl; + lr := 1.1D-3; ws(" 1.1D-3: "); wh(lr); wl; + lr := 1.2345678987654321D3; ws(" 1.2345678987654321D3: "); wh(lr); wl; + lr := 0.0; ws(" 0.0: "); wh(lr); wl; + lr := 0.000123D0; ws(" 0.000123D0: "); wh(lr); wl; + lr := 0.0; lr := 1/lr; ws(" 1/0.0: "); wh(lr); wl; + lr := 0.0; lr := -1/lr; ws("-1/0.0: "); wh(lr); wl; +(*lr := 0.0; lr := 0.0D0/lr; ws(" 0.0/0.0: "); wh(lr); wl;*) + wl; + r := 1.0E0; ws(" 1.0E0: "); wh(r); wl; + r := 1.1E0; ws(" 1.1E0: "); wh(r); wl; + r := 2.1E0; ws(" 2.1E0: "); wh(r); wl; + r := -1.1E0; ws("-1.1E0: "); wh(r); wl; + r := 1.1E3; ws(" 1.1E3: "); wh(r); wl; + r := 1.1E-3; ws(" 1.1E-3: "); wh(r); wl; + r := 1.2345678987654321E3; ws(" 1.2345678987654321E3: "); wh(r); wl; + r := 0.0; ws(" 0.0: "); wh(r); wl; + r := 0.000123E0; ws(" 0.000123E0: "); wh(r); wl; + r := 0.0; r := 1/r; ws(" 1/0.0: "); wh(r); wl; + r := 0.0; r := -1/r; ws("-1/0.0: "); wh(r); wl; +(*r := 0.0; r := 0.0E0/r; ws(" 0.0/0.0: "); wh(r); wl;*) + wl; wl; + + ws("Out module tests."); wl; + ws("SIZE(INTEGER) = "); wi(SIZE(INTEGER)); wl; wl; + + ws("Testing LONGREAL."); wl; wl; + ws(" 1 2 3 4"); wl; + ws(" 1234567890123456789012345678901234567890"); wl; + ws(" 1.0D0: "); Out.LongReal( 1.0D0, 1); wl; + ws(" 1.1D0: "); Out.LongReal( 1.1D0, 1); wl; + ws(" 2.1D0: "); Out.LongReal( 2.1D0, 1); wl; + ws("-1.1D0: "); Out.LongReal(-1.1D0, 1); wl; + ws(" 1.1D3: "); Out.LongReal( 1.1D3, 1); wl; + ws(" 1.1D-3: "); Out.LongReal( 1.1D-3, 1); wl; + ws(" 1.2345678987654321D3: "); Out.LongReal( 1.2345678987654321D3, 1); wl; + ws(" 0.0: "); Out.LongReal(0.0, 1); wl; + ws(" 0.000123D0: "); Out.LongReal(0.000123D0, 1); wl; + lr := 0.0; lr := 1/lr; + ws(" 1/0.0: "); Out.LongReal(lr, 1); wl; + lr := 0.0; lr := -1/lr; + ws("-1/0.0: "); Out.LongReal(lr, 1); wl; + lr := 0.0; lr := 0.0D0/lr; + ws(" 0.0/0.0: "); Out.LongReal(lr, 1); wl; + wl; + ws(" 1 2 3 4"); wl; + ws(" 1234567890123456789012345678901234567890"); wl; + ws(" 1.0D0: "); Out.LongReal( 1.0D0, 12); wl; + ws(" 1.1D0: "); Out.LongReal( 1.1D0, 12); wl; + ws(" 2.1D0: "); Out.LongReal( 2.1D0, 12); wl; + ws("-1.1D0: "); Out.LongReal(-1.1D0, 12); wl; + ws(" 1.1D3: "); Out.LongReal( 1.1D3, 12); wl; + ws(" 1.1D-3: "); Out.LongReal( 1.1D-3, 12); wl; + ws(" 1.2345678987654321D3: "); Out.LongReal( 1.2345678987654321D3, 12); wl; + ws(" 0.0: "); Out.LongReal(0.0, 12); wl; + ws(" 0.000123D0: "); Out.LongReal(0.000123D0, 12); wl; + lr := 0.0; lr := 1/lr; + ws(" 1/0.0: "); Out.LongReal(lr, 12); wl; + lr := 0.0; lr := -1/lr; + ws("-1/0.0: "); Out.LongReal(lr, 12); wl; + lr := 0.0; lr := 0.0D0/lr; + ws(" 0.0/0.0: "); Out.LongReal(lr, 12); wl; + wl; + ws(" 1 2 3 4"); wl; + ws(" 1234567890123456789012345678901234567890"); wl; + ws(" 1.0D0: "); Out.LongReal( 1.0D0, 40); wl; + ws(" 1.1D0: "); Out.LongReal( 1.1D0, 40); wl; + ws(" 2.1D0: "); Out.LongReal( 2.1D0, 40); wl; + ws("-1.1D0: "); Out.LongReal(-1.1D0, 40); wl; + ws(" 1.1D3: "); Out.LongReal( 1.1D3, 40); wl; + ws(" 1.1D-3: "); Out.LongReal( 1.1D-3, 40); wl; + ws(" 1.2345678987654321D3: "); Out.LongReal( 1.2345678987654321D3, 40); wl; + ws(" 0.0: "); Out.LongReal(0.0, 40); wl; + ws(" 0.000123D0: "); Out.LongReal(0.000123D0, 40); wl; + lr := 0.0; lr := 1/lr; + ws(" 1/0.0: "); Out.LongReal(lr, 40); wl; + lr := 0.0; lr := -1/lr; + ws("-1/0.0: "); Out.LongReal(lr, 40); wl; + lr := 0.0; lr := 0.0D0/lr; + ws(" 0.0/0.0: "); Out.LongReal(lr, 40); wl; + wl; wl; wl; + + + ws("Testing REAL."); wl; wl; + ws(" 1 2 3 4"); wl; + ws(" 1234567890123456789012345678901234567890"); wl; + ws(" 1.0E0: "); Out.Real( 1.0E0, 1); wl; + ws(" 1.1E0: "); Out.Real( 1.1E0, 1); wl; + ws(" 2.1E0: "); Out.Real( 2.1E0, 1); wl; + ws("-1.1E0: "); Out.Real(-1.1E0, 1); wl; + ws(" 1.1E3: "); Out.Real( 1.1E3, 1); wl; + ws(" 1.1E-3: "); Out.Real( 1.1E-3, 1); wl; + ws(" 1.2345678987654321E3: "); Out.Real( 1.2345678987654321E3, 1); wl; + ws(" 0.0: "); Out.Real(0.0, 1); wl; + ws(" 0.000123E0: "); Out.Real(0.000123E0, 1); wl; + r := 0.0; r := 1/r; + ws(" 1/0.0: "); Out.Real(r, 1); wl; + r := 0.0; r := -1/r; + ws("-1/0.0: "); Out.Real(r, 1); wl; + r := 0.0; r := 0.0E0/r; + ws(" 0.0/0.0: "); Out.Real(r, 1); wl; + wl; + ws(" 1 2 3"); wl; + ws(" 123456789012345678901234567890"); wl; + ws(" 1.0E0: "); Out.Real( 1.0E0, 12); wl; + ws(" 1.1E0: "); Out.Real( 1.1E0, 12); wl; + ws(" 2.1E0: "); Out.Real( 2.1E0, 12); wl; + ws("-1.1E0: "); Out.Real(-1.1E0, 12); wl; + ws(" 1.1E3: "); Out.Real( 1.1E3, 12); wl; + ws(" 1.1E-3: "); Out.Real( 1.1E-3, 12); wl; + ws(" 1.2345678987654321E3: "); Out.Real( 1.2345678987654321E3, 12); wl; + ws(" 0.0: "); Out.Real(0.0, 12); wl; + ws(" 0.000123E0: "); Out.Real(0.000123E0, 12); wl; + r := 0.0; r := 1/r; + ws(" 1/0.0: "); Out.Real(r, 12); wl; + r := 0.0; r := -1/r; + ws("-1/0.0: "); Out.Real(r, 12); wl; + r := 0.0; r := 0.0E0/r; + ws(" 0.0/0.0: "); Out.Real(r, 12); wl; + wl; + ws(" 1 2 3 4"); wl; + ws(" 1234567890123456789012345678901234567890"); wl; + ws(" 1.0E0: "); Out.Real( 1.0E0, 40); wl; + ws(" 1.1E0: "); Out.Real( 1.1E0, 40); wl; + ws(" 2.1E0: "); Out.Real( 2.1E0, 40); wl; + ws("-1.1E0: "); Out.Real(-1.1E0, 40); wl; + ws(" 1.1E3: "); Out.Real( 1.1E3, 40); wl; + ws(" 1.1E-3: "); Out.Real( 1.1E-3, 40); wl; + ws(" 1.2345678987654321E3: "); Out.Real( 1.2345678987654321E3, 40); wl; + ws(" 0.0: "); Out.Real(0.0, 40); wl; + ws(" 0.000123E0: "); Out.Real(0.000123E0, 40); wl; + r := 0.0; r := 1/r; + ws(" 1/0.0: "); Out.Real(r, 40); wl; + r := 0.0; r := -1/r; + ws("-1/0.0: "); Out.Real(r, 40); wl; + r := 0.0; r := 0.0E0/r; + ws(" 0.0/0.0: "); Out.Real(r, 40); wl; + wl; + +END outtest. diff --git a/src/test/confidence/out/test.sh b/src/test/confidence/out/test.sh new file mode 100644 index 00000000..16bf63be --- /dev/null +++ b/src/test/confidence/out/test.sh @@ -0,0 +1,14 @@ +#!/bin/sh +. ../testenv.sh +rm -f outtest # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP outtest.mod -m -O2 +./outtest >result-O2 +$OBECOMP outtest.mod -m -OC +./outtest >result-OC +echo --- Testing with Oberon 2 variable model --- >result +cat result-O2 >>result +echo "" >>result +echo "" >>result +echo --- Testing with Component Pascal variable model --- >>result +cat result-OC >>result +. ../testresult.sh diff --git a/src/test/confidence/planned-binary-change b/src/test/confidence/planned-binary-change new file mode 100644 index 00000000..9135bbd2 --- /dev/null +++ b/src/test/confidence/planned-binary-change @@ -0,0 +1 @@ +18 Dec 2016 16:55:53 diff --git a/src/test/confidence/signal/expected b/src/test/confidence/signal/expected new file mode 100644 index 00000000..b9d387bd --- /dev/null +++ b/src/test/confidence/signal/expected @@ -0,0 +1 @@ +Signal 2 diff --git a/src/test/confidence/signal/old.cygwin.ILP32.gcc.s b/src/test/confidence/signal/old.cygwin.ILP32.gcc.s new file mode 100644 index 00000000..d9de6f01 --- /dev/null +++ b/src/test/confidence/signal/old.cygwin.ILP32.gcc.s @@ -0,0 +1,400 @@ +55 pushl %ebp +89E5 movl %esp, %ebp +83EC10 subl $16, %esp +C745FC00 movl $0, -4(%ebp) +8B55FC movl -4(%ebp), %edx +8B4508 movl 8(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FB movb %al, -5(%ebp) +8B55FC movl -4(%ebp), %edx +8B450C movl 12(%ebp), %eax +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +8845FA movb %al, -6(%ebp) +8345FC01 addl $1, -4(%ebp) +807DFB00 cmpb $0, -5(%ebp) +7508 jne L2 +0FB645FA movzbl -6(%ebp), %eax +F7D8 negl %eax +EB15 jmp L3 +0FB645FB movzbl -5(%ebp), %eax +3A45FA cmpb -6(%ebp), %al +74C9 je L4 +0FB655FB movzbl -5(%ebp), %edx +0FB645FA movzbl -6(%ebp), %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C9 leave +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +53 pushl %ebx +83EC24 subl $36, %esp +8B5D0C movl 12(%ebp), %ebx +8B450C movl 12(%ebp), %eax +890424 movl %eax, (%esp) +E8000000 call _Platform_OSAllocate +89C2 movl %eax, %edx +895C2408 movl %ebx, 8(%esp) +8B4508 movl 8(%ebp), %eax +89442404 movl %eax, 4(%esp) +891424 movl %edx, (%esp) +E8000000 call _memcpy +894508 movl %eax, 8(%ebp) +66C745F6 movw $0, -10(%ebp) +EB51 jmp L6 +0FBF55F6 movswl -10(%ebp), %edx +8B450C movl 12(%ebp), %eax +39C2 cmpl %eax, %edx +7306 jnb L7 +0FBF45F6 movswl -10(%ebp), %eax +EB11 jmp L8 +C70424FE movl $-2, (%esp) +E8000000 call _Platform_Halt +B8000000 movl $0, %eax +8B5508 movl 8(%ebp), %edx +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +0FB6D0 movzbl %al, %edx +A1000000 movl _Files_Rider__typ, %eax +89542408 movl %edx, 8(%esp) +89442404 movl %eax, 4(%esp) +C7042404 movl $_SignalTest_rider, (%esp) +E8000000 call _Files_Write +0FB745F6 movzwl -10(%ebp), %eax +83C001 addl $1, %eax +668945F6 movw %ax, -10(%ebp) +0FBF45F6 movswl -10(%ebp), %eax +3B450C cmpl 12(%ebp), %eax +7D32 jge L9 +0FBF55F6 movswl -10(%ebp), %edx +8B450C movl 12(%ebp), %eax +39C2 cmpl %eax, %edx +7306 jnb L10 +0FBF45F6 movswl -10(%ebp), %eax +EB11 jmp L11 +C70424FE movl $-2, (%esp) +E8000000 call _Platform_Halt +B8000000 movl $0, %eax +8B5508 movl 8(%ebp), %edx +01D0 addl %edx, %eax +0FB600 movzbl (%eax), %eax +84C0 testb %al, %al +0F8574FF jne L12 +8B4508 movl 8(%ebp), %eax +890424 movl %eax, (%esp) +E8000000 call _Platform_OSFree +90 nop +83C424 addl $36, %esp +5B popl %ebx +5D popl %ebp +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +83EC18 subl $24, %esp +A1000000 movl _Files_Rider__typ, %eax +C7442408 movl $10, 8(%esp) +0A000000 +89442404 movl %eax, 4(%esp) +C7042404 movl $_SignalTest_rider, (%esp) +E8000000 call _Files_Write +90 nop +C9 leave +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +53 pushl %ebx +83EC34 subl $52, %esp +66C745F6 movw $0, -10(%ebp) +837D0800 cmpl $0, 8(%ebp) +790F jns L15 +C645D82D movb $45, -40(%ebp) +0FB745F6 movzwl -10(%ebp), %eax +83C001 addl $1, %eax +668945F6 movw %ax, -10(%ebp) +0FB745F6 movzwl -10(%ebp), %eax +6683F81D cmpw $29, %ax +7706 ja L16 +0FBF5DF6 movswl -10(%ebp), %ebx +EB11 jmp L17 +C70424FE movl $-2, (%esp) +E8000000 call _Platform_Halt +BB000000 movl $0, %ebx +837D0800 cmpl $0, 8(%ebp) +782A js L18 +8B4D08 movl 8(%ebp), %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C1E002 sall $2, %eax +01D0 addl %edx, %eax +01C0 addl %eax, %eax +29C1 subl %eax, %ecx +89CA movl %ecx, %edx +89D0 movl %edx, %eax +83C030 addl $48, %eax +EB16 jmp L19 +8B4508 movl 8(%ebp), %eax +C7442404 movl $10, 4(%esp) +0A000000 +890424 movl %eax, (%esp) +E8000000 call _SYSTEM_MOD +83C030 addl $48, %eax +88441DD8 movb %al, -40(%ebp,%ebx) +0FB745F6 movzwl -10(%ebp), %eax +83C001 addl $1, %eax +668945F6 movw %ax, -10(%ebp) +837D0800 cmpl $0, 8(%ebp) +781A js L20 +8B4D08 movl 8(%ebp), %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +EB21 jmp L21 +B8090000 movl $9, %eax +2B4508 subl 8(%ebp), %eax +89C1 movl %eax, %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +F7D8 negl %eax +894508 movl %eax, 8(%ebp) +E9BA0000 jmp L22 +0FB745F6 movzwl -10(%ebp), %eax +6683F81D cmpw $29, %ax +7706 ja L23 +0FBF5DF6 movswl -10(%ebp), %ebx +EB11 jmp L24 +C70424FE movl $-2, (%esp) +E8000000 call _Platform_Halt +BB000000 movl $0, %ebx +837D0800 cmpl $0, 8(%ebp) +782A js L25 +8B4D08 movl 8(%ebp), %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +C1E002 sall $2, %eax +01D0 addl %edx, %eax +01C0 addl %eax, %eax +29C1 subl %eax, %ecx +89CA movl %ecx, %edx +89D0 movl %edx, %eax +83C030 addl $48, %eax +EB16 jmp L26 +8B4508 movl 8(%ebp), %eax +C7442404 movl $10, 4(%esp) +0A000000 +890424 movl %eax, (%esp) +E8000000 call _SYSTEM_MOD +83C030 addl $48, %eax +88441DD8 movb %al, -40(%ebp,%ebx) +0FB745F6 movzwl -10(%ebp), %eax +83C001 addl $1, %eax +668945F6 movw %ax, -10(%ebp) +837D0800 cmpl $0, 8(%ebp) +781A js L27 +8B4D08 movl 8(%ebp), %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +EB21 jmp L28 +B8090000 movl $9, %eax +2B4508 subl 8(%ebp), %eax +89C1 movl %eax, %ecx +BA676666 movl $1717986919, %edx +89C8 movl %ecx, %eax +F7EA imull %edx +C1FA02 sarl $2, %edx +89C8 movl %ecx, %eax +C1F81F sarl $31, %eax +29C2 subl %eax, %edx +89D0 movl %edx, %eax +F7D8 negl %eax +894508 movl %eax, 8(%ebp) +837D0800 cmpl $0, 8(%ebp) +0F8F3CFF jg L29 +EB4D jmp L30 +0FB745F6 movzwl -10(%ebp), %eax +83E801 subl $1, %eax +668945F6 movw %ax, -10(%ebp) +0FB745F6 movzwl -10(%ebp), %eax +6683F81D cmpw $29, %ax +7706 ja L31 +0FBF45F6 movswl -10(%ebp), %eax +EB11 jmp L32 +C70424FE movl $-2, (%esp) +E8000000 call _Platform_Halt +B8000000 movl $0, %eax +0FB64405 movzbl -40(%ebp,%eax), %eax +0FB6D0 movzbl %al, %edx +A1000000 movl _Files_Rider__typ, %eax +89542408 movl %edx, 8(%esp) +89442404 movl %eax, 4(%esp) +C7042404 movl $_SignalTest_rider, (%esp) +E8000000 call _Files_Write +66837DF6 cmpw $0, -10(%ebp) +7FAC jg L33 +90 nop +83C434 addl $52, %esp +5B popl %ebx +5D popl %ebp +C3 ret +5369676E .ascii "Signal: \0" +616C3A20 +5369676E .ascii "Signal \0" +616C2000 +55 pushl %ebp +89E5 movl %esp, %ebp +83EC28 subl $40, %esp +8B4508 movl 8(%ebp), %eax +668945F4 movw %ax, -12(%ebp) +E8000000 call _Console_Ln +C7442404 movl $9, 4(%esp) +09000000 +C7042400 movl $LC0, (%esp) +E8000000 call _Console_String +0FBF45F4 movswl -12(%ebp), %eax +C7442404 movl $1, 4(%esp) +01000000 +890424 movl %eax, (%esp) +E8000000 call _Console_Int +E8000000 call _Console_Ln +C7442404 movl $8, 4(%esp) +08000000 +C7042409 movl $LC1, (%esp) +E8B2FCFF call _SignalTest_ws +0FBF45F4 movswl -12(%ebp), %eax +890424 movl %eax, (%esp) +E89FFDFF call _SignalTest_wi +E874FDFF call _SignalTest_wl +90 nop +C9 leave +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +83EC28 subl $40, %esp +8B4508 movl 8(%ebp), %eax +668945F4 movw %ax, -12(%ebp) +EB30 jmp L36 +0FBF45F4 movswl -12(%ebp), %eax +C7442404 movl $2, 4(%esp) +02000000 +890424 movl %eax, (%esp) +E8000000 call _Console_Int +E8000000 call _Console_Flush +C70424E8 movl $1000, (%esp) +E8000000 call _Platform_Delay +0FB745F4 movzwl -12(%ebp), %eax +83E801 subl $1, %eax +668945F4 movw %ax, -12(%ebp) +66837DF4 cmpw $0, -12(%ebp) +7FC9 jg L37 +E8000000 call _Console_Ln +90 nop +C9 leave +C3 ret +55 pushl %ebp +89E5 movl %esp, %ebp +83EC28 subl $40, %esp +A1000000 movl _SignalTest_result, %eax +890424 movl %eax, (%esp) +8B4508 movl 8(%ebp), %eax +FFD0 call *%eax +A1000000 movl _Files_Rider__typ, %eax +8B5508 movl 8(%ebp), %edx +89542410 movl %edx, 16(%esp) +C744240C movl $1, 12(%esp) +01000000 +C7442408 movl $20, 8(%esp) +14000000 +89442404 movl %eax, 4(%esp) +C7042404 movl $_SignalTest_rider, (%esp) +E8000000 call _SYSTEM_ENUMR +90 nop +C9 leave +C3 ret +5369676E .ascii "SignalTest\0" +616C5465 +72657375 .ascii "result\0" +00 .text +55 pushl %ebp +89E5 movl %esp, %ebp +83E4F0 andl $-16, %esp +83EC10 subl $16, %esp +E8000000 call ___main +8D550C leal 12(%ebp), %edx +8B4508 movl 8(%ebp), %eax +98 cwtl +89542404 movl %edx, 4(%esp) +890424 movl %eax, (%esp) +E8000000 call _Platform_Init +E8000000 call _Console__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _Files__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +E8000000 call _Platform__init +890424 movl %eax, (%esp) +E8000000 call _Heap_INCREF +C7442404 movl $_EnumPtrs, 4(%esp) +02040000 +C7042411 movl $LC2, (%esp) +E8000000 call _Heap_REGMOD +A3180000 movl %eax, _m.1984 +C7442404 movl $7, 4(%esp) +07000000 +C704241C movl $LC3, (%esp) +E8000000 call _Files_New +A3000000 movl %eax, _SignalTest_result +8B150000 movl _SignalTest_result, %edx +A1000000 movl _Files_Rider__typ, %eax +C744240C movl $0, 12(%esp) +00000000 +89542408 movl %edx, 8(%esp) +89442404 movl %eax, 4(%esp) +C7042404 movl $_SignalTest_rider, (%esp) +E8000000 call _Files_Set +0FB70500 movzwl _Platform_ArgCount, %eax +6683F801 cmpw $1, %ax +7E18 jle L40 +C704244D movl $_SignalTest_handle, (%esp) +E8000000 call _Platform_SetInterruptHandler +C704244D movl $_SignalTest_handle, (%esp) +E8000000 call _Platform_SetQuitHandler +C7042404 movl $4, (%esp) +E89EFEFF call _SignalTest_Take5 +A1000000 movl _SignalTest_result, %eax +890424 movl %eax, (%esp) +E8000000 call _Files_Register +E8000000 call _Heap_FINALL +B8000000 movl $0, %eax +C9 leave +C3 ret diff --git a/src/test/confidence/signal/signal.mod b/src/test/confidence/signal/signal.mod new file mode 100644 index 00000000..294345f2 --- /dev/null +++ b/src/test/confidence/signal/signal.mod @@ -0,0 +1,51 @@ +(* Test that interrupt and quit are handled correctly. *) +MODULE SignalTest; +IMPORT Console, Platform, Modules, Files, SYSTEM; + +VAR result: Files.File; rider: Files.Rider; + +PROCEDURE ws(s: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN i := 0; + WHILE (i < LEN(s)) & (s[i] # 0X) DO Files.Write(rider, s[i]); INC(i) END +END ws; + +PROCEDURE wl; +BEGIN Files.Write(rider, 0AX) END wl; + +PROCEDURE wi(i: LONGINT); +VAR s: ARRAY 30 OF CHAR; j: INTEGER; +BEGIN + j := 0; + IF i<0 THEN s[0] := '-'; INC(j) END; + s[j] := CHR(i MOD 10 + 48); INC(j); i := i DIV 10; + WHILE i > 0 DO s[j] := CHR(i MOD 10 + 48); INC(j); i := i DIV 10 END; + WHILE j > 0 DO DEC(j); Files.Write(rider, s[j]) END +END wi; + + +PROCEDURE handle(signal: SYSTEM.INT32); +BEGIN + Console.Ln; Console.String("Signal: "); Console.Int(signal,1); Console.Ln; + ws("Signal "); wi(signal); wl; + (*Platform.Delay(1000)*) +END handle; + +PROCEDURE Take5(i: INTEGER); +BEGIN + WHILE i > 0 DO + Console.Int(i,2); Console.Flush(); Platform.Delay(1000); DEC(i) + END; + Console.Ln; +END Take5; + +BEGIN + result := Files.New("result"); + Files.Set(rider, result, 0); + IF Modules.ArgCount > 1 THEN + Platform.SetInterruptHandler(handle); + Platform.SetQuitHandler(handle) + END; + Take5(4); + Files.Register(result); +END SignalTest. \ No newline at end of file diff --git a/src/test/confidence/signal/test.sh b/src/test/confidence/signal/test.sh new file mode 100755 index 00000000..b9131862 --- /dev/null +++ b/src/test/confidence/signal/test.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ../testenv.sh +rm -f SignalTest # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP signal.mod -m +./SignalTest x & +sleep 1 +kill -2 $! +wait +. ../testresult.sh diff --git a/src/test/confidence/testenv.sh b/src/test/confidence/testenv.sh new file mode 100755 index 00000000..e0a157ee --- /dev/null +++ b/src/test/confidence/testenv.sh @@ -0,0 +1,21 @@ +#!/bin/sh +## '.' this file from individual test.sh files. +#set -e + +echo --- Confidence test $(basename "$PWD") --- + +if which cygpath >/dev/null 2>/dev/null +then export PATH="$(cygpath "$1")/bin":"$PATH" +else export PATH="$1/bin":"$PATH" +fi +# Set library paths for darwin and termux(android) +export DYLD_LIBRARY_PATH=$1/lib:$DYLD_LIBRARY_PATH +export LD_LIBRARY_PATH=$1/lib:$LD_LIBRARY_PATH +rm -f *.o *.obj *.exe *.sym *.c *.h result new.asm $(basename "$PWD") + +# Under gcc generate assembly source for source change test. +# NOTE: The cygwin 64 bit build has relocation errors with +# these assembly generation options. +if [ "$COMPILER" = "gcc" -a "$FLAVOUR" != "cygwin.LP64.gcc" ] +then export CFLAGS="-g1 -Wa,-acdhln=new.asm -Wl,-Map=output.map" +fi diff --git a/src/test/confidence/testresult.sh b/src/test/confidence/testresult.sh new file mode 100755 index 00000000..2dfd8a34 --- /dev/null +++ b/src/test/confidence/testresult.sh @@ -0,0 +1,24 @@ +#!/bin/sh +# '.' this from indiviual test.sh files +if diff -b expected result +then printf "PASSED: $PWD\n\n" +else printf "FAILED: $PWD\n\n"; exit 1 +fi + +# Compare generated code +if [ -f new.asm ] +#then sed -n '/^ *[0-9]\+ \([0-9a-f]\{4\}\| \) [0-9A-F]\{2\}[0-9A-F ]\{6\}/s/^ *[0-9]\+ ....//p' new.asm>new.$FLAVOUR.$BRANCH.s +then sed -n '/^ *[0-9]\+ \([0-9a-f]\{4\}\| \) [0-9A-F]\{2\}[0-9A-F ]\{6\}/s/^ *[0-9]\+ ....//p' new.asm | sed 's/_m.[0-9]\+/_m.xxx/' >new.$FLAVOUR.$BRANCH.s + + if [ -f old.$FLAVOUR.$BRANCH.s -a old.$FLAVOUR.$BRANCH.s -nt ../planned-binary-change ] + then + if diff -b old.$FLAVOUR.$BRANCH.s new.$FLAVOUR.$BRANCH.s + then echo "--- Generated code unchanged ---" + else echo "--- Generated code changed ---" + fi + else + cp new.$FLAVOUR.$BRANCH.s old.$FLAVOUR.$BRANCH.s + echo "--- Generated code snapped ---" + fi + +fi diff --git a/src/test/confidence/texts/expected b/src/test/confidence/texts/expected new file mode 100644 index 00000000..96ea4526 --- /dev/null +++ b/src/test/confidence/texts/expected @@ -0,0 +1,4 @@ +aaa + -3.1E+02 +-311.141504 + -3.1D+002 diff --git a/src/test/confidence/texts/test.sh b/src/test/confidence/texts/test.sh new file mode 100644 index 00000000..d84c0df4 --- /dev/null +++ b/src/test/confidence/texts/test.sh @@ -0,0 +1,6 @@ +#!/bin/sh +. ../testenv.sh +rm -f testTexts # Remove LSW binary so it doesn't hide Cygwin binary. +$OBECOMP testTexts.mod -m +./testTexts >result +. ../testresult.sh diff --git a/src/test/confidence/texts/testTexts.mod b/src/test/confidence/texts/testTexts.mod new file mode 100644 index 00000000..cc2484d1 --- /dev/null +++ b/src/test/confidence/texts/testTexts.mod @@ -0,0 +1,41 @@ +(* compile with voc -M testTexts.Mod *) +MODULE testTexts; + +IMPORT Texts, Console; + +CONST pi = -311.1415; + +VAR + W: Texts.Writer; + T: Texts.Text; + R: Texts.Reader; + ch: CHAR; + i: INTEGER; + s: ARRAY 1024 OF CHAR; + +BEGIN + Texts.OpenWriter(W); + + Texts.WriteString(W, "aaa"); Texts.WriteLn(W); + Texts.WriteReal(W, pi, 7); Texts.WriteLn(W); + Texts.WriteRealFix(W, pi, 0, 7); Texts.WriteLn(W); + Texts.WriteLongReal(W, pi, 7); Texts.WriteLn(W); + + NEW(T); Texts.Open(T, "test.txt"); + + Texts.Append(T, W.buf); + (*Texts.Store(W, T);*) + + Texts.OpenReader(R, T, 0); + Texts.Read(R, ch); + i := 0; + WHILE ~R.eot DO + IF ch = 0DX THEN + s[i] := 0X; i := 0; Console.String(s); Console.Ln + ELSE + s[i] := ch; INC(i) + END; + Texts.Read(R, ch) + END; + s[i] := 0X; (*Console.String(s)*) +END testTexts. diff --git a/src/test/events/README.md b/src/test/events/README.md new file mode 100644 index 00000000..32729f67 --- /dev/null +++ b/src/test/events/README.md @@ -0,0 +1,7 @@ +**events example in oberon** + +Just a simple example which helps to explain how events are implemented, what is callback procedure, and how easy it is. + +Some languages simplify programmer's work, hide details, so that it's not obvious to him what's going on when he defines it's own OnSomething function. + +Callbacks are common when dealing with gui events like OnClick but they can be used with any events. I guess code is simple enough, it doesn't need explanation. diff --git a/src/test/events/clb.Mod b/src/test/events/clb.Mod new file mode 100644 index 00000000..a414cc44 --- /dev/null +++ b/src/test/events/clb.Mod @@ -0,0 +1,44 @@ +MODULE clb; + +IMPORT Console; + +TYPE OnSomething = PROCEDURE (x, y: INTEGER); + +PROCEDURE ProcessEvents(x, y: INTEGER; onsomething: OnSomething); +BEGIN + IF onsomething # NIL THEN + onsomething(x, y) + ELSE + Console.String("didn't happen"); Console.Ln + END +END ProcessEvents; + + +PROCEDURE OnEvent(x, y : INTEGER); +BEGIN + Console.String("event happened"); Console.Ln +END OnEvent; + +PROCEDURE OnEvent2(x, y : INTEGER); +BEGIN + Console.String("event 2 happened"); Console.Ln +END OnEvent2; + +PROCEDURE Something; + VAR onsmth: OnSomething; +BEGIN + onsmth := NIL; + ProcessEvents(0, 0, onsmth); + + onsmth := OnEvent; + ProcessEvents(0, 0, onsmth); +END Something; + +BEGIN + Something; + (* + ProcessEvents(0, 0, NIL); + ProcessEvents(0, 0, OnEvent); + ProcessEvents(0, 0, OnEvent2); + *) +END clb. diff --git a/src/test/events/makefile b/src/test/events/makefile new file mode 100644 index 00000000..b2f73828 --- /dev/null +++ b/src/test/events/makefile @@ -0,0 +1,4 @@ + + +all: + /opt/voc/bin/voc -M clb.Mod diff --git a/src/test/files/testFiles.Mod b/src/test/files/testFiles.Mod index f6361b89..8eaaba8e 100644 --- a/src/test/files/testFiles.Mod +++ b/src/test/files/testFiles.Mod @@ -5,30 +5,24 @@ IMPORT Files, Texts, Console; CONST file="testFiles.Mod"; -VAR +VAR T : Texts.Text; R : Texts.Reader; F : Files.File; ch : CHAR; BEGIN + F := Files.Old (file); + IF F # NIL THEN + NEW(T); + Texts.Open(T, file); + Texts.OpenReader(R, T, 0); + Texts.Read (R, ch); -F := Files.Old (file); -IF F # NIL THEN - NEW(T); - Texts.Open(T, file); - Texts.OpenReader(R, T, 0); - Texts.Read (R, ch); - - WHILE ~R.eot DO + WHILE ~R.eot DO + IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END; Texts.Read (R, ch); - Console.Char(ch); - END; - -ELSE - - Console.String ("cannot open"); Console.Ln; - -END; - - + END; + ELSE + Console.String ("cannot open"); Console.Ln; + END; END testFiles. diff --git a/src/test/gtk/gui.glade b/src/test/gtk/gui.glade index e90f3634..b152f480 100644 --- a/src/test/gtk/gui.glade +++ b/src/test/gtk/gui.glade @@ -7,7 +7,7 @@ 150 True False - OOC-Glade-Test + voc-glade-test False diff --git a/src/test/md5/hello.txt b/src/test/md5/hello.txt new file mode 100644 index 00000000..980a0d5f --- /dev/null +++ b/src/test/md5/hello.txt @@ -0,0 +1 @@ +Hello World! diff --git a/src/test/md5/md5test.Mod b/src/test/md5/md5test.Mod new file mode 100644 index 00000000..a6e685fb --- /dev/null +++ b/src/test/md5/md5test.Mod @@ -0,0 +1,55 @@ +MODULE md5test; + IMPORT MD5 := ethMD5, Out, Files, Strings; +PROCEDURE dump(VAR arr: ARRAY OF CHAR); +VAR + i: INTEGER; + ch: CHAR; +BEGIN + i := 0; + REPEAT + Out.String("arr["); Out.Int(i, 0); Out.String("]="); Out.Int(ORD(arr[i]), 0);Out.Ln; + INC(i) + UNTIL i = Strings.Length(arr)+2 +END dump; + +PROCEDURE main; + VAR + context: MD5.Context; + digest: MD5.Digest; + hexDigest: ARRAY 33 OF CHAR; + F: Files.File; + R: Files.Rider; + input: POINTER TO ARRAY OF CHAR; + ilen: LONGINT; + ch: CHAR; + i: INTEGER; +BEGIN + F := Files.Old("hello.txt"); + IF F # NIL THEN + Files.Set(R, F, 0); + ilen := Files.Length(F); + Out.String("file length is "); Out.Int(ilen, 0); Out.Ln; + NEW(input, ilen+1); + i := 0; + REPEAT + Files.Read(R, ch); + input^[i] := ch; + INC(i) + UNTIL R.eof; + (*dump(input^);*) + END; + + context := MD5.New(); (* Initialize MD5 context *) + + (*MD5.WriteBytes(context, input^, Strings.Length(input^));*) (* Process input string *) + MD5.WriteBytes(context, input^, LEN(input^)-1); (* Process input string *) + MD5.Close(context, digest); (* Finalize and get digest *) + + MD5.ToString(digest, hexDigest); (* Convert digest to hex string *) + Out.String("MD5 Hash: "); Out.String(hexDigest); Out.Ln; +END main; + +BEGIN + main; +END md5test. + diff --git a/src/test/newt/newttest.Mod b/src/test/newt/newttest.Mod index 46d82a8e..ff673863 100644 --- a/src/test/newt/newttest.Mod +++ b/src/test/newt/newttest.Mod @@ -1,46 +1,50 @@ MODULE newttest; -IMPORT newt, oocIntStr, Unix; -VAR i, j, k : newt.Int32; -str : ARRAY 32 OF CHAR; -ch : CHAR; -fo, co : newt.Component; +IMPORT newt, oocIntStr, Platform; + +CONST delayTime = 1000; + +VAR + i, j, k : newt.Int32; + str : ARRAY 32 OF CHAR; + ch : CHAR; + fo, co : newt.Component; BEGIN -i := newt.Init(); -newt.Cls(); -str := "hello world!"; -newt.DrawRootText(5, 7, str); -newt.GetScreenSize(i, j); -oocIntStr.IntToStr(i, str); -newt.DrawRootText(5, 9, str); -str := "x"; -newt.DrawRootText(7, 9, "x"); -oocIntStr.IntToStr(j, str); -newt.DrawRootText(9, 9, str); + i := newt.Init(); + newt.Cls(); + str := "hello world!"; + newt.DrawRootText(5, 7, str); + newt.GetScreenSize(i, j); + oocIntStr.IntToStr(i, str); + newt.DrawRootText(5, 9, str); + str := "x"; + newt.DrawRootText(7, 9, "x"); + oocIntStr.IntToStr(j, str); + newt.DrawRootText(9, 9, str); -newt.PushHelpLine(""); -newt.Refresh(); -i := Unix.Sleep(1); + newt.PushHelpLine(""); + newt.Refresh(); + Platform.Delay(delayTime); -newt.PushHelpLine("A help line"); -newt.Refresh(); -i := Unix.Sleep(1); + newt.PushHelpLine("A help line"); + newt.Refresh(); + Platform.Delay(delayTime); -newt.PopHelpLine(); -newt.Refresh(); -i := Unix.Sleep(1); + newt.PopHelpLine(); + newt.Refresh(); + Platform.Delay(delayTime); -REPEAT -ch := newt.GetKey(); -str[0] := ch; -str[1] := 0X; -newt.DrawRootText(5, 5, str); -newt.PushHelpLine(str); -newt.Refresh; -UNTIL ch = ' '; + REPEAT + ch := newt.GetKey(); + str[0] := ch; + str[1] := 0X; + newt.DrawRootText(5, 5, str); + newt.PushHelpLine(str); + newt.Refresh; + UNTIL ch = ' '; -(* -newt.WaitForKey(); -newt.Delay(30);*) -i := newt.Finished(); + (* + newt.WaitForKey(); + newt.Delay(30);*) + i := newt.Finished(); END newttest. diff --git a/src/test/newt/newttest2.Mod b/src/test/newt/newttest2.Mod index 9cd02d99..a26248ab 100644 --- a/src/test/newt/newttest2.Mod +++ b/src/test/newt/newttest2.Mod @@ -1,6 +1,6 @@ MODULE newttest2; -IMPORT newt, oocIntStr, Unix; +IMPORT newt, oocIntStr; VAR i, j, k : newt.Int32; str : ARRAY 32 OF CHAR; form, b1, b2, comp: newt.Component; @@ -20,7 +20,7 @@ newt.FormAddComponent(form, b1); newt.FormAddComponent(form, b2); comp := newt.RunForm(form); newt.WaitForKey(); -newt.Delay(30); +newt.Delay(3000); newt.FormDestroy(form); i := newt.Finished(); END newttest2. diff --git a/src/test/server/s.Mod b/src/test/server/s.Mod index 0c559600..38a92496 100644 --- a/src/test/server/s.Mod +++ b/src/test/server/s.Mod @@ -1,106 +1,93 @@ MODULE s; -IMPORT sockets, types, Out := Console, Unix, S := SYSTEM; +IMPORT sockets, types, Out := Console, SYSTEM, Platform, Strings; -TYPE Int32 = types.Int32; - Int16 = types.Int16; - String = types.String; -PROCEDURE DoSmth(sock : Int32); -VAR str, aff : String; - n, s : LONGINT; +PROCEDURE DoSmth(sock: Platform.FileHandle); +VAR + str, aff: ARRAY 256 OF CHAR; + n: LONGINT; BEGIN - s := SIZE(String); - aff := "Affirmative, Dave"; - n := Unix.Read(sock, S.ADR(str), s); + aff := "Affirmative, Dave"; +(* IF Platform.Read(sock, SYSTEM.ADR(str), 256, n) # 0 THEN *) + IF Platform.ReadBuf(sock, str, n) # 0 THEN + Out.String("error reading from socket"); Out.Ln; + ELSE + str[n] := 0X; (* Make sure that received message is zero terminated *) + Out.String("received message is "); Out.String(str); Out.Ln; - IF n < 0 THEN - Out.String("error reading from socket"); Out.Ln; - END; - Out.String("received message is "); Out.String(str); Out.Ln; - s := 17; - n := Unix.Write(sock, S.ADR(aff), s); - IF n < 2 THEN + IF Platform.Write(sock, SYSTEM.ADR(aff), Strings.Length(aff)) # 0 THEN Out.String("error writing to socket"); Out.Ln - END; - + END; + END; END DoSmth; -PROCEDURE ZeroByteArr(VAR a : ARRAY OF S.BYTE); -VAR i : LONGINT; -BEGIN - FOR i := 0 TO LEN(a)-1 DO - a[i] := 0 - END; -END ZeroByteArr; + + +PROCEDURE -includeunistd "#include "; +PROCEDURE -fork(): LONGINT "(LONGINT)fork()"; + PROCEDURE serve; -VAR sockfd, newsockfd, portno, clilen, pid: sockets.Int32; - ServAddr, CliAddr: sockets.SockAddrIn; - Null : Int32; - Port, maxQueue, res : Int32; - afinet, port, port0: Int16; +CONST + Port = 2055; + MaxQueue = 5; +VAR + sockfd: LONGINT; + newsockfd: LONGINT; + ServAddr: sockets.SockAddrIn; + pid: LONGINT; + res: Platform.ErrorCode; + sockaddrlen: LONGINT; + ipAddr: LONGINT; ip: ARRAY 16 OF CHAR; BEGIN - Port := 2055; - maxQueue := 5; - Null := 0; - sockfd := sockets.Socket(S.VAL(Int32, sockets.AfInet), S.VAL(Int32, sockets.SockStream), Null); - IF sockfd < 0 THEN - Out.String("error opening socket") - ELSE - Out.String("socket created.") - END; - Out.Ln; - - types.IntegerToInt16(sockets.AfInet, afinet); - types.IntegerToInt16(Port, port); - types.htons(port, port0); (* only necessary on little endian computers *) - ServAddr.SinFamily := afinet; - ServAddr.SinPort := port0; - ZeroByteArr(ServAddr.SinZero); - (*Out.String("listening on port ");Out.Int(S.VAL(INTEGER, ServAddr.SinPort), 0); Out.Ln;*) - ServAddr.SinAddr.SAddr := 0(*sockets.InAddrAny*); - - res := sockets.Bind(sockfd, S.VAL(sockets.SockAddr, ServAddr), (SIZE(sockets.SockAddr))); - IF res < 0 THEN - Out.String("error on binding") - ELSE - Out.String("binding completed.") - END; - Out.Ln; - - res := sockets.Listen(sockfd, maxQueue); - - IF res # 0 THEN - Out.String("listen() failed"); - ELSE - Out.String("listen okay"); - END; - Out.Ln; - clilen := SIZE(sockets.SockAddrIn); - LOOP - newsockfd := sockets.Accept(sockfd, S.VAL(sockets.SockAddr, ServAddr), clilen); - IF newsockfd < 0 THEN - Out.String("error on accept") - ELSE - Out.String("accept okay") - END; - Out.Ln; + sockfd := sockets.Socket(sockets.AfInet, sockets.SockStream, 0); + IF sockfd < 0 THEN + Out.String("error opening socket") + ELSE + Out.String("socket created.") + END; + Out.Ln; + COPY("127.0.0.1", ip); + ipAddr := sockets.inetaddr(ip); - pid := Unix.Fork(); - IF pid < 0 THEN - Out.String("error on fork") - ELSIF pid = 0 THEN - Out.String("forked okay"); Out.Ln; - res := Unix.Close(sockfd); - DoSmth(newsockfd); - EXIT - ELSE - res := Unix.Close(newsockfd); - END; - END; + sockets.SetSockAddrIn(sockets.AfInet, Port, ipAddr, ServAddr); + IF sockets.Bind(sockfd, SYSTEM.VAL(sockets.SockAddr, ServAddr), SIZE(sockets.SockAddr)) < 0 THEN + Out.String("error on binding") + ELSE + Out.String("binding completed.") + END; + Out.Ln; + IF sockets.Listen(sockfd, MaxQueue) # 0 THEN + Out.String("listen() failed"); + ELSE + Out.String("listen okay"); + END; + Out.Ln; + LOOP + sockaddrlen := SIZE(sockets.SockAddrIn); + newsockfd := sockets.Accept(sockfd, SYSTEM.VAL(sockets.SockAddr, ServAddr), sockaddrlen); + IF newsockfd < 0 THEN + Out.String("error on accept") + ELSE + Out.String("accept okay") + END; + Out.Ln; + + pid := fork(); + IF pid < 0 THEN + Out.String("error on fork") + ELSIF pid = 0 THEN + Out.String("forked okay"); Out.Ln; + res := Platform.Close(sockfd); + DoSmth(newsockfd); + EXIT + ELSE + res := Platform.Close(newsockfd) + END + END END serve; diff --git a/src/test/server/sockets.Mod b/src/test/server/sockets.Mod index 4cba806e..ded7a61f 100644 --- a/src/test/server/sockets.Mod +++ b/src/test/server/sockets.Mod @@ -1,119 +1,129 @@ MODULE sockets; -IMPORT types, SYS := SYSTEM; -TYPE - Int16* = types.Int16; (* INTEGER on 32 bit platform *) - Int32* = types.Int32; - Int64* = types.Int64; +IMPORT SYSTEM, oocC; -CONST - SockStream* = 1; - SockDgram* = 2; - SockRaw* = 3; - SockRdm* = 4; - SockSeqpacket* = 5; - SockDccp* = 6; - SockPacket* = 10; +CONST + SockStream* = 1; + SockDgram* = 2; + SockRaw* = 3; + SockRdm* = 4; + SockSeqpacket* = 5; + SockDccp* = 6; + SockPacket* = 10; - AfUnscec* = 0; (* Unspecified. *) - AfLocal* = 1; (* Local to host (pipes and file-domain). *) - AfUnix* = 1; (* POSIX name for PF_LOCAL. *) - AfFile* = 1; (* Another non-standard name for PF_LOCAL. *) - AfInet* = 2; (* IP protocol family. *) - AfAx25* = 3; (* Amateur Radio AX.25. *) - AfIpx* = 4; (* Novell Internet Protocol. *) - AfAppletalk* = 5; (* Appletalk DDP. *) - AfNetrom* = 6; (* Amateur radio NetROM. *) - AfBridge* = 7; (* Multiprotocol bridge. *) - AfAtmpvc* = 8; (* ATM PVCs. *) - AfX25* = 9; (* Reserved for X.25 project. *) - AfInet6* = 10; (* IP version 6. *) - AfRose* = 11; (* Amateur Radio X.25 PLP. *) - AfDecnet* = 12; (* Reserved for DECnet project. *) - AfNetbeui*= 13; (* Reserved for 802.2LLC project. *) - AfSecurity*=14; (* Security callback pseudo AF. *) - AfKey* = 15; (* PF_KEY key management API. *) - AfNetlink*= 16; - AfRoute* = 16; (* Alias to emulate 4.4BSD. *) - AfPacket = 17; (* Packet family. *) - AfAsh = 18; (* Ash. *) - AfEconet* = 19; (* Acorn Econet. *) - AfAtmsvc* = 20; (* ATM SVCs. *) - AfRds* = 21; (* RDS sockets. *) - AfSna = 22; (* Linux SNA Project *) - AfIrda* = 23; (* IRDA sockets. *) - AfPppox = 24; (* PPPoX sockets. *) - AfWanpipe*= 25; (* Wanpipe API sockets. *) - AfLlc* = 26; (* Linux LLC. *) - AfCan* = 29; (* Controller Area Network. *) - AfTipc* = 30; (* TIPC sockets. *) - AfBluetooth* = 31; (* Bluetooth sockets. *) - AfIucv* = 32; (* IUCV sockets. *) - AfRxrpc* = 33; (* RxRPC sockets. *) - AfIsdn* = 34; (* mISDN sockets. *) - AfPhonet* = 35; (* Phonet sockets. *) - AfIeee802154* = 36; (* IEEE 802.15.4 sockets. *) - AfCaif* = 37; (* CAIF sockets. *) - AfAlg* = 38; (* Algorithm sockets. *) - AfNfc* = 39; (* NFC sockets. *) - AfVsock* = 40; (* vSockets. *) - AfMax* = 41; (* For now.. *) + AfUnscec* = 0; (* Unspecified. *) + AfLocal* = 1; (* Local to host (pipes and file-domain). *) + AfUnix* = 1; (* POSIX name for PF_LOCAL. *) + AfFile* = 1; (* Another non-standard name for PF_LOCAL. *) + AfInet* = 2; (* IP protocol family. *) + AfAx25* = 3; (* Amateur Radio AX.25. *) + AfIpx* = 4; (* Novell Internet Protocol. *) + AfAppletalk* = 5; (* Appletalk DDP. *) + AfNetrom* = 6; (* Amateur radio NetROM. *) + AfBridge* = 7; (* Multiprotocol bridge. *) + AfAtmpvc* = 8; (* ATM PVCs. *) + AfX25* = 9; (* Reserved for X.25 project. *) + AfInet6* = 10; (* IP version 6. *) + AfRose* = 11; (* Amateur Radio X.25 PLP. *) + AfDecnet* = 12; (* Reserved for DECnet project. *) + AfNetbeui* = 13; (* Reserved for 802.2LLC project. *) + AfSecurity* = 14; (* Security callback pseudo AF. *) + AfKey* = 15; (* PF_KEY key management API. *) + AfNetlink* = 16; + AfRoute* = 16; (* Alias to emulate 4.4BSD. *) + AfPacket = 17; (* Packet family. *) + AfAsh = 18; (* Ash. *) + AfEconet* = 19; (* Acorn Econet. *) + AfAtmsvc* = 20; (* ATM SVCs. *) + AfRds* = 21; (* RDS sockets. *) + AfSna = 22; (* Linux SNA Project *) + AfIrda* = 23; (* IRDA sockets. *) + AfPppox = 24; (* PPPoX sockets. *) + AfWanpipe* = 25; (* Wanpipe API sockets. *) + AfLlc* = 26; (* Linux LLC. *) + AfCan* = 29; (* Controller Area Network. *) + AfTipc* = 30; (* TIPC sockets. *) + AfBluetooth* = 31; (* Bluetooth sockets. *) + AfIucv* = 32; (* IUCV sockets. *) + AfRxrpc* = 33; (* RxRPC sockets. *) + AfIsdn* = 34; (* mISDN sockets. *) + AfPhonet* = 35; (* Phonet sockets. *) + AfIeee802154* = 36; (* IEEE 802.15.4 sockets. *) + AfCaif* = 37; (* CAIF sockets. *) + AfAlg* = 38; (* Algorithm sockets. *) + AfNfc* = 39; (* NFC sockets. *) + AfVsock* = 40; (* vSockets. *) + AfMax* = 41; (* For now.. *) - InAddrAny* = 0; + InAddrAny* = 0; TYPE - (* /usr/include/netinet/in.h *) InAddr* = RECORD - SAddr* : Int32; + SAddr*: oocC.int; END; SockAddrIn* = RECORD - SinFamily* : Int16; - SinPort* : Int16; - SinAddr* : InAddr; - SinZero* : ARRAY 8 OF CHAR; + SinFamily*: oocC.shortint; + SinPort*: oocC.shortint; + SinAddr*: InAddr; + SinZero*: ARRAY 8 OF CHAR; END; (* /usr/include/sys/socket.h *) - + SockAddr* = RECORD - SaFamily* : Int16; - SaData* : ARRAY 14 OF CHAR + SaFamily*: oocC.shortint; + SaData*: ARRAY 14 OF CHAR END; - PROCEDURE -socket(domain, type, protocol: Int32): Int32 - "(int)socket(domain, type, protocol)"; + PROCEDURE -includesocket "#include "; + PROCEDURE -includeInet "#include "; - PROCEDURE Socket*(domain, type, protocol: Int32): Int32; + PROCEDURE -inetaddr*(s: ARRAY OF CHAR): LONGINT "(LONGINT)inet_addr((char*)s)"; + + PROCEDURE -SetCShort(i: INTEGER; VAR si: oocC.shortint) + "*(short*)si = i"; + + PROCEDURE -SetCShortSwapped(i: INTEGER; VAR si: oocC.shortint) + "*(short*)si = ((i >> 8) & 0x00ff) | ((i << 8) & 0xff00)"; + + PROCEDURE SetSockAddrIn*(family, port: INTEGER; inaddr: LONGINT; VAR sai: SockAddrIn); + VAR i: INTEGER; BEGIN - RETURN socket(domain, type, protocol) + SetCShort(family, sai.SinFamily); + SetCShortSwapped(port, sai.SinPort); + sai.SinAddr.SAddr := inaddr; + i := 0; WHILE i < 8 DO sai.SinZero[i] := 0X; INC(i) END + END SetSockAddrIn; + + PROCEDURE -socket(domain, type, protocol: LONGINT): INTEGER + "(INTEGER)socket((int)domain, (int)type, (int)protocol)"; + + PROCEDURE Socket*(domain, type, protocol: LONGINT): INTEGER; + BEGIN RETURN socket(domain, type, protocol) END Socket; - PROCEDURE -bind(sockfd: Int32; VAR addr: SockAddr; addrlen: Int32): Int32 - "(int)bind(sockfd, addr, addrlen)"; + PROCEDURE -bind(sockfd: LONGINT; VAR addr: SockAddr; addrlen: LONGINT): INTEGER + "(INTEGER)bind((int)sockfd, (const struct sockaddr*)addr, (int)addrlen)"; - PROCEDURE Bind*(sockfd: Int32; VAR addr: SockAddr; addrlen: Int32): Int32; - BEGIN - RETURN bind(sockfd, addr, addrlen) + PROCEDURE Bind*(sockfd: LONGINT; VAR addr: SockAddr; addrlen: LONGINT): INTEGER; + BEGIN RETURN bind(sockfd, addr, addrlen) END Bind; - PROCEDURE -listen(sockfd, backlog: Int32): Int32 - "(int)listen(sockfd, backlog)"; + PROCEDURE -listen(sockfd, backlog: LONGINT): INTEGER + "(INTEGER)listen((int)sockfd, (int)backlog)"; - PROCEDURE Listen*(sockfd, backlog: Int32): Int32; - BEGIN - RETURN listen(sockfd, backlog) + PROCEDURE Listen*(sockfd, backlog: LONGINT): INTEGER; + BEGIN RETURN listen(sockfd, backlog) END Listen; - PROCEDURE -accept(sockfd: Int32; VAR addr: SockAddr; VAR addrlen: Int32): Int32 - "(int)accept(sockfd, addr, addrlen)"; + PROCEDURE -accept(sockfd: LONGINT; VAR addr: SockAddr; VAR addrlen: LONGINT; VAR result: INTEGER) + "int _o_al = (int)addrlen; *result = (INTEGER)accept((int)sockfd, (struct sockaddr*)addr, &_o_al); *addrlen = _o_al"; - PROCEDURE Accept*(sockfd: Int32; VAR addr: SockAddr; VAR addrlen: Int32): Int32; - BEGIN - RETURN accept(sockfd, addr, addrlen) + PROCEDURE Accept*(sockfd: LONGINT; VAR addr: SockAddr; VAR addrlen: LONGINT): INTEGER; + VAR result: INTEGER; + BEGIN accept(sockfd, addr, addrlen, result); RETURN result END Accept; -BEGIN - END sockets. diff --git a/src/test/server/types.Mod b/src/test/server/types.Mod index 633e6b26..ca6b5d02 100644 --- a/src/test/server/types.Mod +++ b/src/test/server/types.Mod @@ -1,38 +1,25 @@ MODULE types; -IMPORT SYS := SYSTEM; +IMPORT SYSTEM; TYPE - intarr64 = ARRAY 8 OF SYS.BYTE; (* to emulate int16 on x86_64; -- noch *) - intarr32 = ARRAY 4 OF SYS.BYTE; - intarr16 = ARRAY 2 OF SYS.BYTE; - Int16* = intarr16; (* INTEGER on 32 bit platform *) - Int32* = INTEGER; - Int64* = LONGINT; - String* = ARRAY 256 OF CHAR; + (* Int32* = ARRAY 4 OF SYSTEM.BYTE; *) + Int16* = ARRAY 2 OF SYSTEM.BYTE; - PROCEDURE LongintToInt16*(int: LONGINT; VAR int16: Int16); - VAR longintarr : intarr64; - BEGIN - (*RETURN SYS.VAL(Int16, int)*) - longintarr := SYS.VAL(intarr64, int); - int16[0] := longintarr[0]; - int16[1] := longintarr[1]; (* this will work for little endian -- noch *) - END LongintToInt16; + PROCEDURE IntegerToInt16*(int: INTEGER; VAR int16: Int16); + TYPE PInt16 = POINTER TO Int16; + VAR p: PInt16; + BEGIN + (* Note: We take the least significant 16 bits of int, which + is correct on supported (i.e. little-endian) architectures. *) + p := SYSTEM.VAL(PInt16, SYSTEM.ADR(int)); + int16 := p^; + END IntegerToInt16; - PROCEDURE IntegerToInt16*(int: INTEGER; VAR int16: Int16); - VAR intarr : intarr32; - BEGIN - int16 := SYS.VAL(Int16, int) - (*intarr := SYS.VAL(intarr32, int); - int16[0] := intarr[0]; - int16[1] := intarr[1];*) (* this will work for little endian -- noch *) - END IntegerToInt16; - - PROCEDURE htons*(in: Int16; VAR out : Int16); - BEGIN - out[0] := in[1]; - out[1] := in[0]; - END htons; + PROCEDURE htons*(in: Int16; VAR out : Int16); + BEGIN + out[0] := in[1]; + out[1] := in[0]; + END htons; END types. diff --git a/src/test/sound/beep.Mod b/src/test/sound/beep.Mod index 6c53ed76..d8b30ae9 100644 --- a/src/test/sound/beep.Mod +++ b/src/test/sound/beep.Mod @@ -1,5 +1,5 @@ MODULE beep; -IMPORT Files, rm:=oocRealMath, Unix; +IMPORT Files, rm:=oocRealMath, Platform; CONST pi2=6.28318; (*pi2 = 6.2831802368164062;*) @@ -52,7 +52,7 @@ FOR i:=1 TO e DO END; Files.Register(outvar); -i:=Unix.System("oggenc -r -C 1 beepfile"); -i:=Unix.System("ogg123 beepfile.ogg"); +i:=Platform.System("oggenc -r -C 1 beepfile"); +i:=Platform.System("ogg123 beepfile.ogg"); END beep. diff --git a/src/test/texts/argTexts.Mod b/src/test/texts/argTexts.Mod new file mode 100644 index 00000000..644813d0 --- /dev/null +++ b/src/test/texts/argTexts.Mod @@ -0,0 +1,24 @@ +MODULE argTexts; (* example how to get arguments by using Texts module *) +IMPORT Texts, Oberon; + +VAR + S: Texts.Scanner; (* we'll read program arguments with it *) + + W : Texts.Writer; (* to write to console *) + T : Texts.Text; + +BEGIN + Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); + Texts.Scan(S); + (*Out.String(S.s); Out.Ln;*) + +Texts.OpenWriter (W); + +Texts.WriteString(W, "aaa"); +Texts.WriteLn(W); +Texts.WriteString(W, S.s); +Texts.WriteLn(W); +Texts.Append(Oberon.Log, W.buf); + + +END argTexts. diff --git a/src/test/vt100/crt.Mod b/src/test/vt100/crt.Mod index 3fd63b47..c5f3662f 100644 --- a/src/test/vt100/crt.Mod +++ b/src/test/vt100/crt.Mod @@ -1,6 +1,6 @@ MODULE crt; -IMPORT vt100, Unix, Console, +IMPORT vt100, Platform, Console, Strings; (* strings to remove later ? *) CONST @@ -28,8 +28,6 @@ CONST (* Add-in for blinking *) Blink* = 128; -TYPE - PFdSet = POINTER TO Unix.FdSet; VAR tmpstr : ARRAY 23 OF CHAR; @@ -58,16 +56,8 @@ VAR tmpstr : ARRAY 23 OF CHAR; vt100.DECTCEMh; END cursoron; - PROCEDURE Delay*( ms : INTEGER); - VAR i : LONGINT; - tv : Unix.Timeval; - pfd : PFdSet; - BEGIN - tv.sec := 0; - tv.usec := ms * 1000; - pfd := NIL; - i := Unix.Select(0, pfd^, pfd^, pfd^, tv); - END Delay; + PROCEDURE Delay*(ms: INTEGER); + BEGIN Platform.Delay(ms) END Delay; PROCEDURE GotoXY* (x, y: INTEGER); BEGIN diff --git a/src/test/x11/0/makefile b/src/test/x11/0/makefile index 67bf3938..c9b9aa5a 100644 --- a/src/test/x11/0/makefile +++ b/src/test/x11/0/makefile @@ -1,12 +1,12 @@ #for old systems like RHEL4 use #CFLAGS=-L/usr/X11R6/lib -lX11 +MODX11="../../../library/oocX11" CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod test.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod test.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/0/test.Mod b/src/test/x11/0/test.Mod index 8ba92261..b15133d1 100644 --- a/src/test/x11/0/test.Mod +++ b/src/test/x11/0/test.Mod @@ -1,29 +1,31 @@ MODULE test; IMPORT p := oocXYplane, Out := Console; -VAR ch : CHAR; -i : INTEGER; + +VAR + ch : CHAR; + i : INTEGER; + BEGIN + p.Open; -p.Open; + (*p.Clear;*) + FOR i := 1 TO 555 DO + p.Dot(i,300 ,p.draw) + END; + + (* + FOR i := 100 TO 500 DO + p.Dot(i,300 ,p.erase) + END; + *) + + IF p.IsDot (5, 300) THEN Out.String("Yes") ELSE Out.String("No") END; Out.Ln; + IF p.IsDot (5, 500) THEN Out.String("Yes") ELSE Out.String("No") END; Out.Ln; -(*p.Clear;*) -FOR i := 1 TO 555 DO -p.Dot(i,300 ,p.draw) -END; -(* -FOR i := 100 TO 500 DO -p.Dot(i,300 ,p.erase) -END; -*) - -IF p.IsDot (5, 300) THEN Out.String("Yes") ELSE Out.String("No") END; Out.Ln; -IF p.IsDot (5, 500) THEN Out.String("Yes") ELSE Out.String("No") END; Out.Ln; - -REPEAT - ch := p.Key(); -UNTIL ch # 0X; - -p.Close; + REPEAT + ch := p.Key(); + UNTIL ch # 0X; + p.Close; END test. diff --git a/src/test/x11/IFS/makefile b/src/test/x11/IFS/makefile index d05ad8f9..0e36987d 100644 --- a/src/test/x11/IFS/makefile +++ b/src/test/x11/IFS/makefile @@ -1,12 +1,10 @@ CFLAGS=-lX11 export CFLAGS - -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) -s IFS.Mod IFStest.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod IFS.Mod IFStest.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/mines/makefile b/src/test/x11/mines/makefile index f0c03002..f31fd926 100644 --- a/src/test/x11/mines/makefile +++ b/src/test/x11/mines/makefile @@ -3,12 +3,12 @@ CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" + VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) -s compatIn.Mod Linie.Mod Minesweeper.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod compatIn.Mod Linie.Mod Minesweeper.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/pacman/makefile b/src/test/x11/pacman/makefile index 59f90e30..a90df273 100644 --- a/src/test/x11/pacman/makefile +++ b/src/test/x11/pacman/makefile @@ -3,12 +3,12 @@ CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" + VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) -s Grafik.Mod PacMan.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod Grafik.Mod PacMan.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/tetris/Tetris.Mod b/src/test/x11/tetris/Tetris.Mod index a3468bd9..977d9ff4 100644 --- a/src/test/x11/tetris/Tetris.Mod +++ b/src/test/x11/tetris/Tetris.Mod @@ -5,7 +5,7 @@ MODULE Tetris; (* Neuerungen: Spielparameter sind ueber Konstantendeklariert, Zweispielermodus bricht bei Limit-Linien ab, Pause-Funktion wurde eingefuehrt *) -IMPORT X:=oocXYplane, L:=Linie, In := compatIn, Out := Console, RN:=ethRandomNumbers, Ziffer, Oberon := Kernel; +IMPORT X:=oocXYplane, L:=Linie, In := compatIn, Out := Console, RN:=ethRandomNumbers, Ziffer, Oberon; CONST diff --git a/src/test/x11/tetris/makefile b/src/test/x11/tetris/makefile index 466b17f2..e7c8a4b7 100644 --- a/src/test/x11/tetris/makefile +++ b/src/test/x11/tetris/makefile @@ -3,12 +3,12 @@ CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" + VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) -s compatIn.Mod Linie.Mod Ziffer.Mod Tetris.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod compatIn.Mod Linie.Mod Ziffer.Mod Tetris.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/tron/makefile b/src/test/x11/tron/makefile index 26bee138..48464d5e 100644 --- a/src/test/x11/tron/makefile +++ b/src/test/x11/tron/makefile @@ -3,12 +3,11 @@ CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) compatIn.Mod Tron.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod compatIn.Mod Tron.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/test/x11/vier/makefile b/src/test/x11/vier/makefile index 06cdaf00..54d4ac35 100644 --- a/src/test/x11/vier/makefile +++ b/src/test/x11/vier/makefile @@ -3,12 +3,12 @@ CFLAGS=-lX11 export CFLAGS -MOD = MODULES="../../../lib/oocX11" +MODX11="../../../library/oocX11" + VOC = $(MOD) /opt/voc/bin/voc all: - $(VOC) -s oocX11.Mod oocXutil.Mod oocXYplane.Mod - $(VOC) -s compatIn.Mod Ausgabe.Mod Vier.Mod -m + $(VOC) -s $(MODX11)/oocX11.Mod $(MODX11)/oocXutil.Mod $(MODX11)/oocXYplane.Mod compatIn.Mod Ausgabe.Mod Vier.Mod -m #$(VOC) -Cm test.Mod #gcc -o test test.o -fPIC -g -I /opt/voc-1.0/src/lib/system/gcc/x86_64 -I /opt/voc-1.0/lib/voc/obj -lVishapOberon -L. -L/opt/voc-1.0/lib -lX11 diff --git a/src/tools/HeapDump/HeapDump.Mod b/src/tools/HeapDump/HeapDump.Mod new file mode 100644 index 00000000..83adadb0 --- /dev/null +++ b/src/tools/HeapDump/HeapDump.Mod @@ -0,0 +1,139 @@ +MODULE HeapDump; + +IMPORT SYSTEM, Heap, Console; + + PROCEDURE -wc(c: CHAR); BEGIN Console.Char(c) END wc; + PROCEDURE -ws(s: ARRAY OF CHAR); BEGIN Console.String(s) END ws; + PROCEDURE -wi(i: LONGINT); BEGIN Console.Int(i, 1) END wi; + PROCEDURE -wl; BEGIN Console.Ln(); Console_Flush() END wl; + + PROCEDURE th(h: LONGINT); + VAR i, d: INTEGER; s: ARRAY 20 OF CHAR; + BEGIN + IF h = 0 THEN ws("0H"); RETURN END; + i := 0; + WHILE (h # 0) DO + d := SHORT(h MOD 16); h := SYSTEM.LSH(h, -4); + IF d < 10 THEN s[i] := CHR(d + ORD("0")) ELSE s[i] := CHR(d - 10 + ORD("a")) END; + INC(i) + END; + WHILE i > 0 DO DEC(i); wc(s[i]) END; + wc("H"); + END th; + + PROCEDURE DumpType(type: LONGINT); + TYPE + typename = POINTER TO ARRAY 24 OF CHAR; + pointers = POINTER TO ARRAY 10000 OF LONGINT; + VAR + tag, next, level, blksz, m: LONGINT; + module: Module; + name: typename; + ptr: pointers; + i: INTEGER; + BEGIN + SYSTEM.GET(type - SZL, tag); + SYSTEM.GET(type, next); + SYSTEM.GET(type + SZL, level); + SYSTEM.GET(type + 2*SZL, m); module := SYSTEM.VAL(Module, m); + name := SYSTEM.VAL(typename, type + 3*SZL); + SYSTEM.GET(type + 20*SZL + 24, blksz); + ptr := SYSTEM.VAL(pointers, type + 21*SZL + 24); + ws("tag "); th(tag); + ws(", level "); wi(level,1); + ws(", blksz "); th(blksz); + ws(", name "); ws(module.name); wc("."); ws(name^); + ws(", pointers: "); + i := 0; WHILE ptr[i] >= 0 DO wi(ptr[i],1); wc(" "); INC(i) END; + wi(ptr[i],1); + END DumpType; + + PROCEDURE DumpTypes(types: LONGINT); + BEGIN + WHILE types # 0 DO + ws(" TYPE at: "); th(types); ws(": "); DumpType(types); wl; + SYSTEM.GET(types, types); + END + END DumpTypes; + + PROCEDURE DumpModules; + VAR m: Module; t: LONGINT; + BEGIN + m := SYSTEM.VAL(Module, modules); + WHILE m # NIL DO + ws(" Module "); ws(m.name); ws(", refcnt "); wi(m.refcnt,1); wl; + DumpTypes(m.types); + m := m.next; + END + END DumpModules; + + + PROCEDURE DumpChunks; + VAR + chunk, nextchunk, chunkend: LONGINT; + block, blocktag, blocksize, blocksizeviatag, blocksentinel, blocknext: LONGINT; + type: LONGINT; + reserved, ptr: LONGINT; + BEGIN + chunk := heap; + WHILE chunk # 0 DO + SYSTEM.GET(chunk + nextChnkOff, nextchunk); + SYSTEM.GET(chunk + endOff, chunkend); + ws(" Chunk at "); th(chunk); + ws(", chunk end "); th(chunkend); + ws(", next chunk "); th(nextchunk); + wl; + block := chunk + blkOff; + WHILE block < chunkend DO + SYSTEM.GET(block+tagOff, blocktag); + SYSTEM.GET(block+sizeOff, blocksize); + SYSTEM.GET(block+sntlOff, blocksentinel); + SYSTEM.GET(block+nextOff, blocknext); + ws(" Block at "); th(block); + + ws(", tag "); th(blocktag); + IF (ODD(blocktag)) THEN ws(" (marked)"); DEC(blocktag) END; + SYSTEM.GET(blocktag, blocksizeviatag); + SYSTEM.GET(blocktag - SZL, reserved); + SYSTEM.GET(blocktag + SZL, ptr); + + (*ws(", size "); th(blocksize); *) + ws(", size via tag "); th(blocksizeviatag); + (*ws(", sentinel "); th(blocksentinel); *) + (*ws(", next block "); th(blocknext); *) + + ws(", .reserved "); th(reserved); + ws(", .ptr[0] "); th(ptr); + + (* The following test attempts to distinguish between blocks + allocated by NEW (whose tag points to a full type descriptor) + and those allocated by SYSTEM.NEW (whose tag points only to a + size and a dummy ptr list sentinel). + It is a safe test in that only full type descriptors have a + non-empty ptr list, but it means we will fail to report the + type of RECORDs that contain no pointers. + *) + IF ptr >= 0 THEN + type := blocktag - (20*SZL + 24); + ws(", type at "); th(type); wl; + ws(" TYPE: "); DumpType(type); + END; + + wl; + + INC(block, blocksizeviatag); + END; + chunk := nextchunk + END + END DumpChunks; + + + PROCEDURE Dump*; + BEGIN + Heap.Lock; + ws("Module and type dump."); wl; DumpModules; wl; wl; + ws("Heap chunk and block dump."); wl; DumpChunks; wl; + Heap.Unlock; + END Dump; + +END HeapDump. diff --git a/src/tools/autobuild/makesvg.pl b/src/tools/autobuild/makesvg.pl new file mode 100644 index 00000000..398d09cd --- /dev/null +++ b/src/tools/autobuild/makesvg.pl @@ -0,0 +1,113 @@ +#!perl -w +use strict; +use warnings; + + +my %BuildStatus = (); +my $Rows = 0; +opendir DIR, "logs"; +while (my $fn = readdir(DIR)) { + if ($fn =~ /^((.+)-(.+))\.state$/) { + my ($build, $branch, $id) = ($1, $2, $3); + open STATE, "); # date time os compiler model compiler-build library-build ssource-change binary-change tests + splice(@state, 2, 0, $branch); + $BuildStatus{$build} = \@state; + close STATE; + $Rows++; + } +} +closedir DIR; + +#for my $fn (sort keys %BuildStatus) { +# print "$fn:\n"; +# my @state = @{$BuildStatus{$fn}}; +# my $i = 0; +# for my $val (@state) { +# print " $i: $val\n"; +# $i++; +# } +#} + + +my $FontHeight = 12; +my $LineHeight = 16; + +sub svgtext { + my ($f, $x, $y, $colour, $msg) = @_; + if ($msg ne '') { + $y = ($y+1)*$LineHeight + $FontHeight*0.4; + print $f <<"--END--TEXT--"; +$msg +--END--TEXT-- + } +} + +sub ColourFor { + my ($str) = @_; + if ($str eq "Failed") {return "#e03030";} # red + if ($str eq "Changed") {return "#ff9d4d";} # amber + if ($str eq "Passed") {return "#5adb5a";} # green + if ($str eq "Built") {return "#5adb5a";} # green + return "#c0c0c0"; +} + + +my @ColWidths = (22, 81, 67, 60, 70, 60, 50, 60, 60, 80, 80, 64); +my @Columns = (0); +for my $width (@ColWidths) {push @Columns, $Columns[$#Columns] + $width} + +my $Width = $Columns[$#Columns]; +my $Height = ($Rows+2.2) * $LineHeight; + + + +open(my $svg, ">vishaps-status.svg") // die "Could not create vishaps-status.svg."; + +print $svg <<"--END--SVG--HEADER--"; + + + +--END--SVG--HEADER-- + + +svgtext($svg, $Columns[1], 0, "#e0e0e0", "Date"); +svgtext($svg, $Columns[2], 0, "#e0e0e0", "Time"); +svgtext($svg, $Columns[3], 0, "#e0e0e0", "Branch"); +svgtext($svg, $Columns[4], 0, "#e0e0e0", "OS"); +svgtext($svg, $Columns[5], 0, "#e0e0e0", "Compiler"); +svgtext($svg, $Columns[6], 0, "#e0e0e0", "Model"); +svgtext($svg, $Columns[7], 0, "#e0e0e0", "Oberon"); +svgtext($svg, $Columns[8], 0, "#e0e0e0", "Library"); +svgtext($svg, $Columns[9], 0, "#e0e0e0", "C Source"); +svgtext($svg, $Columns[10], 0, "#e0e0e0", "Assembler"); +svgtext($svg, $Columns[11], 0, "#e0e0e0", "Tests"); + + +my $Row = 1; +for my $build (sort keys %BuildStatus) { + my @state = @{$BuildStatus{$build}}; + + my $y = $Row*$LineHeight + $FontHeight*0.8; + my $h = $LineHeight * 0.9; + print $svg <<"--END--HIGHLIGHT--"; + + +--END--HIGHLIGHT-- + + my $column = 1; + for my $field (@state) { + svgtext($svg, $Columns[$column], $Row, ColourFor($field), $field); + $column++; + } + $Row++; + + print $svg "\n" +} + +print $svg "\n"; +close $svg; diff --git a/src/tools/autobuild/response.html b/src/tools/autobuild/response.html new file mode 100644 index 00000000..12acbc38 --- /dev/null +++ b/src/tools/autobuild/response.html @@ -0,0 +1,5 @@ + + +github webhook response +github webhook response + diff --git a/src/tools/autobuild/runbuilds.pl b/src/tools/autobuild/runbuilds.pl new file mode 100644 index 00000000..23a7f1db --- /dev/null +++ b/src/tools/autobuild/runbuilds.pl @@ -0,0 +1,205 @@ +#!perl -w +use strict; +use warnings; +use POSIX "strftime"; + +$SIG{CHLD} = 'IGNORE'; + +my $home = "/home/dave/vishap-build"; + +chdir $home; +mkdir "logs"; +#my $GlobalLog = *STDOUT; +open my $GlobalLog, ">$home/logs/runbuilds.log"; + +my $LogToScreenToo = 1; + + +# Find a build to run + +sub FindTriggeredBuild { + opendir (DIR, "$home") || die "$!"; + my $branch = undef; + while ((!defined $branch) && (my $fn = readdir DIR)) { + if ($fn =~ /^trigger-(\w+)/) {$branch = $1; unlink "$home/$fn"} + } + closedir DIR; + return $branch; +} + + + + +# Status information +# +# Build type: Datestamp Branch Platform Compiler Model +# Status: Compiler-build Library-build C-changed Assembler? Tests +# + +my %BuildStatus = (); + +sub WriteStatus {my ($timestamp, $id) = @_; + open STATE, ">logs/$id.state"; + print STATE "$timestamp "; + print STATE $BuildStatus{$id}->{kind}, ' '; + print STATE $BuildStatus{$id}->{compile}, ' '; + print STATE $BuildStatus{$id}->{library}, ' '; + print STATE $BuildStatus{$id}->{csource}, ' '; + print STATE $BuildStatus{$id}->{binary}, ' '; + print STATE $BuildStatus{$id}->{tests}, "\n"; + close STATE; +} + +sub SetStatus {my ($timestamp, $id, $section, $state) = @_; + if (!exists $BuildStatus{$id}) {$BuildStatus{$id} = { + kind => "- - -", compile => "Pending", library => "Pending", + csource => "Pending", binary => "Pending", tests => "Pending" + }} + $BuildStatus{$id}->{$section} = $state; + WriteStatus($timestamp, $id) +} + + +sub UpdateStatus {my ($timestamp, $id, $msg) = @_; + if ($msg =~ /^Configuration: ([^ ]+) \[[0-9\/]+\] for ([^ ]+) ([^ ]+) on ([^ ]+)/) { + SetStatus($timestamp, $id, 'kind', "$4 $2 $3") + } else { + if ($msg =~ /^--- (.*) ---$/) { + my $status = $1; + if ($status eq 'Build starts') {$id =~ /^.+?-(.+)$/; SetStatus($timestamp, $id, 'kind', "($1 rsync) -")} + elsif ($status eq 'Compiler build started') {SetStatus($timestamp, $id, 'compile', 'Busy')} + elsif ($status eq 'Compiler build successfull') {SetStatus($timestamp, $id, 'compile', 'Built')} + elsif ($status eq 'Library build started') {SetStatus($timestamp, $id, 'library', 'Busy')} + elsif ($status eq 'Library build successfull') {SetStatus($timestamp, $id, 'library', 'Built')} + elsif ($status eq 'Generated c source files match bootstrap') {SetStatus($timestamp, $id, 'csource', 'Unchanged')} + elsif ($status eq 'Generated c source files differ from bootstrap') {SetStatus($timestamp, $id, 'csource', 'Changed')} + elsif ($status eq 'Generated code unchanged') {SetStatus($timestamp, $id, 'binary', 'Unchanged')} + elsif ($status eq 'Generated code changed') {SetStatus($timestamp, $id, 'binary', 'Changed')} + elsif ($status eq 'Confidence tests started') {SetStatus($timestamp, $id, 'tests', 'Busy')} + elsif ($status eq 'Confidence tests passed') {SetStatus($timestamp, $id, 'tests', 'Passed')} + elsif ($status eq 'Build ends') { + my %status = %{$BuildStatus{$id}}; + foreach my $sec (keys %status) { + if ($status{$sec} eq 'Busy') {$BuildStatus{$id}->{$sec} = 'Failed'} + if ($status{$sec} eq 'Pending') {$BuildStatus{$id}->{$sec} = '-'} + } + WriteStatus($timestamp, $id) + } + } + } +} + + +sub Log {my ($log, $id, $msg) = @_; + my $timestamp = strftime("%Y/%m/%d %H.%M.%S", localtime); + $msg =~ s/[\r\n]*$//; # Remove trailing newline characters + UpdateStatus($timestamp, $id, $msg); + substr($timestamp,0,11) = ''; # Remove date part as not needed in logs + if ($LogToScreenToo) {print "($id) $timestamp $msg\n"} + print $GlobalLog "$timestamp ($id) $msg\n"; + if (defined $log) {print $log "$timestamp $msg\n"} +} + + +sub DoLogged {my ($log, $id, $cmd) = @_; + Log $log, $id, "Executing '$cmd'."; + open(my $pipe, "$cmd 2>&1 |") // die "Could not open pipe from command $cmd."; + while (<$pipe>) {Log $log, $id, $_} + close($pipe); +} + + + +sub SendFile {my ($log, $id, $dest, $port, $filename, $content) = @_; + Log $log, $id, "SendFile($dest,$port,$filename)"; + open PIPE, "|ssh -p $port $dest 'cat >$filename'"; + $content =~ s/\n/\r\n/g; # Unix to MS line ends. + print PIPE $content; + close PIPE; +} + + + +## my %machines = ( +## "cygwin32" => ['5932', 'dave@wax', 'sh build-oberon.sh n oberon/cygwin/voc gcc ' . $branch], +## "cygwin64" => ['5932', 'dave@wax', 'sh start64.sh \'sh build-oberon.sh n oberon/cygwin/voc gcc ' . $branch . '\''], +## "mingw32" => ['5932', 'dave@wax', 'sh build-oberon.sh n oberon/mingw/voc i686-w64-mingw32-gcc ' . $branch], +## "mingw64" => ['5932', 'dave@wax', 'sh start64.sh \'sh build-oberon.sh n oberon/mingw/voc x86_64-w64-mingw32-gcc ' . $branch . '\''], +## "ce64" => ['5922', 'obe@www', 'sh build-oberon.sh sudo vishap/voc gcc ' . $branch], +## ); + + + + +my @Builds = ( + ['pi', 'pi@pie', '22', '', 'cd vishaps/$id && make full'], + ['android', 'and', '8022', '', 'cd vishaps/$id && CC=gcc make full'], + ['lub32', 'vim-lub32', '22', '', 'cd vishaps/$id && make full'], + ['lub32cl', 'vim-lub32', '22', '', 'cd vishaps/$id && CC=clang make full'], + ['obs32', 'vim-obs32', '22', '', 'cd vishaps/$id && make full'], + ['cyg32', 'wax', '5932', '', 'cd vishaps/$id && make full'], + ['ming32', 'wax', '5932', '', 'cd vishaps/$id && CC=i686-w64-mingw32-gcc make full'], + ['cyg64', 'wax', '5932', '', 'sh start64.sh \'cd vishaps/$id && make full\''], + ['ming64', 'wax', '5932', '', 'sh start64.sh \'cd vishaps/$id && CC=x86_64-w64-mingw32-gcc make full\''], + ['lub64', 'vim', '22', '', 'cd vishaps/$id && make full'], + ['osu64', 'vim-osu64', '22', '', 'cd vishaps/$id && make full'], + ['fed64', 'vim-fed64', '22', '', 'cd vishaps/$id && make full'], + ['fbs64', 'githubhook', '22', '', 'cd vishaps/$id && make full'], + ['ce64', 'vim-ce64', '22', '', 'cd vishaps/$id && make full'], + ['darwin', 'dcb', '22', '', 'cd vishaps/$id && make full'], + ['win32', 'vim-win64', '22', 'x86', 'cmd /c x86.cmd'], + ['win64', 'vim-win64', '22', 'x64', 'cmd /c x64.cmd'] +); + +sub Prepare {my ($log, $id, $dest, $port, $preparation) = @_; + SendFile($log, $id, $dest, $port, "$preparation.cmd", <<"--END--MS--"); +call \"C:\\Program Files (x86)\\Microsoft Visual C++ Build Tools\\vcbuildtools.bat\" $preparation +cd %HOME%\\vishaps\\$id +make full +--END--MS-- +} + +sub BuildBranch {my ($branch) = @_; + Log undef, $branch, "$branch branch build triggered."; + + # Obtain a clean clone of vishaps + DoLogged undef, $branch, "rm -rf $home/voc"; + DoLogged undef, $branch, "cd $home && git clone -b $branch --single-branch https://github.com/vishaps/voc"; + + # Start each build in turn + + unlink glob "$home/logs/$branch-*"; + for my $build (@Builds) { + my ($id, $dest, $port, $preparation, $command) = @$build; + my $rsynccompress = "-z"; if ($id eq "android") {$rsynccompress = "-zz"} + $id = "$branch-$id"; + my $child = fork; if (not defined $child) {die "Fork failed.";} + if ($child) {print "Opened process $child for build $id at $dest.\n"} + else { + # child process + my $log; + open $log, ">$home/logs/$id.log"; + Log $log, $id, "--- Build starts ---"; + Log $log, $id, strftime("%Y/%m/%d ", localtime) . "Build $id starting at $dest."; + DoLogged $log, $id, "ssh -p $port $dest mkdir -p vishaps/$id"; + DoLogged $log, $id, "rsync -r $rsynccompress --delete -e 'ssh -p $port' $home/voc/ $dest:vishaps/$id/"; + if ($preparation ne '') {Prepare($log, $id, $dest, $port, $preparation)} + $command =~ s/\$id /$id /g; + DoLogged $log, $id, "ssh -p $port $dest \"$command\""; + Log $log, $id, "Build $id for branch $branch at $dest completed."; + Log $log, $id, "--- Build ends ---"; + close $log; + exit; + } + } + + Log undef, $branch, "$branch branch: all builds started."; +} + + + +Log undef, 'runbuilds', strftime("%Y/%m/%d ", localtime) . "runbuilds starting."; +while (my $branch = FindTriggeredBuild()) {BuildBranch($branch)} +Log undef, 'runbuilds', "No more build triggers found, runbuilds complete."; +close $GlobalLog; + diff --git a/src/tools/autobuild/server.pl b/src/tools/autobuild/server.pl new file mode 100755 index 00000000..f076a6c5 --- /dev/null +++ b/src/tools/autobuild/server.pl @@ -0,0 +1,163 @@ +#!/usr/bin/perl +use strict; +use warnings; +use HTTP::Daemon; +use HTTP::Status; +use HTTP::Response; +use HTTP::Date qw(time2str); +use LWP::MediaTypes qw(guess_media_type); +use Digest::SHA qw(hmac_sha1_hex); +use Data::Dumper; +use JSON; +use sigtrap qw(die INT QUIT); + +my $home = "/home/dave/vishap-build"; +my $criggleplop = "splurd crungle splonge."; + +$| = 1; +$SIG{CHLD} = 'IGNORE'; + +my $PORT = 9000; +my $server = HTTP::Daemon->new(Family => AF_INET, LocalPort => $PORT, ReuseAddr => 1); +die "Cannot setup server" unless $server; +print "[$$: Accepting clients at http://localhost:$PORT/]\n"; + +while (my $client = $server->accept) { + (my $pid = fork()) // die("Couldn't fork."); + if ($pid) {$client->close; undef $client} + else {ServeRequests($client); $client->close; undef $client; exit} +} +print "$$: server->accept failed. Exiting.\n"; +exit; + + +sub StartBuilds {my ($branch) = @_; + print " -- start builds for branch $branch.\n"; + open TRIGGER, ">trigger-$branch"; print TRIGGER "trigger.\n"; close TRIGGER; + my $running = 0; + if (open PID, "; close PID} + if (!$running) { + my $child = fork; + if ($child) { + # This is the parent. We get to know the child PID, write it out. + print "Started build, pid $child.\n"; + open PID, ">pid"; print PID "$child.\n"; close PID; + } else { + # This is the child, we actually run all triggered builds. + # print "Debug: About to run perl >$home/runbuilds.log ...\n"; + exec "perl $home/runbuilds.pl >$home/runbuilds.log"; + exit; # Shouldn't get here + } + } +} + + +sub decodehook {my ($hook) = @_; + my %modifiedfiles = (); + my %commitauthors = (); + my $buildrequired = 0; + + my $commits = $hook->{commits}; + for my $commit (@$commits) { + my $committer = $commit->{committer}; + $commitauthors{$committer->{username}}++; + my $modified = $commit->{modified}; + for my $modfile (@$modified) { + $modifiedfiles{$modfile}++; + if ($modfile !~ m/\.(md|svg)$/i) {$buildrequired = 1;} + } + } + my $pusher = $hook->{pusher}; + my $repository = $hook->{repository}; + my $branch = $hook->{ref}; $branch =~ s'^.*\/''; + print "Repository: $repository->{name}, branch: $branch.\n"; + print "Commit authors: " . join(", ", keys %commitauthors) . ".\n"; + print "Pusher: " . $pusher->{name} . "\n"; + print "Files modified: " . join(", ", keys %modifiedfiles) . ".\n"; + print "Build " . ($buildrequired ? '' : 'not') . " required.\n"; + if ($buildrequired) {StartBuilds($branch)} +} + + +sub SendFile {my ($client, $file) = @_; + my $CRLF = "\r\n"; + local(*F); + sysopen(F, $file, 0); + binmode(F); + my($ct,$ce) = guess_media_type($file); + my($size,$mtime) = (stat $file)[7,9]; + $client->send_basic_header; + print $client "Content-Encoding: $ce$CRLF" if $ce; + print $client "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; + print $client "Accept-Ranges: bytes$CRLF"; + print $client "Content-Length: $size$CRLF" if $size; + print $client "Cache-Control: no-cache, no-store, must-revalidate, max-age=0$CRLF"; + print $client "Pragma: no-cache$CRLF"; + print $client "Expires: Wed, 11 Jan 1984 05:00:00 GMT$CRLF"; + print $client "Content-Type: $ct$CRLF"; + print $client $CRLF; + $client->send_file(\*F) unless $client->head_request; +} + + +sub VishapStatus {my ($client) = @_; + print " -- generate status.\n"; + system "perl makesvg.pl"; # Construct an up-to-date status file + SendFile($client, "vishaps-status.svg"); +} + +sub LogFileResponse {my ($client, $path) = @_; + if (-f "logs/$path.log") { + print " -- send log for build $path.\n"; + SendFile($client, "logs/$path.log") + } else { + print " -- respond forbidden: no log for $path.\n"; + $client->send_error(RC_FORBIDDEN) + } +} + + +sub ServeRequests {my ($client) = @_; + $client->autoflush(1); + while (my $request = $client->get_request) { + if ($request->method eq 'GET') { + + my $host = $request->headers->{host}; + my $uri = $request->uri; + $uri =~ s/^\///; + $uri =~ s/^githubhook\///; + + print "Request: $uri\n"; + + if ($uri eq 'vishaps-status.svg') {VishapStatus($client)} + elsif ($uri eq 'vishaps-trigger') { + $client->send_file_response("response.html"); + StartBuilds("master"); + } + elsif ($uri =~ /^vishaps-trigger\/([-_a-z0-9]+)/i) { + $client->send_file_response("response.html"); + StartBuilds($1); + } + else {LogFileResponse($client, $uri)} + + } elsif ($request->method eq 'POST') { + + $client->send_file_response("response.html"); + my $event = $request->headers->{'x-github-event'}; + my $githubsig = substr($request->headers->{'x-hub-signature'}, 5); + my $mysig = hmac_sha1_hex($request->content, $criggleplop); + print "Github POST: $event, mysig $mysig, githubsig: $githubsig.\n"; + if (($event eq "push") && ($mysig eq $githubsig)) { + my $content = $request->content; + $content =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; # Unescape %xx sequences. + decodehook(JSON::decode_json(substr($content,8))); + } + + } else { + + print "Request method $request->method forbidden.\n"; + $client->send_error(RC_FORBIDDEN) + + } + } +} diff --git a/src/tools/beautifier/makefile b/src/tools/beautifier/makefile new file mode 100644 index 00000000..2108b547 --- /dev/null +++ b/src/tools/beautifier/makefile @@ -0,0 +1,4 @@ +VOC = /opt/voc/bin/voc + +all: + $(VOC) -m vbeautify.Mod diff --git a/src/tools/beautifier/vbeautify.Mod b/src/tools/beautifier/vbeautify.Mod new file mode 100644 index 00000000..ef38edba --- /dev/null +++ b/src/tools/beautifier/vbeautify.Mod @@ -0,0 +1,758 @@ +MODULE vbeautify; + +IMPORT Oberon, Out, Strings, Texts; + +CONST + Tab = 09X; LF = 0DX; + SK = 0; (* Section - Keyword *) + IK = 1; (* Indent Keyword *) + IEK = 2; (* Indent ending Keyword *) + IBK = 3; (* Indent breaking Keyword *) + NK = -1; (* No keyword -- used when end of text is reached*) + TwoCharOp = 0; SpcAfterOnly = 1; SpcAllOps = 2; + +TYPE + Keyword = RECORD + word: ARRAY 10 OF CHAR; + class: SHORTINT + END; + +VAR + w: Texts.Writer; + b: Texts.Buffer; + fC, lC: ARRAY 23 OF INTEGER; + hashT: ARRAY 51 OF Keyword; + +PROCEDURE (VAR k: Keyword) Init (s: ARRAY (*10*) OF CHAR; class: SHORTINT); +BEGIN + COPY(s, k.word); + k.class := class +END Init; + +PROCEDURE passComments (VAR s: Texts.Reader); + VAR cmt: INTEGER; ch: CHAR; +BEGIN + cmt := 1; + WHILE ~s.eot & (cmt > 0) DO + Texts.Read(s, ch); + WHILE ch = "(" DO Texts.Read(s, ch); IF ch = "*" THEN INC(cmt) END END; (* Nested comment opening *) + WHILE ch = "*" DO Texts.Read(s, ch); IF ch = ")" THEN DEC(cmt) END END (* comment closing *) + END +END passComments; + +PROCEDURE passProcHead (VAR s: Texts.Scanner; bText: Texts.Text; VAR noProc: BOOLEAN; VAR procName: ARRAY OF CHAR); + VAR ch: CHAR; +BEGIN + noProc := FALSE; + Texts.Scan(s); + (* --- Type-bound procedures can have Receiver *) + WHILE ~s.eot & (s.class = Texts.Char) & (s.c = Texts.ElemChar) DO Texts.Scan(s) END; + IF (s.class = Texts.Char) & (s.c = "(") THEN + REPEAT Texts.Scan(s) UNTIL (s.class = Texts.Char) & (s.c = ")") OR s.eot; + Texts.Scan(s) + END; + WHILE ~s.eot & (s.class = Texts.Char) & (s.c = Texts.ElemChar) DO Texts.Scan(s) END; + (* --- Check name of procedure *) + IF s.class # Texts.Name THEN noProc := TRUE; RETURN END; + COPY(s.s, procName); + (* --- Formal parameters *) + Texts.OpenScanner(s, bText, Texts.Pos(s) - 1); + Texts.Read(s, ch); + WHILE ~s.eot & (ch # ";") DO + IF ch = "(" THEN + WHILE ~s.eot & (ch # ")") DO Texts.Read(s, ch) END + ELSE + Texts.Read(s, ch) + END + END +END passProcHead; +(* +PROCEDURE MarkedViewer (): TextFrames.Frame; + VAR v: Viewers.Viewer; +BEGIN + v := Oberon.MarkedViewer(); + IF (v # NIL) & (v.dsc # NIL) & (v.dsc.next IS TextFrames.Frame) THEN + RETURN v.dsc.next(TextFrames.Frame) + ELSE + RETURN NIL + END +END MarkedViewer; +*) +PROCEDURE NoNotify (t: Texts.Text; op: INTEGER; beg, end: LONGINT); END NoNotify; + +PROCEDURE ParseCmdLine (VAR bText: Texts.Text; VAR oldNotifier: Texts.Notifier); +VAR + beg, end, time: LONGINT; + (*f: TextFrames.Frame;*) + par: Oberon.ParList; + s: Texts.Scanner; + t: Texts.Text; +(* +PROCEDURE OpenText (fileName: ARRAY OF CHAR; VAR t: Texts.Text; VAR f: TextFrames.Frame); + VAR menuF: TextFrames.Frame; v: Viewers.Viewer; x, y: INTEGER; +BEGIN + menuF := TextFrames.NewMenu(fileName, "Edit.Store System.Close"); + t := TextFrames.Text(fileName); + f := TextFrames.NewText(t, 0); + Oberon.AllocateUserViewer(0, x, y); + v := MenuViewers.New(menuF, f, TextFrames.menuH, x, y) +END OpenText; +*) +PROCEDURE OpenText (fileName: ARRAY OF CHAR; VAR t: Texts.Text); +BEGIN + NEW(t); + Texts.Open(t, fileName); + +END OpenText; +BEGIN + oldNotifier := NIL; par := Oberon.Par; + Texts.OpenScanner(s, par.text, par.pos); + Texts.Scan(s); + IF s.class = Texts.Name THEN (* Called by filename *) + (*OpenText(s.s, bText, f)*) + OpenText(s.s, bText) + (* + ELSIF (s.class = Texts.Char) & (s.c = "*") THEN (* Called by selected viewer *) + f := MarkedViewer() + ELSIF (s.class = Texts.Char) & (s.c = "^") THEN (* Called by selection *) + Oberon.GetSelection(t, beg, end, time); + IF time >= 0 THEN (* Selection found *) + Texts.OpenScanner(s, t, beg); Texts.Scan(s); + IF s.class = Texts.Name THEN + OpenText(s.s, bText, f) + END + END + *) (* commented out oberon system specific parts. -- noch *) + END; + (*IF f # NIL THEN + bText := f.text; + oldNotifier := f.text.notify; + bText.notify := NoNotify + ELSE + Out.String("Could not find TextFrames.Frame. Program aborted."); Out.Ln; + HALT(99) + END*) +END ParseCmdLine; +(* +PROCEDURE GetFontsFromText (bText: Texts.Text; VAR expNamFnt, cmtFnt: Fonts.Font); +VAR + r: Texts.Reader; + ch: CHAR; + boldfont, italicfont: ARRAY 32 OF CHAR; + i: INTEGER; +BEGIN + (* --- Get the fontname *) + Texts.OpenReader(r, bText, 0); + Texts.Read(r, ch); + COPY(r.fnt.name, boldfont); + COPY(r.fnt.name, italicfont); + + (* --- Get fonts *) + i := Strings.Pos(".", boldfont, 0); + Strings.Insert("b", i, boldfont); + expNamFnt := Fonts.This(boldfont); + Strings.Insert("i", i, italicfont); + cmtFnt := Fonts.This(italicfont) +END GetFontsFromText; +*) +PROCEDURE UpdateText (bText: Texts.Text; oldNotifier: Texts.Notifier); +BEGIN + IF oldNotifier # NIL THEN + bText.notify := oldNotifier; + bText.notify(bText, Texts.replace, 0, bText.len) + END +END UpdateText; + +PROCEDURE getKeyword (t: Texts.Text; VAR s: Texts.Scanner; section: BOOLEAN): SHORTINT; + VAR i, firstC, lastC: INTEGER; pos: LONGINT; noProc: BOOLEAN; dummy: ARRAY 32 OF CHAR; +BEGIN + WHILE ~s.eot DO + Texts.Scan(s); + IF s.class = Texts.Name THEN + (* --- hash value calculation *) + firstC := ORD(s.s[0]) - ORD('A'); + lastC := ORD(s.s[s.len - 1]) - ORD('A'); + IF (firstC >= 0) & (firstC < 23) & (lastC < 23) & (lastC >= 0) THEN + i := (fC[firstC] + 11 * lC[lastC]) MOD 51; + IF (i # 17) & (i # 35) & (i # 4) & (hashT[i].word = s.s) THEN + RETURN hashT[i].class + ELSIF (i = 35) & (s.nextCh = LF) & (s.s = "VAR") THEN + RETURN IBK + ELSIF (i = 4) & (s.s = "BEGIN") THEN + IF section THEN RETURN IBK ELSE RETURN IK END + ELSIF (i = 17) THEN + passProcHead(s, t, noProc, dummy); + IF ~noProc THEN RETURN hashT[i].class END + END + END + ELSIF (s.class = Texts.Char) THEN + IF (s.c = "|") THEN RETURN IBK END; + IF (s.c = "(") & (s.nextCh = "*") THEN Texts.Scan(s); passComments(s) END + END + END; + RETURN NK +END getKeyword; + +PROCEDURE InsertInd (VAR r: Texts.Reader; VAR s: Texts.Scanner; t: Texts.Text; ind: SHORTINT; decInd: BOOLEAN); +VAR + ch, ch2: CHAR; + lastLF, sPos: LONGINT; + i: INTEGER; +BEGIN + FOR i := 1 TO ind DO Texts.Write(w, Tab) END; + sPos := Texts.Pos(s); + lastLF := - 1; + (* --- Trace reader to position of Scanner *) + WHILE (Texts.Pos(r) + 1 < sPos) & ~r.eot DO + Texts.Read(r, ch); Texts.Read(r, ch2); IF ~r.eot THEN Texts.OpenReader(r, t, Texts.Pos(r) - 1); END; + IF (ch = LF) & (ch2 # LF) & (ind > 0) THEN + lastLF := Texts.Pos(r); + sPos := sPos + ind; + Texts.Copy(w.buf, b); + Texts.Insert(t, lastLF, b); + Texts.OpenReader(r, t, lastLF + ind) + END + END; + Texts.OpenBuf(w.buf); (* Flush buffer *) + Texts.OpenScanner(s, t, sPos); + (* --- Check if we have to move the last line one tab position to the left *) + IF decInd & (lastLF # - 1) THEN + Texts.Delete(t, lastLF, lastLF + 1); + Texts.OpenScanner(s, t, Texts.Pos(s) - 1); + Texts.OpenReader(r, t, Texts.Pos(r) - 1) + END +END InsertInd; + +PROCEDURE IndentCheck (bText: Texts.Text); +VAR + r: Texts.Reader; s: Texts.Scanner; ch: CHAR; ind, i: SHORTINT; pos: LONGINT; section: BOOLEAN; leadStart, trailStart: LONGINT; +BEGIN + (* --- Kill leading and trailing Tabs/Blanks *) + pos := 0; + Texts.OpenReader(r, bText, pos); + Texts.Read(r, ch); + trailStart := 0; + WHILE (~r.eot) DO + IF ch = LF THEN + leadStart := Texts.Pos(r); + Texts.Read(r, ch); + WHILE (ch = " ") OR (ch = Tab) DO Texts.Read(r, ch) END; + pos := Texts.Pos(r) - 1; + Texts.Delete(bText, leadStart, pos); + Texts.OpenReader(r, bText, leadStart + 1) + ELSE + WHILE (ch # LF) & ~r.eot DO + IF (ch = " ") OR (ch = Tab) THEN + IF trailStart = - 1 THEN trailStart := Texts.Pos(r) - 1 END + ELSE + trailStart := - 1 + END; + Texts.Read(r, ch) + END; + IF trailStart > - 1 THEN + pos := Texts.Pos(r) - 1; + Texts.Delete(bText, trailStart, pos); + Texts.OpenReader(r, bText, trailStart + 1); + trailStart := - 1 + END + END + END; + + (* --- Insert correct tabulation *) + Texts.OpenScanner(s, bText, 0); + Texts.OpenReader(r, bText, 0); + Texts.Scan(s); + section := FALSE; + ind := 0; + WHILE ~s.eot & (ind >= 0) DO + i := getKeyword(bText, s, section); + IF i = IK THEN + InsertInd(r, s, bText, ind, FALSE); + INC(ind) + ELSIF i = IEK THEN + InsertInd(r, s, bText, ind, TRUE); + DEC(ind); + IF ind = 0 THEN section := FALSE END + ELSIF i = IBK THEN + InsertInd(r, s, bText, ind, TRUE) + ELSIF i = SK THEN + InsertInd(r, s, bText, ind, section); + IF ~section THEN INC(ind) END; + section := TRUE + END + END +END IndentCheck; +(* +PROCEDURE ChangeFont (bText: Texts.Text; expNamFnt, cmtFnt: Fonts.Font); +VAR + s: Texts.Scanner; ch: CHAR; oPos, pos: LONGINT; exp: BOOLEAN; noExpLine: INTEGER; +BEGIN + pos := 0; noExpLine := -1; + exp := TRUE; + Texts.OpenScanner(s, bText, pos); + WHILE ~s.eot DO + Texts.Scan(s); + oPos := pos; + pos := Texts.Pos(s); + IF (s.class = Texts.Char) & (s.c = "(") & (s.nextCh = "*") THEN (* comment *) + oPos := pos; + Texts.Scan(s); + passComments(s); + pos := Texts.Pos(s); + Texts.ChangeLooks(bText, oPos - 2, pos, {0}, cmtFnt, s.col, s.voff); + Texts.OpenScanner(s, bText, pos) + ELSIF (s.class = Texts.Char) & ((s.c = "=") OR (s.c = ":")) THEN + noExpLine := s.line; + ELSIF (s.class = Texts.Char) & (s.c = ";") THEN + noExpLine := -1; + ELSIF (s.class = Texts.Name) THEN + IF (s.s = "BEGIN") THEN exp := FALSE + ELSIF (s.s = "PROCEDURE") THEN exp := TRUE + ELSIF exp & (noExpLine # s.line) & (s.nextCh = " ") THEN (* probably spaces between name and '*' *) + Texts.Read(s, ch); + WHILE ~s.eot & (ch = " ") DO Texts.Read(s, ch) END; + IF (ch = "*") OR (ch = "-") THEN + Texts.Delete(bText, pos - 1, Texts.Pos(s) - 1); + Texts.ChangeLooks(bText, oPos, pos, {0}, expNamFnt, s.col, s.voff); + Texts.OpenScanner(s, bText, pos) + ELSE (* rewind *) + Texts.OpenScanner(s, bText, Texts.Pos(s) - 1) + END + ELSIF exp & (noExpLine # s.line) & ((s.nextCh = "*") OR (s.nextCh = "-")) THEN (* "regular" exported name *) + Texts.ChangeLooks(bText, oPos - 1, pos, {0}, expNamFnt, s.col, s.voff); + Texts.OpenScanner(s, bText, pos) + END + END + END +END ChangeFont; +*) +PROCEDURE Format*; +VAR + bText: Texts.Text; oldNotifier: Texts.Notifier;(* expNamFnt, cmtFnt: Fonts.Font;*) +BEGIN + bText := NIL; oldNotifier := NIL; + ParseCmdLine(bText, oldNotifier); + IF bText = NIL THEN + (*Out.String("Usage: Beautifier.Format * | ^ | Filename.Mod"); Out.Ln*) + Out.String("Usage: vbeautify Filename.Mod"); Out.Ln + ELSE + (*GetFontsFromText(bText, expNamFnt, cmtFnt); + FoldElems.ExpandAll(bText, 0, TRUE); + ChangeFont(bText, expNamFnt, cmtFnt);*) + IndentCheck(bText); + (*FoldElems.CollapseAll(bText, {FoldElems.tempLeft});*) + UpdateText(bText, oldNotifier) + END +END Format; + + +PROCEDURE RemSemicolons (bText: Texts.Text); + VAR s: Texts.Scanner; lastSC, pos: LONGINT; eCount: INTEGER; err: BOOLEAN; procName: ARRAY 24 OF CHAR; + i: INTEGER; +BEGIN + lastSC := - 1; eCount := 0; + Texts.OpenScanner(s, bText, 0); + Texts.Scan(s); + WHILE ~s.eot DO + IF (s.class = Texts.Char) THEN + IF (s.c = ';') THEN + lastSC := Texts.Pos(s) - 1; + Texts.Scan(s) + END + END; + IF (s.c = "(") & (s.nextCh = "*") THEN + Texts.Scan(s); + passComments(s); Texts.Scan(s) + END; + + IF (s.class = Texts.Name) THEN + (* --- delete semicolons *) + IF (lastSC # - 1) & (eCount > 0) & ((s.s = "END") OR (s.s = "ELSE") OR (s.s = "ELSIF") OR (s.s = "UNTIL")) THEN + pos := Texts.Pos(s); + Texts.Delete(bText, lastSC - 1, lastSC); + Texts.OpenScanner(s, bText, pos - 1) + END; + IF (s.s = "IF") OR (s.s = "WHILE") OR (s.s = "FOR") OR (s.s = "RECORD") OR (s.s = "WITH") OR (s.s = "LOOP") OR (s.s = "CASE") THEN + INC(eCount) + ELSIF (s.s = "END") THEN + DEC(eCount) + END; + IF (s.s = "PROCEDURE") THEN + passProcHead(s, bText, err, procName); + IF ~err THEN INC(eCount) END + END + END; + lastSC := - 1; + Texts.Scan(s) + END +END RemSemicolons; + +PROCEDURE RemoveSemicolons*; + VAR bText: Texts.Text; oldNotifier: Texts.Notifier; +BEGIN + ParseCmdLine(bText, oldNotifier); + IF bText = NIL THEN + Out.String("Usage: Beautifier.RemSemicolons * | ^ | Filename.Mod"); Out.Ln + ELSE + (*FoldElems.ExpandAll(bText, 0, TRUE);*) + RemSemicolons(bText); + (*FoldElems.CollapseAll(bText, {FoldElems.tempLeft});*) + UpdateText(bText, oldNotifier) + END +END RemoveSemicolons; + + +PROCEDURE FoldProcedures (bText: Texts.Text); + VAR s: Texts.Scanner; start, end: LONGINT; procName: ARRAY 24 OF CHAR; err: BOOLEAN; ch: CHAR; (*e: FoldElems.Elem;*) te: Texts.Elem; +BEGIN + Texts.OpenScanner(s, bText, 0); + Texts.Scan(s); + WHILE ~s.eot DO + IF(s.class = Texts.Name) & (s.s = "PROCEDURE") THEN (* FoldProcedures *) + passProcHead(s, bText, err, procName); + IF ~err THEN + start := Texts.Pos(s); + (* --- Read to end of line *) + Texts.Read(s, ch); + WHILE (ch # LF) & ((s.elem = NIL)(* OR ~(s.elem IS FoldElems.Elem)*)) DO Texts.Read(s, ch) END; + te := s.elem; + + (* --- find end of procedure *) + Texts.OpenScanner(s, bText, start); + Texts.Scan(s); + end := - 1; + WHILE ~s.eot & (end = - 1) DO + IF (s.class = Texts.Name) & (s.s = "END") THEN Texts.Scan(s); + IF (s.class = Texts.Name) & (s.s = procName) THEN end := Texts.Pos(s) END + ELSE + Texts.Scan(s) + END + END; + + (* --- Check, whether Procedure has not yet been folded *) + (*IF (te = NIL) OR ~(te IS FoldElems.Elem) THEN + (* --- Insert FoldElems *) + NEW(e); e.mode := FoldElems.expRight; e.W := FoldElems.elemW; e.H := FoldElems.elemH; + e.handle := FoldElems.FoldHandler; e.visible := TRUE; Texts.WriteElem(w, e); Texts.Insert(bText, end, w.buf); + NEW(e); e.mode := FoldElems.expLeft; e.W := FoldElems.elemW; e.H := FoldElems.elemH; + e.handle := FoldElems.FoldHandler; NEW(e.hidden); Texts.OpenBuf(e.hidden); e.visible := TRUE; + Texts.WriteElem(w, e); Texts.Insert(bText, start, w.buf); + Texts.OpenScanner(s, bText, end) + END*) + END + ELSIF (s.class = Texts.Name) & (s.s = "BEGIN") THEN (* Fold Module-Body *) + start := Texts.Pos(s) - 1; + Texts.OpenReader(s, bText, start); + (* --- Read to end of line *) + Texts.Read(s, ch); + WHILE (ch # LF) & ((s.elem = NIL)(* OR ~(s.elem IS FoldElems.Elem)*)) DO Texts.Read(s, ch) END; + te := s.elem; + + (* --- Find end of Module *) + WHILE ~s.eot DO + Texts.Scan(s); + WHILE ~s.eot & (s.class = Texts.Name) & (s.s = "END") DO + end := Texts.Pos(s) - 5; + Texts.Scan(s) + END + END; + (* --- Check, whether Procedure has not yet been folded *) + (*IF (te = NIL) OR ~(te IS FoldElems.Elem) THEN + (* --- Insert FoldElems *) + NEW(e); e.mode := FoldElems.expRight; e.W := FoldElems.elemW; e.H := FoldElems.elemH; + e.handle := FoldElems.FoldHandler; e.visible := TRUE; Texts.WriteElem(w, e); Texts.Insert(bText, end, w.buf); + NEW(e); e.mode := FoldElems.expLeft; e.W := FoldElems.elemW; e.H := FoldElems.elemH; + e.handle := FoldElems.FoldHandler; NEW(e.hidden); Texts.OpenBuf(e.hidden); e.visible := TRUE; + Texts.WriteElem(w, e); Texts.Insert(bText, start, w.buf); + Texts.OpenScanner(s, bText, end) + END*) + ELSIF (s.class = Texts.Char) & (s.c = "(") & (s.nextCh = "*") THEN + passComments(s) + END; + Texts.Scan(s) + END +END FoldProcedures; + +PROCEDURE FoldProc*; + VAR bText: Texts.Text; oldNotifier: Texts.Notifier; +BEGIN + ParseCmdLine(bText, oldNotifier); + IF bText = NIL THEN + Out.String("Usage: Beautifier.FoldProc * | ^ | Filename.Mod"); Out.Ln + ELSE + (*FoldElems.ExpandAll(bText, 0, TRUE);*) + FoldProcedures(bText); + (*FoldElems.CollapseAll(bText, {FoldElems.tempLeft});*) + UpdateText(bText, oldNotifier) + END +END FoldProc; + +PROCEDURE ReadOperator (VAR r: Texts.Reader; VAR buf: ARRAY OF CHAR; VAR opFlags: SET); + VAR i, cmt: INTEGER; ch, ech: CHAR; opFound: BOOLEAN; +BEGIN + opFound := FALSE; + EXCL(opFlags, TwoCharOp); EXCL(opFlags, SpcAfterOnly); + + Texts.Read(r, ch); + WHILE ~r.eot & ~opFound DO + (* --- Move buffer content *) + FOR i := 0 TO 7 DO buf[i] := buf[i + 1] END; + buf[8] := ch; + + (* --- Leave out comments *) + WHILE ~r.eot & (ch = "(") DO + Texts.Read(r, ch); + IF (ch = "*") THEN + passComments(r); Texts.Read(r, ch) + END + END; + + (* --- Leave out String and Character constants *) + IF (ch = "'") OR (ch = '"') THEN + REPEAT + Texts.Read(r, ech) + UNTIL r.eot OR (ch = ech) + END; + + (* --- Check for spcAllOps & Spacing of parameter lists *) + IF (buf = "PROCEDURE") THEN + EXCL(opFlags, SpcAllOps) + + END; + IF (buf[4] = "B") & (buf[5] = "E") & (buf[6] = "G") & (buf[7] = "I") & (buf[8] = "N") THEN INCL(opFlags, SpcAllOps) END; + + (* --- Check for Operators *) + IF (ch = "<") OR (ch = ">") OR (ch = ":") THEN + opFound := TRUE; + INCL(opFlags, TwoCharOp) + ELSIF (ch = "+") OR ((SpcAllOps IN opFlags) & ((ch = "-") OR (ch = "*")) ) OR (ch = "/") OR (ch = "=") OR (ch = "#") OR (ch = "&") THEN + opFound := TRUE + ELSIF (ch = ";") OR (ch = ",") THEN + opFound := TRUE; + INCL(opFlags, SpcAfterOnly) + END; + + Texts.Read(r, ch) + END; + + IF opFound THEN + FOR i := 0 TO 7 DO buf[i] := buf[i + 1] END; + buf[8] := ch; + IF (TwoCharOp IN opFlags) & (ch = "=") THEN + FOR i := 0 TO 7 DO buf[i] := buf[i + 1] END; + Texts.Read(r, ch); buf[8] := ch + ELSE + EXCL(opFlags, TwoCharOp); + IF buf[7] = ":" THEN INCL(opFlags, SpcAfterOnly) END + END + END +END ReadOperator; + +PROCEDURE SpaceOperators (bText: Texts.Text); + VAR r: Texts.Reader; opFlags: SET; buffer: ARRAY 10 OF CHAR; ch: CHAR; pos: LONGINT; + +PROCEDURE InsertSpace (pos: LONGINT); +BEGIN + Texts.Write(w, " "); + Texts.Insert(bText, pos, w.buf); + Texts.OpenReader(r, bText, pos) +END InsertSpace; + +BEGIN + Texts.OpenReader(r, bText, 0); + COPY(" ", buffer); + ReadOperator(r, buffer, opFlags); + WHILE ~r.eot DO + pos := Texts.Pos(r); + IF TwoCharOp IN opFlags THEN + IF (buffer[8] # " ") THEN InsertSpace(pos - 1) END; + IF (buffer[5] # " ") THEN InsertSpace(pos - 3) END + ELSE + IF SpcAfterOnly IN opFlags THEN + IF (buffer[8] # " ") & (buffer[8] # LF) THEN InsertSpace(pos - 1) END + ELSE + IF (buffer[8] # " ") THEN InsertSpace(pos - 1) END; + IF (buffer[6] # " ") THEN InsertSpace(pos - 2) END + END + END; + ReadOperator(r, buffer, opFlags) + END +END SpaceOperators; + +PROCEDURE SpaceFormParms (bText: Texts.Text); + VAR s: Texts.Scanner; r: Texts.Reader; ch: CHAR; +BEGIN + Texts.OpenScanner(s, bText, 0); + Texts.Scan(s); + WHILE ~s.eot DO + IF (s.class = Texts.Name) & (s.s = "PROCEDURE") THEN + Texts.OpenReader(r, bText, Texts.Pos(s) - 1); + Texts.Read(r, ch); + (* --- Search through the Procedure Heading *) + WHILE ~r.eot & (ch # ";") DO + IF (ch = "(") THEN + (* --- Parameterlist found *) + Texts.OpenReader(r, bText, Texts.Pos(r) - 2); + Texts.Read(r, ch); + IF ch # " " THEN + (* --- Insert space *) + Texts.Write(w, ' '); + Texts.Insert(bText, Texts.Pos(r) , w.buf); + Texts.OpenReader(r, bText, Texts.Pos(r)) + END; + (* --- Search for end of parameterlist *) + WHILE ~r.eot & (ch # ")") DO Texts.Read(r, ch) END; + Texts.OpenScanner(s, bText, Texts.Pos(s)) + END; + Texts.Read(r, ch) + END + END; + Texts.Scan(s) + END +END SpaceFormParms; + +PROCEDURE RemSpaces (bText: Texts.Text); + VAR r: Texts.Reader; linStart: BOOLEAN; ch, ech: CHAR; start, end: LONGINT; +BEGIN + linStart := TRUE; + Texts.OpenReader(r, bText, 0); + Texts.Read(r, ch); + WHILE ~r.eot DO + IF ch = LF THEN + linStart := TRUE + ELSIF ch # " " THEN + linStart := FALSE; + (* --- Pass by comments *) + WHILE ~r.eot & (ch = "(") DO + Texts.Read(r, ch); + IF ch = "*" THEN passComments(r) END + END; + + (* --- Pass by string & character constants *) + IF (ch = "'") OR (ch = '"') THEN + ech := ch; + REPEAT Texts.Read(r, ch) UNTIL r.eot OR (ch = ech) + END + ELSIF ~linStart THEN + start := Texts.Pos(r); + REPEAT Texts.Read(r, ch) UNTIL r.eot OR (ch # " "); + end := Texts.Pos(r); + IF (end - start) > 1THEN + Texts.Delete(bText, start, end - 1) + END; + Texts.OpenReader(r, bText, start) + END; + Texts.Read(r, ch) + END +END RemSpaces; + +PROCEDURE SpaceOps*; + VAR bText: Texts.Text; oldNotifier: Texts.Notifier; +BEGIN + ParseCmdLine(bText, oldNotifier); + IF bText = NIL THEN + Out.String("Usage: Beautifier.SpaceOps * | ^ | Filename.Mod"); Out.Ln + ELSE + (*FoldElems.ExpandAll(bText, 0, TRUE);*) + SpaceOperators(bText); + SpaceFormParms(bText); + RemSpaces(bText); + (*FoldElems.CollapseAll(bText, {FoldElems.tempLeft});*) + UpdateText(bText, oldNotifier) + END +END SpaceOps; + +PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR); + VAR R : Texts.Reader; + ch : CHAR; + i : LONGINT; +BEGIN + COPY("", string); + Texts.OpenReader(R, T, 0); + i := 0; + WHILE Texts.Pos(R) < T.len DO + Texts.Read(R, ch); + IF ch # 0DX THEN string[i] := ch ELSE string[i] := 0AX END; + INC(i); + END; + (*string[i] := 0X;*) +END TextToString; + +PROCEDURE DumpText(VAR t: Texts.Text); +VAR s : POINTER TO ARRAY OF CHAR; +BEGIN + NEW(s, t.len + 1); + COPY("", s^); + TextToString(t, s^); + Out.String(s^); Out.Ln; +END DumpText; + +PROCEDURE Beautify*; + VAR bText: Texts.Text; oldNotifier: Texts.Notifier; (*expNamFnt, cmtFnt: Fonts.Font;*) +BEGIN + ParseCmdLine(bText, oldNotifier); + IF bText = NIL THEN + (*Out.String("Usage: Beautifier.SpaceOps * | ^ | Filename.Mod"); Out.Ln*) + Out.String("Usage: vbeautify Filename.Mod"); Out.Ln + ELSE + (*GetFontsFromText(bText, expNamFnt, cmtFnt); + FoldElems.ExpandAll(bText, 0, TRUE); + ChangeFont(bText, expNamFnt, cmtFnt);*) + IndentCheck(bText); + RemSemicolons(bText); + FoldProcedures(bText); + SpaceOperators(bText); + SpaceFormParms(bText); + (*FoldElems.CollapseAll(bText, {FoldElems.tempLeft});*) + UpdateText(bText, oldNotifier); + (*Texts.CloseAscii(bText, 'test');*) + DumpText(bText) + END +END Beautify; + +PROCEDURE InitHashTable; + VAR i: INTEGER; +BEGIN + (* --- empty the Character Functions *) + FOR i := 0 TO 22 DO + fC[i] := 0; + lC[i] := 0 + END; + (* --- empty Hash-Table *) + FOR i := 0 TO 50 DO + COPY("", hashT[i].word) + END + (* --- Set Character Functions *) ; + fC[1] := 0; fC[2] := 1; fC[4] := 2; fC[5] := 3; fC[8] := 4; fC[11] := 5; fC[15] := 6; fC[17] := 7; + fC[20] := 8; fC[21] := 9; fC[22] := 10; + lC[3] := 0; lC[4] := 1; lC[5] := 2; lC[7] := 3; lC[11] := 4; lC[13] := 5; lC[15] := 6; lC[17] := 7; + lC[19] := 8; + (* --- Put Keywords into hashtable *) + hashT[1].Init("UNTIL", IEK); + hashT[2].Init("END", IEK); + hashT[4].Init("BEGIN", IK); (* only if ~section , else BEGIN is IBK *) + hashT[7].Init("RECORD", IK); + hashT[11].Init("TYPE", SK); + hashT[12].Init("CASE", IK); + hashT[13].Init("ELSE", IBK); + hashT[17].Init("PROCEDURE", SK); (* only if not a type definition *) + hashT[20].Init("LOOP", IK); + hashT[21].Init("WHILE", IK); + hashT[24].Init("ELSIF", IBK); + hashT[26].Init("IF", IK); + hashT[29].Init("FOR", IK); + hashT[35].Init("VAR", IBK); (* only if nextCh = LF *) + hashT[38].Init("CONST", SK); + hashT[41].Init("IMPORT", SK); + hashT[43].Init("WITH", IK); + hashT[44].Init("REPEAT", IK) + +END InitHashTable; + +BEGIN + Texts.OpenWriter(w); + NEW(b); + Texts.OpenBuf(b); + InitHashTable; + Beautify +END vbeautify. diff --git a/src/tools/browser/BrowserCmd.Mod b/src/tools/browser/BrowserCmd.Mod index 323181c5..e4ffe88f 100644 --- a/src/tools/browser/BrowserCmd.Mod +++ b/src/tools/browser/BrowserCmd.Mod @@ -1,42 +1,32 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line version jt 4.4.95 *) - IMPORT + IMPORT OPM, OPS, OPT, OPV, - Texts := Texts0, Console, Args; + Texts, Strings, Files, Out, + Oberon, Modules, SYSTEM, Configuration; CONST OptionChar = "-"; - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; Comp = 15; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* symbol file items *) - Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; - Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; - Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; VAR W: Texts.Writer; option: CHAR; PROCEDURE Ws(s: ARRAY OF CHAR); BEGIN Texts.WriteString(W, s) END Ws; - PROCEDURE Wch(ch: CHAR); BEGIN Texts.Write(W, ch) END Wch; - PROCEDURE Wi(i: LONGINT); BEGIN Texts.WriteInt(W, i, 0) END Wi; - PROCEDURE Wln; BEGIN Texts.WriteLn(W) END Wln; + PROCEDURE Wc(ch: CHAR); BEGIN Texts.Write(W, ch) END Wc; + PROCEDURE Wi(i: SYSTEM.INT64); BEGIN Texts.WriteInt(W, i, 0) END Wi; + PROCEDURE Wln; BEGIN Texts.WriteLn(W) END Wln; + + PROCEDURE Wh(i: SYSTEM.INT64); + BEGIN + IF i >= 16 THEN Wh(i DIV 10H) + ELSIF i >= 10 THEN Wc("0") END; + i := i MOD 16; + IF i < 10 THEN Wc(CHR(i+30H)) ELSE Wc(CHR(i+37H)) END + END Wh; PROCEDURE Indent(i: INTEGER); - BEGIN WHILE i > 0 DO Wch(" "); Wch(" "); DEC(i) END + BEGIN WHILE i > 0 DO Wc(" "); Wc(" "); DEC(i) END END Indent; PROCEDURE ^Wtype(typ: OPT.Struct); @@ -47,89 +37,107 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver BEGIN first := TRUE; res := (result # NIL) (* hidden mthd *) & (result # OPT.notyp); paren := res OR (par # NIL); - IF paren THEN Wch("(") END ; + IF paren THEN Wc("(") END; WHILE par # NIL DO - IF ~first THEN Ws("; ") ELSE first := FALSE END ; - IF option = "x" THEN Wi(par^.adr); Wch(" ") END ; - IF par^.mode = VarPar THEN Ws("VAR ") END ; + IF ~first THEN Ws("; ") ELSE first := FALSE END; + IF option = "x" THEN Wi(par^.adr); Wc(" ") END; + IF par^.mode = OPT.VarPar THEN Ws("VAR ") END; Ws(par^.name); Ws(": "); Wtype(par^.typ); par := par^.link - END ; - IF paren THEN Wch(")") END ; + END; + IF paren THEN Wc(")") END; IF res THEN Ws(": "); Wtype(result) END END Wsign; + PROCEDURE HasForm(obj: OPT.Object; mode: SET): BOOLEAN; + BEGIN + RETURN (obj # NIL) + & ( ((obj.mode IN mode) & (obj.name # "")) + OR HasForm(obj.left, mode) + OR HasForm(obj.right, mode)); + END HasForm; + PROCEDURE Objects(obj: OPT.Object; mode: SET); - VAR i: LONGINT; m: INTEGER; s: SET; ext: OPT.ConstExt; + VAR i: SYSTEM.INT64; m: INTEGER; s: SYSTEM.SET64; ext: OPT.ConstExt; BEGIN IF obj # NIL THEN Objects(obj^.left, mode); IF obj^.mode IN mode THEN + (* Output comment if present *) + IF obj^.comment # NIL THEN + Indent(1); + Ws("(** "); + (* Handle multi-line comments *) + i := 0; + WHILE obj^.comment^[i] # 0X DO + IF obj^.comment^[i] = 0AX THEN + Ws(" *)"); Wln; + Indent(1); Ws(" "); + ELSE + Wc(obj^.comment^[i]) + END; + INC(i) + END; + Ws(" *)"); + Wln + END; CASE obj^.mode OF - | Con: - Indent(2); Ws(obj^.name); Ws(" = "); - CASE obj^.typ^.form OF - | Bool: - IF obj^.conval^.intval = 1 THEN Ws("TRUE") ELSE Ws("FALSE") END - | Char: - IF (obj^.conval^.intval >= 32) & (obj^.conval^.intval <= 126) THEN - Wch(22X); Wch(CHR(obj^.conval^.intval)); Wch(22X) - ELSE - i := obj^.conval^.intval DIV 16; - IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ; - i := obj^.conval^.intval MOD 16; - IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ; - Wch("X") - END - | SInt, Int, LInt: - Wi(obj^.conval^.intval) - | Set: - Wch("{"); i := 0; s := obj^.conval^.setval; - WHILE i <= MAX(SET) DO - IF i IN s THEN Wi(i); EXCL(s, i); - IF s # {} THEN Ws(", ") END - END ; - INC(i) - END ; - Wch("}") - | Real: - Texts.WriteReal(W, SHORT(obj^.conval^.realval), 16) - | LReal: - Texts.WriteLongReal(W, obj^.conval^.realval, 23) - | String: - Ws(obj^.conval^.ext^) - | NilTyp: - Ws("NIL") - END ; - Wch(";"); Wln - | Typ: - IF obj^.name # "" THEN Indent(2); - IF obj^.typ^.strobj = obj THEN (* canonical name *) - Wtype(obj^.typ); Ws(" = "); Wstruct(obj^.typ) - ELSE (* alias *) - Ws(obj^.name); Ws(" = "); Wtype(obj^.typ) - END ; - Wch(";"); Wln - END - | Var: - Indent(2); Ws(obj^.name); - IF obj^.vis = externalR THEN Ws("-: ") ELSE Ws(": ") END ; - Wtype(obj^.typ); Wch(";"); Wln - | XProc, CProc, IProc: - Indent(1); Ws("PROCEDURE "); - IF obj^.mode = IProc THEN Wch("+") - ELSIF obj^.mode = CProc THEN Wch("-") - END ; - Ws(obj^.name); - Wsign(obj^.typ, obj^.link); - IF obj^.mode = CProc THEN - ext := obj^.conval^.ext; m := ORD(ext^[0]); i := 1; Ws(' "'); - WHILE i <= m DO Wch(ext^[i]); INC(i) END ; - Wch('"'); - END ; - Wch(";"); Wln + |OPT.Con: Indent(2); Ws(obj^.name); Ws(" = "); + CASE obj^.typ^.form OF + |OPT.Bool: IF obj^.conval^.intval = 1 THEN Ws("TRUE") ELSE Ws("FALSE") END + |OPT.Char: IF (obj^.conval^.intval >= 32) & (obj^.conval^.intval <= 126) THEN + Wc(22X); Wc(CHR(obj^.conval^.intval)); Wc(22X) + ELSE + i := obj^.conval^.intval DIV 16; + IF i > 9 THEN Wc(CHR(55 + i)) ELSE Wc(CHR(48 + i)) END; + i := obj^.conval^.intval MOD 16; + IF i > 9 THEN Wc(CHR(55 + i)) ELSE Wc(CHR(48 + i)) END; + Wc("X") + END + |OPT.Int: Wi(obj^.conval^.intval) + |OPT.Set: Wc("{"); i := 0; s := obj^.conval^.setval; + WHILE i <= MAX(SYSTEM.SET64) DO + IF i IN s THEN Wi(i); EXCL(s, i); + IF s # {} THEN Ws(", ") END + END; + INC(i) + END; + Wc("}") + |OPT.Real: Texts.WriteReal(W, SHORT(obj^.conval^.realval), 16) + |OPT.LReal: Texts.WriteLongReal(W, obj^.conval^.realval, 23) + |OPT.String: Wc('"'); Ws(obj^.conval^.ext^); Wc('"') + |OPT.NilTyp: Ws("NIL") + ELSE (* Ignore other forms *) + END; + Wc(";"); Wln + |OPT.Typ: IF obj^.name # "" THEN Indent(2); + IF obj^.typ^.strobj = obj THEN (* canonical name *) + Wtype(obj^.typ); Ws(" = "); Wstruct(obj^.typ) + ELSE (* alias *) + Ws(obj^.name); Ws(" = "); Wtype(obj^.typ) + END; + Wc(";"); Wln + END + |OPT.Var: Indent(2); Ws(obj^.name); + IF obj^.vis = OPT.externalR THEN Ws("-: ") ELSE Ws(": ") END; + Wtype(obj^.typ); Wc(";"); Wln + |OPT.XProc, + OPT.CProc, + OPT.IProc: Indent(1); Ws("PROCEDURE "); + IF obj^.mode = OPT.IProc THEN Wc("+") + ELSIF obj^.mode = OPT.CProc THEN Wc("-") + END; + Ws(obj^.name); + Wsign(obj^.typ, obj^.link); + IF obj^.mode = OPT.CProc THEN + ext := obj^.conval^.ext; m := ORD(ext^[0]); i := 1; Ws(' "'); + WHILE i <= m DO Wc(ext^[i]); INC(i) END; + Wc('"'); + END; + Wc(";"); Wln + ELSE (* Ignore other modes *) END - END ; + END; Objects(obj^.right, mode) END END Objects; @@ -139,20 +147,20 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver BEGIN IF obj # NIL THEN Wmthd(obj^.left); - IF (obj^.mode = TProc) & ((obj^.name # OPM.HdTProcName) OR (option = "x")) THEN + IF (obj^.mode = OPT.TProc) & ((obj^.name # OPM.HdTProcName) OR (option = "x")) THEN Indent(3); Ws("PROCEDURE ("); IF obj^.name # OPM.HdTProcName THEN - IF obj^.link^.mode = VarPar THEN Ws("VAR ") END ; + IF obj^.link^.mode = OPT.VarPar THEN Ws("VAR ") END; Ws(obj^.link^.name); Ws(": "); Wtype(obj^.link^.typ) - END ; + END; Ws(") "); Ws(obj^.name); Wsign(obj^.typ, obj^.link^.link); - Wch(";"); + Wc(";"); IF option = "x" THEN Indent(1); Ws("(* methno: "); Wi(obj^.adr DIV 10000H); Ws(" *)") - END ; + END; Wln; - END ; + END; Wmthd(obj^.right) END END Wmthd; @@ -161,47 +169,39 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver VAR fld: OPT.Object; PROCEDURE SysFlag; - BEGIN - IF typ^.sysflag # 0 THEN - Wch("["); Wi(typ^.sysflag); Ws("] ") - END + BEGIN IF typ^.sysflag # 0 THEN Wc("["); Wh(typ^.sysflag); Ws("H] ") END END SysFlag; BEGIN CASE typ^.form OF - | Undef: - Ws("Undef") - | Pointer: - Ws("POINTER "); SysFlag; Ws("TO "); Wtype(typ^.BaseTyp) - | ProcTyp: - Ws("PROCEDURE "); SysFlag; Wsign(typ^.BaseTyp, typ^.link) - | Comp: - CASE typ^.comp OF - | Array: - Ws("ARRAY "); SysFlag; Wi(typ^.n); Ws(" OF "); Wtype(typ^.BaseTyp) - | DynArr: - Ws("ARRAY "); SysFlag; Ws("OF "); Wtype(typ^.BaseTyp) - | Record: - Ws("RECORD ");SysFlag; - IF typ^.BaseTyp # NIL THEN Wch("("); Wtype(typ^.BaseTyp); Wch(")") END ; - Wln; fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (option = "x") OR (fld^.name[0] # "@") THEN Indent(3); - IF option = "x" THEN Wi(fld^.adr); Wch(" ") END ; - Ws(fld^.name); - IF fld^.vis = externalR THEN Wch("-") END ; - Ws(": "); Wtype(fld^.typ); Wch(";"); - Wln - END ; - fld := fld^.link - END ; - Wmthd(typ^.link); - Indent(2); Ws("END "); - IF option = "x" THEN Indent(1); - Ws("(* size: "); Wi(typ^.size); Ws(" align: "); Wi(typ^.align); - Ws(" nofm: "); Wi(typ^.n); Ws(" *)") - END - END + |OPT.Undef: Ws("Undef") + |OPT.Pointer: Ws("POINTER "); SysFlag; Ws("TO "); Wtype(typ^.BaseTyp) + |OPT.ProcTyp: Ws("PROCEDURE "); SysFlag; Wsign(typ^.BaseTyp, typ^.link) + |OPT.Comp: CASE typ^.comp OF + |OPT.Array: Ws("ARRAY "); SysFlag; Wi(typ^.n); Ws(" OF "); Wtype(typ^.BaseTyp) + |OPT.DynArr: Ws("ARRAY "); SysFlag; Ws("OF "); Wtype(typ^.BaseTyp) + |OPT.Record: Ws("RECORD ");SysFlag; + IF typ^.BaseTyp # NIL THEN Wc("("); Wtype(typ^.BaseTyp); Wc(")") END; + Wln; fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO + IF (option = "x") OR (fld^.name[0] # "@") THEN Indent(3); + IF option = "x" THEN Wi(fld^.adr); Wc(" ") END; + Ws(fld^.name); + IF fld^.vis = OPT.externalR THEN Wc("-") END; + Ws(": "); Wtype(fld^.typ); Wc(";"); + Wln + END; + fld := fld^.link + END; + Wmthd(typ^.link); + Indent(2); Ws("END"); + IF option = "x" THEN Indent(1); + Ws("(* size: "); Wi(typ^.size); Ws(" align: "); Wi(typ^.align); + Ws(" nofm: "); Wi(typ^.n); Ws(" *)") + END + ELSE (* Ignore other comps *) + END + ELSE (* Ignore other froms *) END END Wstruct; @@ -210,20 +210,23 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver BEGIN obj := typ^.strobj; IF obj^.name # "" THEN - IF typ^.mno # 0 THEN Ws(OPT.GlbMod[typ^.mno].name); Wch(".") + IF typ^.mno # 0 THEN Ws(OPT.GlbMod[typ^.mno].name); Wc(".") ELSIF (typ = OPT.bytetyp) OR (typ = OPT.sysptrtyp) THEN Ws("SYSTEM.") - ELSIF obj^.vis = internal THEN Wch("#") - END ; + ELSIF obj^.vis = OPT.internal THEN Wc("#") + END; Ws(obj^.name) ELSE - IF (option = "x") & (typ^.ref > OPM.MaxStruct) THEN Wch("#"); Wi(typ^.ref - OPM.MaxStruct); Wch(" ") END ; + IF (option = "x") & (typ^.ref > OPM.MaxStruct) THEN Wc("#"); Wi(typ^.ref - OPM.MaxStruct); Wc(" ") END; Wstruct(typ) END END Wtype; PROCEDURE WModule(name: OPS.Name; T: Texts.Text); - VAR i: INTEGER; - beg, end: LONGINT; first, done: BOOLEAN; + VAR + i: INTEGER; + beg, end: LONGINT; + first, done: BOOLEAN; + obj: OPT.Object; PROCEDURE Header(s: ARRAY OF CHAR); BEGIN @@ -238,66 +241,82 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver ELSE Wln END END CheckHeader; - + BEGIN OPT.Import("@notself", name, done); IF done THEN - Ws("DEFINITION "); Ws(name); Wch(";"); Wln; Wln; - Header("IMPORT"); i := 1; first := TRUE; - WHILE i < OPT.nofGmod DO - IF first THEN first := FALSE; Indent(2) ELSE Ws(", ") END ; - Ws(OPT.GlbMod[i].name); - INC(i) - END ; - IF ~first THEN Wch(";"); Wln END ; + Ws("DEFINITION "); Ws(name); Wc(";"); Wln; + + IF OPT.nofGmod > 1 THEN + Header("IMPORT"); i := 1; first := TRUE; + WHILE i < OPT.nofGmod DO + IF first THEN first := FALSE; Indent(2) ELSE Ws(", ") END; + Ws(OPT.GlbMod[i].name); + INC(i) + END; + IF ~first THEN Wc(";"); Wln END + END; CheckHeader; - Header("CONST"); Objects(OPT.GlbMod[0].right, {Con}); CheckHeader; - Header("TYPE"); Objects(OPT.GlbMod[0].right, {Typ}); CheckHeader; - Header("VAR"); Objects(OPT.GlbMod[0].right, {Var}); CheckHeader; - Objects(OPT.GlbMod[0].right, {XProc, IProc, CProc}); - Wln; - Ws("END "); Ws(name); Wch("."); Wln; Texts.Append(T, W.buf) + obj := OPT.GlbMod[0].right; + IF HasForm(obj, {OPT.Con}) THEN Header("CONST"); Objects(obj, {OPT.Con}); CheckHeader END; + IF HasForm(obj, {OPT.Typ}) THEN Header("TYPE"); Objects(obj, {OPT.Typ}); CheckHeader END; + IF HasForm(obj, {OPT.Var}) THEN Header("VAR"); Objects(obj, {OPT.Var}); CheckHeader END; + Objects(obj, {OPT.XProc, OPT.IProc, OPT.CProc}); Wln; + Ws("END "); Ws(name); Wc("."); Wln; Texts.Append(T, W.buf) ELSE Texts.WriteString(W, name); Texts.WriteString(W, " -- symbol file not found"); Texts.WriteLn(W); Texts.Append(T, W.buf) END END WModule; - + PROCEDURE Ident(VAR name, first: ARRAY OF CHAR); - VAR i, j: INTEGER; ch: CHAR; + VAR i, j: INTEGER; ch: CHAR; BEGIN i := 0; - WHILE name[i] # 0X DO INC(i) END ; - WHILE (i >= 0) & (name[i] # "/") DO DEC(i) END ; + WHILE name[i] # 0X DO INC(i) END; + WHILE (i >= 0) & (name[i] # "/") DO DEC(i) END; + IF i > 0 THEN name[i] := 0X; Files.SetSearchPath(name) END; INC(i); j := 0; ch := name[i]; - WHILE (ch # ".") & (ch # 0X) DO first[j] := ch; INC(i); INC(j); ch := name[i] END ; + WHILE (ch # ".") & (ch # 0X) DO first[j] := ch; INC(i); INC(j); ch := name[i] END; first[j] := 0X END Ident; PROCEDURE ShowDef*; - VAR T, dummyT: Texts.Text; S, vname, name: OPS.Name; R: Texts.Reader; ch: CHAR; - s: ARRAY 1024 OF CHAR; i: INTEGER; + VAR S, vname, name: OPS.Name; BEGIN - option := 0X; Args.Get(1, S); - IF Args.argc > 2 THEN - IF S[0] = OptionChar THEN option := S[1]; Args.Get(2, S) - ELSE Args.Get(2, vname); option := vname[1] + option := 0X; Modules.GetArg(1, S); + IF Modules.ArgCount > 2 THEN + IF S[0] = OptionChar THEN option := S[1]; Modules.GetArg(2, S) + ELSE Modules.GetArg(2, vname); option := vname[1] END - END ; - IF Args.argc >= 2 THEN + END; + IF Modules.ArgCount >= 2 THEN Ident(S, name); - NEW(T); Texts.Open(T, ""); - OPT.Init(name, {}); OPT.SelfName := "AvoidErr154"; WModule(name, T); OPT.Close; - Texts.OpenReader(R, T, 0); Texts.Read(R, ch); i := 0; - WHILE ~R.eot DO - IF ch = 0DX THEN s[i] := 0X; i := 0; Console.String(s); Console.Ln - ELSE s[i] := ch; INC(i) - END ; - Texts.Read(R, ch) - END ; - s[i] := 0X; Console.String(s) + OPT.Init(name, {}); OPT.SelfName := "AvoidErr154"; + WModule(name, Oberon.Log); + OPT.Close; + ELSE + Ws("showdef - Display module's public interface."); Wln; + Wln; + Ws("Usage: showdef module"); Wln; + Wln; + Ws("Where is a symbol file name. The .sym may be omitted."); Wln; + Ws("If no path is provided, and the module does not exist in the current directory,"); Wln; + Ws("then showdef will also look for the module in the installed libraries."); Wln; + Texts.Append(Oberon.Log, W.buf) END END ShowDef; +PROCEDURE SetDefaultPath; +VAR path: ARRAY 256 OF CHAR; BEGIN - OPT.typSize := OPV.TypSize; Texts.OpenWriter(W); ShowDef + path := ".;"; + Strings.Append(Configuration.installdir, path); + Strings.Append("/2/sym", path); + Files.SetSearchPath(path) +END SetDefaultPath; + +BEGIN + Texts.OpenWriter(W); + SetDefaultPath; + ShowDef END BrowserCmd. diff --git a/src/tools/make/addlibrary.sh b/src/tools/make/addlibrary.sh new file mode 100644 index 00000000..46e6e3e4 --- /dev/null +++ b/src/tools/make/addlibrary.sh @@ -0,0 +1,28 @@ +# addlibrary - shell script to install/uninstall oberon libraries +# +# $1 - "install" or "uninstall" +# $2 - location containing .so's +# $3 - oberon name + + +if ! which ldconfig >/dev/null 2>&1; then exit 0; fi + +if test -d /etc/ld.so.conf.d; then + + # Linux-like system + # Need to update the ldconfig configuration in the /etc/ld.so.conf.d dir. + if test "$1" = "install"; then + echo $2>/etc/ld.so.conf.d/lib$3.conf + else + rm -f /etc/ld.so.conf.d/lib$3.conf + fi + ldconfig + +else + + # BSD-like system + # Just run ldconfig -m to update the cache. It'll add-to/update/reove-from + # the cache appropraitely for whether they are present opt not. + ldconfig -m "$2" + +fi diff --git a/src/tools/make/configure.c b/src/tools/make/configure.c new file mode 100644 index 00000000..258a1b4e --- /dev/null +++ b/src/tools/make/configure.c @@ -0,0 +1,469 @@ +// Test platform supportability and establish build configuration: +// +// Writes the configuration parameters to these two files: +// +// Configuration.Mod - settings to compile into the compiler binary +// Configuration.make - makefile variable settings for this configuration +// +// Derived from vocparam.c originally by J. Templ 23.6.95 + + +#define O_VER 2.1.0 // Version number to be reported by compiler. +#define O_NAME voc // Compiler name used for binary, install dir and references in text. + + +#include "SYSTEM.h" + + +#ifdef _WIN32 + #define strncasecmp _strnicmp + char* getcwd(char* buf, size_t size); +#else + #include + #include + #include + #include + #include +#endif + +#include +#include +#include +#include + + +void fail(char *msg) {fprintf(stderr, "Error: %s\n", msg); exit(1);} +void assert(int truth, char *complaint) {if (!truth) fail(complaint);} + + + + +char builddate[256]; +char installdir[256]; +char versionstring[256]; +char osrelease[1024]; +char cwd[1024]; +char libspec[1024]; + +#define macrotostringhelper(s) #s +#define macrotostring(s) macrotostringhelper(s) +char *version = macrotostring(O_VER); +char *objext = ".o"; +char *objflag = " -o "; +char *linkflags = " -L\""; +char *libext = ""; +char *oname = NULL; // From O_NAME env var if present, or O_NAME macro otherwise. +char *dynext = ".so"; +char *dataModel = NULL; +char *compiler = NULL; +char *cc = NULL; +char *os = NULL; +char *platform = NULL; +char *binext = NULL; +char *staticlink = NULL; // Static compilation option - none on darwin / windows. +int alignment = 0; +int addressSize = 0; +int intsize = 0; +int bsd = 0; +int termux = 0; +int bootstrap = 0; // 1 iff generating a bootstrap compiler. + + + +void ParseOsRelease(FILE *fd) { + while (fgets(osrelease, sizeof(osrelease), fd) != NULL) { + if (strncasecmp(osrelease, "id=", 3) == 0) { + int i=3; + while (osrelease[i] == '"') {i++;} + int j=i; + while (osrelease[j] > '"') {j++;} + if (j>i) { + osrelease[j] = 0; + os = osrelease + i; + } + break; + } + } + fclose(fd); +} + + +void determineLinuxVariant() { + FILE *fd = NULL; + os = "linux"; + + if ((fd = fopen("/etc/os-release", "r"))) {ParseOsRelease(fd); return;} + // Hack for centos without /etc/os-release + if ((fd = fopen("/etc/centos-release", "r"))) {os = "centos"; fclose(fd); return;} + // Hack to detect running in termux in android + if ((fd = fopen("/data/data/com.termux/files/usr/bin/bash", "r"))) {os = "termux"; staticlink = ""; termux = 1; fclose(fd); return;} +} + + +void determineOS() { + #ifdef _WIN32 + os = "windows"; platform = "windows"; binext = ".exe"; staticlink = ""; + #else + os = "unknown"; platform = "unix"; binext = ""; staticlink = " -static"; + + struct utsname sys; + if (uname(&sys)<0) fail("Couldn't get sys name - uname() failed."); + + if (strncasecmp(sys.sysname, "cygwin", 6) == 0) {os = "cygwin"; binext = ".exe";} + else if (strncasecmp(sys.sysname, "linux", 5) == 0) {determineLinuxVariant();} + else if (strncasecmp(sys.sysname, "freebsd", 5) == 0) {os = "freebsd"; bsd = 1;} + else if (strncasecmp(sys.sysname, "openbsd", 5) == 0) {os = "openbsd"; bsd = 1;} + else if (strncasecmp(sys.sysname, "netbsd", 5) == 0) {os = "netbsd"; bsd = 1;} + else if (strncasecmp(sys.sysname, "darwin", 5) == 0) {os = "darwin"; staticlink = ""; dynext = ".dylib";} + else { + fprintf(stderr, "\n\n** Unrecognised utsname.sysname '%s' returned by uname().\n", sys.sysname); + fprintf(stderr, "** Please add a test for this OS in src/buildtools/configure.c\n"); + fprintf(stderr, "** in function determineOS() near line %d.\n\n", __LINE__-3); + fail("Unrecognised OS architecture name (sysname) returned by uname."); + } + #endif +} + +#define optimize "" // " -O1" +// FIXME ignoring warning floods that possibly are problems +#define ignore_gcc_warning_flood " -Wno-stringop-overflow -std=gnu11" +#define ignore_clang_warning_flood " -Wno-deprecated-non-prototype" + +void determineCCompiler() { + snprintf(libspec, sizeof(libspec), " -l%s", oname); + #if defined(__MINGW32__) + compiler = "mingw"; + if (sizeof (void*) == 4) { + cc = "i686-w64-mingw32-gcc -g" ignore_gcc_warning_flood optimize; + } else { + cc = "x86_64-w64-mingw32-gcc -g" ignore_gcc_warning_flood optimize; + } + #elif defined(__clang__) + compiler = "clang"; + cc = "clang -fPIC -g" ignore_clang_warning_flood optimize; + #elif defined(__TINYC__) + compiler = "tcc"; + cc = "tcc -g"; + staticlink = ""; + #elif defined(__GNUC__) + compiler = "gcc"; + if (strncasecmp(os, "cygwin", 6) == 0) { + // Avoid cygwin specific warning that -fPIC is ignored. + cc = "gcc -g" ignore_gcc_warning_flood optimize; + } else { + cc = "gcc -fPIC -g" ignore_gcc_warning_flood optimize; + } + #elif defined(_MSC_VER) + compiler = "msc"; + cc = "cl /nologo"; + objext = ".obj"; + objflag = " -Fe"; + linkflags = " -link -libpath:\""; + snprintf(libspec, sizeof(libspec), " lib%s", oname); + libext = ".lib"; + #else + fail("Unrecognised C compiler."); + #endif +} + + + +void determineInstallDirectory() { + if (bootstrap) { + installdir[0] = 0; + } else { + char *env = getenv("INSTALLDIR"); + if (env) { + strncpy(installdir, env, sizeof(installdir)); + } else { + #if defined(_MSC_VER) || defined(__MINGW32__) + if (sizeof (void*) == 8) { + snprintf(installdir, sizeof(installdir), "%s\\%s", getenv("ProgramFiles"), oname); + } else { + snprintf(installdir, sizeof(installdir), "%s\\%s", getenv("ProgramFiles(x86)"), oname); + } + #if defined(__MINGW32__) + int i; for(i=0; installdir[i]; i++) if (installdir[i] == '\\') installdir[i] = '/'; + #endif + #else + if (bsd) { + snprintf(installdir, sizeof(installdir), "/usr/local/share/%s", oname); + } else if (termux) { + snprintf(installdir, sizeof(installdir), "/data/data/com.termux/files/opt/%s", oname); + } else { + snprintf(installdir, sizeof(installdir), "/opt/%s", oname); + } + #endif + } + } +} + + + + +void determineBuildDate() { + time_t t = time(0); + strftime(builddate, sizeof(builddate), "%Y/%m/%d", localtime(&t)); +} + + + +struct {char ch; CHAR x;} c; +struct {char ch; BOOLEAN x;} b; +//struct {char ch; SHORTINT x;} si; +//struct {char ch; INTEGER x;} i; +//struct {char ch; LONGINT x;} li; +//struct {char ch; SET x;} s; +struct {char ch; REAL x;} r; +struct {char ch; LONGREAL x;} lr; +struct {char ch; void* x;} p; +struct {char ch; void (*x)();} f; +struct {char ch; int x;} in; +struct {char ch; long x;} lo; +struct {char ch; long long x;} ll; +struct {char ch; char x[1];} a1; +struct {char ch; char x[2];} a2; +struct {char ch; char x[4];} a4; +struct {char ch; char x[8];} a8; + +struct s1 {char ch;}; struct {char ch; struct s1 x;} s1; +struct s2 {char ch[2];}; struct {char ch; struct s2 x;} s2; +struct s4 {char ch[4];}; struct {char ch; struct s4 x;} s4; +struct s8 {char ch[8];}; struct {char ch; struct s8 x;} s8; + +struct {char ch;} rec0; +struct {char x[65];} rec2; + + + + +// Pass any parameter to configure and it will report sizes and alignments +// instead of generating configuration files. + +void ReportSizesAndAlignments() { + printf("Type Size Align\n"); + printf("CHAR %4zd %4td\n", sizeof(CHAR), (char*)&c.x - (char*)&c); + printf("BOOLEAN %4zd %4td\n", sizeof(BOOLEAN), (char*)&b.x - (char*)&b); +//printf("SHORTINT %4zd %4td\n", sizeof(SHORTINT), (char*)&si.x - (char*)&si); +//printf("INTEGER %4zd %4td\n", sizeof(INTEGER), (char*)&i.x - (char*)&i); +//printf("LONGINT %4zd %4td\n", sizeof(LONGINT), (char*)&li.x - (char*)&li); +//printf("SET %4zd %4td\n", sizeof(SET), (char*)&s.x - (char*)&s); + printf("REAL %4zd %4td\n", sizeof(REAL), (char*)&r.x - (char*)&r); + printf("LONGREAL %4zd %4td\n", sizeof(LONGREAL), (char*)&lr.x - (char*)&lr); + printf("void* %4zd %4td\n", sizeof(void*), (char*)&p.x - (char*)&p); + printf("int %4zd %4td\n", sizeof(int), (char*)&in.x - (char*)&in); + printf("long %4zd %4td\n", sizeof(long), (char*)&lo.x - (char*)&lo); + printf("long long %4zd %4td\n", sizeof(long long), (char*)&ll.x - (char*)&ll); + printf("char[1] %4zd %4td\n", sizeof(a1.x), (char*)&a1.x - (char*)&a1); + printf("char[2] %4zd %4td\n", sizeof(a2.x), (char*)&a2.x - (char*)&a2); + printf("char[4] %4zd %4td\n", sizeof(a4.x), (char*)&a4.x - (char*)&a4); + printf("char[8] %4zd %4td\n", sizeof(a8.x), (char*)&a8.x - (char*)&a8); + printf("struct s1 %4zd %4td\n", sizeof(struct s1), (char*)&s1.x - (char*)&s1); + printf("struct s2 %4zd %4td\n", sizeof(struct s2), (char*)&s2.x - (char*)&s2); + printf("struct s4 %4zd %4td\n", sizeof(struct s4), (char*)&s4.x - (char*)&s4); + printf("struct s8 %4zd %4td\n", sizeof(struct s8), (char*)&s8.x - (char*)&s8); +} + + + +#define MIN(a,b) (((a)<(b)) ? (a) : (b)) + +void determineCDataModel() { + addressSize = sizeof(void*); + alignment = (char*)&lr.x - (char*)&lr; // Base alignment measure on largest type. + + if (addressSize == 4 && sizeof(int) == 4) dataModel = "ILP32"; // Unix/Linux and modern Win32 + else if (addressSize == 8 && sizeof(long) == 4) dataModel = "LLP64"; // Windows/mingw 64 bit + else if (addressSize == 8 && sizeof(long) == 8) dataModel = "LP64"; // Unix/Linux 64 bit + else fail("Unsupported combination of address size and int/long size."); + + // Check for supported address sie and alignment + + if (addressSize == 4) { + assert(alignment == 4 || alignment == 8, "Aligment neither 4 nor 8 when address size is 4."); + } else { + assert(addressSize == 8, "Address size neither 4 nor 8."); + assert(alignment == 8, "Alignemnt not 8 when address size is 8."); + } + + // Define 'LARGE' to get 32 bit INTEGER and 64 bit LONGINT even on 32 bit systems. + // Note that plenty of the library source files do not expect this. + + #ifdef LARGE + intsize = 4; + #else + intsize = (addressSize == 4) ? 2 : 4; + #endif +} + + + + +void testSystemDotH() { + /* test the __ASHR macro */ + assert(__ASHR(-1, 1) == -1, "ASH(-1, -1) # -1."); + assert(__ASHR(-2, 1) == -1, "ASH(-2, -1) # -1."); + assert(__ASHR(0, 1) == 0, "ASH(0, 1) # 0."); + assert(__ASHR(1, 1) == 0, "ASH(1, 1) # 0."); + assert(__ASHR(2, 1) == 1, "ASH(2, 1) # 1."); + + /* test the __SETRNG macro */ + long x = 0; + long y; + y=31; assert(__SETRNG(x, y, 32) == -1, "SETRNG(0, MAX(SET), 32) != -1."); + y=63; assert(__SETRNG(x, y, 64) == -1, "SETRNG(0, MAX(SET), 32) != -1."); +// long y = sizeof(SET)*8 - 1; +// if (sizeof(SET) == 4) +// assert(__SETRNG(x, y, 32) == -1, "SETRNG(0, MAX(SET)) != -1."); +// else +// assert(__SETRNG(x, y, 64) == -1, "SETRNG(0, MAX(SET)) != -1."); + + /* test string comparison for extended ascii */ + {char a[10], b[10]; + a[0] = (CHAR)128; a[1] = 0; + b[0] = 0; + assert(__STRCMP(a, b) >= 0, "__STRCMP(a, b) with extended ascii charcters; should be unsigned."); + } + + // Check the sizes of the Oberon basic types as defined in SYSTEM.h. + // By design all but INTEGER and LONGINT are fixed across all supported platfroms. + + assert(sizeof(CHAR) == 1, "Size of CHAR not 1."); + assert(sizeof(BOOLEAN) == 1, "Size of BOOLEAN not 1."); +//assert(sizeof(SHORTINT) == 1, "Size of SHORTINT not 1."); +//assert(sizeof(INTEGER) == 2 +// || sizeof(INTEGER) == 4, "Size of INTEGER neither 2 nor 4 bytes."); +//assert(sizeof(LONGINT) == 4 +// || sizeof(LONGINT) == 8, "Size of LONGINT neither 4 nor 8 bytes."); +//assert(sizeof(SET) == sizeof(LONGINT), "Size of SET differs from size of LONGINT."); + assert(sizeof(REAL) == 4, "Size of REAL not 4 bytes."); + assert(sizeof(LONGREAL) == 8, "Size of LONGREAL not 8 bytes."); + assert(sizeof(f.x) == sizeof(p.x), "Size of function pointer differs from size of data pointer."); + + assert((alignment == 4) || (alignment == 8), "Alignment of LONGINT neither 4 nor 8 bytes."); + + assert(((char*)&c.x - (char*)&c) == 1, "Alignment of CHAR not 1."); + assert(((char*)&b.x - (char*)&b) == 1, "Alignment of BOOLEAN not 1."); +//assert(((char*)&si.x - (char*)&si) == 1, "Alignment of SHORTINT not 1."); +//assert(((char*)&i.x - (char*)&i) == 4, "Alignment of INTEGER not 4 bytes."); + assert(((char*)&r.x - (char*)&r) == 4, "Alignment of REAL not 4 bytes."); + assert(((char*)&lr.x - (char*)&lr) >= 4, "Alignment of LONGREAL less than 4 bytes."); +//assert(((char*)&s.x - (char*)&s) == MIN(alignment, sizeof(SET)), "Alignment of SET differs from alignmnet of LONGINT."); + assert(((char*)&p.x - (char*)&p) == addressSize, "Alignment of data pointer differs from address size."); + assert(((char*)&f.x - (char*)&f) == addressSize, "Alignment of data pointer differs from address size."); + assert(((char*)&lr.x - (char*)&lr) == ((char*)&ll.x - (char*)&ll), "Alignment of LONGREAL differs from alignment of long long."); + + assert(sizeof(rec0) == 1, "CHAR wrapped in record aligns differently to CHAR alone."); + assert(sizeof(rec2) == 65, "CHAR array wrapped in record aligns differently to CHAR array alone."); + +//assert(sizeof(LONGINT) >= sizeof(p.x), "LONGINT should have at least the same size as data pointers."); +//assert(sizeof(LONGINT) >= sizeof(f.x), "LONGINT should have at least the same size as function pointers."); + + if (((sizeof(rec2)==65) == (sizeof(rec0)==1)) && ((sizeof(rec2)-64) != sizeof(rec0))) + printf("error: unsupported record layout sizeof(rec0) = %lu sizeof(rec2) = %lu\n", (long)sizeof(rec0), (long)sizeof(rec2)); + + x = 1; + assert(*(char*)&x == 1, "C compiler does not store multibyte numeric values in little-endian order."); +} + + + + +void writeMakeParameters() { + FILE *fd = fopen("Configuration.Make", "w"); + if (fd == NULL) fail("Couldn't create Configuration.make."); + fprintf(fd, "OLANGDIR=%s\n", cwd); + fprintf(fd, "COMPILER=%s\n", compiler); + fprintf(fd, "OS=%s\n", os); + fprintf(fd, "VERSION=%s\n", version); + fprintf(fd, "ONAME=%s\n", oname); + fprintf(fd, "DATAMODEL=%s\n", dataModel); + fprintf(fd, "ADRSIZE=%d\n", addressSize); + fprintf(fd, "ALIGNMENT=%d\n", alignment); + fprintf(fd, "INSTALLDIR=%s\n", installdir); + fprintf(fd, "PLATFORM=%s\n", platform); + fprintf(fd, "BINEXT=%s\n", binext); + fprintf(fd, "DYNEXT=%s\n", dynext); + fprintf(fd, "COMPILE=%s\n", cc); + fprintf(fd, "STATICLINK=%s\n", staticlink); + fclose(fd); +} + + + + +void writeConfigurationMod() { + FILE *fd = fopen("Configuration.Mod", "w"); + if (fd == NULL) fail("Couldn't create Configuration.Mod."); + + fprintf(fd, "MODULE Configuration;\n"); + fprintf(fd, "CONST\n"); + fprintf(fd, " name* = '%s';\n", oname); + fprintf(fd, " objext* = '%s';\n", objext); + fprintf(fd, " objflag* = '%s';\n", objflag); + fprintf(fd, " linkflags* = '%s';\n", linkflags); + fprintf(fd, " libspec* = '%s';\n", libspec); + fprintf(fd, " libext* = '%s';\n", libext); + fprintf(fd, " os* = '%s';\n", os); + fprintf(fd, " compiler* = '%s';\n", compiler); + fprintf(fd, " compile* = '%s';\n", cc); + fprintf(fd, " installdir* = '%s';\n", installdir); + fprintf(fd, " staticLink* = '%s';\n", staticlink); + fprintf(fd, "VAR\n"); + fprintf(fd, " versionLong-: ARRAY %d OF CHAR;\n", (int)strnlen(versionstring, 100)+1); + fprintf(fd, "BEGIN\n"); + fprintf(fd, " versionLong := '%s';\n", versionstring); + fprintf(fd, "END Configuration.\n"); + + fclose(fd); +} + + + + +int main(int argc, char *argv[]) +{ + // Make sure SYSTEM.h has set up our core data types correctly. + assert(sizeof(INT8) == 1, "sizeof(INT8) is not 1."); + assert(sizeof(INT16) == 2, "sizeof(INT16) is not 2."); + assert(sizeof(INT32) == 4, "sizeof(INT32) is not 4."); + assert(sizeof(INT64) == 8, "sizeof(INT64) is not 8."); + + oname = getenv("ONAME"); if (!oname) oname = macrotostring(O_NAME); + + if (argc>1) { + if (strncasecmp(argv[1], "rep", 3) == 0) { + ReportSizesAndAlignments(); + exit(0); + } else { + bootstrap = 1; + } + } + + getcwd(cwd, sizeof(cwd)); + int i; for (i=0; cwd[i]; i++) if (cwd[i]=='\\') cwd[i]='/'; + + determineOS(); + determineCCompiler(); + determineCDataModel(); + determineBuildDate(); + determineInstallDirectory(); + + testSystemDotH(); + + if (bootstrap) { + snprintf(versionstring, sizeof(versionstring), + "%s [%s]. Bootstrapping compiler for address size %d, alignment %d.", + version, builddate, addressSize, alignment); + } else { + snprintf(versionstring, sizeof(versionstring), + "%s [%s] for %s %s on %s", + version, builddate, compiler, dataModel, os); + } + + writeConfigurationMod(); + writeMakeParameters(); + + printf("Configuration: %s\n", versionstring); + return 0; +} diff --git a/src/tools/make/ignore b/src/tools/make/ignore new file mode 100644 index 00000000..8985991b --- /dev/null +++ b/src/tools/make/ignore @@ -0,0 +1,8 @@ +^/\* voc + +Configuration_ +OPM_ResourceDir +OPM_InstallDir +__MOVE.* cmd, +OPM_(IntSize|PointerSize|Alignment) = +Strings_Append.+void\*\)(cmd|OPM_OBERON|extTools_comp) +__COPY\("(gcc|clang|msc|i686-w64-mingw|x86_64-w64-mingw) diff --git a/src/tools/make/oberon.mk b/src/tools/make/oberon.mk new file mode 100644 index 00000000..d68cc09b --- /dev/null +++ b/src/tools/make/oberon.mk @@ -0,0 +1,416 @@ +# DO NOT RUN THIS MAKEFILE DIRECTLY. +# +# Always use the makefile in the root of the enlistment. This makefile +# depends on up to date configuration files generated by the root makefile. + + + + +# Be independent of any CFLAGS settings in the calling environment +CFLAGS = + +# Gnu make has the make initial directory in CURDIR, BSD make has it in .CURDIR. +ROOTDIR = $(CURDIR)$(.CURDIR) + +# Configuration.Make is created by src/tools/make/configure.c, which is run on +# *every* build by the makefile in the enlistment root. +include ./Configuration.Make + +FLAVOUR = $(OS).$(DATAMODEL).$(COMPILER) +BUILDDIR = build/$(FLAVOUR) +OBECOMP = $(ONAME)$(BINEXT) + + + +# Default make target - explain usage +usage: + @echo "" + @echo Do not run this makefile directly, always run the makefile in + @echo the root of the enlistment. + + + + +clean: + @printf '\n\n--- Cleaning branch $(BRANCH) $(OS) $(COMPILER) $(DATAMODEL) ---\n\n' + rm -rf $(BUILDDIR) "$(ROOTDIR)/install" + rm -f $(OBECOMP) + + + + +# Assemble: Generate the Vishap Oberon compiler binary by compiling the C sources in the build directory + +assemble: + @printf '\nmake assemble - compiling Oberon compiler c source:\n' + @printf ' VERSION: %s\n' "$(VERSION)" + @printf ' BRANCH: %s\n' "$(BRANCH)" + @printf ' Target characteristics:\n' + @printf ' PLATFORM: %s\n' "$(PLATFORM)" + @printf ' OS: %s\n' "$(OS)" + @printf ' BUILDDIR: %s\n' "$(BUILDDIR)" + @printf ' INSTALLDIR: %s\n' "$(INSTALLDIR)" + @printf ' Oberon characteristics:\n' + @printf ' MODEL: %s\n' "$(MODEL)" + @printf ' ADRSIZE: %s\n' "$(ADRSIZE)" + @printf ' ALIGNMENT: %s\n' "$(ALIGNMENT)" + @printf ' C compiler:\n' + @printf ' COMPILER: %s\n' "$(COMPILER)" + @printf ' COMPILE: %s\n' "$(COMPILE)" + @printf ' DATAMODEL: %s\n' "$(DATAMODEL)" + + cd $(BUILDDIR) && $(COMPILE) -c SYSTEM.c Configuration.c Platform.c Heap.c + cd $(BUILDDIR) && $(COMPILE) -c Out.c Reals.c Strings.c Modules.c + cd $(BUILDDIR) && $(COMPILE) -c Files.c Texts.c VT100.c + cd $(BUILDDIR) && $(COMPILE) -c OPM.c extTools.c OPS.c OPT.c + cd $(BUILDDIR) && $(COMPILE) -c OPC.c OPV.c OPB.c OPP.c + + cd $(BUILDDIR) && $(COMPILE) $(STATICLINK) Compiler.c -o "$(ROOTDIR)/$(OBECOMP)" \ + SYSTEM.o Configuration.o Platform.o Heap.o Out.o \ + Strings.o Modules.o Files.o Reals.o Texts.o \ + VT100.o extTools.o \ + OPM.o OPS.o OPT.o OPC.o OPV.o OPB.o OPP.o + + cp src/runtime/*.[ch] $(BUILDDIR) + cp src/runtime/*.Txt $(BUILDDIR) + cp src/runtime/*.Txt "$(ROOTDIR)" + @printf '$(OBECOMP) created.\n' + + + + +compilerfromsavedsource: + @echo Populating clean build directory from bootstrap C sources $(PLATFORM)-$(ADRSIZE)$(ALIGNMENT). + @mkdir -p $(BUILDDIR) + @cp bootstrap/$(PLATFORM)-$(ADRSIZE)$(ALIGNMENT)/* $(BUILDDIR) + @cp bootstrap/*.[ch] $(BUILDDIR) + @make -f src/tools/make/oberon.mk -s assemble + @cp bootstrap/*.[ch] $(BUILDDIR) + + + + +translate: +# Make sure we have an oberon compiler binary: if we built one earlier we'll use it, +# otherwise use one of the pre-prepared sets of C sources in the bootstrap directory. + + if [ ! -e $(OBECOMP) ]; then make -f src/tools/make/oberon.mk -s compilerfromsavedsource; fi + + @printf '\nmake translate - translating compiler source from Oberon to C:\n' + @printf ' PLATFORM: %s\n' $(PLATFORM) + @printf ' MODEL: %s\n' $(MODEL) + @printf ' ADRSIZE: %s\n' $(ADRSIZE) + @printf ' ALIGNMENT: %s\n' $(ALIGNMENT) + @mkdir -p $(BUILDDIR) + @rm -f $(BUILDDIR)/*.sym + + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../Configuration.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Platform$(PLATFORM).Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrFapx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Heap.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Reals.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Strings.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Out.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Modules.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Files.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Texts.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/VT100.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPM.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/extTools.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPS.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPT.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPC.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPV.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPB.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -SsrF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPP.Mod + cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -Ssrm -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/Compiler.Mod + + cp src/runtime/*.[ch] $(BUILDDIR) + cp src/runtime/*.Txt $(BUILDDIR) + @printf '$(BUILDDIR) filled with compiler C source.\n' + + + + +browsercmd: + @printf '\nMaking symbol browser\n' + @cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -Ss -O$(MODEL) ../../src/runtime/Oberon.Mod + @cd $(BUILDDIR); "$(ROOTDIR)/$(OBECOMP)" -Sm -O$(MODEL) ../../src/tools/browser/BrowserCmd.Mod + @cd $(BUILDDIR); $(COMPILE) BrowserCmd.c Oberon.c -o showdef \ + Platform.o Texts.o OPT.o Heap.o Out.o SYSTEM.o OPM.o OPS.o OPV.o \ + Files.o Reals.o Modules.o VT100.o Configuration.o Strings.o \ + OPC.o + + + + +# makeinstalldir: Use only after a successful full build. Creates an +# installation directory image in $(BUILDDOR)/install +makeinstalldir: + @printf '\nCreating installation image at "$(ROOTDIR)/install\n"' + @rm -rf "$(ROOTDIR)/install" + + @mkdir -p "$(ROOTDIR)/install/bin" + @cp $(OBECOMP) "$(ROOTDIR)/install/bin/$(OBECOMP)" + @-cp $(BUILDDIR)/showdef$(BINEXT) "$(ROOTDIR)/install/bin" + + @mkdir -p "$(ROOTDIR)/install/2/include" && cp $(BUILDDIR)/2/*.h "$(ROOTDIR)/install/2/include/" + @mkdir -p "$(ROOTDIR)/install/2/sym" && cp $(BUILDDIR)/2/*.sym "$(ROOTDIR)/install/2/sym/" + @mkdir -p "$(ROOTDIR)/install/C/include" && cp $(BUILDDIR)/C/*.h "$(ROOTDIR)/install/C/include/" + @mkdir -p "$(ROOTDIR)/install/C/sym" && cp $(BUILDDIR)/C/*.sym "$(ROOTDIR)/install/C/sym/" + + @cp $(BUILDDIR)/*.Txt "$(ROOTDIR)/install/2/sym/" + @cp $(BUILDDIR)/*.Txt "$(ROOTDIR)/install/C/sym/" + + @mkdir -p "$(ROOTDIR)/install/lib" + @cp $(BUILDDIR)/2/lib$(ONAME)* "$(ROOTDIR)/install/lib/" + @cp $(BUILDDIR)/C/lib$(ONAME)* "$(ROOTDIR)/install/lib/" + + +# instructions: Advice on completion of local build +instructions: FORCE + @printf '\nOberon build and test complete, result is in "$(ROOTDIR)/install".\n' + @printf '\nYou can use the new compiler by running "$(ROOTDIR)/install/bin/$(ONAME)",\n' + @printf 'or add it to your path as follows:\n' + @printf 'export PATH=\"$(ROOTDIR)/install/bin:$$PATH\"\n' + @printf '\n' + + + + +FORCE: + + +# installable: Check for access to the installation directory +installable: + @rm -rf "S(INSTALLDIR)/test-access-qqq" + @if ! mkdir -p "$(INSTALLDIR)/test-access-qqq";then printf '\n\n Cannot write to install directory.\n Please use sudo or run as root/administrator.\n\n'; exit 1;fi + @rm -rf "S(INSTALLDIR)/test-access-qqq" + + +uninstall: installable + @printf '\nUninstalling from \"$(INSTALLDIR)\"\n' + @[ -d "$(INSTALLDIR)/lib" ] && sh src/tools/make/addlibrary.sh uninstall "$(INSTALLDIR)/lib" $(ONAME) || echo nolibdir, skipping + rm -rf "$(INSTALLDIR)" + + +# install: Use only after a successful full build. Installs the compiler +# and libraries in /opt/$(ONAME). +# May require root access. +install: uninstall + @printf '\nInstalling into \"$(INSTALLDIR)\"\n' + @rm -rf "$(INSTALLDIR)" + @cp -rf "$(ROOTDIR)/install/" "$(INSTALLDIR)" + @sh src/tools/make/addlibrary.sh install "$(INSTALLDIR)/lib" $(ONAME) + @printf '\nOberon compiler installed to $(INSTALLDIR)\n' + @printf '\nNow add $(INSTALLDIR)/bin to your path, for example with the command:\n' + @printf 'export PATH=\"$(INSTALLDIR)/bin:$$PATH\"\n' + @printf '\n' + + +runtime: FORCE + @printf '\nMaking run time library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Platform$(PLATFORM).Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Heap.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Out.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Modules.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Reals.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Strings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/In.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/VT100.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Files.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Math.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/MathL.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Texts.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/runtime/Oberon.Mod + + +v4: + @printf '\nMaking v4 library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/v4/Args.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/v4/Console.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/v4/Printer.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/v4/Sets.Mod + +ooc2: + @printf '\nMaking ooc2 library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2Strings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2Ascii.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2CharClass.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2ConvTypes.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2IntConv.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2IntStr.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc2/ooc2Real0.Mod + +ooc: + @printf '\nMaking ooc library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLowReal.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLowLReal.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocRealMath.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocOakMath.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLRealMath.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLongInts.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocComplexMath.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLComplexMath.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocAscii.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocCharClass.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocStrings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocConvTypes.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLRealConv.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocLRealStr.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocRealConv.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocRealStr.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocIntConv.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocIntStr.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocMsg.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocSysClock.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocTime.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocChannel.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocStrings2.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocRts.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocFilenames.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocTextRider.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocBinaryRider.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocJulianDay.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocFilenames.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocwrapperlibc.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ooc/oocC$(DATAMODEL).Mod + +oocX11: + @printf '\nMaking oocX11 library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/oocX11/oocX11.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/oocX11/oocXutil.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/oocX11/oocXYplane.Mod + +ulm: + @printf '\nMaking ulm library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTypes.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmObjects.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmPriorities.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmDisciplines.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmServices.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSys.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSYSTEM.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmEvents.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmProcess.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmResources.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmForwarders.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmRelatedEvents.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmStreams.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmStrings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSysTypes.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTexts.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSysConversions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmErrors.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSysErrors.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSysStat.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmASCII.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSets.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmIO.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmAssertions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmIndirectDisciplines.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmStreamDisciplines.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmIEEE.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmMC68881.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmReals.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmPrint.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmWrite.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmConstStrings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmPlotters.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmSysIO.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmLoader.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmNetIO.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmPersistentObjects.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmPersistentDisciplines.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmOperations.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmScales.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTimes.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmClocks.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTimers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmConditions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmStreamConditions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTimeConditions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmCiphers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmCipherOps.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmBlockCiphers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmAsymmetricCiphers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmConclusions.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmRandomGenerators.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmTCrypt.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/ulm/ulmIntOperations.Mod + +pow32: + @printf '\nMaking pow library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/pow/powStrings.Mod + +misc: + @printf '\nMaking misc library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/misc/crt.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/misc/Listen.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/misc/MersenneTwister.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/misc/MultiArrays.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/misc/MultiArrayRiders.Mod + +s3: + @printf '\nMaking s3 library for -O$(MODEL)\n' + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethBTrees.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethMD5.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethSets.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlib.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlibBuffers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlibInflate.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlibDeflate.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlibReaders.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZlibWriters.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethZip.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethRandomNumbers.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethGZReaders.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethGZWriters.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethUnicode.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethDates.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethReals.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethStrings.Mod + cd $(BUILDDIR)/$(MODEL); "$(ROOTDIR)/$(OBECOMP)" -Fs -O$(MODEL) ../../../src/library/s3/ethBase64.Mod + + + + +O2library: runtime v4 ooc2 ooc ulm pow32 misc s3 + +OClibrary: runtime + +library: + @printf '\nCompiling lib$(ONAME)-O$(MODEL) sources\n' + rm -rf $(BUILDDIR)/$(MODEL) + mkdir -p $(BUILDDIR)/$(MODEL) + cp $(BUILDDIR)/SYSTEM.[ho] $(BUILDDIR)/$(MODEL) + cp src/runtime/*.Txt $(BUILDDIR)/$(MODEL) + cp $(BUILDDIR)/WindowsWrapper.h $(BUILDDIR)/$(MODEL) + @make -f src/tools/make/oberon.mk -s O$(MODEL)library MODEL=$(MODEL) + @printf '\nMaking lib$(ONAME)-O$(MODEL) .a and .so\n' + ar rcs "$(BUILDDIR)/$(MODEL)/lib$(ONAME)-O$(MODEL).a" $(BUILDDIR)/$(MODEL)/*.o + @cd $(BUILDDIR)/$(MODEL) && $(COMPILE) -shared -o lib$(ONAME)-O$(MODEL)$(DYNEXT) *.o + + + +sourcechanges: + @cd $(BUILDDIR) && sh "$(ROOTDIR)/src/tools/make/sourcechanges.sh" "$(ROOTDIR)/bootstrap/$(PLATFORM)-$(ADRSIZE)$(ALIGNMENT)" + + + +RUNTEST = COMPILER=$(COMPILER) OBECOMP="$(OBECOMP) -O$(MODEL)" FLAVOUR=$(FLAVOUR) BRANCH=$(BRANCH) sh ./test.sh "$(ROOTDIR)/install" + +confidence: + @printf '\n\n--- Confidence tests ---\n\n' + cd src/test/confidence/hello; $(RUNTEST) + cd src/test/confidence/out; $(RUNTEST) + cd src/test/confidence/in; $(RUNTEST) + cd src/test/confidence/math; $(RUNTEST) + cd src/test/confidence/intsyntax; $(RUNTEST) + cd src/test/confidence/language; $(RUNTEST) + cd src/test/confidence/arrayassignment; $(RUNTEST) + cd src/test/confidence/texts; $(RUNTEST) + cd src/test/confidence/library; $(RUNTEST) + cd src/test/confidence/isptest; $(RUNTEST) + cd src/test/confidence/lola; $(RUNTEST) + if [ "$(PLATFORM)" != "windows" ] ; then cd src/test/confidence/signal; $(RUNTEST); fi + @printf '\n\n--- Confidence tests passed ---\n\n' diff --git a/src/tools/make/sourcechanges.sh b/src/tools/make/sourcechanges.sh new file mode 100644 index 00000000..86aa9542 --- /dev/null +++ b/src/tools/make/sourcechanges.sh @@ -0,0 +1,33 @@ +# Source change tests. +# +# Compares compiler source files against the appropriate bootstrap source. +# The voc compiler version comment line is skipped. +# +# Parameters +# +# $1 - bootstrap directory +# +# Assumptions +# +# The current directory is the build directory + +changes="0" +find "$1" -type f -print0 | while IFS= read -r -d '' f; do + fn=$(basename "$f") + grep -E -v -f ../../src/tools/make/ignore "$f" >$fn.old + grep -E -v -f ../../src/tools/make/ignore $fn >$fn.new + if ! diff -U 2 -b $fn.old $fn.new >$fn.diff; then + echo "" + echo "" + cat $fn.diff + changes=1; + fi + rm -f $fn.old $fn.new $fn.diff +done +echo "" +if [ "$changes" = "0" ]; then + echo "--- Generated c source files match bootstrap ---" +else + echo "--- Generated c source files differ from bootstrap ---" +fi +echo "" diff --git a/src/tools/ocat/OCatCmd.Mod b/src/tools/ocat/OCatCmd.Mod index 030011a1..3d76a745 100644 --- a/src/tools/ocat/OCatCmd.Mod +++ b/src/tools/ocat/OCatCmd.Mod @@ -2,7 +2,7 @@ MODULE OCatCmd; (* J. Templ, 13-Jan-96 *) (* looks at the OBERON search path and writes one or more Oberon or ascii texts to standard out *) - IMPORT Args, Console, Files := Files0, Texts := Texts0; + IMPORT Args, Console, Files, Texts; PROCEDURE Cat*; VAR path: ARRAY 128 OF CHAR; i: INTEGER; T: Texts.Text; R: Texts.Reader; ch: CHAR; tab: BOOLEAN; diff --git a/src/tools/testcoordinator/IP.Mod b/src/tools/testcoordinator/IP.Mod new file mode 100644 index 00000000..cec11d98 --- /dev/null +++ b/src/tools/testcoordinator/IP.Mod @@ -0,0 +1,283 @@ +MODULE IP; + +IMPORT SYSTEM, Platform, Console; + +CONST + FDcount- = 1024; (* Number of FDs in FD set *) + +TYPE + SocketAddress* = RECORD + length-: LONGINT; + buf: ARRAY 28 OF SYSTEM.BYTE; (* Sufficient for IPv4 and IPv6. *) + END; + FDset* = ARRAY 128 OF SYSTEM.BYTE; (* Exposes C fd_set *) + + InAddr = POINTER TO InAddrDesc; + InAddrDesc = RECORD + addr: ARRAY 128 OF SYSTEM.BYTE; + next: InAddr + END; + +VAR + v4-: LONGINT; (* AF_INET *) + v6-: LONGINT; (* AF_INET6 *) + Stream-: LONGINT; (* SOCK_STREAM *) + Datagram-: LONGINT; (* SOCK_DGRAM *) + + + (* Testing *) + + addr: InAddr; + err: Platform.ErrorCode; + + + PROCEDURE -AAincludetypes "#include "; + PROCEDURE -AAincludetime "#include "; + PROCEDURE -AAincludesocket "#include "; + PROCEDURE -AAincludeselect "#include "; + PROCEDURE -AAincludenetdb "#include "; + + + PROCEDURE -AICANONNAME (): LONGINT "AI_CANONNAME"; + PROCEDURE -AIPASSIVE (): LONGINT "AI_PASSIVE "; + PROCEDURE -AFUNSPEC (): LONGINT "AF_UNSPEC"; + PROCEDURE -AFINET (): LONGINT "AF_INET"; + PROCEDURE -AFINET6 (): LONGINT "AF_INET6"; + PROCEDURE -SOCKSTREAM (): LONGINT "SOCK_STREAM"; + PROCEDURE -SOCKDGRAM (): LONGINT "SOCK_DGRAM"; + PROCEDURE -NINUMERICHOST(): LONGINT "NI_NUMERICHOST"; + PROCEDURE -NINUMERICSERV(): LONGINT "NI_NUMERICSERV"; + PROCEDURE -EAISYSTEM (): LONGINT "EAI_SYSTEM"; + PROCEDURE -EAIFAIL (): LONGINT "EAI_FAIL"; + + +(* Console output convenience APIs *) + + PROCEDURE cs (s: ARRAY OF CHAR); BEGIN Console.String(s) END cs; + PROCEDURE csl(s: ARRAY OF CHAR); BEGIN Console.String(s); Console.Ln END csl; + PROCEDURE ci (i,w: LONGINT); BEGIN Console.Int(i,w) END ci; + PROCEDURE ch (i: LONGINT); BEGIN Console.Hex(i) END ch; + PROCEDURE cc (c: CHAR); BEGIN Console.Char(c) END cc; + PROCEDURE cl (); BEGIN Console.Ln END cl; + PROCEDURE hex(i: INTEGER): CHAR; + BEGIN IF i < 10 THEN RETURN CHR(i+48) ELSE RETURN CHR(i+55) END END hex; + PROCEDURE cb (b: SYSTEM.BYTE); + VAR v: INTEGER; + BEGIN + v := SYSTEM.VAL(INTEGER, b); cc(hex(v DIV 16)); cc(hex(v MOD 16)); + END cb; + + + PROCEDURE -getnameinfo(sa, salen, flags: LONGINT; VAR host, serv: ARRAY OF CHAR): INTEGER + "(INTEGER)getnameinfo((const struct sockaddr*)sa, salen, host, host__len, serv, serv__len, flags)"; + + PROCEDURE WriteSocketAddress*(s: SocketAddress); + VAR host, service: ARRAY 4096 OF CHAR; IPv6: BOOLEAN; + BEGIN + IPv6 := s.length > 20; (* IPv4 len = 16, IPv6 len = 28 *) + IF getnameinfo(SYSTEM.ADR(s.buf), s.length, NINUMERICHOST(), host, service) >= 0 THEN + IF IPv6 THEN cc('[') END; cs(host); IF IPv6 THEN cs("]:") ELSE cc(':') END; + cs(service) + END + END WriteSocketAddress; + + PROCEDURE SameAddress*(s1, s2: SocketAddress): BOOLEAN; + (* True if same IP address, independent of port number *) + VAR host1, host2, service: ARRAY 4096 OF CHAR; i: INTEGER; result: BOOLEAN; + BEGIN + result := getnameinfo(SYSTEM.ADR(s1.buf), s1.length, NINUMERICHOST(), host1, service) >= 0; + IF result THEN result := getnameinfo(SYSTEM.ADR(s2.buf), s2.length, NINUMERICHOST(), host2, service) >= 0 END; + cs("host1: '"); cs(host1); cs("', host2: '"); cs(host2); csl("'."); + IF result THEN + i := 0; + WHILE (host1[i] # 0X) & (host2[i] # 0X) & (host1[i] = host2[i]) DO INC(i) END; + result := host1[i] = host2[i] + END; + RETURN result; + END SameAddress; + + PROCEDURE -aiFlags (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_flags"; + PROCEDURE -aiFamily (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_family"; + PROCEDURE -aiSocketType(p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_socktype"; + PROCEDURE -aiProtocol (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_protocol"; + PROCEDURE -aiAddrLen (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_addrlen"; + PROCEDURE -aiSockAddr (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_addr"; + PROCEDURE -aiCanonName (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_canonname"; + PROCEDURE -aiNext (p: LONGINT): LONGINT "(LONGINT)((struct addrinfo*)p)->ai_next"; + + + PROCEDURE -caddrinfo(family, socktype, protocol, flags: LONGINT) "struct addrinfo ai={flags,family,socktype,protocol,0}"; + PROCEDURE -caddrinfoptr "struct addrinfo *pai"; + PROCEDURE -getaddrinfo(host, service: LONGINT): INTEGER + "(INTEGER)getaddrinfo((char*)host, (char*)service, &ai, &pai)"; + PROCEDURE -pai(): LONGINT "(LONGINT)pai"; + PROCEDURE -freeaddrinfo(addrinfo: LONGINT) "freeaddrinfo((struct addrinfo*)addrinfo)"; + + + (* To get a local receiving address, past host as an empty string. *) + PROCEDURE Lookup*(host, service: ARRAY OF CHAR; family, socktype: LONGINT; VAR addr: SocketAddress): Platform.ErrorCode; + VAR addrinfo, hostptr, flags: LONGINT; result: Platform.ErrorCode; + BEGIN + IF host[0] = 0X THEN + hostptr := 0; flags := AIPASSIVE(); + ELSE + hostptr := SYSTEM.ADR(host); flags := 0; + END; + caddrinfo(family, socktype, 0, flags); + caddrinfoptr; + result := getaddrinfo(hostptr, SYSTEM.ADR(service)); + IF result = EAISYSTEM() THEN RETURN Platform.Error() END; + (* Return getaddrinfo specific reslts as negative numbers to avoid clash with OS error codes. *) + IF result # 0 THEN RETURN -ABS(result) END; + + addrinfo := pai(); addr.length := aiAddrLen(addrinfo); + IF (addrinfo = 0) OR (addr.length <= 0) THEN RETURN SHORT(-ABS(EAIFAIL())) END; + + ASSERT(addr.length <= LEN(addr.buf)); + SYSTEM.MOVE(aiSockAddr(addrinfo), SYSTEM.ADR(addr.buf), addr.length); + + freeaddrinfo(addrinfo); + + RETURN result; + END Lookup; + + + + + PROCEDURE -socket(domain, type, protocol: LONGINT): LONGINT + "(LONGINT)socket((int)domain, (int)type, (int)protocol)"; + + PROCEDURE Socket*(domain, type: LONGINT; VAR fd: LONGINT): Platform.ErrorCode; + BEGIN + fd := socket(domain, type, 0); (* No supported domain needs a non-zero protocol *) + IF fd < 0 THEN RETURN Platform.Error() END; + RETURN 0; + END Socket; + + + + + PROCEDURE -bind(sockfd: LONGINT; addr, addrlen: LONGINT): INTEGER + "(INTEGER)bind((int)sockfd, (const struct sockaddr*)addr, (socklen_t)addrlen)"; + + PROCEDURE Bind*(sockfd: LONGINT; address: SocketAddress): Platform.ErrorCode; + BEGIN + IF bind(sockfd, SYSTEM.ADR(address.buf), address.length) < 0 THEN RETURN Platform.Error() END; + RETURN 0; + END Bind; + + + + + PROCEDURE -listen(sockfd, backlog: LONGINT): INTEGER + "(INTEGER)listen((int)sockfd, (int)backlog)"; + + PROCEDURE Listen*(sockfd, backlog: LONGINT): INTEGER; + BEGIN RETURN listen(sockfd, backlog) + END Listen; + + + + + PROCEDURE -accept(sockfd: LONGINT; addr, addrlen: LONGINT): LONGINT + "(LONGINT)accept((int)sockfd, (struct sockaddr*)addr, (socklen_t*)addrlen)"; + + PROCEDURE Accept*(sockfd: LONGINT; VAR address: SocketAddress; VAR newfd: LONGINT): Platform.ErrorCode; + BEGIN + address.length := LEN(address.buf); + newfd := accept(sockfd, SYSTEM.ADR(address.buf), SYSTEM.ADR(address.length)); + IF newfd < 0 THEN RETURN Platform.Error() END; + RETURN 0 + END Accept; + + + + + PROCEDURE -connect(sockfd, addr, length: LONGINT): INTEGER + "(INTEGER)connect((int)sockfd, (struct sockaddr*)addr, (socklen_t)length)"; + + PROCEDURE Connect*(sockfd: LONGINT; addr: SocketAddress): Platform.ErrorCode; + BEGIN + IF connect(sockfd, SYSTEM.ADR(addr.buf), addr.length) < 0 THEN RETURN Platform.Error() END; + RETURN 0; + END Connect; + + + + + PROCEDURE -recvfrom(sockfd, buf, buflen, flags, saddr: LONGINT; socklen: LONGINT): INTEGER + "(INTEGER)recvfrom((int)sockfd, (void*)buf, (size_t)buflen, (int)flags, (struct sockaddr*)saddr, (socklen_t*)socklen)"; + + PROCEDURE ReceiveFrom*( + sockfd: LONGINT; + VAR buf: ARRAY OF SYSTEM.BYTE; VAR length: LONGINT; + flags: LONGINT; + VAR sockaddr: SocketAddress + ): Platform.ErrorCode; + BEGIN + sockaddr.length := LEN(sockaddr.buf); + length := recvfrom( + sockfd, + SYSTEM.ADR(buf), LEN(buf), + flags, + SYSTEM.ADR(sockaddr.buf), SYSTEM.ADR(sockaddr.length) + ); + IF length < 0 THEN RETURN Platform.Error() END; + RETURN 0; + END ReceiveFrom; + + + + PROCEDURE -sendto(sockfd, buf, len, flags, addr, addrlen: LONGINT): LONGINT + "(LONGINT)sendto((int)sockfd, (void*)buf, (size_t)len, (int)flags, (struct sockaddr*)addr, (socklen_t)addrlen)"; + + PROCEDURE SendTo*(sockfd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; buflen, flags: LONGINT; addr: SocketAddress): Platform.ErrorCode; + BEGIN + IF sendto(sockfd, SYSTEM.ADR(buf), buflen, flags, SYSTEM.ADR(addr.buf), addr.length) < 0 THEN + RETURN Platform.Error() + ELSE + RETURN 0 + END + END SendTo; + + + + + PROCEDURE -FDZERO(VAR fds: FDset) "FD_ZERO((fd_set*)fds)"; + PROCEDURE ZeroFDs*(VAR fds: FDset); BEGIN FDZERO(fds) END ZeroFDs; + + PROCEDURE -FDCLR(i: LONGINT; VAR fds: FDset) "FD_CLR((int)i, (fd_set*)fds)"; + PROCEDURE ClearFD*(i: LONGINT; VAR fds: FDset); BEGIN FDCLR(i, fds) END ClearFD; + + PROCEDURE -FDSET(i: LONGINT; VAR fds: FDset) "FD_SET((int)i, (fd_set*)fds)"; + PROCEDURE SetFD*(i: LONGINT; VAR fds: FDset); BEGIN FDSET(i, fds) END SetFD; + + PROCEDURE -FDISSET(i: LONGINT; VAR fds: FDset): INTEGER "(INTEGER)FD_ISSET((int)i, (fd_set*)fds)"; + PROCEDURE FDisSet*(i: LONGINT; VAR fds: FDset): BOOLEAN; + BEGIN RETURN FDISSET(i, fds) # 0 END FDisSet; + + PROCEDURE -SizeofFdSet(): LONGINT "(LONGINT)sizeof(fd_set)"; + + + PROCEDURE -timeval(ms: LONGINT) "struct timeval tv = {ms/1000, (ms%1000)*1000}"; + PROCEDURE -select(socketLimit: LONGINT; VAR read, write, except: FDset): LONGINT + "select((int)socketLimit, (fd_set*)read, (fd_set*)write, (fd_set*)except, &tv)"; + + PROCEDURE Select*(socketLimit: LONGINT; VAR read, write, except: FDset; ms: LONGINT; VAR readycount: LONGINT): Platform.ErrorCode; + BEGIN + timeval(ms); + readycount := select(socketLimit, read, write, except); + IF readycount < 0 THEN readycount := 0; RETURN Platform.Error() END; + RETURN 0 + END Select; + + + + +BEGIN + ASSERT(SIZE(FDset) >= SizeofFdSet()); + v4 := AFINET(); + v6 := AFINET6(); + Stream := SOCKSTREAM(); + Datagram := SOCKDGRAM(); +END IP. diff --git a/src/tools/testcoordinator/TestClient.Mod b/src/tools/testcoordinator/TestClient.Mod new file mode 100644 index 00000000..efbc2597 --- /dev/null +++ b/src/tools/testcoordinator/TestClient.Mod @@ -0,0 +1,219 @@ +MODULE TestClient; + +IMPORT IP, Platform, Console, Strings, SYSTEM; + +CONST + ServerName = "gan.brownsmeet.com"; + ServerPort = "2055"; + +TYPE + LineBuffer = RECORD + text: ARRAY 4096 OF CHAR; + length: INTEGER; + CR: BOOLEAN + END; + +VAR + Socket: Platform.FileHandle; + Server: IP.SocketAddress; + Param: ARRAY 1024 OF CHAR; + Buffer: LineBuffer; + +(* Console output convenience APIs *) + +PROCEDURE cs(s: ARRAY OF CHAR); +(* Oberon07 compatible variant of Console.String (LEN(s) safe). *) +VAR i: LONGINT; +BEGIN + i := 0; WHILE (i10 THEN eu(l DIV 10) END; ec(CHR(ORD('0') + (l MOD 10))) END eu; +PROCEDURE ei(l: LONGINT); + BEGIN IF l<0 THEN ec('-'); l := -l END; eu(l) END ei; + + + +PROCEDURE ConnectSocket; +VAR err: Platform.ErrorCode; +BEGIN + err := IP.Connect(Socket, Server); + WHILE Platform.ConnectionFailed(err) OR Platform.TimedOut(err) DO + es("Waiting for coordinator, error code: "); ei(err); esl("."); + Platform.Delay(30000); + err := IP.Connect(Socket, Server); + END; + ErrorCheck(err, "Couldn't connect to server: "); +END ConnectSocket; + + +PROCEDURE LogStdIn; +VAR i, n: LONGINT; inbuf: ARRAY 8192 OF CHAR; +BEGIN + ConnectSocket; + ErrorCheck(Platform.ReadBuf(Platform.StdIn, inbuf, n), "Failure reading standard input: "); + InitBuffer; + WHILE n > 0 DO + i := 0; + WHILE i < n DO LogCharacter(inbuf[i]); INC(i) END; + ErrorCheck(Platform.ReadBuf(Platform.StdIn, inbuf, n), "Failure reading standard input: "); + END; + FlushLog; +END LogStdIn; + + +PROCEDURE SendString(s: ARRAY OF CHAR); +BEGIN + ErrorCheck(Platform.Write(Socket, SYSTEM.ADR(s), Strings.Length(s)), + "Failed to write string to socket: "); +END SendString; + + +PROCEDURE SendStrings(s1, s2: ARRAY OF CHAR); +VAR buf: ARRAY 4096 OF CHAR; +BEGIN COPY(s1, buf); Strings.Append(s2, buf); SendString(buf) +END SendStrings; + + +PROCEDURE Continue; +BEGIN ConnectSocket; SendStrings("-continue ", Param) +END Continue; + + +PROCEDURE Wait; +VAR buf: ARRAY 64 OF CHAR; n: LONGINT; err: Platform.ErrorCode; waiting: BOOLEAN; +BEGIN + waiting := TRUE; + WHILE waiting DO + ConnectSocket; SendStrings("-wait ", Param); + ErrorCheck(Platform.ReadBuf(Socket, buf, n), "Failed to read command from test coordinator: "); + waiting := n <= 0 (* n=0 => coordinator was terminated *) + END; + IF n < LEN(buf) THEN buf[n] := 0X END; + es("Received command: '"); es(buf); esl("'."); + csl(buf); + IF buf = "exit" THEN Platform.Exit(1) END +END Wait; + + +PROCEDURE Help; +BEGIN + cl; + csl("TestClient - test log client"); cl; + csl("usage:"); cl; + csl(" command | TestClient -s id - Send command output identified by id."); + csl(" TestClient -w id - wait until TestClient -c runs somewhere."); + csl(" TestClient -c - continue all pending TestClient -w commands."); + Platform.Exit(0); +END Help; + + +PROCEDURE ParseParameters; +VAR option: ARRAY 1024 OF CHAR; +BEGIN + IF Platform.ArgCount > 1 THEN Platform.GetArg(1, option) END; + IF Platform.ArgCount = 3 THEN Platform.GetArg(2, Param) END; + + IF (Platform.ArgCount = 3) & (option = "-w") THEN Wait + ELSIF (Platform.ArgCount = 3) & (option = "-c") THEN Continue + ELSIF (Platform.ArgCount = 3) & (option = "-s") THEN LogStdIn + ELSE Help + END +END ParseParameters; + + + + +BEGIN + ErrorCheck(IP.Socket(IP.v4, IP.Stream, Socket), "Couldn't create sender socket: "); + ErrorCheck(IP.Lookup(ServerName, ServerPort, IP.v4, IP.Stream, Server), + "Couldn't lookup server socket address: "); + ParseParameters; + ErrorCheck(Platform.Close(Socket), "Couldn't close socket: ") +END TestClient. + diff --git a/src/tools/testcoordinator/TestCoordinator.Mod b/src/tools/testcoordinator/TestCoordinator.Mod new file mode 100644 index 00000000..b7983472 --- /dev/null +++ b/src/tools/testcoordinator/TestCoordinator.Mod @@ -0,0 +1,270 @@ +MODULE TestCoordinator; + +(* +Listens for client test machines, telling them when to start tests and recording +status and log data that they send. +Also listens to command machine that says when to start a new set of tests. +*) + +IMPORT IP, Platform, SYSTEM, Console, Strings; + +CONST + ListenPort = "2055"; + CoIdle = 0; + CoConnected = 1; + CoUnderway = 2; + CoWaiting = 3; + +TYPE + Connection = POINTER TO ConnectionState; + ConnectionState = RECORD + fd: LONGINT; (* Socket descriptor *) + state: INTEGER; (* CoIdle / CoConnected / CoWaiting *) + file: Platform.FileHandle; + text: ARRAY 4096 OF CHAR; + length: INTEGER; + CR: BOOLEAN; + END; + +VAR + MaxSocket: LONGINT; + Listener: LONGINT; + Connections: ARRAY IP.FDcount OF Connection; + + +(* Console output convenience APIs *) + +PROCEDURE cs (s: ARRAY OF CHAR); +(* Oberon07 compatible variant of Console.String (LEN(s) safe). *) +VAR i: LONGINT; +BEGIN + i := 0; WHILE (i END; *) + IF co.CR OR (c = 0AX) THEN FlushLine(co) END; + CASE c OF + 0DX: co.CR := TRUE + | 0AX: + ELSE co.text[co.length] := c; INC(co.length) + END +END lc; + +PROCEDURE ls(co: Connection; s: ARRAY OF CHAR); +VAR i: LONGINT; +BEGIN i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO lc(co, s[i]); INC(i) END +END ls; + + + + +PROCEDURE AcceptConnection; +VAR + Them: IP.SocketAddress; + fd: LONGINT; +BEGIN + ErrorCheck(IP.Accept(Listener, Them, fd), "Accept failed: "); + IF fd > MaxSocket THEN MaxSocket := fd END; + InitConnection(fd); + (* TODO: Set fd as non-blocking: O_NONBLOCK and fcntl(). *) +END AcceptConnection; + + +PROCEDURE Continue(co: Connection; param: ARRAY OF CHAR); +VAR msg: ARRAY 10 OF CHAR; err: Platform.ErrorCode; +BEGIN + cs("Starting fd "); ci(co.fd,1); cl; + msg := "Go."; + ErrorCheck(Platform.Write(co.fd, SYSTEM.ADR(param), Strings.Length(param)), "Couldn't send continue message: "); + ErrorCheck(Platform.Close(co.fd), "Couldn't close waiting socket: "); + co.fd := 0; + co.state := CoIdle; +END Continue; + + +PROCEDURE ParseWord(buf: ARRAY OF CHAR; VAR i: INTEGER; VAR word: ARRAY OF CHAR); +VAR j: INTEGER; +BEGIN +END ParseWord; + + +PROCEDURE Command(co: Connection; buf: ARRAY OF CHAR); +VAR cmd, param: ARRAY 1024 OF CHAR; i,j: INTEGER; +BEGIN + i := 0; + (* The command is everything up to the first space *) + WHILE (i 32) DO + cmd[j] := buf[i]; INC(i); INC(j) + END; + IF j < LEN(cmd) THEN cmd[j] := 0X END; + + (* The parameter is everything else (except leading spaces). *) + WHILE (i 0 THEN FlushLine(co) END; + IF co.file # 0 THEN + ErrorCheck(Platform.Close(co.file), "Failed to close connection log file: "); + END; + co.state := CoIdle; + co.file := 0; + END +END ConnectionClosed; + + +PROCEDURE Cycle; +VAR + Us: IP.SocketAddress; + err: Platform.ErrorCode; + n: LONGINT; + rbuf: ARRAY 4100 OF CHAR; + i: LONGINT; + waitcount: LONGINT; + readFDs: IP.FDset; + noFDs: IP.FDset; + co: Connection; +BEGIN + IP.ZeroFDs(noFDs); + + ErrorCheck(IP.Socket(IP.v4, IP.Stream, Listener), "Couldn't create listener socket: "); + ErrorCheck(IP.Lookup("", ListenPort, IP.v4, IP.Stream, Us), "Couldn't lookup our own socket address: "); + ErrorCheck(IP.Bind (Listener, Us), "Bind failed: "); + ErrorCheck(IP.Listen(Listener, 10), "Listen failed: "); + + csl("Test coordinator listening for test clients."); + + MaxSocket := Listener; + LOOP + (* Prepare select parameters *) + IP.ZeroFDs(readFDs); + IP.SetFD(Listener, readFDs); + i := 0; WHILE i <= MaxSocket DO + co := Connections[i]; + IF (co # NIL) & (co.state >= CoConnected) THEN IP.SetFD(i, readFDs) END; + INC(i) END; + + (* Wait for some fd to need servicing, or 60 seconds. *) + ErrorCheck(IP.Select(MaxSocket+1, readFDs, noFDs, noFDs, 60000, waitcount), "Wait for next service activity failed: "); + IF waitcount > 0 THEN + i := 0; + WHILE i <= MaxSocket DO + IF IP.FDisSet(i, readFDs) THEN + IF i = Listener THEN + AcceptConnection; + ELSE + ErrorCheck(Platform.ReadBuf(i, rbuf, n), "ReadBuf failed: "); + IF n = 0 THEN + ConnectionClosed(Connections[i]); (* Client has closed the connection in an orderly manner. *) + ELSE + DataReceived(Connections[i], rbuf, n) + END + END + END; + INC(i) + END + END + END; + err := Platform.Close(Listener) +END Cycle; + +BEGIN + Cycle; +END TestCoordinator. + diff --git a/src/tools/vocparam/vocparam.c b/src/tools/vocparam/vocparam.c deleted file mode 100644 index 4fb325fd..00000000 --- a/src/tools/vocparam/vocparam.c +++ /dev/null @@ -1,78 +0,0 @@ -/* J. Templ 23.6.95 -this program tests and outputs important characteristics of -the C compiler and SYSTEM.h file used to compile it. -The output of this program is accepted by voc as file voc.par. -% cc vocparam.c; a.out > voc.par -*/ - - -#include "SYSTEM.h" -#include "stdio.h" - -struct {CHAR ch; CHAR x;} c; -struct {CHAR ch; BOOLEAN x;} b; -struct {CHAR ch; SHORTINT x;} si; -struct {CHAR ch; INTEGER x;} i; -struct {CHAR ch; LONGINT x;} li; -struct {CHAR ch; SYSTEM_INT8 x;} i8; -struct {CHAR ch; SYSTEM_INT16 x;} i16; -struct {CHAR ch; SYSTEM_INT32 x;} i32; -struct {CHAR ch; SYSTEM_INT64 x;} i64; -struct {CHAR ch; SET x;} s; -struct {CHAR ch; REAL x;} r; -struct {CHAR ch; LONGREAL x;} lr; -struct {CHAR ch; void *x;} p; -struct {CHAR ch; void (*x)();} f; -struct {CHAR ch;} rec0; -struct {CHAR ch; LONGREAL x;} rec1; -struct {char x[65];} rec2; - -int main() -{ - long x, y; - /* get size and alignment of standard types */ - printf("CHAR %lu %lu\n", sizeof(CHAR), (char*)&c.x - (char*)&c); - printf("BOOLEAN %lu %lu\n", sizeof(BOOLEAN), (char*)&b.x - (char*)&b); - printf("SHORTINT %lu %lu\n", sizeof(SHORTINT), (char*)&si.x - (char*)&si); - printf("INTEGER %lu %lu\n", sizeof(INTEGER), (char*)&i.x - (char*)&i); - printf("LONGINT %lu %lu\n", sizeof(LONGINT), (char*)&li.x - (char*)&li); - printf("SET %lu %lu\n", sizeof(SET), (char*)&s.x - (char*)&s); - printf("REAL %lu %lu\n", sizeof(REAL), (char*)&r.x - (char*)&r); - printf("LONGREAL %lu %lu\n", sizeof(LONGREAL), (char*)&lr.x - (char*)&lr); - printf("PTR %lu %lu\n", sizeof p.x, (char*)&p.x - (char*)&p); - printf("PROC %lu %lu\n", sizeof f.x, (char*)&f.x - (char*)&f); - printf("RECORD %d %lu\n", (sizeof rec2 == 65) == (sizeof rec0 == 1), sizeof rec2 - 64); - x = 1; - printf("ENDIAN %hhd %d\n", *(char*)&x, 0); - printf("SYSTEM.INT8 %lu %lu\n", sizeof(SYSTEM_INT8), (char*)&i8.x - (char*)&i8); - printf("SYSTEM.INT16 %lu %lu\n", sizeof(SYSTEM_INT16), (char*)&i16.x - (char*)&i16); - printf("SYSTEM.INT32 %lu %lu\n", sizeof(SYSTEM_INT32), (char*)&i32.x - (char*)&i32); - printf("SYSTEM.INT64 %lu %lu\n", sizeof(SYSTEM_INT64), (char*)&i64.x - (char*)&i64); - - - if (sizeof(CHAR)!=1) printf("error: CHAR should have size 1\n"); - if (sizeof(BOOLEAN)!=1) printf("error: BOOLEAN should have size 1\n"); - if (sizeof(SHORTINT)!=1) printf("error: SHORTINT should have size 1\n"); - if (sizeof(long)!=sizeof p.x) printf("error: LONGINT should have the same size as pointers\n"); - if (sizeof(long)!=sizeof f.x) printf("error: LONGINT should have the same size as function pointers\n"); - if (((sizeof rec2 == 65) == (sizeof rec0 == 1)) && ((sizeof rec2 - 64) != sizeof rec0)) - printf("error: unsupported record layout sizeof rec0 = %lu sizeof rec2 = %lu\n", sizeof rec0, sizeof rec2); - - /* test the __ASHR macro */ - if (__ASHR(-1, 1) != -1) printf("error: ASH(-1, -1) # -1\n"); - if (__ASHR(-2, 1) != -1) printf("error: ASH(-2, -1) # -1\n"); - if (__ASHR(0, 1) != 0) printf("error: ASH(0, 1) # 0\n"); - if (__ASHR(1, 1) != 0) printf("error: ASH(1, 1) # 0\n"); - if (__ASHR(2, 1) != 1) printf("error: ASH(2, 1) # 1\n"); - - /* test the __SETRNG macro */ - x = 0; y = sizeof(SET)*8 - 1; - if (__SETRNG(x, y) != -1) printf("error: SETRNG(0, MAX(SET)) != -1\n"); - - /* test string comparison for extended ascii */ - {char a[10], b[10]; - a[0] = (CHAR)128; a[1] = 0; - b[0] = 0; - if (__STRCMP(a, b) < 0) printf("error: __STRCMP(a, b) with extended ascii charcters; should be unsigned\n"); - } -} diff --git a/src/voc/OPB.Mod b/src/voc/OPB.Mod deleted file mode 100644 index 1bf703a4..00000000 --- a/src/voc/OPB.Mod +++ /dev/null @@ -1,1613 +0,0 @@ -MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) -(* build parse tree *) - - IMPORT OPT, OPS, OPM, SYSTEM; - - CONST - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; - *) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; realSet = {Real, LReal}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; - haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; - entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; - shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - - (*SYSTEM function number*) - adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; - bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; - - AssertTrap = 0; (* default trap number *) - - VAR - typSize*: PROCEDURE(typ: OPT.Struct); - exp: INTEGER; (*side effect of log*) - maxExp: LONGINT; (* max n in ASH(1, n) on this machine *) - - PROCEDURE err(n: INTEGER); - BEGIN OPM.err(n) - END err; - - PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node; - VAR node: OPT.Node; - BEGIN - CASE obj^.mode OF - Var: - node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0) - | VarPar: - node := OPT.NewNode(Nvarpar) - | Con: - node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst(); - node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) - | Typ: - node := OPT.NewNode(Ntype) - | LProc..IProc: - node := OPT.NewNode(Nproc) - ELSE err(127); node := OPT.NewNode(Nvar) - END ; - node^.obj := obj; node^.typ := obj^.typ; - RETURN node - END NewLeaf; - - PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node; y: OPT.Node); - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(class); node^.typ := OPT.notyp; - node^.left := x; node^.right := y; x := node - END Construct; - - PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node); - BEGIN - IF x = NIL THEN x := y ELSE last^.link := y END ; - WHILE y^.link # NIL DO y := y^.link END ; - last := y - END Link; - - PROCEDURE BoolToInt(b: BOOLEAN): LONGINT; - BEGIN - IF b THEN RETURN 1 ELSE RETURN 0 END - END BoolToInt; - - PROCEDURE IntToBool(i: LONGINT): BOOLEAN; - BEGIN - IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END - END IntToBool; - - PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp; - x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x - END NewBoolConst; - - PROCEDURE OptIf*(VAR x: OPT.Node); (* x^.link = NIL *) - VAR if, pred: OPT.Node; - BEGIN - if := x^.left; - WHILE if^.left^.class = Nconst DO - IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN - ELSIF if^.link = NIL THEN x := x^.right; RETURN - ELSE if := if^.link; x^.left := if - END - END ; - pred := if; if := if^.link; - WHILE if # NIL DO - IF if^.left^.class = Nconst THEN - IF IntToBool(if^.left^.conval^.intval) THEN - pred^.link := NIL; x^.right := if^.right; RETURN - ELSE if := if^.link; pred^.link := if - END - ELSE pred := if; if := if^.link - END - END - END OptIf; - - PROCEDURE Nil*(): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp; - x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x - END Nil; - - PROCEDURE EmptySet*(): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.settyp; - x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x - END EmptySet; - - PROCEDURE SetIntType(node: OPT.Node); - VAR v: LONGINT(*SYSTEM.INT64*); - BEGIN v := node^.conval^.intval; - IF (OPM.MinSInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp - ELSIF (OPM.MinInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxInt) THEN node^.typ := OPT.inttyp - ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN - node^.typ := OPT.linttyp - (*ELSIF (OPM.MinInt64) <= v) & (v <= OPM.MaxInt64) THEN - node^.typ := OPT.int64typ*) - ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1 - END - END SetIntType; - - PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); - x^.conval^.intval := intval; SetIntType(x); RETURN x - END NewIntConst; - - PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); - x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc; - RETURN x - END NewRealConst; - - PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node; - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; - x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len; - x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str; - RETURN x - END NewString; - - PROCEDURE CharToString(n: OPT.Node); - VAR ch: CHAR; - BEGIN - n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt(); - IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ; - n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL - END CharToString; - - PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(class); node^.typ := typ; - node^.left := x; node^.right := y; x := node - END BindNodes; - - PROCEDURE NotVar(x: OPT.Node): BOOLEAN; - BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst)) - END NotVar; - - PROCEDURE DeRef*(VAR x: OPT.Node); - VAR strobj, bstrobj: OPT.Object; typ, btyp: OPT.Struct; - BEGIN - typ := x^.typ; - IF x^.class >= Nconst THEN err(78) - ELSIF typ^.form = Pointer THEN - IF typ = OPT.sysptrtyp THEN err(57) END ; - btyp := typ^.BaseTyp; strobj := typ^.strobj; bstrobj := btyp^.strobj; - IF (strobj # NIL) & (strobj^.name # "") & (bstrobj # NIL) & (bstrobj^.name # "") THEN - btyp^.pbused := TRUE - END ; - BindNodes(Nderef, btyp, x, NIL) - ELSE err(84) - END - END DeRef; - - PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node); - VAR f: INTEGER; typ: OPT.Struct; - BEGIN - f := y^.typ^.form; - IF x^.class >= Nconst THEN err(79) - ELSIF ~(f IN intSet) OR (y^.class IN {Nproc, Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; - IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END - ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END - ELSE err(82); typ := OPT.undftyp - END ; - BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly - END Index; - - PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object); - BEGIN (*x^.typ^.comp = Record*) - IF x^.class >= Nconst THEN err(77) END ; - IF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN - BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y; - x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0)) - ELSE err(83); x^.typ := OPT.undftyp - END - END Field; - - PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN); - - PROCEDURE GTT(t0, t1: OPT.Struct); - VAR node: OPT.Node; t: OPT.Struct; - BEGIN t := t0; - WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ; - IF t # t1 THEN - WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ; - IF (t1 = t0) OR (t0.form = Undef (*SYSTEM.PTR*)) THEN - IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly - ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; - node^.obj := obj; x := node - END - ELSE err(85) - END - ELSIF t0 # t1 THEN err(85) (* prevent down guard *) - ELSIF ~guard THEN - IF x^.class = Nguard THEN (* cannot skip guard *) - node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; - node^.obj := obj; x := node - ELSE x := NewBoolConst(TRUE) - END - END - END GTT; - - BEGIN - IF NotVar(x) THEN err(112) - ELSIF x^.typ^.form = Pointer THEN - IF (x^.typ^.BaseTyp^.comp # Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) - ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) - ELSE err(86) - END - ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN - GTT(x^.typ, obj^.typ) - ELSE err(87) - END ; - IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END - END TypTest; - - PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node); - VAR f: INTEGER; k: LONGINT; - BEGIN f := x^.typ^.form; - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN - IF x^.class = Nconst THEN - k := x^.conval^.intval; - IF (k < 0) OR (k > OPM.MaxSet) THEN err(202) - ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in - END - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in - END - ELSE err(92) - END ; - x^.typ := OPT.booltyp - END In; - - PROCEDURE log(x: LONGINT): LONGINT; - BEGIN exp := 0; - IF x > 0 THEN - WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END - END ; - RETURN x - END log; - - PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const); - VAR min, max, r: LONGREAL; - BEGIN - IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal - ELSE min := OPM.MinLReal; max := OPM.MaxLReal - END ; - r := ABS(x^.realval); - IF (r > max) OR (r < min) THEN - err(nr); x^.realval := 1.0 - ELSIF f = Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) - END ; - x^.intval := OPM.ConstNotAlloc - END CheckRealType; - - PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node); - VAR f: INTEGER; typ: OPT.Struct; z: OPT.Node; - - PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node; - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ; - node^.left := z; RETURN node - END NewOp; - - BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) THEN err(126) - ELSE typ := z^.typ; f := typ^.form; - CASE op OF - not: - IF f = Bool THEN - IF z^.class = Nconst THEN - z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(98) - END - | plus: - IF ~(f IN intSet + realSet) THEN err(96) END - | minus: - IF f IN intSet + realSet +{Set}THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN - IF z^.conval^.intval = MIN(LONGINT) THEN err(203) - ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z) - END - ELSIF f IN realSet THEN z^.conval^.realval := -z^.conval^.realval - ELSE z^.conval^.setval := -z^.conval^.setval - END ; - z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(97) - END - | abs: - IF f IN intSet + realSet THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN - IF z^.conval^.intval = MIN(LONGINT) THEN err(203) - ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z) - END - ELSE z^.conval^.realval := ABS(z^.conval^.realval) - END ; - z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111) - END - | cap: - IF f = Char THEN - IF z^.class = Nconst THEN - z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111); z^.typ := OPT.chartyp - END - | odd: - IF f IN intSet THEN - IF z^.class = Nconst THEN - z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111) - END ; - z^.typ := OPT.booltyp - | adr: (*SYSTEM.ADR*) - IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z) - ELSE err(127) - END ; - z^.typ := OPT.linttyp - | cc: (*SYSTEM.CC*) - IF (f IN intSet) & (z^.class = Nconst) THEN - IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END - ELSE err(69) - END ; - z^.typ := OPT.booltyp - ELSE - OPM.LogWStr("unhandled case in OPB.MOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; - END - END ; - x := z - END MOp; - - PROCEDURE CheckPtr(x, y: OPT.Node); - VAR g: INTEGER; p, q, t: OPT.Struct; - BEGIN g := y^.typ^.form; - IF g = Pointer THEN - p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN - IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ; - WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ; - IF p = NIL THEN err(100) END - ELSE err(100) - END - ELSIF g # NilTyp THEN err(100) - END - END CheckPtr; - - PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN); - VAR ft, at: OPT.Struct; - BEGIN - WHILE fp # NIL DO - IF ap # NIL THEN - ft := fp^.typ; at := ap^.typ; - WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO - ft := ft^.BaseTyp; at := at^.BaseTyp - END ; - IF ft # at THEN - IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN - IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE) - ELSE err(117) - END - ELSE err(115) - END - END ; - IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ; - ap := ap^.link - ELSE err(116) - END ; - fp := fp^.link - END ; - IF ap # NIL THEN err(116) END - END CheckParameters; - - PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *) - BEGIN - IF y^.mode IN {XProc, IProc, LProc} THEN - IF y^.mode = LProc THEN - IF y^.mnolev = 0 THEN y^.mode := XProc - ELSE err(73) - END - END ; - IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE) - ELSE err(117) - END - ELSE err(113) - END - END CheckProc; - - PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node); - VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: LONGINT; - temp: BOOLEAN; (* temp avoids err 215 *) - - PROCEDURE ConstCmp(): INTEGER; - VAR res: INTEGER; - BEGIN - CASE f OF - Undef: - res := eql - | Byte, Char..LInt(*,Int8..Int64*): - IF xval^.intval < yval^.intval THEN res := lss - ELSIF xval^.intval > yval^.intval THEN res := gtr - ELSE res := eql - END - | Real, LReal: - IF xval^.realval < yval^.realval THEN res := lss - ELSIF xval^.realval > yval^.realval THEN res := gtr - ELSE res := eql - END - | Bool: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql - END - | Set: - IF xval^.setval # yval^.setval THEN res := neq - ELSE res := eql - END - | String: - IF xval^.ext^ < yval^.ext^ THEN res := lss - ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr - ELSE res := eql - END - | NilTyp, Pointer, ProcTyp: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql - END - ELSE - OPM.LogWStr("unhandled case in OPB.ConstCmp, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; - END ; - x^.typ := OPT.booltyp; RETURN res - END ConstCmp; - - BEGIN - f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval; - IF f # g THEN - CASE f OF - Char: - IF g = String THEN CharToString(x) - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END ; - | SInt(*, Int8*): - IF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | Int(*, Int16, Int32, Int64*): - IF g = SInt THEN y^.typ := OPT.inttyp - ELSIF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | LInt: - IF g IN intSet THEN y^.typ := OPT.linttyp - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | Real: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | LReal: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = Real THEN y^.typ := OPT.lrltyp - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | String: - IF g = Char THEN CharToString(y); g := String - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END ; - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: - CheckPtr(x, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END ; - f := x^.typ^.form - END ; (* {x^.typ = y^.typ} *) - CASE op OF - times: - IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval; - IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *) - (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR - (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR - (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR - (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN - xval^.intval := xv * yv; SetIntType(x) - ELSE err(204) - END - ELSIF f IN realSet THEN - temp := ABS(yval^.realval) <= 1.0; - IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN - xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval) - ELSE err(204) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval * yval^.setval - ELSIF f # Undef THEN err(101) - END - | slash: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval) - ELSE err(205); xval^.realval := 1.0 - END ; - x^.typ := OPT.realtyp - ELSIF f IN realSet THEN - temp := ABS(yval^.realval) >= 1.0; - IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN - xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval) - ELSE err(205) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval / yval^.setval - ELSIF f # Undef THEN err(102) - END - | div: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x) - ELSE err(205) - END - ELSIF f # Undef THEN err(103) - END - | mod: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x) - ELSE err(205) - END - ELSIF f # Undef THEN err(104) - END - | and: - IF f = Bool THEN - xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval)) - ELSE err(94) - END - | plus: - IF f IN intSet THEN - temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval); - IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN - INC(xval^.intval, yval^.intval); SetIntType(x) - ELSE err(206) - END - ELSIF f IN realSet THEN - temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval); - IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN - xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) - ELSE err(206) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval + yval^.setval - ELSIF f # Undef THEN err(105) - END - | minus: - IF f IN intSet THEN - IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR - (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN - DEC(xval^.intval, yval^.intval); SetIntType(x) - ELSE err(207) - END - ELSIF f IN realSet THEN - temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval); - IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN - xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) - ELSE err(207) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval - yval^.setval - ELSIF f # Undef THEN err(106) - END - | or: - IF f = Bool THEN - xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval)) - ELSE err(95) - END - | eql: - xval^.intval := BoolToInt(ConstCmp() = eql) - | neq: - xval^.intval := BoolToInt(ConstCmp() # eql) - | lss: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = lss) - END - | leq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # gtr) - END - | gtr: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = gtr) - END - | geq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # lss) - END - ELSE - OPM.LogWStr("unhandled case in OPB.ConstOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; - END - END ConstOp; - - PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct); - VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL; - BEGIN f := x^.typ^.form; g := typ^.form; - IF x^.class = Nconst THEN - IF f IN intSet THEN - IF g IN intSet THEN - IF f > g THEN SetIntType(x); - IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END - END - ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc - ELSE (*g = Char*) k := x^.conval^.intval; - IF (0 > k) OR (k > 0FFH) THEN err(220) END - END - ELSIF f IN realSet THEN - IF g IN realSet THEN CheckRealType(g, 203, x^.conval) - ELSE (*g = LInt*) - r := x^.conval^.realval; - IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ; - x^.conval^.intval := ENTIER(r); SetIntType(x) - END - ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *) - END ; - x^.obj := NIL - ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN - (* don't create new node *) - IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END - ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node - END ; - x^.typ := typ - END Convert; - - PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node); - VAR f, g: INTEGER; t, z: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: LONGINT; - - PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ; - node^.left := x; node^.right := y; x := node - END NewOp; - - PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN; - VAR ok, xCharArr, yCharArr: BOOLEAN; - BEGIN - xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String); - yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String)); - IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ; - IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ; - ok := xCharArr & yCharArr; - IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *) - IF (f=String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) - x^.typ := OPT.chartyp; x^.conval^.intval := 0; - Index(y, NewIntConst(0)) - ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) - y^.typ := OPT.chartyp; y^.conval^.intval := 0; - Index(x, NewIntConst(0)) - END - END ; - RETURN ok - END strings; - - - BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (z^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, z, y); z^.obj := NIL - ELSE - IF z^.typ # y^.typ THEN - g := y^.typ^.form; - CASE z^.typ^.form OF - Char: - IF z^.class = Nconst THEN CharToString(z) ELSE err(100) END - | SInt(*, Int8*): - IF g IN intSet + realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | Int: - IF g = SInt THEN Convert(y, z^.typ) - ELSIF g IN intSet + realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | LInt(*, Int16, Int32, Int64*): - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | Real: - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | LReal: - IF g IN intSet + realSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(y, z^.typ) - ELSE err(100) - END - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: - CheckPtr(z, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END - | String: - | Comp: - IF z^.typ^.comp = Record THEN err(100) END - ELSE err(100) - END - END ; (* {z^.typ = y^.typ} *) - typ := z^.typ; f := typ^.form; g := y^.typ^.form; - CASE op OF - times: - do := TRUE; - IF f IN intSet THEN - IF z^.class = Nconst THEN val := z^.conval^.intval; - IF val = 1 THEN do := FALSE; z := y - ELSIF val = 0 THEN do := FALSE - ELSIF log(val) = 1 THEN - t := y; y := z; z := t; - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL - END - ELSIF y^.class = Nconst THEN val := y^.conval^.intval; - IF val = 1 THEN do := FALSE - ELSIF val = 0 THEN do := FALSE; z := y - ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL - END - END - ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp - END ; - IF do THEN NewOp(op, typ, z, y) END - | slash: - IF f IN intSet THEN - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; - Convert(z, OPT.realtyp); Convert(y, OPT.realtyp); - typ := OPT.realtyp - ELSIF f IN realSet THEN - IF (y^.class = Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END - ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | div: - do := TRUE; - IF f IN intSet THEN - IF y^.class = Nconst THEN val := y^.conval^.intval; - IF val = 0 THEN err(205) - ELSIF val = 1 THEN do := FALSE - ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL - END - END - ELSIF f # Undef THEN err(103); typ := OPT.undftyp - END ; - IF do THEN NewOp(op, typ, z, y) END - | mod: - IF f IN intSet THEN - IF y^.class = Nconst THEN - IF y^.conval^.intval = 0 THEN err(205) - ELSIF log(y^.conval^.intval) = 1 THEN - op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL - END - END - ELSIF f # Undef THEN err(104); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | and: - IF f = Bool THEN - IF z^.class = Nconst THEN - IF IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) - (* ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN - don't optimize z & FALSE -> FALSE: side effects possible *) - ELSE NewOp(op, typ, z, y) - END - ELSIF f # Undef THEN err(94); z^.typ := OPT.undftyp - END - | plus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(105); typ := OPT.undftyp END ; - do := TRUE; - IF f IN intSet THEN - IF (z^.class = Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END - END ; - IF do THEN NewOp(op, typ, z, y) END - | minus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(106); typ := OPT.undftyp END ; - IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END - | or: - IF f = Bool THEN - IF z^.class = Nconst THEN - IF ~IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) - (* ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN - don't optimize z OR TRUE -> TRUE: side effects possible *) - ELSE NewOp(op, typ, z, y) - END - ELSIF f # Undef THEN err(95); z^.typ := OPT.undftyp - END - | eql, neq: - IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp - ELSE err(107); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | lss, leq, gtr, geq: - IF (f IN {Undef, Char..LReal(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp - ELSE - OPM.LogWLn; OPM.LogWStr("ELSE in Op()"); OPM.LogWLn; - err(108); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - ELSE - OPM.LogWStr("unhandled case in OPB.Op, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; - END - END ; - x := z - END Op; - - PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node); - VAR k, l: LONGINT; - BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN - IF x^.class = Nconst THEN - k := x^.conval^.intval; - IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END - END ; - IF y^.class = Nconst THEN - l := y^.conval^.intval; - IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END - END ; - IF (x^.class = Nconst) & (y^.class = Nconst) THEN - IF k <= l THEN - x^.conval^.setval := {k..l} - ELSE err(201); x^.conval^.setval := {l..k} - END ; - x^.obj := NIL - ELSE BindNodes(Nupto, OPT.settyp, x, y) - END - ELSE err(93) - END ; - x^.typ := OPT.settyp - END SetRange; - - PROCEDURE SetElem*(VAR x: OPT.Node); - VAR k: LONGINT; - BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN intSet) THEN err(93) - ELSIF x^.class = Nconst THEN - k := x^.conval^.intval; - IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k} - ELSE err(202) - END ; - x^.obj := NIL - ELSE Convert(x, OPT.settyp) - END ; - x^.typ := OPT.settyp - END SetElem; - - PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *) - VAR f, g: INTEGER; y, p, q: OPT.Struct; - BEGIN - IF OPM.Verbose THEN - OPM.LogWLn; OPM.LogWStr("PROCEDURE CheckAssign"); OPM.LogWLn; - END; - y := ynode^.typ; f := x^.form; g := y^.form; - IF OPM.Verbose THEN - OPM.LogWStr("y.form = "); OPM.LogWNum(y.form, 0); OPM.LogWLn; - OPM.LogWStr("f = "); OPM.LogWNum(f, 0); OPM.LogWLn; - OPM.LogWStr("g = "); OPM.LogWNum(g, 0); OPM.LogWLn; - OPM.LogWStr("ynode.typ.syze = "); OPM.LogWNum(ynode.typ.size, 0); OPM.LogWLn; - END; - IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ; - CASE f OF - Undef, String: - (* | Int8: - IF (ynode.typ.size > OPM.Int8Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int8"); OPM.LogWLn END; - err(113) - END - | Int16: - IF (ynode.typ.size > OPM.Int16Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int16"); OPM.LogWLn END; - err(113) - END - | Int32: - IF (ynode.typ.size > OPM.Int32Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int32"); OPM.LogWLn END; - err(113) - END - | Int64: - IF ynode.typ.size > OPM.Int64Size THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int64"); OPM.LogWLn END; - err(113) - END*) - | Byte: - IF ~(g IN {Byte, Char, SInt}) THEN err(113) END - | Bool, Char, SInt, Set: - IF g # f THEN err(113) END - | Int: - IF ~(g IN {SInt, Int}) THEN err(113) END - | LInt: - IF OPM.LIntSize = 4 THEN - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32*)}) THEN err(113) END - ELSE (* assume OPM.LIntSize = 8 *) - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN err(113) END - END; - | Real: - IF ~(g IN {SInt..Real}) THEN err(113) END - | LReal: - IF ~(g IN {SInt..LReal}) THEN err(113) END - | Pointer: - IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *) - ELSIF g = Pointer THEN - p := x^.BaseTyp; q := y^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN - WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE err(113) - END - | ProcTyp: - IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj) - ELSIF (x = y) OR (g = NilTyp) THEN (* ok *) - ELSE err(113) - END - | NoTyp, NilTyp: - err(113) - | Comp: - x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) - IF x^.comp = Array THEN - IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ; - IF x = y THEN (* ok *) - ELSIF (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*) - IF ynode^.conval^.intval2 > x^.n THEN err(114) END ; - ELSE err(113) - END - ELSIF x^.comp = Record THEN - IF x = y THEN (* ok *) - ELSIF y^.comp = Record THEN - q := y^.BaseTyp; - WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE (*DynArr*) err(113) - END - ELSE (* In case of not estimated f it would crash -- noch *) - OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; - END ; - IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN - Convert(ynode, x) - END - END CheckAssign; - - PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN); - BEGIN -(* -avoid unnecessary intermediate variables in voc - - IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ; - IF x^.class = Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) - IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END -*) - END CheckLeaf; - - PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER); (* par0: first param of standard proc *) - VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node; - BEGIN x := par0; f := x^.typ^.form; - CASE fctno OF - haltfn: (*HALT*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x) - ELSE err(218) - END - ELSE err(69) - END ; - x^.typ := OPT.notyp - | newfn: (*NEW*) - typ := OPT.notyp; - IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN - IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; - IF x^.readonly THEN err(76) END ; - f := x^.typ^.BaseTyp^.comp; - IF f IN {Record, DynArr, Array} THEN - IF f = DynArr THEN typ := x^.typ^.BaseTyp END ; - BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn - ELSE err(111) - END - ELSE err(111) - END ; - x^.typ := typ - | absfn: (*ABS*) - MOp(abs, x) - | capfn: (*CAP*) - MOp(cap, x) - | ordfn: (*ORD*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Char THEN Convert(x, OPT.inttyp) - ELSE err(111) - END ; - x^.typ := OPT.inttyp - | entierfn: (*ENTIER*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN realSet THEN Convert(x, OPT.linttyp) - ELSE err(111) - END ; - x^.typ := OPT.linttyp - | oddfn: (*ODD*) - MOp(odd, x) - | minfn: (*MIN*) - IF x^.class = Ntype THEN - CASE f OF - Bool: x := NewBoolConst(FALSE) - | Char: x := NewIntConst(0); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MinSInt) - | Int: x := NewIntConst(OPM.MinInt) - | LInt: x := NewIntConst(OPM.MinLInt) - (* | Int8: x := NewIntConst(OPM.MinInt8) - | Int16: x := NewIntConst(OPM.MinInt16) - | Int32: x := NewIntConst(OPM.MinInt32) - | Int64: err(111)(*x := NewIntConst(OPM.MinInt64)*) (* int64 constants not implemented yet *)*) - | Set: x := NewIntConst(0); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) - ELSE err(111) - END - ELSE err(110) - END - | maxfn: (*MAX*) - IF x^.class = Ntype THEN - CASE f OF - Bool: x := NewBoolConst(TRUE) - | Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MaxSInt) - | Int: x := NewIntConst(OPM.MaxInt) - | LInt: x := NewIntConst(OPM.MaxLInt) - (* | Int8: x := NewIntConst(OPM.MaxInt8) - | Int16: x := NewIntConst(OPM.MaxInt16) - | Int32: x := NewIntConst(OPM.MaxInt32) - | Int64: err(111); (*x := NewIntConst(OPM.MaxInt64)*) (* int64 contstants not implemented yet *)*) - | Set: x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) - ELSE err(111) - END - ELSE err(110) - END - | chrfn: (*CHR*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef, SInt..LInt(*, Int8..Int64*)} THEN Convert(x, OPT.chartyp) - ELSE err(111); x^.typ := OPT.chartyp - END - | shortfn: (*SHORT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Int THEN Convert(x, OPT.sinttyp) - ELSIF f = LInt THEN Convert(x, OPT.inttyp) - (*ELSIF f = Int64 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int8typ)*) - ELSIF f = LReal THEN Convert(x, OPT.realtyp) - ELSE err(111) - END - | longfn: (*LONG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = SInt THEN Convert(x, OPT.inttyp) - ELSIF f = Int THEN Convert(x, OPT.linttyp) - (*ELSIF f = Int8 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int64typ)*) - ELSIF f = Real THEN Convert(x, OPT.lrltyp) - ELSIF f = Char THEN Convert(x, OPT.linttyp) - ELSE err(111) - END - | incfn, decfn: (*INC, DEC*) - IF NotVar(x) THEN err(112) - ELSIF ~(f IN intSet) THEN err(111) - ELSIF x^.readonly THEN err(76) - END - | inclfn, exclfn: (*INCL, EXCL*) - IF NotVar(x) THEN err(112) - ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp - ELSIF x^.readonly THEN err(76) - END - | lenfn: (*LEN*) - IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END - | copyfn: (*COPY*) - IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char)) - & (f # String) THEN err(111) - END - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF f # LInt THEN Convert(x, OPT.linttyp) END - ELSE err(111); x^.typ := OPT.linttyp - END - | adrfn: (*SYSTEM.ADR*) - CheckLeaf(x, FALSE); MOp(adr, x) - | sizefn: (*SIZE*) - IF x^.class # Ntype THEN err(110); x := NewIntConst(1) - ELSIF (f IN {Byte..Set(*, Int8..Int64*), Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN - typSize(x^.typ); x^.typ^.pvused := TRUE; x := NewIntConst(x^.typ^.size) - ELSE err(111); x := NewIntConst(1) - END - | ccfn: (*SYSTEM.CC*) - MOp(cc, x) - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet + {Byte, Char, Set(*, Int8, Int16, Int32, Int64*)}) THEN err(111) - END - | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp - END - | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END - ELSE err(69) - END - | valfn: (*SYSTEM.VAL*) - IF x^.class # Ntype THEN err(110) - ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111) - END - | sysnewfn: (*SYSTEM.NEW*) - IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN - IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END - ELSE err(111) - END - | assertfn: (*ASSERT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) - ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) - ELSE MOp(not, x) - END - ELSE - OPM.LogWStr("unhandled case in OPB.StPar0, fctno = "); OPM.LogWNum(fctno, 0); OPM.LogWLn; - END ; - par0 := x - END StPar0; - - PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT); (* x: second parameter of standard proc *) - VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node; - - PROCEDURE NewOp(class, subcl: SHORTINT; left, right: OPT.Node): OPT.Node; - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(class); node^.subcl := subcl; - node^.left := left; node^.right := right; RETURN node - END NewOp; - - BEGIN p := par0; f := x^.typ^.form; - CASE fctno OF - incfn, decfn: (*INC DEC*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp - ELSE - IF x^.typ # p^.typ THEN - IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ) - ELSE err(111) - END - END ; - p := NewOp(Nassign, fctno, p, x); - p^.typ := OPT.notyp - END - | inclfn, exclfn: (*INCL, EXCL*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202) - END ; - p := NewOp(Nassign, fctno, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | lenfn: (*LEN*) - IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69) - ELSIF f = SInt THEN - L := SHORT(x^.conval^.intval); typ := p^.typ; - WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ; - IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132) - ELSE x^.obj := NIL; - IF typ^.comp = DynArr THEN - WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) - p := NewOp(Ndop, len, p, x); p^.typ := OPT.linttyp - ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p) - END - END - ELSE err(132) - END - | copyfn: (*COPY*) - IF NotVar(x) THEN err(112) - ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN - IF x^.readonly THEN err(76) END ; - t := x; x := p; p := t; p := NewOp(Nassign, copyfn, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (p^.class = Nconst) & (x^.class = Nconst) THEN - IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1 - ELSIF x^.conval^.intval >= 0 THEN - IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN - p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval) - ELSE err(208); p^.conval^.intval := 1 - END - ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval) - END ; - p^.obj := NIL - ELSE p := NewOp(Ndop, ash, p, x); p^.typ := OPT.linttyp - END - ELSE err(111) - END - | newfn: (*NEW(p, x...)*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp = DynArr THEN - IF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END - ELSE err(111) - END ; - p^.right := x; p^.typ := p^.typ^.BaseTyp - ELSE err(64) - END - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet) THEN err(111) - ELSE - IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; - p^.typ := p^.left^.typ - END - | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN - IF (fctno = getfn) OR (fctno = getrfn) THEN - IF NotVar(x) THEN err(112) END ; - t := x; x := p; p := t - END ; - p := NewOp(Nassign, fctno, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | bitfn: (*SYSTEM.BIT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Ndop, bit, p, x) - ELSE err(111) - END ; - p^.typ := OPT.booltyp - | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) - IF (x^.class = Ntype) OR (x^.class = Nproc) OR - (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126) - END ; - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t; -(* - IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t - ELSE x^.readonly := FALSE - END ; -*) - x^.typ := p^.typ; p := x - | sysnewfn: (*SYSTEM.NEW*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Nassign, sysnewfn, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | movefn: (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp - END ; - p^.link := x - | assertfn: (*ASSERT*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x); - x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); - IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn - END - ELSE err(218) - END - ELSE err(69) - END - ELSE err(64) - END ; - par0 := p - END StPar1; - - PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *) - VAR node: OPT.Node; f: INTEGER; p: OPT.Node; - BEGIN p := par0; f := x^.typ^.form; - IF fctno = newfn THEN (*NEW(p, ..., x...*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp # DynArr THEN err(64) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; - node := p^.right; WHILE node^.link # NIL DO node := node^.link END; - node^.link := x; p^.typ := p^.typ^.BaseTyp - ELSE err(111) - END - ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p; - node^.left := p^.link; p^.link := x; p := node - ELSE err(111) - END ; - p^.typ := OPT.notyp - ELSE err(64) - END ; - par0 := p - END StParN; - - PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER); - VAR dim: INTEGER; x, p: OPT.Node; - BEGIN p := par0; - IF fctno <= ashfn THEN - IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN - IF p^.typ^.comp = DynArr THEN err(65) END ; - p^.typ := OPT.notyp - ELSIF fctno <= sizefn THEN (* 1 param *) - IF parno < 1 THEN err(65) END - ELSE (* more than 1 param *) - IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) - BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ - ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) - IF p^.typ^.comp = DynArr THEN dim := 0; - WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) - BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len - ELSE - p := NewIntConst(p^.typ^.n) - END - ELSIF parno < 2 THEN err(65) - END - END - ELSIF fctno = assertfn THEN - IF parno = 1 THEN x := NIL; - BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); - x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); - IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn - END - ELSIF parno < 1 THEN err(65) - END - ELSE (*SYSTEM*) - IF (parno < 1) OR - (fctno > ccfn) & (parno < 2) OR - (fctno = movefn) & (parno < 3) THEN err(65) - END - END ; - par0 := p - END StFct; - - PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN); - VAR f: INTEGER; - BEGIN (* ftyp^.comp = DynArr *) - f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; - IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *) - IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt(*, Int8..Int64*)}) THEN err(-301) END (* ... warning 301 *) - ELSIF f IN {Array, DynArr} THEN - IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) - ELSIF ftyp # atyp THEN - IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN - ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; - IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN - WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ; - IF atyp = NIL THEN err(113) END - ELSE err(66) - END - ELSE err(66) - END - END ; - ELSE err(67) - END - END DynArrParCheck; - - PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object); - BEGIN - IF fp^.typ^.form = Pointer THEN - IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END - END - END CheckReceiver; - - PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object); - BEGIN - IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN - fpar := x^.obj^.link; - IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END - ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN - fpar := x^.typ^.link - ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp - END - END PrepCall; - - PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object); - VAR q: OPT.Struct; - BEGIN - IF fp.typ.form # Undef THEN - IF fp^.mode = VarPar THEN - IF NotVar(ap) THEN err(122) - ELSE CheckLeaf(ap, FALSE) - END ; - IF ap^.readonly THEN err(76) END ; - IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) - ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN - q := ap^.typ; - WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(111) END - ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *) - ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123) - ELSIF (fp^.typ^.form = Pointer) & (ap^.class = Nguard) THEN err(123) - END - ELSIF fp^.typ^.comp = DynArr THEN - IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ; - IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *) - ELSIF ap^.class >= Nconst THEN err(59) - ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE) - END - ELSE CheckAssign(fp^.typ, ap) - END - END - END Param; - - PROCEDURE StaticLink*(dlev: SHORTINT); - VAR scope: OPT.Object; - BEGIN - scope := OPT.topScope; - WHILE dlev > 0 DO DEC(dlev); - INCL(scope^.link^.conval^.setval, slNeeded); - scope := scope^.left - END - END StaticLink; - - PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object); - VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT; - BEGIN - IF x^.class = Nproc THEN typ := x^.typ; - lev := x^.obj^.mnolev; - IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ; - IF x^.obj^.mode = IProc THEN err(121) END - ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ; - x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link - ELSE typ := x^.typ^.BaseTyp - END ; - BindNodes(Ncall, typ, x, apar); x^.obj := fp - END Call; - - PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object); - VAR x: OPT.Node; - BEGIN - x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc; - x^.left := procdec; x^.right := stat; procdec := x - END Enter; - - PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object); - VAR node: OPT.Node; - BEGIN - IF proc = NIL THEN (* return from module *) - IF x # NIL THEN err(124) END - ELSE - IF x # NIL THEN CheckAssign(proc^.typ, x) - ELSIF proc^.typ # OPT.notyp THEN err(124) - END - END ; - node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node - END Return; - - PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node); - VAR z: OPT.Node; - BEGIN - IF x^.class >= Nconst THEN err(56) END ; - CheckAssign(x^.typ, y); - IF x^.readonly THEN err(76) END ; - IF x^.typ^.comp = Record THEN - IF x^.class = Nguard THEN z := x^.left ELSE z := x END ; - IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN - z^.left := z^.left^.left (* skip guard before dereferencing *) - END ; - IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN - BindNodes(Neguard, x^.typ, z, NIL); x := z - END - ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) & - (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) - y^.typ := OPT.chartyp; y^.conval^.intval := 0; - Index(x, NewIntConst(0)) - END ; - BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign - END Assign; - - PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct); - VAR node: OPT.Node; - BEGIN - node := OPT.NewNode(Ninittd); node^.typ := typ; - node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos; - IF inittd = NIL THEN inittd := node ELSE last^.link := node END ; - last := node - END Inittd; - -BEGIN - maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp -END OPB. diff --git a/src/voc/OPC.Mod b/src/voc/OPC.Mod deleted file mode 100644 index 77547af9..00000000 --- a/src/voc/OPC.Mod +++ /dev/null @@ -1,1410 +0,0 @@ -MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) -(* C source code generator version - - 30.4.2000 jt, synchronized with BlackBox version, in particular - various promotion rules changed (long) => (LONGINT), xxxL avoided -*) - - IMPORT OPT, OPM, version; - - CONST demoVersion = FALSE; - - CONST - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* - Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; -*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* object history *) - removed = 4; - - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; Mod = 11; TProc = 13; - - (* symbol values and ops *) - eql = 9; neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - - (* nodes classes *) - Ninittd = 14; - - (* module visibility of objects *) - internal = 0; external = 1; - - UndefinedType = 0; (* named type not yet defined *) - ProcessingType = 1; (* pointer type is being processed *) - PredefinedType = 2; (* for all predefined types *) - DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) - DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) - - - HeaderMsg = " voc "; - BasicIncludeFile = "SYSTEM"; - Static = "static "; - Export = "export "; (* particularily introduced for VC++ declspec() *) - Extern = "import "; (* particularily introduced for VC++ declspec() *) - Struct = "struct "; - LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) - GlobalScope = "_s"; (* pointer to current scope extension *) - LinkName = "lnk"; (* pointer to previous scope field *) - FlagExt = "__h"; - LenExt = "__len"; - DynTypExt = "__typ"; - TagExt = "__typ"; - - OpenParen = "("; - CloseParen = ")"; - OpenBrace = "{"; - CloseBrace = "}"; - OpenBracket = "["; - CloseBracket = "]"; - Underscore = "_"; - Quotes = 22X; - SingleQuote = 27X; - Tab = 9X; - Colon = ": "; - Semicolon = ";"; - Comma = ", "; - Becomes = " = "; - Star = "*"; - Blank = " "; - Dot = "."; - - DupFunc = "__DUP("; (* duplication of dynamic arrays *) - DupArrFunc = "__DUPARR("; (* duplication of fixed size arrays *) - DelFunc = "__DEL("; (* removal of dynamic arrays *) - - NilConst = "NIL"; - - VoidType = "void"; - CaseStat = "case "; - - VAR - indentLevel: INTEGER; - ptrinit, mainprog, ansi: BOOLEAN; - hashtab: ARRAY 105 OF SHORTINT; - keytab: ARRAY 36, 9 OF CHAR; - GlbPtrs: BOOLEAN; - BodyNameExt: ARRAY 13 OF CHAR; - - PROCEDURE Init*; - BEGIN - indentLevel := 0; - ptrinit := OPM.ptrinit IN OPM.opt; - (*mainprog := OPM.mainprog IN OPM.opt;*) - mainprog := OPM.mainProg OR OPM.mainLinkStat; - ansi := OPM.ansi IN OPM.opt; - IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END - END Init; - - PROCEDURE Indent* (count: INTEGER); - BEGIN INC(indentLevel, count) - END Indent; - - PROCEDURE BegStat*; - VAR i: INTEGER; - BEGIN i := indentLevel; - WHILE i > 0 DO OPM.Write(Tab); DEC (i) END - END BegStat; - - PROCEDURE EndStat*; - BEGIN OPM.Write(Semicolon); OPM.WriteLn - END EndStat; - - PROCEDURE BegBlk*; - BEGIN OPM.Write(OpenBrace); OPM.WriteLn; INC(indentLevel) - END BegBlk; - - PROCEDURE EndBlk*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace); OPM.WriteLn - END EndBlk; - - PROCEDURE EndBlk0*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace) - END EndBlk0; - - PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); - VAR ch: CHAR; i: INTEGER; - BEGIN ch := s[0]; i := 0; - WHILE ch # 0X DO - IF ch = "#" THEN OPM.WriteInt(x) - ELSE OPM.Write(ch); - END ; - INC(i); ch := s[i] - END - END Str1; - - PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO INC(i) END ; - RETURN i - END Length; - - PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; - VAR i, h: INTEGER; - BEGIN i := 0; h := 0; - WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; - RETURN h MOD 105 - END PerfectHash; - - PROCEDURE Ident* (obj: OPT.Object); - VAR mode, level, h: INTEGER; - BEGIN - mode := obj^.mode; level := obj^.mnolev; - IF (mode IN {Var, Typ, LProc}) & (level > 0) OR (mode IN {Fld, VarPar}) THEN - OPM.WriteStringVar(obj^.name); - h := PerfectHash(obj^.name); - IF hashtab[h] >= 0 THEN - IF keytab[hashtab[h]] = obj^.name THEN OPM.Write(Underscore) END - END - ELSE - IF (mode # Typ) OR (obj^.linkadr # PredefinedType) THEN - IF mode = TProc THEN Ident(obj^.link^.typ^.strobj) - ELSIF level < 0 THEN (* use unaliased module name *) - OPM.WriteStringVar(OPT.GlbMod[-level].name); - IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; - ELSE OPM.WriteStringVar(OPM.modName) - END ; - OPM.Write(Underscore) - ELSIF (obj = OPT.sysptrtyp^.strobj) OR (obj = OPT.bytetyp^.strobj) (*OR (obj = OPT.int8typ^.strobj) OR (obj = OPT.int16typ^.strobj) OR (obj = OPT.int32typ^.strobj) OR (obj = OPT.int64typ^.strobj)*) THEN - OPM.WriteString("SYSTEM_") - - END ; - OPM.WriteStringVar(obj^.name) - END - END Ident; - - PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); - VAR pointers: INTEGER; - BEGIN - openClause := FALSE; - IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # Record) THEN - IF typ^.comp IN {Array, DynArr} THEN - Stars (typ^.BaseTyp, openClause); - openClause := (typ^.comp = Array) - ELSIF typ^.form = ProcTyp THEN - OPM.Write(OpenParen); OPM.Write(Star) - ELSE - pointers := 0; - WHILE (typ^.strobj = NIL) & (typ^.form = Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; - IF typ^.comp # DynArr THEN Stars (typ, openClause) END ; - IF pointers > 0 THEN - IF openClause THEN OPM.Write(OpenParen); openClause := FALSE END ; - WHILE pointers > 0 DO OPM.Write(Star); DEC (pointers) END - END - END - END - END Stars; - - PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - - PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); - VAR - typ: OPT.Struct; - varPar, openClause: BOOLEAN; form, comp: INTEGER; - BEGIN - typ := dcl^.typ; - varPar := ((dcl^.mode = VarPar) & (typ^.comp # Array)) OR (typ^.comp = DynArr) OR scopeDef; - Stars(typ, openClause); - IF varPar THEN - IF openClause THEN OPM.Write(OpenParen) END ; - OPM.Write(Star) - END ; - IF dcl.name # "" THEN Ident(dcl) END ; - IF varPar & openClause THEN OPM.Write(CloseParen) END ; - openClause := FALSE; - LOOP - form := typ^.form; - comp := typ^.comp; - IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = NoTyp) OR (comp = Record) THEN EXIT - ELSIF (form = Pointer) & (typ^.BaseTyp^.comp # DynArr) THEN - openClause := TRUE - ELSIF (form = ProcTyp) OR (comp IN {Array, DynArr}) THEN - IF openClause THEN OPM.Write(CloseParen); openClause := FALSE END ; - IF form = ProcTyp THEN - IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE) - ELSE OPM.WriteString(")()") - END ; - EXIT - ELSIF comp = Array THEN - OPM.Write(OpenBracket); OPM.WriteInt(typ^.n); OPM.Write(CloseBracket) - END - ELSE - EXIT - END ; - typ := typ^.BaseTyp - END - END DeclareObj; - - PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) - BEGIN - IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN - OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) - ELSE Ident(typ^.strobj) - END - END Andent; - - PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; - BEGIN - (* imported anonymous types have obj^.name = ""; used e.g. for repeating inherited fields *) - RETURN (obj^.mnolev >= 0) & (obj^.linkadr # 3+OPM.currFile ) & (obj^.linkadr # PredefinedType) OR (obj^.name = "") - END Undefined; - - PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - - PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) - VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; - BEGIN - typ := dcl^.typ; prev := typ; - WHILE ((typ^.strobj = NIL) OR (typ^.comp = DynArr) OR Undefined(typ^.strobj)) & (typ^.comp # Record) & (typ^.form # NoTyp) - & ~((typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr)) DO - prev := typ; typ := typ^.BaseTyp - END ; - obj := typ^.strobj; - IF typ^.form = NoTyp THEN (* proper procedure *) - OPM.WriteString(VoidType) - ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) - Ident(obj) - ELSIF typ^.comp = Record THEN - OPM.WriteString(Struct); Andent(typ); - IF (prev.form # Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN - (* named record type not yet declared OR anonymous record with empty name *) - IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # internal) THEN - OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) - ELSE OPM.Write(Blank); BegBlk - END ; - FieldList(typ, TRUE, off, n, dummy); - EndBlk0 - END - ELSIF (typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr) THEN - typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; - WHILE typ^.comp = DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; - OPM.WriteString(Struct); BegBlk; - BegStat; Str1("LONGINT len[#]", nofdims); EndStat; - BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) - obj.typ.form := Comp; obj.typ.comp := Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := Fld; obj.name := "data"; - obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(Blank); DeclareObj(obj, FALSE); - EndStat; EndBlk0 - END - END DeclareBase; - - PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; - VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN RETURN 1 - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) - ELSE INC(n) - END ; - fld := fld^.link - END ; - RETURN n - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - RETURN NofPtrs(btyp) * n - ELSE RETURN 0 - END - END NofPtrs; - - PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); - VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN - OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) - ELSE - OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - END ; - fld := fld^.link - END - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - IF NofPtrs(btyp) > 0 THEN i := 0; - WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END - END - END - END PutPtrOffsets; - - PROCEDURE InitTProcs(typ, obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitTProcs(typ, obj^.left); - IF obj^.mode = TProc THEN - BegStat; - OPM.WriteString("__INITBP("); - Ident(typ); OPM.WriteString(Comma); Ident(obj); - Str1(", #)", obj^.adr DIV 10000H); - EndStat - END ; - InitTProcs(typ, obj^.right) - END - END InitTProcs; - - PROCEDURE PutBase(typ: OPT.Struct); - BEGIN - IF typ # NIL THEN - PutBase(typ^.BaseTyp); - Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") - END - END PutBase; - - PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); - VAR typ: OPT.Struct; dim: INTEGER; - BEGIN - IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; - dim := 1; typ := par^.typ^.BaseTyp; - WHILE typ^.comp = DynArr DO - IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(Comma) END ; - IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp; INC(dim) - END - END LenList; - - PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); - BEGIN - OPM.Write(OpenParen); - WHILE par # NIL DO - IF macro THEN OPM.WriteStringVar(par.name) - ELSE - IF (par^.mode = Var) & (par^.typ^.form = Real) THEN OPM.Write("_") END ; - Ident(par) - END ; - IF par^.typ^.comp = DynArr THEN - OPM.WriteString(Comma); LenList(par, FALSE, TRUE); - ELSIF (par^.mode = VarPar) & (par^.typ^.comp = Record) THEN - OPM.WriteString(Comma); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) - END ; - par := par^.link; - IF par # NIL THEN OPM.WriteString(Comma) END - END ; - OPM.Write(CloseParen) - END DeclareParams; - - PROCEDURE ^DefineType(str: OPT.Struct); - PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); - - PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a TProc definition *) - VAR par: OPT.Object; - BEGIN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF ansi THEN par := obj^.link; - WHILE par # NIL DO DefineType(par^.typ); par := par^.link END - END - END DefineTProcTypes; - - PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DeclareTProcs(obj^.left, empty); - IF obj^.mode = TProc THEN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF OPM.currFile = OPM.HeaderFile THEN - IF obj^.vis = external THEN - DefineTProcTypes(obj); - OPM.WriteString(Extern); empty := FALSE; - ProcHeader(obj, FALSE) - END - ELSE empty := FALSE; - DefineTProcTypes(obj); - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE) - END - END ; - DeclareTProcs(obj^.right, empty) - END - END DeclareTProcs; - - PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; - VAR typ, base: OPT.Struct; mno: LONGINT; - BEGIN typ := obj^.link^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; - WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; - OPT.FindField(obj^.name, typ, obj); - RETURN obj - END BaseTProc; - - PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DefineTProcMacros(obj^.left, empty); - IF (obj^.mode = TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = external)) THEN - OPM.WriteString("#define __"); - Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.WriteString(" __SEND("); - IF obj^.link^.typ^.form = Pointer THEN - OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") - ELSE Ident(obj^.link); OPM.WriteString(TagExt) - END ; - Str1(", #, ", obj^.adr DIV 10000H); - IF obj^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(obj^.typ^.strobj) END ; - OPM.WriteString("(*)"); - IF ansi THEN - AnsiParamList(obj^.link, FALSE); - ELSE - OPM.WriteString("()"); - END ; - OPM.WriteString(", "); - DeclareParams(obj^.link, TRUE); - OPM.Write(")"); OPM.WriteLn - END ; - DefineTProcMacros(obj^.right, empty) - END - END DefineTProcMacros; - - PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) - VAR obj, field, par: OPT.Object; empty: BOOLEAN; - BEGIN - IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN - obj := str^.strobj; - IF (obj = NIL) OR Undefined(obj) THEN - IF obj # NIL THEN (* check for cycles *) - IF obj^.linkadr = ProcessingType THEN - IF str^.form # Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END - ELSE obj^.linkadr := ProcessingType - END - END ; - IF str^.comp = Record THEN - (* the following exports the base type of an exported type even if the former is non-exported *) - IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE (field # NIL) & (field^.mode = Fld) DO - IF (field^.vis # internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; - field := field^.link - END - ELSIF str^.form = Pointer THEN - IF str^.BaseTyp^.comp # Record THEN DefineType(str^.BaseTyp) END - ELSIF str^.comp IN {Array, DynArr} THEN - DefineType(str^.BaseTyp) - ELSIF str^.form = ProcTyp THEN - IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE field # NIL DO DefineType(field^.typ); field := field^.link END - END - END ; - IF (obj # NIL) & Undefined(obj) THEN - OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); - obj^.linkadr := ProcessingType; - DeclareBase(obj); OPM.Write(Blank); - obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) - DeclareObj(obj, FALSE); - obj^.typ^.strobj := obj; (* SG: revert trick *) - obj^.linkadr := 3+OPM.currFile; - EndStat; Indent(-1); OPM.WriteLn; - IF obj^.typ^.comp = Record THEN empty := TRUE; - DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); - IF ~empty THEN OPM.WriteLn END - END - END - END - END DefineType; - - PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; - VAR i: INTEGER; - BEGIN i := 0; - WHILE x[i+1] = y[i] DO INC(i) END ; - RETURN y[i] = 0X - END Prefixed; - - PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); - VAR i: INTEGER; ext: OPT.ConstExt; - BEGIN - IF obj # NIL THEN - CProcDefs(obj^.left, vis); - (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) - IF (obj^.mode = CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN - ext := obj.conval.ext; i := 1; - IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN - OPM.WriteString("#define "); Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.Write(Tab); - END ; - FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; - OPM.WriteLn - END ; - CProcDefs(obj^.right, vis) - END - END CProcDefs; - - PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); - BEGIN - IF obj # NIL THEN - TypeDefs(obj^.left, vis); - (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) - IF (obj^.mode = Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; - TypeDefs(obj^.right, vis) - END - END TypeDefs; - - PROCEDURE DefAnonRecs(n: OPT.Node); - VAR o: OPT.Object; typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN - DefineType(typ); (* declare base and field types, if any *) - NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn - (* simply defines a named struct, but not a type; - o.name = "" signals field list expansion for DeclareBase in this very special case *) - END ; - n := n^.link - END - END DefAnonRecs; - - PROCEDURE TDescDecl* (typ: OPT.Struct); - VAR nofptrs: LONGINT; - o: OPT.Object; - BEGIN - BegStat; OPM.WriteString("__TDESC("); - Andent(typ); - Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); - OPM.Write('"'); - IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; - Str1('", #), {', typ^.size); - nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize); - EndStat - END TDescDecl; - - PROCEDURE InitTDesc*(typ: OPT.Struct); - BEGIN - BegStat; OPM.WriteString("__INITYP("); - Andent(typ); OPM.WriteString(", "); - IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; - Str1(", #)", typ^.extlev); - EndStat; - IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END - END InitTDesc; - - PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); - BEGIN - CASE base OF - | 2: INC(adr, adr MOD 2) - | 4: INC(adr, (-adr) MOD 4) - | 8: INC(adr, (-adr) MOD 8) - |16: INC(adr, (-adr) MOD 16) - ELSE (*1*) - (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) - END - END Align; - - PROCEDURE Base*(typ: OPT.Struct): LONGINT; - BEGIN - CASE typ^.form OF - | Byte: RETURN 1 - | Char: RETURN OPM.CharAlign - | Bool: RETURN OPM.BoolAlign - | SInt: RETURN OPM.SIntAlign - | Int: RETURN OPM.IntAlign - | LInt: RETURN OPM.LIntAlign - (* | Int8: RETURN OPM.Int8Align - | Int16: RETURN OPM.Int16Align - | Int32: RETURN OPM.Int32Align - | Int64: RETURN OPM.Int64Align*) - | Real: RETURN OPM.RealAlign - | LReal: RETURN OPM.LRealAlign - | Set: RETURN OPM.SetAlign - | Pointer: RETURN OPM.PointerAlign - | ProcTyp: RETURN OPM.ProcAlign - | Comp: - IF typ^.comp = Record THEN RETURN typ^.align MOD 10000H - ELSE RETURN Base(typ^.BaseTyp) - END - ELSE OPM.LogWStr("unhandled case in OPC.Base, typ^form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; - END - END Base; - - PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); - VAR adr: LONGINT; - BEGIN - adr := off; Align(adr, align); - IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) - DEC(gap, (adr - off) + align); - BegStat; - IF align = OPM.IntSize THEN OPM.WriteString("INTEGER") - ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT") - ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL") - END ; - Str1(" _prvt#", n); INC(n); EndStat; - curAlign := align - END ; - IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END - END FillGap; - - PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; - BEGIN - fld := typ.link; align := typ^.align MOD 10000H; - IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) - ELSE off := 0; n := 0; curAlign := 1 - END ; - WHILE (fld # NIL) & (fld.mode = Fld) DO - IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = internal) OR - (OPM.currFile = OPM.BodyFile) & (fld.vis = internal) & (typ^.mno # 0) THEN - fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.vis = internal) DO fld := fld.link END ; - ELSE - (* mimic OPV.TypSize to detect gaps caused by private fields *) - adr := off; fldAlign := Base(fld^.typ); Align(adr, fldAlign); - gap := fld.adr - adr; - IF fldAlign > curAlign THEN curAlign := fldAlign END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ; - BegStat; DeclareBase(fld); OPM.Write(Blank); DeclareObj(fld, FALSE); - off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.typ = base) & (fld.adr = off) -(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # internal) OR (fld.typ.strobj = NIL)) DO - OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link - END ; - EndStat - END - END ; - IF last THEN - adr := typ.size - typ^.sysflag DIV 100H; - IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END - END - END FieldList; - - PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); - (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) - VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; - BEGIN - base := NIL; first := TRUE; - WHILE (obj # NIL) & (obj^.mode # TProc) DO - IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN - IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) - IF ~first THEN EndStat END ; - first := FALSE; - base := obj^.typ; lastvis := obj^.vis; - BegStat; - IF (vis = 1) & (obj^.vis # internal) THEN OPM.WriteString(Extern) - ELSIF (obj^.mnolev = 0) & (vis = 0) THEN - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END - END ; - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.WriteString("double") - ELSE DeclareBase(obj) - END - ELSE OPM.Write(","); - END ; - OPM.Write(Blank); - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.Write("_") END ; - DeclareObj(obj, vis = 3); - IF obj^.typ^.comp = DynArr THEN (* declare len parameter(s) *) - EndStat; BegStat; - base := OPT.linttyp; - OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - EndStat; BegStat; - OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt); - base := NIL - ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = Pointer) THEN - OPM.WriteString(" = NIL") - END - END ; - obj := obj^.link - END ; - IF ~first THEN EndStat END - END IdentList; - - PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - VAR name: ARRAY 32 OF CHAR; - BEGIN - OPM.Write("("); - IF (obj = NIL) OR (obj^.mode = TProc) THEN OPM.WriteString("void") - ELSE - LOOP - DeclareBase(obj); - IF showParamNames THEN - OPM.Write(Blank); DeclareObj(obj, FALSE) - ELSE - COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) - END ; - IF obj^.typ^.comp = DynArr THEN - OPM.WriteString(", LONGINT "); - LenList(obj, TRUE, showParamNames) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - OPM.WriteString(", LONGINT *"); - IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END - END ; - IF (obj^.link = NIL) OR (obj^.link.mode = TProc) THEN EXIT END ; - OPM.WriteString(", "); - obj := obj^.link - END - END ; - OPM.Write(")") - END AnsiParamList; - - PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); - BEGIN - IF proc^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(proc^.typ^.strobj) END ; - OPM.Write(Blank); Ident(proc); OPM.Write(Blank); - IF ansi THEN - AnsiParamList(proc^.link, TRUE); - IF ~define THEN OPM.Write(";") END ; - OPM.WriteLn; - ELSIF define THEN - DeclareParams(proc^.link, FALSE); - OPM.WriteLn; - Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1) - ELSE OPM.WriteString("();"); OPM.WriteLn - END - END ProcHeader; - - PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) - BEGIN - IF obj # NIL THEN - ProcPredefs(obj^.left, vis); - IF (obj^.mode IN {LProc, XProc}) & (obj^.vis >= vis) & ((obj^.history # removed) OR (obj^.mode = LProc)) THEN - (* previous XProc may be deleted or become LProc after interface change*) - IF vis = external THEN OPM.WriteString(Extern) - ELSIF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE); - END ; - ProcPredefs(obj^.right, vis); - END; - END ProcPredefs; - - PROCEDURE Include(name: ARRAY OF CHAR); - BEGIN - OPM.WriteString("#include "); OPM.Write(Quotes); OPM.WriteStringVar(name); - OPM.WriteString(".h"); OPM.Write(Quotes); OPM.WriteLn - END Include; - - PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); - BEGIN - IF obj # NIL THEN - IncludeImports(obj^.left, vis); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) - Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) - END; - IncludeImports(obj^.right, vis); - END; - END IncludeImports; - - PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); - VAR typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (vis = internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN - BegStat; - IF vis = external THEN OPM.WriteString(Extern) - ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt); - EndStat - END ; - n := n^.link - END - END GenDynTypes; - - PROCEDURE GenHdr*(n: OPT.Node); - BEGIN - (* includes are delayed until it is known which ones are needed in the header *) - OPM.currFile := OPM.HeaderFile; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; - GenDynTypes(n, external); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 1); - OPM.WriteString(Extern); OPM.WriteString("void *"); - OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); - EndStat; OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; - OPM.WriteString("#endif"); OPM.WriteLn - END GenHdr; - - PROCEDURE GenHeaderMsg; - VAR i: INTEGER; - BEGIN - OPM.WriteString("/*"); OPM.WriteString(HeaderMsg); - OPM.Write(" "); OPM.WriteString(version.versionLong); OPM.Write (" "); (* noch *) - FOR i := 0 TO OPM.MaxSet (*31*) DO (*noch*) - IF i IN OPM.glbopt THEN - CASE i OF (* c.f. ScanOptions in OPM *) - | OPM.extsf: OPM.Write("e") - | OPM.newsf: OPM.Write("s") - | OPM.mainprog: OPM.Write("m") - | OPM.inxchk: OPM.Write("x") - | OPM.vcpp: OPM.Write("v") - | OPM.ranchk: OPM.Write("r") - | OPM.typchk: OPM.Write("t") - | OPM.assert: OPM.Write("a") - | OPM.ansi: OPM.Write("k") - | OPM.ptrinit: OPM.Write("p") - | OPM.include0: OPM.Write("i") - | OPM.lineno: OPM.Write("l") - | OPM.useparfile: OPM.Write("P") - | OPM.dontasm: OPM.Write("S") - | OPM.dontlink: OPM.Write("c") - | OPM.mainlinkstat: OPM.Write("M") - | OPM.notcoloroutput: OPM.Write("f") - | OPM.forcenewsym: OPM.Write("F") - | OPM.verbose: OPM.Write("v") - ELSE - (* this else is necessary cause - if someone defined a new option in OPM module - and forgot to add it here then - if option is passed this will - generate __CASECHK and cause Halt, - noch *) - OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; - END - END - END; - OPM.WriteString(" */"); OPM.WriteLn - END GenHeaderMsg; - - PROCEDURE GenHdrIncludes*; - BEGIN - OPM.currFile := OPM.HeaderInclude; - GenHeaderMsg; - OPM.WriteLn; - OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteLn; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn - END GenHdrIncludes; - - PROCEDURE GenBdy*(n: OPT.Node); - BEGIN - OPM.currFile := OPM.BodyFile; - GenHeaderMsg; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; - GenDynTypes(n, internal); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn - END GenBdy; - - PROCEDURE RegCmds(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - RegCmds(obj^.left); - IF (obj^.mode = XProc) & (obj^.history # removed) THEN - IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) - BegStat; OPM.WriteString('__REGCMD("'); - OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat - END - END ; - RegCmds(obj^.right) - END - END RegCmds; - - PROCEDURE InitImports(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitImports(obj^.left); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) THEN - BegStat; OPM.WriteString("__IMPORT("); - OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); - OPM.Write(CloseParen); EndStat - END ; - InitImports(obj^.right) - END - END InitImports; - - PROCEDURE GenEnumPtrs* (var: OPT.Object); - VAR typ: OPT.Struct; n: LONGINT; - BEGIN GlbPtrs := FALSE; - WHILE var # NIL DO - typ := var^.typ; - IF NofPtrs(typ) > 0 THEN - IF ~GlbPtrs THEN GlbPtrs := TRUE; - OPM.WriteString(Static); - IF ansi THEN - OPM.WriteString("void EnumPtrs(void (*P)(void*))") - ELSE - OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("void (*P)();"); - END ; - OPM.WriteLn; - BegBlk - END ; - BegStat; - IF typ^.form = Pointer THEN - OPM.WriteString("P("); Ident(var); OPM.Write(")"); - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") - ELSIF typ^.comp = Array THEN - n := typ^.n; typ := typ^.BaseTyp; - WHILE typ^.comp = Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; - IF typ^.form = Pointer THEN - OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) - END - END ; - EndStat - END ; - var := var^.link - END ; - IF GlbPtrs THEN - EndBlk; OPM.WriteLn - END - END GenEnumPtrs; - - PROCEDURE EnterBody*; - BEGIN - OPM.WriteLn; OPM.WriteString(Export); - IF mainprog THEN - IF ansi THEN - OPM.WriteString("main(int argc, char **argv)"); OPM.WriteLn; - ELSE - OPM.WriteString("main(argc, argv)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn - END - ELSE - OPM.WriteString("void *"); - OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; - END ; - BegBlk; BegStat; - IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; - EndStat; - IF mainprog & demoVersion THEN BegStat; - OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); - EndStat - END ; - InitImports(OPT.topScope^.right); - BegStat; - IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; - OPM.WriteString(OPM.modName); - IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; - EndStat; - IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END - END EnterBody; - - PROCEDURE ExitBody*; - BEGIN - BegStat; - IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; - OPM.WriteLn; EndBlk - END ExitBody; - - PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) - VAR scope: OPT.Object; - BEGIN - scope := proc^.scope; - OPM.WriteString(Static); OPM.WriteString(Struct); OPM.WriteStringVar(scope^.name); OPM.Write(Blank); - BegBlk; - IdentList(proc^.link, 3); (* parameters *) - IdentList(scope^.scope, 3); (* local variables *) - BegStat; (* scope link field declaration *) - OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.Write(Star); OPM.WriteString(LinkName); EndStat; - EndBlk0; OPM.Write(Blank); - OPM.Write(Star); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; - ProcPredefs (scope^.right, 0); - OPM.WriteLn; - END DefineInter; - - PROCEDURE EnterProc* (proc: OPT.Object); - VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; - BEGIN - IF proc^.vis # external THEN OPM.WriteString(Static) END ; - ProcHeader(proc, TRUE); - BegBlk; - scope := proc^.scope; - IdentList(scope^.scope, 0); - IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) - BegStat; OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.WriteString(LocalScope); EndStat - END ; - var := proc^.link; - WHILE var # NIL DO (* declare copy of fixed size value array parameters *) - IF (var^.typ^.comp = Array) & (var^.mode = Var) THEN - BegStat; - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; - OPM.Write(Blank); Ident(var); OPM.WriteString("__copy"); - EndStat - END ; - var := var^.link - END ; - IF ~ansi THEN - var := proc^.link; - WHILE var # NIL DO (* "unpromote" value real parameters *) - IF (var^.typ^.form = Real) & (var^.mode = Var) THEN - BegStat; - Ident(var^.typ^.strobj); OPM.Write(Blank); Ident(var); OPM.WriteString(" = _"); Ident(var); - EndStat - END ; - var := var^.link - END - END ; - var := proc^.link; - WHILE var # NIL DO (* copy value array parameters *) - IF (var^.typ^.comp IN {Array, DynArr}) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - BegStat; - IF var^.typ^.comp = Array THEN - OPM.WriteString(DupArrFunc); - Ident(var); OPM.WriteString(Comma); - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END - ELSE - OPM.WriteString(DupFunc); - Ident(var); OPM.WriteString(Comma); Ident(var); OPM.WriteString(LenExt); - typ := var^.typ^.BaseTyp; dim := 1; - WHILE typ^.comp = DynArr DO - OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); - typ := typ^.BaseTyp; INC(dim) - END ; - OPM.WriteString(Comma); - IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) - ELSE Ident(typ^.strobj) - END - END ; - OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END ; - IF ~scope^.leaf THEN - var := proc^.link; (* copy addresses of parameters into local scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); - OPM.WriteString(Becomes); - IF var^.typ^.comp IN {Array, DynArr} THEN OPM.WriteString("(void*)") - (* K&R and ANSI differ in the type: array or element type*) - ELSIF var^.mode # VarPar THEN OPM.Write("&") - END ; - Ident(var); - IF var^.typ^.comp = DynArr THEN - typ := var^.typ; dim := 0; - REPEAT (* copy len(s) *) - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp - UNTIL typ^.comp # DynArr; - ELSIF (var^.mode = VarPar) & (var^.typ^.comp = Record) THEN - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(TagExt); - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(TagExt) - END ; - EndStat - END; - var := var^.link; - END; - var := scope^.scope; (* copy addresses of local variables into scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(Becomes); - IF var^.typ^.comp # Array THEN OPM.Write("&") - ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) - END ; - Ident(var); EndStat - END ; - var := var^.link - END; - (* now link new scope *) - BegStat; OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - OPM.WriteString(Becomes); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; - BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(Becomes); - OPM.Write("&"); OPM.WriteString(LocalScope); EndStat - END - END EnterProc; - - PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); - VAR var: OPT.Object; indent: BOOLEAN; - BEGIN - indent := eoBlock; - IF implicitRet & (proc^.typ # OPT.notyp) THEN - OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn - ELSIF ~eoBlock OR implicitRet THEN - IF ~proc^.scope^.leaf THEN - (* link scope pointer of nested proc back to previous scope *) - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString(Becomes); OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - EndStat - END; - (* delete array value parameters *) - var := proc^.link; - WHILE var # NIL DO - IF (var^.typ^.comp = DynArr) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteString(DelFunc); Ident(var); OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END - END ; - IF eoBlock THEN EndBlk; OPM.WriteLn - ELSIF indent THEN BegStat - END - END ExitProc; - - PROCEDURE CompleteIdent*(obj: OPT.Object); - VAR comp, level: INTEGER; - BEGIN - (* obj^.mode IN {Var, VarPar} *) - level := obj^.mnolev; - IF obj^.adr = 1 THEN (* WITH-variable *) - IF obj^.typ^.comp = Record THEN Ident(obj); OPM.WriteString("__") - ELSE (* cast with guard pointer type *) - OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")") - END - ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) - comp := obj^.typ^.comp; - IF (obj^.mode # VarPar) & (comp # DynArr) THEN OPM.Write(Star); END; - OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString("->"); Ident(obj) - ELSE - Ident(obj) - END - END CompleteIdent; - - PROCEDURE TypeOf*(ap: OPT.Object); - VAR i: INTEGER; - BEGIN - ASSERT(ap.typ.comp = Record); - IF ap.mode = VarPar THEN - IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) - OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) - ELSE (*local var-par record*) - Ident(ap) - END ; - OPM.WriteString(TagExt) - ELSIF ap^.typ^.strobj # NIL THEN - Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) - ELSE Andent(ap.typ) (*anonymous ap type, p^ *) - END - END TypeOf; - - PROCEDURE Cmp*(rel: INTEGER); - BEGIN - CASE rel OF - eql : - OPM.WriteString(" == "); - | neq : - OPM.WriteString(" != "); - | lss : - OPM.WriteString(" < "); - | leq : - OPM.WriteString(" <= "); - | gtr : - OPM.WriteString(" > "); - | geq : - OPM.WriteString(" >= "); - ELSE - OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; - END; - END Cmp; - - PROCEDURE Case*(caseVal: LONGINT; form: INTEGER); - VAR - ch: CHAR; - BEGIN - OPM.WriteString(CaseStat); - CASE form OF - | Char : - ch := CHR (caseVal); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\"); OPM.Write(ch); - ELSE OPM.Write(ch); - END; - OPM.Write(SingleQuote); - ELSE - OPM.WriteString("0x"); OPM.WriteHex (caseVal); - END; - | SInt, Int, LInt : - OPM.WriteInt (caseVal); - ELSE - OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - OPM.WriteString(Colon); - END Case; - - PROCEDURE SetInclude* (exclude: BOOLEAN); - BEGIN - IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; - END SetInclude; - - PROCEDURE Increment* (decrement: BOOLEAN); - BEGIN - IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; - END Increment; - - PROCEDURE Halt* (n: LONGINT); - BEGIN - Str1("__HALT(#)", n) - END Halt; - - PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT); - BEGIN - IF array^.comp = DynArr THEN - CompleteIdent(obj); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END - ELSE (* array *) - WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ; - OPM.WriteInt(array^.n); OPM.PromoteIntConstToLInt() - END - END Len; - - PROCEDURE Constant* (con: OPT.Const; form: INTEGER); - VAR i, len: INTEGER; ch: CHAR; s: SET; - hex: LONGINT; skipLeading: BOOLEAN; - BEGIN - CASE form OF - Byte: - OPM.WriteInt(con^.intval) - | Bool: - OPM.WriteInt(con^.intval) - | Char: - ch := CHR(con^.intval); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); - OPM.Write(SingleQuote) - ELSE - OPM.WriteString("0x"); OPM.WriteHex(con^.intval) - END - | SInt, Int, LInt: - OPM.WriteInt(con^.intval) -(* | Int8, Int16, Int32, Int64: - OPM.WriteInt(con^.intval)*) - - | Real: - OPM.WriteReal(con^.realval, "f") - | LReal: - OPM.WriteReal(con^.realval, 0X) - | Set: - OPM.WriteString("0x"); - skipLeading := TRUE; - s := con^.setval; i := MAX(SET) + 1; - REPEAT - hex := 0; - REPEAT - DEC(i); hex := 2 * hex; - IF i IN s THEN INC(hex) END - UNTIL i MOD 8 = 0; - IF (hex # 0) OR ~skipLeading THEN - OPM.WriteHex(hex); - skipLeading := FALSE - END - UNTIL i = 0; - IF skipLeading THEN OPM.Write("0") END - | String: - OPM.Write(Quotes); - len := SHORT(con^.intval2) - 1; i := 0; - WHILE i < len DO ch := con^.ext^[i]; - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); INC(i) - END ; - OPM.Write(Quotes) - | NilTyp: - OPM.WriteString(NilConst); - ELSE - OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - END Constant; - - - PROCEDURE InitKeywords; - VAR n, i: SHORTINT; - - PROCEDURE Enter(s: ARRAY OF CHAR); - VAR h: INTEGER; - BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) - END Enter; - - BEGIN n := 0; - FOR i := 0 TO 104 DO hashtab[i] := -1 END ; - Enter("asm"); - Enter("auto"); - Enter("break"); - Enter("case"); - Enter("char"); - Enter("const"); - Enter("continue"); - Enter("default"); - Enter("do"); - Enter("double"); - Enter("else"); - Enter("enum"); - Enter("extern"); - Enter("export"); (* pseudo keyword used by voc *) - Enter("float"); - Enter("for"); - Enter("fortran"); - Enter("goto"); - Enter("if"); - Enter("import"); (* pseudo keyword used by voc *) - Enter("int"); - Enter("long"); - Enter("register"); - Enter("return"); - Enter("short"); - Enter("signed"); - Enter("sizeof"); - Enter("static"); - Enter("struct"); - Enter("switch"); - Enter("typedef"); - Enter("union"); - Enter("unsigned"); - Enter("void"); - Enter("volatile"); - Enter("while"); - -(* what about common predefined names from cpp as e.g. - Operating System: ibm, gcos, os, tss and unix - Hardware: interdata, pdp11, u370, u3b, - u3b2, u3b5, u3b15, u3b20d, - vax, ns32000, iAPX286, i386, - sparc , and sun - UNIX system variant: - RES, and RT - The lint(1V) command: - lint - *) - END InitKeywords; - -BEGIN InitKeywords -END OPC. diff --git a/src/voc/OPM.cmdln.Mod b/src/voc/OPM.cmdln.Mod deleted file mode 100644 index 3f995c90..00000000 --- a/src/voc/OPM.cmdln.Mod +++ /dev/null @@ -1,1021 +0,0 @@ -MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) -(* constants needed for C code generation - - 31.1.2007 jt synchronized with BlackBox version, in particular PromoteIntConstToLInt added -*) - - IMPORT SYSTEM, Texts := Texts0, Files := Files0, Args, Console, errors, version, vt100; - - CONST - OptionChar* = "-"; - - (* compiler options; don't change the encoding *) - inxchk* = 0; (* index check on *) - vcpp* = 1; (* VC++ support on; former ovflchk; neither used nor documented *) - ranchk* = 2; (* range check on *) - typchk* = 3; (* type check on *) - newsf* = 4; (* generation of new symbol file allowed *) - ptrinit* = 5; (* pointer initialization *) - ansi* = 6; (* ANSI or K&R style prototypes *) - assert* = 7; (* assert evaluation *) - include0* = 8; (* include M.h0 in header file and M.c0 in body file if such files exist *) - extsf* = 9; (* extension of old symbol file allowed *) - mainprog* = 10; (* translate module body into C main function *) - lineno* = 11; (* emit line numbers rather than text positions in error messages *) - useparfile* = 12; (* use .par file *) - dontasm* = 13; (* don't call external assembler/C compiler *) - dontlink* = 14; (* don't link *) - mainlinkstat* = 15; (* generate code for main module and then link object file statically *) - notcoloroutput* = 16; (* turn off color output *) - forcenewsym* = 17; (* force new symbol file *) - verbose* = 18; (* verbose *) - defopt* = {inxchk, typchk, ptrinit, ansi, assert}; (* default options *) - - nilval* = 0; -(* - MinRealPat = 0FF7FFFFFH; (* most negative, 32-bit pattern, -3.40282346E38 *) - MinLRealPatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *) - MinLRealPatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *) - MaxRealPat = 7F7FFFFFH; (*3.40282346E38*) - MaxLRealPatL = -1; - MaxLRealPatH = 7FEFFFFFH; -*) - - MaxRExp* = 38; MaxLExp* = 308; MaxHDig* = 8; - - MinHaltNr* = 0; - MaxHaltNr* = 255; - MaxSysFlag* = 1; - - MaxCC* = -1; (* SYSTEM.CC, GETREG, PUTREG; not implementable in C backend *) - MinRegNr* = 0; - MaxRegNr* = -1; - - LANotAlloc* = -1; (* XProc link adr initialization *) - ConstNotAlloc* = -1; (* for allocation of string and real constants *) - TDAdrUndef* = -1; (* no type desc allocated *) - - MaxCases* = 128; - MaxCaseRange* = 512; - - MaxStruct* = 255; - - (* maximal number of pointer fields in a record: *) - MaxPtr* = MAX(LONGINT); - - (* maximal number of global pointers per module: *) - MaxGPtr* = MAX(LONGINT); - - (* maximal number of hidden fields in an exported record: *) - MaxHdFld* = 2048; - - HdPtrName* = "@ptr"; - HdProcName* = "@proc"; - HdTProcName* = "@tproc"; - - ExpHdPtrFld* = TRUE; - ExpHdProcFld* = FALSE; - ExpHdTProc* = FALSE; - - NEWusingAdr* = FALSE; - - Eot* = 0X; - - SFext = ".sym"; (* symbol file extension *) - BFext = ".c"; (* body file extension *) - HFext = ".h"; (* header file extension *) - SFtag = 0F7X; (* symbol file tag *) - - HeaderFile* = 0; - BodyFile* = 1; - HeaderInclude* = 2; - - TYPE - FileName = ARRAY 32 OF CHAR; - - VAR - SourceFileName : ARRAY 256 OF CHAR; - ByteSize*, CharSize*, BoolSize*, SIntSize*, IntSize*, - LIntSize*, SetSize*, RealSize*, LRealSize*, PointerSize*, ProcSize*, RecSize*, - (*Int8Size*, Int16Size*, Int32Size*, Int64Size*,*) (* these are constants actually, we need it to pass to GetProperty function; -- noch *) - CharAlign*, BoolAlign*, SIntAlign*, IntAlign*, - (*Int8Align*, Int16Align*, Int32Align*, Int64Align*,*) (* need this for SYSTEM types; -- noch *) - LIntAlign*, SetAlign*, RealAlign*, LRealAlign*, PointerAlign*, ProcAlign*, RecAlign*, - ByteOrder*, BitOrder*, MaxSet*: INTEGER; - MinSInt*, MinInt*, MinLInt*, MaxSInt*, MaxInt*, MaxLInt*, MaxIndex*: LONGINT; - (*MinInt8*, MaxInt8*, MinInt16*, MaxInt16*, MinInt32*, MaxInt32* : LONGINT; - MinInt64*, MaxInt64* : SYSTEM.INT64;*) - MinReal*, MaxReal*, MinLReal*, MaxLReal*: LONGREAL; - - noerr*: BOOLEAN; - curpos*, errpos*: LONGINT; (* character and error position in source file *) - breakpc*: LONGINT; (* set by OPV.Init *) - currFile*: INTEGER; (* current output file *) - level*: INTEGER; (* procedure nesting level *) - pc*, entno*: INTEGER; (* entry number *) - modName*: ARRAY 32 OF CHAR; - objname*: ARRAY 64 OF CHAR; - - opt*, glbopt*: SET; - - lasterrpos: LONGINT; - inR: Texts.Reader; - Log: Texts.Text; - W: Texts.Writer; - oldSF, newSF: Files.Rider; - R: ARRAY 3 OF Files.Rider; - oldSFile, newSFile, HFile, BFile, HIFile: Files.File; - - S: INTEGER; - stop, useLineNo, useParFile, dontAsm-, dontLink-, mainProg-, mainLinkStat-, notColorOutput-, forceNewSym-, Verbose-: BOOLEAN; - - - (* ------------------------- Log Output ------------------------- *) - - PROCEDURE LogW*(ch: CHAR); - BEGIN Console.Char(ch) - END LogW; - - PROCEDURE LogWStr*(s: ARRAY OF CHAR); - BEGIN Console.String(s) - END LogWStr; - - PROCEDURE LogWNum*(i, len: LONGINT); - BEGIN Console.Int(i, len) - END LogWNum; - - PROCEDURE LogWLn*; - BEGIN Console.Ln - END LogWLn; - - - (* ------------------------- parameter handling -------------------------*) - - PROCEDURE ScanOptions(VAR s: ARRAY OF CHAR; VAR opt: SET); - VAR i: INTEGER; - BEGIN - i := 1; (* skip - *) - WHILE s[i] # 0X DO - CASE s[i] OF - | "e": opt := opt / {extsf} - | "s": opt := opt / {newsf} - | "m": opt := opt / {mainprog} - | "x": opt := opt / {inxchk} - | "v": opt := opt / {vcpp}; - | "r": opt := opt / {ranchk} - | "t": opt := opt / {typchk} - | "a": opt := opt / {assert} - | "k": opt := opt / {ansi} - | "p": opt := opt / {ptrinit} - | "i": opt := opt / {include0} - | "l": opt := opt / {lineno} - | "P": opt := opt / {useparfile} - | "S": opt := opt / {dontasm} - | "c": opt := opt / {dontlink} - | "M": opt := opt / {mainlinkstat} - | "f": opt := opt / {notcoloroutput} - | "F": opt := opt / {forcenewsym} - | "V": opt := opt / {verbose} - ELSE LogWStr(" warning: option "); LogW(OptionChar); LogW(s[i]); LogWStr(" ignored"); LogWLn - END ; - INC(i) - END; - END ScanOptions; - - PROCEDURE ^GetProperties; - - PROCEDURE OpenPar*; (* prepare for a sequence of translations *) - VAR s: ARRAY 256 OF CHAR; - BEGIN - IF Args.argc = 1 THEN stop := TRUE; - Console.Ln; - Console.String("voc - Vishap Oberon-2 compiler "); - Console.String(version.version); Console.String (" "); - Console.String(version.date); Console.String (" for "); Console.String(version.arch); - Console.Ln; - Console.String("based on Ofront by Software Templ OEG"); Console.Ln; - Console.String("continued by Norayr Chilingarian and others"); Console.Ln; - Console.Ln; - Console.String(' command = "voc" options {file options}.'); Console.Ln; - Console.String(' options = ["-" {option} ].'); Console.Ln; - Console.String(' option = "m" | "M" | "s" | "e" | "i" | "l" | "k" | "r" | "x" | "a" | "p" | "t" | "P" | "S" | "c" | "f" | "F" | "V" .'); Console.Ln; - Console.Ln; - Console.String(" m - generate code for main module"); Console.Ln; - Console.String(" M - generate code for main module and link object statically"); Console.Ln; - Console.String(" s - generate new symbol file"); Console.Ln; - Console.String(" e - allow extending the module interface"); Console.Ln; - Console.String(" i - include header and body prefix files (c0)"); Console.Ln; - Console.String(" l - use line numbers"); Console.Ln; - Console.String(" r - check value ranges"); Console.Ln; - Console.String(" x - turn off array indices check"); Console.Ln; - Console.String(" a - don't check ASSERTs at runtime, use this option in tested production code"); Console.Ln; - Console.String(" p - turn off automatic pointer initialization"); Console.Ln; - Console.String(" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)"); Console.Ln; - Console.String(" P - use .par file"); Console.Ln; - Console.String(" S - don't call external assembler/compiler, only generate the asm/C code"); Console.Ln; - Console.String(" c - don't call linker"); Console.Ln; - Console.String(" f - don't use color output"); Console.Ln; - Console.String(" F - force writing new symbol file"); Console.Ln; - Console.String(" V - verbose output"); Console.Ln; - Console.Ln; - ELSE - glbopt := defopt; S := 1; s := ""; - Args.Get(1, s); stop := FALSE; - WHILE s[0] = OptionChar DO ScanOptions(s, glbopt); INC(S); s := ""; Args.Get(S, s) END; - IF lineno IN opt THEN (* this brought here from InitOptions which turned out to be unnecessary *) - useLineNo := TRUE; curpos := 256; errpos := curpos; - lasterrpos := curpos - 10 - ELSE - useLineNo := FALSE; - END; - IF useparfile IN glbopt THEN useParFile := TRUE ELSE useParFile := FALSE END; (* this check must be made before calling getproperties, noch *) - IF dontasm IN glbopt THEN dontAsm := TRUE ELSE dontAsm := FALSE END; - IF dontlink IN glbopt THEN dontLink := TRUE ELSE dontLink := FALSE END; - IF mainprog IN glbopt THEN mainProg := TRUE ELSE mainProg := FALSE END; - IF mainlinkstat IN glbopt THEN INCL(glbopt, mainprog); mainLinkStat := TRUE ELSE mainLinkStat := FALSE END; - IF notcoloroutput IN glbopt THEN notColorOutput := TRUE ELSE notColorOutput := FALSE END; - IF forcenewsym IN glbopt THEN forceNewSym := TRUE ELSE forceNewSym := FALSE END; - IF verbose IN glbopt THEN Verbose := TRUE ELSE Verbose := FALSE END; - GetProperties; (* GetProperties moved here in order to call it after ScanOptions because we have an option whether to use par file or not, noch *) - - END; - END OpenPar; - - PROCEDURE InitOptions*; (* get the options for one translation *) - VAR s: ARRAY 256 OF CHAR; - BEGIN - opt := glbopt; s := ""; Args.Get(S, s); - WHILE s[0] = OptionChar DO ScanOptions(s, opt); INC(S); s := ""; Args.Get(S, s) END ; - IF lineno IN opt THEN useLineNo := TRUE; curpos := 256; errpos := curpos; lasterrpos := curpos - 10 - ELSE useLineNo := FALSE; - END; - - IF useparfile IN opt THEN useParFile := TRUE ELSE useParFile := FALSE END; (* this check must be made before calling getproperties, noch *) - IF dontasm IN opt THEN dontAsm := TRUE ELSE dontAsm := FALSE END; - IF dontlink IN opt THEN dontLink := TRUE ELSE dontLink := FALSE END; - IF mainprog IN opt THEN mainProg := TRUE ELSE mainProg := FALSE END; - IF mainlinkstat IN opt THEN INCL(glbopt, mainprog); mainLinkStat := TRUE ELSE mainLinkStat := FALSE END; - IF forcenewsym IN glbopt THEN forceNewSym := TRUE ELSE forceNewSym := FALSE END; - IF verbose IN glbopt THEN Verbose := TRUE ELSE Verbose := FALSE END; - END InitOptions; - - PROCEDURE Init*(VAR done: BOOLEAN; VAR mname : ARRAY OF CHAR); (* get the source for one translation *) - VAR T: Texts.Text; beg, end, time: LONGINT; - s: ARRAY 256 OF CHAR; - BEGIN - done := FALSE; curpos := 0; - IF stop OR (S >= Args.argc) THEN RETURN END ; - s := ""; Args.Get(S, s); - NEW(T); Texts.Open(T, s); - LogWStr(s); - COPY(s, mname); - COPY(s, SourceFileName); (* to keep it also in this module -- noch *) - IF T.len = 0 THEN LogWStr(" not found"); LogWLn - ELSE - Texts.OpenReader(inR, T, 0); - LogWStr(" translating"); - done := TRUE - END ; - INC(S); - level := 0; noerr := TRUE; errpos := curpos; lasterrpos := curpos -10; - END Init; - - (* ------------------------- read source text -------------------------*) - - PROCEDURE Get*(VAR ch: CHAR); (* read next character from source text, 0X if eof *) - BEGIN - Texts.Read(inR, ch); - IF useLineNo THEN - IF ch = 0DX THEN curpos := (curpos DIV 256 + 1) * 256 - ELSIF curpos MOD 256 # 255 THEN INC(curpos) - (* at 255 means: >= 255 *) - END - ELSIF ch = 0DX THEN - curpos := Texts.Pos(inR); (* supports CR LF mapping *) - ELSE - INC(curpos) - END ; - IF (ch < 09X) & ~inR.eot THEN ch := " " END - END Get; - - PROCEDURE MakeFileName(VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR); - VAR i, j: INTEGER; ch: CHAR; - BEGIN i := 0; - LOOP ch := name[i]; - IF ch = 0X THEN EXIT END ; - FName[i] := ch; INC(i) - END ; - j := 0; - REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j) - UNTIL ch = 0X - END MakeFileName; - - PROCEDURE LogErrMsg(n: INTEGER); - VAR S: Texts.Scanner; T: Texts.Text; ch: CHAR; i: INTEGER; - buf: ARRAY 1024 OF CHAR; - BEGIN - IF n >= 0 THEN - IF ~notColorOutput THEN vt100.SetAttr(vt100.Red) END; - LogWStr(" err "); - IF ~notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - ELSE - IF ~notColorOutput THEN vt100.SetAttr(vt100.Magenta) END; - LogWStr(" warning "); n := -n; - IF ~notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - END ; - LogWNum(n, 1); - LogWStr(" "); - (*NEW(T); Texts.Open(T, "vocErrors.Text"); Texts.OpenScanner(S, T, 0); - REPEAT S.line := 0; - REPEAT Texts.Scan(S) UNTIL S.eot OR (S.line # 0) - UNTIL S.eot OR (S.class = Texts.Int) & (S.i = n); - IF ~S.eot THEN Texts.Read(S, ch); i := 0; - WHILE ~S.eot & (ch # 0DX) DO buf[i] := ch; INC(i); Texts.Read(S, ch) END ; - buf[i] := 0X; LogWStr(buf); - END*) - LogWStr(errors.errors[n]); - END LogErrMsg; - - PROCEDURE ShowLine(pos: LONGINT); - VAR - f : Files.File; - r : Files.Rider; - newpos, localpos, delta : LONGINT; - line : ARRAY 1023 OF CHAR; - i : INTEGER; - ch : CHAR; - BEGIN - localpos := pos; - f := Files.Old(SourceFileName); - - (* - Console.Ln; Console.String("-- source file is "); Console.String(SourceFileName); Console.Ln; - Console.String("-- pos is "); Console.Int(pos, 0); Console.Ln; - *) - (* make sure previous character is character *) - REPEAT - DEC(localpos); IF localpos < 0 THEN localpos := 0 END; - Files.Set(r, f, localpos); - Files.Read(r, ch); - UNTIL (localpos < 1) OR(ORD(ch) >= 32) OR (ORD(ch)=9); - newpos := localpos; - (* - Console.String("-- newpos, last character before error "); Console.Int(newpos, 0); Console.Ln; - *) - (* finding last line end *) - REPEAT - DEC(localpos); IF localpos < 0 THEN newpos := 0 END; - Files.Set(r, f, localpos); - Files.Read(r, ch); -(* - Console.String("-- prev num "); Console.Int(localpos, 0);Console.String(" "); Console.Char(ch); Console.Ln; -*) - UNTIL (localpos < 1) OR ((ORD(ch) < 32) & (ORD(ch) # 9)); -(* - Console.String("-- previous line at pos "); Console.Int(localpos, 0); Console.Ln; -*) - delta := newpos - localpos - 1; - IF delta < 1 THEN delta := 1 END; - (* - Console.String("-- delta "); Console.Int(delta, 0); Console.Ln; -*) - (* skip enter *) - REPEAT - INC(localpos); - Files.Set(r, f, localpos); - Files.Read(r, ch); - UNTIL (ORD(ch) >= 32) OR (ORD(ch) = 9); - i := 0; - REPEAT - Files.Set(r, f, localpos); - Files.Read(r, ch); - IF ORD(ch) = 9 THEN ch := " " END; - line[i] := ch; -(* - Console.String("-- localpos "); Console.Int(localpos, 0); Console.Ln; - Console.String(" -- ch "); Console.Char(ch); Console.Ln; -*) - INC(localpos); - INC(i); - UNTIL r.eof OR (i >= 1022) OR ((ORD(ch) < 32) & (ORD(ch) # 9)); - line[i] := 0X; - IF (line[i-1] = 0AX) OR (line[i-1] = 0DX) THEN line[i-1] := 0X END; - (*Console.String(" -- length of line "); Console.Int(i, 0); Console.Ln;*) - Console.Ln; Console.Ln; Console.String(" "); Console.String(line); - Console.Ln; - - i := 0; - Console.String(" "); - REPEAT - Console.Char(" "); - INC(i); - UNTIL i >= delta; - IF ~notColorOutput THEN vt100.SetAttr(vt100.Green) END; - Console.Char("^"); (*Console.Ln;*) - IF ~notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - Files.Close(f); - - END ShowLine; - - PROCEDURE ShowLineErr(linenum, posnum : LONGINT); - VAR - f : Files.File; - r : Files.Rider; - line : ARRAY 1023 OF CHAR; - i,j : LONGINT; - ch : CHAR; - BEGIN - - f := Files.Old(SourceFileName); - Files.Set(r, f, 0); - - (* skip non character symbols in the beginning *) - REPEAT - Files.Read(r, ch); - UNTIL ORD(ch) > 31; - - i := 0; j := 0; - REPEAT - IF (ORD(ch) > 31) OR (ORD(ch) = 9) THEN - IF ORD(ch)=9 THEN ch := " " END; - line[i] := ch; INC(i); line[i+1] := 0X; - ELSE - IF ch = 0AX THEN INC(j); i := 0 END - END; - (* - Console.Ln; Console.String("-- line["); Console.Int(i-1, 0); Console.String("] = "); Console.Char(ch); Console.Ln; -*) - Files.Read(r, ch); -(* - Console.String("-- i "); Console.Int(i, 0); Console.Ln; - - Console.String("--j "); Console.Int(j, 0); Console.Ln; - - Console.Char(ch); Console.Ln; -*) - UNTIL (j >= linenum) OR (i >= 1022); - - Console.Ln; Console.String(" "); Console.String(line); Console.Ln; - - i := 0; - WHILE i < posnum-1 DO - Console.Char(" "); - INC(i); - END; - - Console.String(" "); (* compensate shift from Mark() ; -- noch *) - IF ~notColorOutput THEN vt100.SetAttr(vt100.Green) END; - Console.Char("^"); Console.Ln; - IF ~notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - - Files.Close(f); - - END ShowLineErr; - - PROCEDURE Mark*(n: INTEGER; pos: LONGINT); - VAR - linenumber, posnumber : LONGINT; - BEGIN - IF pos = -1 THEN pos := 0 END; - - linenumber := pos DIV 256; - posnumber := pos MOD 256; -(* - Console.Ln; Console.String("-- linenumber "); Console.Int(linenumber, 0); Console.Ln; - Console.String("-- posnumber "); Console.Int(posnumber, 0); Console.Ln; -*) - IF useLineNo THEN - IF n >= 0 THEN - noerr := FALSE; -(* - Console.String("n = "); Console.Int(n, 0); Console.Ln; -*) - IF (pos < lasterrpos) OR (lasterrpos + 9 < pos) THEN lasterrpos := pos; LogWLn; LogWStr(" "); - IF n < 249 THEN ShowLineErr(linenumber, posnumber); LogWStr(" line "); LogWNum(linenumber, 1); - LogWStr(" pos "); LogWNum(posnumber, 1); LogErrMsg(n) - ELSIF n = 255 THEN ShowLineErr(linenumber, posnumber); LogWStr(" line "); LogWNum(linenumber, 1); - LogWStr(" pos "); LogWNum(posnumber, 1); LogWStr(" pc "); LogWNum(breakpc, 1) - ELSIF n = 254 THEN LogWStr("pc not found") - ELSE LogWStr(objname); - IF n = 253 THEN LogWStr(" is new, compile with option e") - ELSIF n = 252 THEN LogWStr(" is redefined, compile with option s") - ELSIF n = 251 THEN LogWStr(" is redefined (private part only), compile with option s") - ELSIF n = 250 THEN LogWStr(" is no longer visible, compile with option s") - ELSIF n = 249 THEN LogWStr(" is not consistently imported, recompile imports") - END - END - END - ELSE - ShowLineErr(linenumber, posnumber); - IF pos >= 0 THEN LogWLn; - LogWStr(" line "); LogWNum(pos DIV 256, 1); LogWStr(" pos "); LogWNum(pos MOD 256, 1) - END ; - LogErrMsg(n); - IF pos < 0 THEN LogWLn END - END - ELSE - IF n >= 0 THEN - noerr := FALSE; - IF (pos < lasterrpos) OR (lasterrpos + 9 < pos) THEN lasterrpos := pos; ShowLine(pos); LogWLn; LogWStr(" "); - IF n < 249 THEN LogWStr(" pos"); LogWNum(pos, 6); LogErrMsg(n) - ELSIF n = 255 THEN LogWStr("pos"); LogWNum(pos, 6); LogWStr(" pc "); LogWNum(breakpc, 1) - ELSIF n = 254 THEN LogWStr("pc not found") - ELSE LogWStr(objname); - IF n = 253 THEN LogWStr(" is new, compile with option e") - ELSIF n = 252 THEN LogWStr(" is redefined, compile with option s") - ELSIF n = 251 THEN LogWStr(" is redefined (private part only), compile with option s") - ELSIF n = 250 THEN LogWStr(" is no longer visible, compile with option s") - ELSIF n = 249 THEN LogWStr(" is not consistently imported, recompile imports") - END - END - END - ELSE - IF pos >= 0 THEN ShowLine(pos); LogWLn; LogWStr(" pos"); LogWNum(pos, 6) END ; - LogErrMsg(n); - IF pos < 0 THEN LogWLn END - END - END - END Mark; - - PROCEDURE err*(n: INTEGER); - BEGIN - IF useLineNo & (errpos MOD 256 = 255) THEN (* line underflow from OPS.Get *) - Mark(n, errpos + 1) - ELSE - Mark(n, errpos) - END - END err; - - PROCEDURE FPrint*(VAR fp: LONGINT; val: LONGINT); - BEGIN - fp := SYSTEM.ROT(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, fp) / SYSTEM.VAL(SET, val)), 1) - END FPrint; - - PROCEDURE FPrintSet*(VAR fp: LONGINT; set: SET); - BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, set)) - END FPrintSet; - - PROCEDURE FPrintReal*(VAR fp: LONGINT; real: REAL); - BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, real)) - END FPrintReal; - - PROCEDURE FPrintLReal*(VAR fp: LONGINT; lr: LONGREAL); - VAR l, h: LONGINT; - BEGIN - SYSTEM.GET(SYSTEM.ADR(lr), l); SYSTEM.GET(SYSTEM.ADR(lr)+4, h); - FPrint(fp, l); FPrint(fp, h) - END FPrintLReal; - - (* ------------------------- initialization ------------------------- *) - - PROCEDURE GetProperty(VAR S: Texts.Scanner; name: ARRAY OF CHAR; VAR size, align: INTEGER); - BEGIN - IF (S.class = Texts.Name) & (S.s = name) THEN Texts.Scan(S); - IF S.class = Texts.Int THEN size := SHORT(S.i); Texts.Scan(S) ELSE Mark(-157, -1) END ; - IF S.class = Texts.Int THEN align := SHORT(S.i); Texts.Scan(S) ELSE Mark(-157, -1) END - ELSE Mark(-157, -1) - END - END GetProperty; - - - - PROCEDURE minus(i: LONGINT): LONGINT; - BEGIN - RETURN -i; - END minus; - - PROCEDURE power0(i, j : LONGINT) : LONGINT; (* we would like to calculate exact Min Max values in GetProperties, not hardcode em, noch *) - VAR k : LONGINT; - p : LONGINT; - BEGIN - k := 1; - p := i; - REPEAT - p := p * i; - INC(k); - UNTIL k=j; - RETURN p; - END power0; - - PROCEDURE VerboseListSizes; - BEGIN - Console.String("Type Size Alignement"); Console.Ln; - Console.String("CHAR "); Console.Int(CharSize, 0); Console.Int(CharAlign, 5); Console.Ln; - Console.String("BOOLEAN "); Console.Int(BoolSize, 0); Console.Int(BoolAlign, 5); Console.Ln; - Console.String("SHORTINT "); Console.Int(SIntSize, 0); Console.Int(SIntAlign, 5); Console.Ln; - Console.String("INTEGER "); Console.Int(IntSize, 0); Console.Int(IntAlign, 5); Console.Ln; - Console.String("LONGINT "); Console.Int(LIntSize, 0); Console.Int(LIntAlign, 5); Console.Ln; - Console.String("SET "); Console.Int(SetSize, 0); Console.Int(SetAlign, 5); Console.Ln; - Console.String("REAL "); Console.Int(RealSize, 0); Console.Int(RealAlign, 5); Console.Ln; - Console.String("LONGREAL "); Console.Int(LRealSize, 0); Console.Int(LRealAlign, 5); Console.Ln; - Console.String("PTR "); Console.Int(PointerSize, 0); Console.Int(PointerAlign, 5); Console.Ln; - Console.String("PROC "); Console.Int(ProcSize, 0); Console.Int(ProcAlign, 5); Console.Ln; - Console.String("RECORD "); Console.Int(RecSize, 0); Console.Int(RecAlign, 5); Console.Ln; - Console.String("ENDIAN "); Console.Int(ByteOrder, 0); Console.Int(BitOrder, 5); Console.Ln; - (* - Console.String("SYSTEM.INT8 "); Console.Int(Int8Size, 0); Console.Int(Int8Align, 5); Console.Ln; - Console.String("SYSTEM.INT16 "); Console.Int(Int16Size, 0); Console.Int(Int16Align, 5); Console.Ln; - Console.String("SYSTEM.INT32 "); Console.Int(Int32Size, 0); Console.Int(Int32Align, 5); Console.Ln; - Console.String("SYSTEM.INT64 "); Console.Int(Int64Size, 0); Console.Int(Int64Align, 5); Console.Ln; - *) - Console.Ln; - Console.String("Min shortint "); Console.Int(MinSInt, 0); Console.Ln; - Console.String("Max shortint "); Console.Int(MaxSInt, 0); Console.Ln; - Console.String("Min integer "); Console.Int(MinInt, 0); Console.Ln; - Console.String("Max integer "); Console.Int(MaxInt, 0); Console.Ln; - Console.String("Min longint "); Console.Int(MinLInt, 0); Console.Ln; - (* - Console.String("Max longint "); Console.Int(MaxLInt, 0); Console.Ln; - Console.String("Min int8 "); Console.Int(MinInt8, 0); Console.Ln; - Console.String("Max int8 "); Console.Int(MaxInt8, 0); Console.Ln; - Console.String("Min int16 "); Console.Int(MinInt16, 0); Console.Ln; - Console.String("Max int16 "); Console.Int(MaxInt16, 0); Console.Ln; - Console.String("Min int32 "); Console.Int(MinInt32, 0); Console.Ln; - Console.String("Max int32 "); Console.Int(MaxInt32, 0); Console.Ln; - *) - - END VerboseListSizes; - - PROCEDURE GetProperties(); - VAR T: Texts.Text; S: Texts.Scanner; - base : LONGINT; - BEGIN - - (* default characteristics *) - IF ~useParFile THEN - IF version.defaultTarget = version.gnux8664 THEN - Console.String (" GNU "); Console.String(version.arch); Console.String(" target"); Console.Ln; - ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 4; LIntSize := 8; - SetSize := 8; RealSize := 4; LRealSize := 8; ProcSize := 8; PointerSize := 8; RecSize := 1; - CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 4; LIntAlign := 8; - (*Int8Align := 1; Int16Align := 2; Int32Align := 4; Int64Align := 8;*) - SetAlign := 8; RealAlign := 4; LRealAlign := 8; ProcAlign := 8; PointerAlign := 8; RecAlign := 1; - (* not necessary, we will calculate values later - MinSInt := -80H; MaxSInt := 7FH; - MinInt := 80000000H(*-2147483648*); - MaxInt := 7FFFFFFFH (*2147483647*); - (*MinLInt := -8000000000000000H*) (*-9223372036854775808*) ; (* -2^63 *) - (*MaxLInt := 7FFFFFFFFFFFFFFFH *)(*9223372036854775807*) ;(* 2^63-1 *) - (*MaxSet := 31;*) - MaxSet := SetSize * 8 - 1; (*noch*) - *) - ELSIF (version.defaultTarget >= version.gnuarmv6j) & (version.defaultTarget <= version.gnuarmv7ahardfp) THEN - Console.String (" GNU "); - Console.String (version.arch); Console.String (" target"); Console.Ln; - ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4; - SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1; - CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4; - (*Int8Align := 1; Int16Align := 2; Int32Align := 4; Int64Align := 4;*) - SetAlign := 4; RealAlign := 4; LRealAlign := 8; ProcAlign := 4; PointerAlign := 4; RecAlign := 1; - - (* not necessary, we will calculate values later - MinSInt := -80H; MinInt := -8000H; MinLInt := 80000000H; (*-2147483648*) - MaxSInt := 7FH; MaxInt := 7FFFH; MaxLInt := 7FFFFFFFH; (*2147483647*) - MaxSet := SetSize * 8 -1; (* noch *) - *) - ELSIF (version.defaultTarget = version.gnupowerpc) THEN - Console.String (" GNU "); - Console.String (version.arch); Console.String (" target"); Console.Ln; - ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4; - SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1; - CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4; - - (*Int8Align := 1; Int16Align := 2; Int32Align := 4; Int64Align := 4;*) - SetAlign := 4; RealAlign := 4; LRealAlign := 8; ProcAlign := 4; PointerAlign := 4; RecAlign := 1; - - - ELSIF version.defaultTarget = version.gnux86 THEN - Console.String("GNU "); Console.String(version.arch); Console.String(" target"); Console.Ln; - ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4; - SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1; - CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4; - - (*Int8Align := 1; Int16Align := 2; Int32Align := 4; Int64Align := 4;*) - SetAlign := 4; RealAlign := 4; LRealAlign := 4; ProcAlign := 4; PointerAlign := 4; RecAlign := 1; - - ELSE (* this should suite any gnu x86 system *) - Console.String (" generic target, like GNU x86 system"); Console.Ln; - ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4; - SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1; - CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4; - - (*Int8Align := 1; Int16Align := 2; Int32Align := 4; Int64Align := 4;*) - SetAlign := 4; RealAlign := 4; LRealAlign := 4; ProcAlign := 4; PointerAlign := 4; RecAlign := 1; -(* LRealAlign should be checked and confirmed *) - (* not necessary, will be calculated later - MinSInt := -80H; MinInt := -8000H; MinLInt := 80000000H; (*-2147483648*) - MaxSInt := 7FH; MaxInt := 7FFFH; MaxLInt := 7FFFFFFFH; (*2147483647*) - MaxSet := SetSize * 8 - 1; - *) - - END; (* if defaultTarget *) - END; (* if ~useParFile *) - (* read voc.par *) - - IF useParFile THEN (* noch *) - IF Verbose THEN Console.String ("loading type sizes from voc.par"); Console.Ln; END; - NEW(T); Texts.Open(T, "voc.par"); - IF T.len # 0 THEN - Texts.OpenScanner(S, T, 0); Texts.Scan(S); - GetProperty(S, "CHAR", CharSize, CharAlign); - GetProperty(S, "BOOLEAN", BoolSize, BoolAlign); - GetProperty(S, "SHORTINT", SIntSize, SIntAlign); - GetProperty(S, "INTEGER", IntSize, IntAlign); - GetProperty(S, "LONGINT", LIntSize, LIntAlign); - GetProperty(S, "SET", SetSize, SetAlign); - GetProperty(S, "REAL", RealSize, RealAlign); - GetProperty(S, "LONGREAL", LRealSize, LRealAlign); - GetProperty(S, "PTR", PointerSize, PointerAlign); - GetProperty(S, "PROC", ProcSize, ProcAlign); - GetProperty(S, "RECORD", RecSize, RecAlign); - (* Size = 0: natural size aligned to next power of 2 up to RecAlign; e.g. i960 - Size = 1; size and alignment follows from field types but at least RecAlign; e.g, SPARC, MIPS, PowerPC - *) - GetProperty(S, "ENDIAN", ByteOrder, BitOrder); (*currently not used*) - - (* - GetProperty(S, "SYSTEM.INT8", Int8Size, Int8Align); - GetProperty(S, "SYSTEM.INT16", Int16Size, Int16Align); - GetProperty(S, "SYSTEM.INT32", Int32Size, Int32Align); - GetProperty(S, "SYSTEM.INT64", Int64Size, Int64Align);*) - (* add here Max and Min sizes, noch *) - ByteSize := CharSize; - - ELSE Mark(-156, -1) - END ; - ELSE - IF Verbose THEN - Console.String ("not using voc.par file"); Console.Ln - END - END; (* if useParFile , noch *) - - (*Int8Size := 1; Int16Size := 2; Int32Size := 4; Int64Size := 8;*) - -(* commenting this by replacing with faster way; -- noch * - MinSInt := power0(-2, (SIntSize*8-1)); (* -2^(SIntSize*8-1)*) - (*MaxSInt := -(MinSint + 1);; may be optimized?*) - MaxSInt := minus(MinSInt + 1); - MinInt := power0(-2, (IntSize*8-1)); - MaxInt := minus(MinInt + 1); - - MinLInt := power0(-2, (LIntSize*8-1)); - MaxLInt := minus(MinLInt +1); -*) - (* and I'd like to calculate it, not hardcode constants *) - base := -2; - (* we can do - MinLInt := ASH(-2, LIntSize*8-2); - but some compilers may treat -2 as SHORTINT, not LONGINT; -- noch *) - MinSInt := ASH(base, SIntSize*8-2); - MaxSInt := minus(MinSInt + 1); - - MinInt := ASH(base, IntSize*8-2); - MaxInt := minus(MinInt + 1); - - MinLInt := ASH(base, LIntSize*8-2); - MaxLInt := minus(MinLInt +1); - (* - MinInt8 := -80H; MinInt16 := -8000H; MinInt32 := 80000000H; (*-2147483648*) - MaxInt8 := 7FH; MaxInt16 := 7FFFH; MaxInt32 := 7FFFFFFFH; (*2147483647*) - - MinInt64 := ASH(base, Int64Size*8-2); - MaxInt64 := minus(ASH(base, Int64Size*8-2) + 1); -*) - IF RealSize = 4 THEN MaxReal := 3.40282346D38 - ELSIF RealSize = 8 THEN MaxReal := 1.7976931348623157D307 * 9.999999 - (*should be 1.7976931348623157D308 *) - END ; - IF LRealSize = 4 THEN MaxLReal := 3.40282346D38 - ELSIF LRealSize = 8 THEN MaxLReal := 1.7976931348623157D307 * 9.999999 - (*should be 1.7976931348623157D308 *) - END ; - MinReal := -MaxReal; - MinLReal := -MaxLReal; - (* commented this out, *) - (*IF IntSize = 4 THEN MinInt := MinLInt; MaxInt := MaxLInt END ;*) - (*IF IntSize = 4 THEN MinLInt := MinInt; MaxLInt := MaxInt END ;*) - MaxSet := SetSize * 8 - 1; - MaxIndex := MaxLInt; (* shouldn't it be like max(int)? so that for loop will be safe, noch *) - IF Verbose THEN - VerboseListSizes - END; - - - END GetProperties; - - (* ------------------------- Read Symbol File ------------------------- *) - - PROCEDURE SymRCh*(VAR ch: CHAR); - BEGIN Files.Read(oldSF, ch) - END SymRCh; - - PROCEDURE SymRInt*(): LONGINT; - VAR k: LONGINT; - BEGIN Files.ReadNum(oldSF, k); RETURN k - END SymRInt; - - PROCEDURE SymRSet*(VAR s: SET); - BEGIN Files.ReadNum(oldSF, SYSTEM.VAL(LONGINT, s)) - END SymRSet; - - PROCEDURE SymRReal*(VAR r: REAL); - BEGIN Files.ReadReal(oldSF, r) - END SymRReal; - - PROCEDURE SymRLReal*(VAR lr: LONGREAL); - BEGIN Files.ReadLReal(oldSF, lr) - END SymRLReal; - - PROCEDURE CloseOldSym*; - END CloseOldSym; - - PROCEDURE OldSym*(VAR modName: ARRAY OF CHAR; VAR done: BOOLEAN); - VAR ch: CHAR; fileName: FileName; - BEGIN MakeFileName(modName, fileName, SFext); - oldSFile := Files.Old(fileName); done := oldSFile # NIL; - IF done THEN - Files.Set(oldSF, oldSFile, 0); Files.Read(oldSF, ch); - IF ch # SFtag THEN err(-306); (*possibly a symbol file from another Oberon implementation, e.g. HP-Oberon*) - CloseOldSym; done := FALSE - END - END - END OldSym; - - PROCEDURE eofSF*(): BOOLEAN; - BEGIN RETURN oldSF.eof - END eofSF; - - (* ------------------------- Write Symbol File ------------------------- *) - - PROCEDURE SymWCh*(ch: CHAR); - BEGIN Files.Write(newSF, ch) - END SymWCh; - - PROCEDURE SymWInt*(i: LONGINT); - BEGIN Files.WriteNum(newSF, i) - END SymWInt; - - PROCEDURE SymWSet*(s: SET); - BEGIN Files.WriteNum(newSF, SYSTEM.VAL(LONGINT, s)) - END SymWSet; - - PROCEDURE SymWReal*(r: REAL); - BEGIN Files.WriteReal(newSF, r) - END SymWReal; - - PROCEDURE SymWLReal*(lr: LONGREAL); - BEGIN Files.WriteLReal(newSF, lr) - END SymWLReal; - - PROCEDURE RegisterNewSym*; - BEGIN - IF (modName # "SYSTEM") OR (mainprog IN opt) THEN Files.Register(newSFile) END - END RegisterNewSym; - - PROCEDURE DeleteNewSym*; - END DeleteNewSym; - - PROCEDURE NewSym*(VAR modName: ARRAY OF CHAR); - VAR fileName: FileName; - BEGIN MakeFileName(modName, fileName, SFext); - newSFile := Files.New(fileName); - IF newSFile # NIL THEN Files.Set(newSF, newSFile, 0); Files.Write(newSF, SFtag) - ELSE err(153) - END - END NewSym; - - (* ------------------------- Write Header & Body Files ------------------------- *) - - PROCEDURE Write*(ch: CHAR); - BEGIN Files.Write(R[currFile], ch) - END Write; - - PROCEDURE WriteString*(s: ARRAY [1] OF CHAR); - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO INC(i) END ; - Files.WriteBytes(R[currFile], s, i) - END WriteString; - - PROCEDURE WriteStringVar*(VAR s: ARRAY OF CHAR); - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO INC(i) END ; - Files.WriteBytes(R[currFile], s, i) - END WriteStringVar; - - PROCEDURE WriteHex* (i: LONGINT); - VAR s: ARRAY 3 OF CHAR; - digit : INTEGER; - BEGIN - digit := SHORT(i) DIV 16; - IF digit < 10 THEN s[0] := CHR (ORD ("0") + digit); ELSE s[0] := CHR (ORD ("a") - 10 + digit ); END; - digit := SHORT(i) MOD 16; - IF digit < 10 THEN s[1] := CHR (ORD ("0") + digit); ELSE s[1] := CHR (ORD ("a") - 10 + digit ); END; - s[2] := 0X; - WriteString(s) - END WriteHex; - - PROCEDURE WriteInt* (i: LONGINT); - VAR s: ARRAY 20 OF CHAR; i1, k: LONGINT; - BEGIN - IF i = MinLInt THEN Write("("); WriteInt(i+1); WriteString("-1)") (* requires special bootstrap for 64 bit *) - 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 ; - IF i < 0 THEN s[k] := "-"; INC(k) END ; - WHILE k > 0 DO DEC(k); Write(s[k]) END - END ; - END WriteInt; - - PROCEDURE WriteReal* (r: LONGREAL; suffx: CHAR); - VAR W: Texts.Writer; T: Texts.Text; R: Texts.Reader; s: ARRAY 32 OF CHAR; ch: CHAR; i: INTEGER; - BEGIN -(*should be improved *) - IF (r < MaxLInt) & (r > MinLInt) & (r = ENTIER(r)) THEN - IF suffx = "f" THEN WriteString("(REAL)") ELSE WriteString("(LONGREAL)") END ; - WriteInt(ENTIER(r)) - ELSE - Texts.OpenWriter(W); - IF suffx = "f" THEN Texts.WriteLongReal(W, r, 16) ELSE Texts.WriteLongReal(W, r, 23) END ; - NEW(T); Texts.Open(T, ""); Texts.Append(T, W.buf); - Texts.OpenReader(R, T, 0); i := 0; Texts.Read(R, ch); - WHILE ch # 0X DO s[i] := ch; INC(i); Texts.Read(R, ch) END ; - (* s[i] := suffx; s[i+1] := 0X; - suffix does not work in K&R *) - s[i] := 0X; - i := 0; ch := s[0]; - WHILE (ch # "D") & (ch # 0X) DO INC(i); ch := s[i] END ; - IF ch = "D" THEN s[i] := "e" END ; - WriteString(s) - END - END WriteReal; - - PROCEDURE WriteLn* (); - BEGIN Files.Write(R[currFile], 0AX) - END WriteLn; - - PROCEDURE Append(VAR R: Files.Rider; F: Files.File); - VAR R1: Files.Rider; buffer: ARRAY 4096 OF CHAR; - BEGIN - IF F # NIL THEN - Files.Set(R1, F, 0); Files.ReadBytes(R1, buffer, LEN(buffer)); - WHILE LEN(buffer) - R1.res > 0 DO - Files.WriteBytes(R, buffer, LEN(buffer) - R1.res); - Files.ReadBytes(R1, buffer, LEN(buffer)) - END - END - END Append; - - PROCEDURE OpenFiles*(VAR moduleName: ARRAY OF CHAR); - VAR FName: ARRAY 32 OF CHAR; - BEGIN - COPY(moduleName, modName); - HFile := Files.New(""); - IF HFile # NIL THEN Files.Set(R[HeaderFile], HFile, 0) ELSE err(153) END ; - MakeFileName(moduleName, FName, BFext); - BFile := Files.New(FName); - IF BFile # NIL THEN Files.Set(R[BodyFile], BFile, 0) ELSE err(153) END ; - MakeFileName(moduleName, FName, HFext); - HIFile := Files.New(FName); - IF HIFile # NIL THEN Files.Set(R[HeaderInclude], HIFile, 0) ELSE err(153) END ; - IF include0 IN opt THEN - MakeFileName(moduleName, FName, ".h0"); Append(R[HeaderInclude], Files.Old(FName)); - MakeFileName(moduleName, FName, ".c0"); Append(R[BodyFile], Files.Old(FName)) - END - END OpenFiles; - - PROCEDURE CloseFiles*; - VAR FName: ARRAY 32 OF CHAR; res: INTEGER; - BEGIN - IF noerr THEN LogWStr(" "); LogWNum(Files.Pos(R[BodyFile]), 0) END ; - IF noerr THEN - IF modName = "SYSTEM" THEN - IF ~(mainprog IN opt) THEN Files.Register(BFile) END - ELSIF ~(mainprog IN opt) THEN - Append(R[HeaderInclude], HFile); - Files.Register(HIFile); Files.Register(BFile) - ELSE - MakeFileName(modName, FName, HFext); Files.Delete(FName, res); - MakeFileName(modName, FName, SFext); Files.Delete(FName, res); - Files.Register(BFile) - END - END ; - HFile := NIL; BFile := NIL; HIFile := NIL; newSFile := NIL; oldSFile := NIL; - Files.Set(R[0], NIL, 0); Files.Set(R[1], NIL, 0); Files.Set(R[2], NIL, 0); Files.Set(newSF, NIL, 0); Files.Set(oldSF, NIL, 0) - END CloseFiles; - - PROCEDURE PromoteIntConstToLInt*(); - BEGIN - (* ANSI C does not need explicit promotion. - K&R C implicitly promotes integer constants to type int in parameter lists. - if the formal parameter, however, is of type long, appending "L" is required in ordere to promote - the parameter explicitly to type long (if LONGINT corresponds to long, which we do not really know). - It works for all known K&R versions of voc and K&R is dying out anyway. - A cleaner solution would be to cast with type (LONGINT), but this requires a bit more changes. - *) - IF ~(ansi IN opt) THEN Write("L") END - END PromoteIntConstToLInt; - -BEGIN Texts.OpenWriter(W) -END OPM. diff --git a/src/voc/OPS.Mod b/src/voc/OPS.Mod deleted file mode 100644 index c251c2be..00000000 --- a/src/voc/OPS.Mod +++ /dev/null @@ -1,315 +0,0 @@ -MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) - - IMPORT OPM; - - CONST - MaxStrLen* = 256; - MaxIdLen = 256; - - TYPE - Name* = ARRAY MaxIdLen OF CHAR; - String* = ARRAY MaxStrLen OF CHAR; - - (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) - - VAR - name*: Name; - str*: String; - numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *) - intval*: LONGINT; (* integer value or string length *) - realval*: REAL; - lrlval*: LONGREAL; - - (*symbols: - | 0 1 2 3 4 - ---|-------------------------------------------------------- - 0 | null * / DIV MOD - 5 | & + - OR = - 10 | # < <= > >= - 15 | IN IS ^ . , - 20 | : .. ) ] } - 25 | OF THEN DO TO BY - 30 | ( [ { ~ := - 35 | number NIL string ident ; - 40 | | END ELSE ELSIF UNTIL - 45 | IF CASE WHILE REPEAT FOR - 50 | LOOP WITH EXIT RETURN ARRAY - 55 | RECORD POINTER BEGIN CONST TYPE - 60 | VAR PROCEDURE IMPORT MODULE eof *) - - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (*symbol values*) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - VAR - ch: CHAR; (*current character*) - - PROCEDURE err(n: INTEGER); - BEGIN OPM.err(n) - END err; - - PROCEDURE Str(VAR sym: SHORTINT); - VAR i: INTEGER; och: CHAR; - BEGIN i := 0; och := ch; - LOOP OPM.Get(ch); - IF ch = och THEN EXIT END ; - IF ch < " " THEN err(3); EXIT END ; - IF i = MaxStrLen-1 THEN err(241); EXIT END ; - str[i] := ch; INC(i) - END ; - OPM.Get(ch); str[i] := 0X; intval := i + 1; - IF intval = 2 THEN - sym := number; numtyp := 1; intval := ORD(str[0]) - ELSE sym := string - END - END Str; - - PROCEDURE Identifier(VAR sym: SHORTINT); - VAR i: INTEGER; - BEGIN i := 0; - REPEAT - name[i] := ch; INC(i); OPM.Get(ch) - UNTIL (ch < "0") OR ("9" < ch) & (CAP(ch) < "A") OR ("Z" < CAP(ch)) OR (i = MaxIdLen); - IF i = MaxIdLen THEN err(240); DEC(i) END ; - name[i] := 0X; sym := ident - END Identifier; - - PROCEDURE Number; - VAR i, m, n, d, e: INTEGER; dig: ARRAY 24 OF CHAR; f: LONGREAL; expCh: CHAR; neg: BOOLEAN; - - PROCEDURE Ten(e: INTEGER): LONGREAL; - VAR x, p: LONGREAL; - BEGIN x := 1; p := 10; - WHILE e > 0 DO - IF ODD(e) THEN x := x*p END; - e := e DIV 2; - IF e > 0 THEN p := p*p END (* prevent overflow *) - END; - RETURN x - END Ten; - - PROCEDURE Ord(ch: CHAR; hex: BOOLEAN): INTEGER; - BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *) - IF ch <= "9" THEN RETURN ORD(ch) - ORD("0") - ELSIF hex THEN RETURN ORD(ch) - ORD("A") + 10 - ELSE err(2); RETURN 0 - END - END Ord; - - BEGIN (* ("0" <= ch) & (ch <= "9") *) - i := 0; m := 0; n := 0; d := 0; - LOOP (* read mantissa *) - IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN - IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *) - IF n < LEN(dig) THEN dig[n] := ch; INC(n) END; - INC(m) - END; - OPM.Get(ch); INC(i) - ELSIF ch = "." THEN OPM.Get(ch); - IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT - ELSIF d = 0 THEN (* i > 0 *) d := i - ELSE err(2) - END - ELSE EXIT - END - END; (* 0 <= n <= m <= i, 0 <= d <= i *) - IF d = 0 THEN (* integer *) - IF n = m THEN intval := 0; i := 0; - IF ch = "X" THEN (* character *) OPM.Get(ch); numtyp := char; - IF n <= 2 THEN - WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END - ELSE err(203) - END - ELSIF ch = "H" THEN (* hexadecimal *) OPM.Get(ch); numtyp := integer; - IF n <= OPM.MaxHDig THEN - IF (n = OPM.MaxHDig) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; - WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END - ELSE err(203) - END - ELSE (* decimal *) numtyp := integer; - WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); - IF intval <= (MAX(LONGINT) - d) DIV 10 THEN intval := intval*10 + d - ELSE err(203) - END - END - END - ELSE err(203) - END - ELSE (* fraction *) - f := 0; e := 0; expCh := "E"; - WHILE n > 0 DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END; - IF (ch = "E") OR (ch = "D") THEN expCh := ch; OPM.Get(ch); neg := FALSE; - IF ch = "-" THEN neg := TRUE; OPM.Get(ch) - ELSIF ch = "+" THEN OPM.Get(ch) - END; - IF ("0" <= ch) & (ch <= "9") THEN - REPEAT n := Ord(ch, FALSE); OPM.Get(ch); - IF e <= (MAX(INTEGER) - n) DIV 10 THEN e := e*10 + n - ELSE err(203) - END - UNTIL (ch < "0") OR ("9" < ch); - IF neg THEN e := -e END - ELSE err(2) - END - END; - DEC(e, i-d-m); (* decimal point shift *) - IF expCh = "E" THEN numtyp := real; - IF (1-OPM.MaxRExp < e) & (e <= OPM.MaxRExp) THEN - IF e < 0 THEN realval := SHORT(f / Ten(-e)) - ELSE realval := SHORT(f * Ten(e)) - END - ELSE err(203) - END - ELSE numtyp := longreal; - IF (1-OPM.MaxLExp < e) & (e <= OPM.MaxLExp) THEN - IF e < 0 THEN lrlval := f / Ten(-e) - ELSE lrlval := f * Ten(e) - END - ELSE err(203) - END - END - END - END Number; - - PROCEDURE Get*(VAR sym: SHORTINT); - VAR s: SHORTINT; - - PROCEDURE Comment; (* do not read after end of file *) - BEGIN OPM.Get(ch); - LOOP - LOOP - WHILE ch = "(" DO OPM.Get(ch); - IF ch = "*" THEN Comment END - END ; - IF ch = "*" THEN OPM.Get(ch); EXIT END ; - IF ch = OPM.Eot THEN EXIT END ; - OPM.Get(ch) - END ; - IF ch = ")" THEN OPM.Get(ch); EXIT END ; - IF ch = OPM.Eot THEN err(5); EXIT END - END - END Comment; - - BEGIN - OPM.errpos := OPM.curpos-1; - WHILE ch <= " " DO (*ignore control characters*) - IF ch = OPM.Eot THEN sym := eof; RETURN - ELSE OPM.Get(ch) - END - END ; - CASE ch OF (* ch > " " *) - | 22X, 27X : Str(s) - | "#" : s := neq; OPM.Get(ch) - | "&" : s := and; OPM.Get(ch) - | "(" : OPM.Get(ch); - IF ch = "*" THEN Comment; Get(s) - ELSE s := lparen - END - | ")" : s := rparen; OPM.Get(ch) - | "*" : s := times; OPM.Get(ch) - | "+" : s := plus; OPM.Get(ch) - | "," : s := comma; OPM.Get(ch) - | "-" : s := minus; OPM.Get(ch) - | "." : OPM.Get(ch); - IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END - | "/" : s := slash; OPM.Get(ch) - | "0".."9": Number; s := number - | ":" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END - | ";" : s := semicolon; OPM.Get(ch) - | "<" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END - | "=" : s := eql; OPM.Get(ch) - | ">" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END - | "A": Identifier(s); IF name = "ARRAY" THEN s := array END - | "B": Identifier(s); - IF name = "BEGIN" THEN s := begin - ELSIF name = "BY" THEN s := by - END - | "C": Identifier(s); - IF name = "CASE" THEN s := case - ELSIF name = "CONST" THEN s := const - END - | "D": Identifier(s); - IF name = "DO" THEN s := do - ELSIF name = "DIV" THEN s := div - END - | "E": Identifier(s); - IF name = "END" THEN s := end - ELSIF name = "ELSE" THEN s := else - ELSIF name = "ELSIF" THEN s := elsif - ELSIF name = "EXIT" THEN s := exit - END - | "F": Identifier(s); IF name = "FOR" THEN s := for END - | "I": Identifier(s); - IF name = "IF" THEN s := if - ELSIF name = "IN" THEN s := in - ELSIF name = "IS" THEN s := is - ELSIF name = "IMPORT" THEN s := import - END - | "L": Identifier(s); IF name = "LOOP" THEN s := loop END - | "M": Identifier(s); - IF name = "MOD" THEN s := mod - ELSIF name = "MODULE" THEN s := module - END - | "N": Identifier(s); IF name = "NIL" THEN s := nil END - | "O": Identifier(s); - IF name = "OR" THEN s := or - ELSIF name = "OF" THEN s := of - END - | "P": Identifier(s); - IF name = "PROCEDURE" THEN s := procedure - ELSIF name = "POINTER" THEN s := pointer - END - | "R": Identifier(s); - IF name = "RECORD" THEN s := record - ELSIF name = "REPEAT" THEN s := repeat - ELSIF name = "RETURN" THEN s := return - END - | "T": Identifier(s); - IF name = "THEN" THEN s := then - ELSIF name = "TO" THEN s := to - ELSIF name = "TYPE" THEN s := type - END - | "U": Identifier(s); IF name = "UNTIL" THEN s := until END - | "V": Identifier(s); IF name = "VAR" THEN s := var END - | "W": Identifier(s); - IF name = "WHILE" THEN s := while - ELSIF name = "WITH" THEN s := with - END - | "G".."H", "J", "K", "Q", "S", "X".."Z": Identifier(s) - | "[" : s := lbrak; OPM.Get(ch) - | "]" : s := rbrak; OPM.Get(ch) - | "^" : s := arrow; OPM.Get(ch) - | "a".."z": Identifier(s) - | "{" : s := lbrace; OPM.Get(ch) - | "|" : s := bar; OPM.Get(ch) - | "}" : s := rbrace; OPM.Get(ch) - | "~" : s := not; OPM.Get(ch) - | 7FX : s := upto; OPM.Get(ch) - ELSE s := null; OPM.Get(ch) - END ; - sym := s - END Get; - - PROCEDURE Init*; - BEGIN ch := " " - END Init; - -END OPS. diff --git a/src/voc/OPT.Mod b/src/voc/OPT.Mod deleted file mode 100644 index 34a57061..00000000 --- a/src/voc/OPT.Mod +++ /dev/null @@ -1,1330 +0,0 @@ -MODULE OPT; (* NW, RC 6.3.89 / 23.1.92 *) (* object model 24.2.94 *) - -(* -2002-08-20 jt: NewStr: txtpos remains 0 for structs read from symbol file -*) - -IMPORT -OPS, OPM; - -CONST -MaxConstLen* = OPS.MaxStrLen; - -TYPE -Const* = POINTER TO ConstDesc; -Object* = POINTER TO ObjDesc; -Struct* = POINTER TO StrDesc; -Node* = POINTER TO NodeDesc; -ConstExt* = POINTER TO OPS.String; - -ConstDesc* = RECORD -ext*: ConstExt; (* string or code for code proc *) -intval*: LONGINT; (* constant value or adr, proc par size, text position or least case label *) -intval2*: LONGINT; (* string length, proc var size or larger case label *) -setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) -realval*: LONGREAL (* real or longreal constant value *) -END ; - -ObjDesc* = RECORD -left*, right*, link*, scope*: Object; -name*: OPS.Name; -leaf*: BOOLEAN; -mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *) -vis*: SHORTINT; (* internal, external, externalR *) -history*: SHORTINT; (* relevant if name # "" *) -used*, fpdone*: BOOLEAN; -fprint*: LONGINT; -typ*: Struct; -conval*: Const; -adr*, linkadr*: LONGINT; -x*: INTEGER (* linkadr and x can be freely used by the backend *) -END ; - -StrDesc* = RECORD -form*, comp*, mno*, extlev*: SHORTINT; -ref*, sysflag*: INTEGER; -n*, size*, align*, txtpos*: LONGINT; (* align is alignment for records and len offset for dynarrs *) -allocated*, pbused*, pvused*, fpdone, idfpdone: BOOLEAN; -idfp, pbfp*, pvfp*:LONGINT; -BaseTyp*: Struct; -link*, strobj*: Object -END ; - -NodeDesc* = RECORD -left*, right*, link*: Node; -class*, subcl*: SHORTINT; -readonly*: BOOLEAN; -typ*: Struct; -obj*: Object; -conval*: Const -END ; - -CONST -maxImps = 64; (* must be <= MAX(SHORTINT) *) -maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) -FirstRef = (*20*)16; (* comp + 1 *) - -VAR -typSize*: PROCEDURE(typ: Struct); -topScope*: Object; -undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*, -realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*, sysptrtyp*(*, -int8typ*, int16typ*, int32typ*, int64typ* *): Struct; -nofGmod*: SHORTINT; (*nof imports*) -GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) -SelfName*: OPS.Name; (* name of module being compiled *) -SYSimported*: BOOLEAN; - -CONST -(* object modes *) -Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; -SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - -(* structure forms *) -Undef = 0; Byte = 1; Bool = 2; Char = 3; -SInt = 4; Int = 5; LInt = 6; -Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; -Pointer = 13; ProcTyp = 14; -Comp = 15; - -(*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; -Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; -Pointer = 17; ProcTyp = 18; -Comp = 19;*) -(*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; -Pointer = 13; ProcTyp = 14; -Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; -Comp = 19;*) - -(* composite structure forms *) -Basic = 1; Array = 2; DynArr = 3; Record = 4; - -(*function number*) -assign = 0; -haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; -entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; -shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; -inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - -(*SYSTEM function number*) -adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; -getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; -bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - -(* module visibility of objects *) -internal = 0; external = 1; externalR = 2; - -(* history of imported objects *) -inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; - -(* symbol file items *) -Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; -Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; -Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; - -TYPE -ImpCtxt = RECORD -nextTag, reffp: LONGINT; -nofr, minr, nofm: INTEGER; -self: BOOLEAN; -ref: ARRAY maxStruct OF Struct; -old: ARRAY maxStruct OF Object; -pvfp: ARRAY maxStruct OF LONGINT; (* set only if old # NIL *) -glbmno: ARRAY maxImps OF SHORTINT (* index is local mno *) -END ; - -ExpCtxt = RECORD -reffp: LONGINT; -ref: INTEGER; -nofm: SHORTINT; -locmno: ARRAY maxImps OF SHORTINT (* index is global mno *) -END ; - -VAR -universe, syslink: Object; -impCtxt: ImpCtxt; -expCtxt: ExpCtxt; -nofhdfld: LONGINT; -newsf, findpc, extsf, sfpresent, symExtended, symNew: BOOLEAN; - -PROCEDURE err(n: INTEGER); -BEGIN OPM.err(n) -END err; - -PROCEDURE NewConst*(): Const; -VAR const: Const; -BEGIN NEW(const); RETURN const -END NewConst; - -PROCEDURE NewObj*(): Object; -VAR obj: Object; -BEGIN NEW(obj); RETURN obj -END NewObj; - -PROCEDURE NewStr*(form, comp: SHORTINT): Struct; -VAR typ: Struct; -BEGIN NEW(typ); typ^.form := form; typ^.comp := comp; typ^.ref := maxStruct; (* ref >= maxStruct: not exported yet *) -IF form # Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) -typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ -END NewStr; - -PROCEDURE NewNode*(class: SHORTINT): Node; -VAR node: Node; -BEGIN NEW(node); node^.class := class; RETURN node -END NewNode; - -PROCEDURE NewExt*(): ConstExt; -VAR ext: ConstExt; -BEGIN NEW(ext); RETURN ext -END NewExt; - -PROCEDURE OpenScope*(level: SHORTINT; owner: Object); -VAR head: Object; -BEGIN head := NewObj(); -head^.mode := Head; head^.mnolev := level; head^.link := owner; -IF owner # NIL THEN owner^.scope := head END ; -head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head -END OpenScope; - -PROCEDURE CloseScope*; -BEGIN topScope := topScope^.left -END CloseScope; - -PROCEDURE Init*(VAR name: OPS.Name; opt: SET); -CONST nsf = 4; fpc = 8; esf = 9; -BEGIN -topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; -SelfName := name; topScope^.name := name; -GlbMod[0] := topScope; nofGmod := 1; -newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE -END Init; - -PROCEDURE Close*; -VAR i: INTEGER; -BEGIN (* garbage collection *) -CloseScope; -i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; -i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END -END Close; - -PROCEDURE FindImport*(mod: Object; VAR res: Object); -VAR obj: Object; -BEGIN obj := mod^.scope; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (*found*) -IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL -ELSE obj^.used := TRUE -END ; -EXIT -END -END ; -res := obj -END FindImport; - -PROCEDURE Find*(VAR res: Object); -VAR obj, head: Object; -BEGIN head := topScope; -LOOP obj := head^.right; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (* found, obj^.used not set for local objects *) EXIT -END -END ; -IF obj # NIL THEN EXIT END ; -head := head^.left; -IF head = NIL THEN EXIT END -END ; -res := obj -END Find; - -PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object); -VAR obj: Object; -BEGIN -WHILE typ # NIL DO obj := typ^.link; -WHILE obj # NIL DO -IF name < obj^.name THEN obj := obj^.left -ELSIF name > obj^.name THEN obj := obj^.right -ELSE (*found*) res := obj; RETURN -END -END ; -typ := typ^.BaseTyp -END ; -res := NIL -END FindField; - -PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object); -VAR ob0, ob1: Object; left: BOOLEAN; mnolev: SHORTINT; -BEGIN ob0 := topScope; ob1 := ob0^.right; left := FALSE; -LOOP -IF ob1 # NIL THEN -IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE -ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE -ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right -END -ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; -IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; -ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); -mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; -EXIT -END -END ; -obj := ob1 -END Insert; - -(*-------------------------- Fingerprinting --------------------------*) - -PROCEDURE FPrintName(VAR fp: LONGINT; VAR name: ARRAY OF CHAR); -VAR i: INTEGER; ch: CHAR; -BEGIN i := 0; -REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X -END FPrintName; - -PROCEDURE ^IdFPrint*(typ: Struct); - -PROCEDURE DebugStruct(btyp: Struct); -BEGIN - - OPM.LogWLn; - IF btyp = NIL THEN OPM.LogWStr("btyp is nil"); OPM.LogWLn END; - OPM.LogWStr("btyp^.strobji^.name = "); OPM.LogWStr(btyp^.strobj^.name); OPM.LogWLn; - OPM.LogWStr("btyp^.form = "); OPM.LogWNum(btyp^.form, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.comp = "); OPM.LogWNum(btyp^.comp, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.mno = "); OPM.LogWNum(btyp^.mno, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.extlev = "); OPM.LogWNum(btyp^.extlev, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.size = "); OPM.LogWNum(btyp^.size, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.align = "); OPM.LogWNum(btyp^.align, 0); OPM.LogWLn; - OPM.LogWStr("btyp^.txtpos = "); OPM.LogWNum(btyp^.txtpos, 0); OPM.LogWLn; -END DebugStruct; - -PROCEDURE FPrintSign(VAR fp: LONGINT; result: Struct; par: Object); -(* depends on assignment compatibility of params only *) -BEGIN - IdFPrint(result); OPM.FPrint(fp, result^.idfp); - WHILE (par # NIL) (*& (par^.typ # NIL)*) DO (* !!! *) - OPM.FPrint(fp, par^.mode); - IdFPrint(par^.typ); - OPM.FPrint(fp, par^.typ^.idfp); - (* par^.name and par^.adr not considered *) - par := par^.link - END -END FPrintSign; - -PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *) -VAR btyp: Struct; strobj: Object; idfp: LONGINT; f, c: INTEGER; -BEGIN - IF ~typ^.idfpdone THEN - typ^.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *) - idfp := 0; f := typ^.form; c := typ^.comp; OPM.FPrint(idfp, f); OPM.FPrint(idfp, c); - btyp := typ^.BaseTyp; strobj := typ^.strobj; - IF (strobj # NIL) & (strobj^.name # "") THEN - FPrintName(idfp, GlbMod[typ^.mno]^.name); FPrintName(idfp, strobj^.name) - END ; - IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN - IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp) - ELSIF c = Array THEN - IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp); OPM.FPrint(idfp, typ^.n) - ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ^.link) - END ; - typ^.idfp := idfp - END -END IdFPrint; - -PROCEDURE FPrintStr*(typ: Struct); -VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; - -PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); - -PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) -VAR i, j, n: LONGINT; btyp: Struct; -BEGIN -IF typ^.comp = Record THEN FPrintFlds(typ^.link, adr, FALSE) -ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; -WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; -IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN - j := nofhdfld; FPrintHdFld(btyp, fld, adr); - IF j # nofhdfld THEN i := 1; - WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO - INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) - END; - END -END -ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN -OPM.FPrint(pvfp, Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) -ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN -OPM.FPrint(pvfp, ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) -END -END FPrintHdFld; - -PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) -BEGIN -WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (fld^.vis # internal) & visible THEN - OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); - FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) - ELSE - FPrintHdFld(fld^.typ, fld, fld^.adr + adr) - END ; - fld := fld^.link -END; -END FPrintFlds; - -PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) -BEGIN - IF obj # NIL THEN - FPrintTProcs(obj^.left); - IF obj^.mode = TProc THEN - IF obj^.vis # internal THEN - OPM.FPrint(pbfp, TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); - FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) - ELSIF OPM.ExpHdTProc THEN - OPM.FPrint(pvfp, TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) - END - END ; - FPrintTProcs(obj^.right) - END; -END FPrintTProcs; - -BEGIN - IF ~typ^.fpdone THEN - IdFPrint(typ); pbfp := typ^.idfp; - IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END ; - pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) - typ^.fpdone := TRUE; - f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; - IF f = Pointer THEN - strobj := typ^.strobj; bstrobj := btyp^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN - FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp - (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) - END - ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) - ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp - ELSE (* c = Record *) - IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END ; - OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); - nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END ; - FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END - END ; - typ^.pbfp := pbfp; typ^.pvfp := pvfp - END; -END FPrintStr; - -PROCEDURE FPrintObj*(obj: Object); -VAR fprint: LONGINT; f, m: INTEGER; rval: REAL; ext: ConstExt; -BEGIN - IF ~obj^.fpdone THEN - fprint := 0; obj^.fpdone := TRUE; - OPM.FPrint(fprint, obj^.mode); - IF obj^.mode = Con THEN - f := obj^.typ^.form; OPM.FPrint(fprint, f); - CASE f OF - | Bool, Char, SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.FPrint(fprint, obj^.conval^.intval) - | Set: - OPM.FPrintSet(fprint, obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) - | LReal: - OPM.FPrintLReal(fprint, obj^.conval^.realval) - | String: - FPrintName(fprint, obj^.conval^.ext^) - | NilTyp: - ELSE err(127) - END - ELSIF obj^.mode = Var THEN - OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - ELSIF obj^.mode IN {XProc, IProc} THEN - FPrintSign(fprint, obj^.typ, obj^.link) - ELSIF obj^.mode = CProc THEN - FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; - m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); - WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; - ELSIF obj^.mode = Typ THEN - FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - END ; - obj^.fprint := fprint - END -END FPrintObj; - -PROCEDURE FPrintErr*(obj: Object; errno: INTEGER); -VAR i, j: INTEGER; ch: CHAR; -BEGIN -IF obj^.mnolev # 0 THEN -COPY(GlbMod[-obj^.mnolev]^.name, OPM.objname); i := 0; -WHILE OPM.objname[i] # 0X DO INC(i) END ; -OPM.objname[i] := "."; j := 0; INC(i); -REPEAT ch := obj^.name[j]; OPM.objname[i] := ch; INC(j); INC(i) UNTIL ch = 0X; -ELSE -COPY(obj^.name, OPM.objname) -END ; -IF errno = 249 THEN -IF OPM.noerr THEN err(errno) END -ELSIF errno = 253 THEN (* extension *) -IF ~symNew & ~symExtended & ~extsf THEN err(errno) END ; -symExtended := TRUE -ELSE -IF ~symNew & ~newsf THEN err(errno) END ; -symNew := TRUE -END -END FPrintErr; - -(*-------------------------- Import --------------------------*) - -PROCEDURE InsertImport*(obj: Object; VAR root, old: Object); -VAR ob0, ob1: Object; left: BOOLEAN; -BEGIN -IF root = NIL THEN root := obj; old := NIL -ELSE -ob0 := root; ob1 := ob0^.right; left := FALSE; -IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE -ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE -ELSE old := ob0; RETURN -END ; -LOOP -IF ob1 # NIL THEN - IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE - ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE - ELSE old := ob1; EXIT - END -ELSE ob1 := obj; - IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; - ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT -END -END -END -END InsertImport; - -PROCEDURE InName(VAR name: ARRAY OF CHAR); -VAR i: INTEGER; ch: CHAR; -BEGIN i := 0; -REPEAT -OPM.SymRCh(ch); name[i] := ch; INC(i) -UNTIL ch = 0X -END InName; - -PROCEDURE InMod(VAR mno: SHORTINT); (* mno is global *) -VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; -BEGIN -mn := OPM.SymRInt(); -IF mn = 0 THEN mno := impCtxt.glbmno[0] -ELSE -IF mn = Smname THEN -InName(name); -IF (name = SelfName) & ~impCtxt.self THEN err(154) END ; -i := 0; -WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END ; -IF i < nofGmod THEN mno := i (*module already present*) -ELSE - head := NewObj(); head^.mode := Head; COPY(name, head^.name); - mno := nofGmod; head^.mnolev := -mno; - IF nofGmod < maxImps THEN - GlbMod[mno] := head; INC(nofGmod) - ELSE err(227) - END -END ; -impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) -ELSE -mno := impCtxt.glbmno[-mn] -END -END -END InMod; - -PROCEDURE InConstant(f: LONGINT; conval: Const); -VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; -BEGIN -CASE f OF -| (*Int8,*) Byte, Char, Bool: -OPM.SymRCh(ch); conval^.intval := ORD(ch) -(*| Int8, Int16, Int32, Int64: -conval^.intval := OPM.SymRInt()*) -| SInt, Int, LInt: -conval^.intval := OPM.SymRInt() -| Set: -OPM.SymRSet(conval^.setval) -| Real: -OPM.SymRReal(rval); conval^.realval := rval; -conval^.intval := OPM.ConstNotAlloc -| LReal: -OPM.SymRLReal(conval^.realval); -conval^.intval := OPM.ConstNotAlloc -| String: -ext := NewExt(); conval^.ext := ext; i := 0; -REPEAT -OPM.SymRCh(ch); ext^[i] := ch; INC(i) -UNTIL ch = 0X; -conval^.intval2 := i; -conval^.intval := OPM.ConstNotAlloc -| NilTyp: -conval^.intval := OPM.nilval -ELSE -OPM.LogWStr("unhandled case in OPT.InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; -END -END InConstant; - -PROCEDURE ^InStruct(VAR typ: Struct); - -PROCEDURE InSign(mno: SHORTINT; VAR res: Struct; VAR par: Object); -VAR last, new: Object; tag: LONGINT; -BEGIN -InStruct(res); -tag := OPM.SymRInt(); last := NIL; -WHILE tag # Send DO -new := NewObj(); new^.mnolev := -mno; -IF last = NIL THEN par := new ELSE last^.link := new END ; -IF tag = Svalpar THEN new^.mode := Var ELSE new^.mode := VarPar END ; -InStruct(new^.typ); new^.adr := OPM.SymRInt(); InName(new^.name); -last := new; tag := OPM.SymRInt() -END -END InSign; - -PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) -VAR tag: LONGINT; obj: Object; -BEGIN -tag := impCtxt.nextTag; obj := NewObj(); -IF tag <= Srfld THEN -obj^.mode := Fld; -IF tag = Srfld THEN obj^.vis := externalR ELSE obj^.vis := external END ; -InStruct(obj^.typ); InName(obj^.name); -obj^.adr := OPM.SymRInt() -ELSE -obj^.mode := Fld; -IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END ; -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := OPM.SymRInt() -END ; -RETURN obj -END InFld; - -PROCEDURE InTProc(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) -VAR tag: LONGINT; obj: Object; -BEGIN -tag := impCtxt.nextTag; -obj := NewObj(); obj^.mnolev := -mno; -IF tag = Stpro THEN -obj^.mode := TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; -InSign(mno, obj^.typ, obj^.link); obj^.vis := external; InName(obj^.name); -obj^.adr := 10000H*OPM.SymRInt() -ELSE (* tag = Shdtpro *) -obj^.mode := TProc; obj^.name := OPM.HdTProcName; -obj^.link := NewObj(); (* dummy, easier in Browser *) -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := 10000H*OPM.SymRInt() -END ; -RETURN obj -END InTProc; - -PROCEDURE InStruct(VAR typ: Struct); -VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; -t: Struct; obj, last, fld, old, dummy: Object; -BEGIN - tag := OPM.SymRInt(); - IF tag # Sstruct THEN - typ := impCtxt.ref[-tag] - ELSE - ref := impCtxt.nofr; INC(impCtxt.nofr); - IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; - InMod(mno); InName(name); obj := NewObj(); - IF name = "" THEN - IF impCtxt.self THEN - old := NIL (* do not insert type desc anchor here, but in OPL *) - ELSE - obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" - END ; - typ := NewStr(Undef, Basic) - ELSE - obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); - IF old # NIL THEN (* recalculate fprints to compare with old fprints *) - FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; - IF impCtxt.self THEN (* do not overwrite old typ *) - typ := NewStr(Undef, Basic) - ELSE (* overwrite old typ for compatibility reason *) - typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; - typ^.fpdone := FALSE; typ^.idfpdone := FALSE - END - ELSE - typ := NewStr(Undef, Basic) - END - END ; - impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; - typ^.ref := ref + maxStruct; - (* ref >= maxStruct: not exported yet, ref used for err 155 *) - typ^.mno := mno; typ^.allocated := TRUE; - typ^.strobj := obj; obj^.mode := Typ; obj^.typ := typ; - obj^.mnolev := -mno; obj^.vis := internal; (* name not visible here *) - tag := OPM.SymRInt(); - IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END ; - CASE tag OF - | Sptr: - typ^.form := Pointer; typ^.size := OPM.PointerSize; - typ^.n := 0; InStruct(typ^.BaseTyp) - | Sarr: - typ^.form := Comp; typ^.comp := Array; - InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); - typSize(typ) (* no bounds address !! *) - | Sdarr: - typ^.form := Comp; typ^.comp := DynArr; InStruct(typ^.BaseTyp); - IF typ^.BaseTyp^.comp = DynArr THEN - typ^.n := typ^.BaseTyp^.n + 1 - ELSE - typ^.n := 0 - END ; - typSize(typ) - | Srec: - typ^.form := Comp; typ^.comp := Record; - InStruct(typ^.BaseTyp); - IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; - typ.extlev := 0; t := typ.BaseTyp; - (* do not take extlev from base type due to possible cycles! *) - WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO INC(typ^.extlev); t := t.BaseTyp END; (* !!! *) - typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); - typ^.n := OPM.SymRInt(); - impCtxt.nextTag := OPM.SymRInt(); last := NIL; - WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO - fld := InFld(); fld^.mnolev := -mno; - IF last # NIL THEN last^.link := fld END ; - last := fld; InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END ; - WHILE impCtxt.nextTag # Send DO - fld := InTProc(mno); - InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END - | Spro: - typ^.form := ProcTyp; typ^.size := OPM.ProcSize; - InSign(mno, typ^.BaseTyp, typ^.link) - ELSE - OPM.LogWStr("unhandled case at OPT.InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; -END ; - IF ref = impCtxt.minr THEN - WHILE (ref < impCtxt.nofr) (*OR ((ref >= Int8) & (ref <= Int64))*) DO - t := impCtxt.ref[ref]; FPrintStr(t); - obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) - IF obj^.name # "" THEN FPrintObj(obj) END ; - old := impCtxt.old[ref]; - IF old # NIL THEN - t^.strobj := old; (* restore strobj *) - IF impCtxt.self THEN - IF old^.mnolev < 0 THEN - IF old^.history # inconsistent THEN - IF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - END - (* ELSE remain inconsistent *) - END - ELSIF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - ELSIF old^.vis = internal THEN - old^.history := same (* may be changed to "removed" in InObj *) - ELSE - old^.history := inserted (* may be changed to "same" in InObj *) - END - ELSE - (* check private part, delay error message until really used *) - IF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := inconsistent - END ; - IF old^.fprint # obj^.fprint THEN - FPrintErr(old, 249) - END - END - ELSIF impCtxt.self THEN - obj^.history := removed - ELSE - obj^.history := same - END ; - INC(ref) - END ; - impCtxt.minr := maxStruct - END - END -END InStruct; - - PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) - VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; - tag: LONGINT; ext: ConstExt; - BEGIN - tag := impCtxt.nextTag; - IF tag = Stype THEN - InStruct(typ); obj := typ^.strobj; - IF ~impCtxt.self THEN obj^.vis := external END (* type name visible now, obj^.fprint already done *) - ELSE - obj := NewObj(); obj^.mnolev := -mno; obj^.vis := external; - IF tag <= Pointer THEN (* Constant *) - obj^.mode := Con; obj^.typ := impCtxt.ref[tag]; obj^.conval := NewConst(); InConstant(tag, obj^.conval) - ELSIF tag >= Sxpro THEN - obj^.conval := NewConst(); - obj^.conval^.intval := -1; - InSign(mno, obj^.typ, obj^.link); - CASE tag OF - | Sxpro: obj^.mode := XProc - | Sipro: obj^.mode := IProc - | Scpro: obj^.mode := CProc; - ext := NewExt(); obj^.conval^.ext := ext; - s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; - WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END - ELSE - OPM.LogWStr("unhandled case at OPT.InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; - END - ELSIF tag = Salias THEN - obj^.mode := Typ; InStruct(obj^.typ) - ELSE - obj^.mode := Var; - IF tag = Srvar THEN obj^.vis := externalR END ; - InStruct(obj^.typ) - END ; - InName(obj^.name) - END ; - FPrintObj(obj); - IF (obj^.mode = Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN - (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) - OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) - END ; - IF tag # Stype THEN - InsertImport(obj, GlbMod[mno].right, old); - IF impCtxt.self THEN - IF old # NIL THEN - (* obj is from old symbol file, old is new declaration *) - IF old^.vis = internal THEN old^.history := removed - ELSE FPrintObj(old); (* FPrint(obj) already called *) - IF obj^.fprint # old^.fprint THEN old^.history := pbmodified - ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := pvmodified - ELSE old^.history := same - END - END - ELSE obj^.history := removed (* OutObj not called if mnolev < 0 *) - END - (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) - END - ELSE (* obj already inserted in InStruct *) - IF impCtxt.self THEN (* obj^.mnolev = 0 *) - IF obj^.vis = internal THEN obj^.history := removed - ELSIF obj^.history = inserted THEN obj^.history := same - END - (* ELSE OutObj not called for obj with mnolev < 0 *) - END - END ; - RETURN obj - END InObj; - - PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); - VAR obj: Object; mno: SHORTINT; (* done used in Browser *) - BEGIN - IF name = "SYSTEM" THEN SYSimported := TRUE; - Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp - ELSE - impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; - impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; - OPM.OldSym(name, done); - IF done THEN - InMod(mno); - impCtxt.nextTag := OPM.SymRInt(); - WHILE ~OPM.eofSF() DO - obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() - END ; - Insert(aliasName, obj); - obj^.mode := Mod; obj^.scope := GlbMod[mno].right; - GlbMod[mno].link := obj; - obj^.mnolev := -mno; obj^.typ := notyp; - OPM.CloseOldSym - ELSIF impCtxt.self THEN - newsf := TRUE; extsf := TRUE; sfpresent := FALSE - ELSE err(152) (*sym file not found*) - END - END - END Import; - -(*-------------------------- Export --------------------------*) - - PROCEDURE OutName(VAR name: ARRAY OF CHAR); - VAR i: INTEGER; ch: CHAR; - BEGIN i := 0; - REPEAT ch := name[i]; OPM.SymWCh(ch); INC(i) UNTIL ch = 0X - END OutName; - - PROCEDURE OutMod(mno: INTEGER); - BEGIN - IF expCtxt.locmno[mno] < 0 THEN (* new mod *) - OPM.SymWInt(Smname); - expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm); - OutName(GlbMod[mno].name) - ELSE OPM.SymWInt(-expCtxt.locmno[mno]) - END - END OutMod; - - PROCEDURE ^OutStr(typ: Struct); - PROCEDURE ^OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); - - PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: LONGINT); - VAR i, j, n: LONGINT; btyp: Struct; - BEGIN - IF typ^.comp = Record THEN OutFlds(typ^.link, adr, FALSE) - ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN - j := nofhdfld; OutHdFld(btyp, fld, adr); - IF j # nofhdfld THEN i := 1; - WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO - INC(adr, btyp^.size); OutHdFld(btyp, fld, adr); INC(i) - END - END - END - ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN - OPM.SymWInt(Shdptr); OPM.SymWInt(adr); INC(nofhdfld) - ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN - OPM.SymWInt(Shdpro); OPM.SymWInt(adr); INC(nofhdfld) - END - END OutHdFld; - - PROCEDURE OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); - BEGIN - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (fld^.vis # internal) & visible THEN - IF fld^.vis = externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END ; - OutStr(fld^.typ); OutName(fld^.name); OPM.SymWInt(fld^.adr) - ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr) - END ; - fld := fld^.link - END - END OutFlds; - - PROCEDURE OutSign(result: Struct; par: Object); - BEGIN - OutStr(result); - WHILE par # NIL DO - IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END ; - OutStr(par^.typ); - OPM.SymWInt(par^.adr); - OutName(par^.name); par := par^.link - END ; - OPM.SymWInt(Send) - END OutSign; - - PROCEDURE OutTProcs(typ: Struct; obj: Object); - BEGIN - IF obj # NIL THEN - OutTProcs(typ, obj^.left); - IF obj^.mode = TProc THEN - IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = internal) THEN - OPM.Mark(109, typ^.txtpos) - (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) - END ; - IF OPM.ExpHdTProc OR (obj^.vis # internal) THEN - IF obj^.vis # internal THEN - OPM.SymWInt(Stpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name); - OPM.SymWInt(obj^.adr DIV 10000H) - ELSE - OPM.SymWInt(Shdtpro); - OPM.SymWInt(obj^.adr DIV 10000H) - END - END - END ; - OutTProcs(typ, obj^.right) - END - END OutTProcs; - - PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *) - VAR strobj: Object; - BEGIN - IF (typ^.ref < expCtxt.ref) (*OR (typ^.ref >= Int8) & (typ^.ref <= Int64)*) THEN OPM.SymWInt(-typ^.ref) - ELSE - OPM.SymWInt(Sstruct); - typ^.ref := expCtxt.ref; INC(expCtxt.ref); - IF expCtxt.ref >= maxStruct THEN err(228) END ; - OutMod(typ^.mno); strobj := typ^.strobj; - - IF (strobj # NIL) & (strobj^.name # "") THEN OutName(strobj^.name); - CASE strobj^.history OF - | pbmodified: FPrintErr(strobj, 252) - | pvmodified: FPrintErr(strobj, 251) - | inconsistent: FPrintErr(strobj, 249) - ELSE (* checked in OutObj or correct indirect export *) - (* OPM.LogWStr("unhandled case at OPT.OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) - END - ELSE OPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) - END ; - IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END ; - CASE typ^.form OF - | Pointer: - OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) - | ProcTyp: - OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) - | Comp: - CASE typ^.comp OF - | Array: - OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) - | DynArr: - OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) - | Record: - OPM.SymWInt(Srec); - IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END ; - (* BaseTyp should be Notyp, too late to change *) - OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); - nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END ; - OutTProcs(typ, typ^.link); OPM.SymWInt(Send) - ELSE - OPM.LogWStr("unhandled case at OPT.OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; - END - ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; - END - END - END OutStr; - - PROCEDURE OutConstant(obj: Object); - VAR f: INTEGER; rval: REAL; - BEGIN - f := obj^.typ^.form; OPM.SymWInt(f); - CASE f OF - | Bool, Char: - OPM.SymWCh(CHR(obj^.conval^.intval)) - | SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.SymWInt(obj^.conval^.intval) - | Set: - OPM.SymWSet(obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) - | LReal: - OPM.SymWLReal(obj^.conval^.realval) - | String: - OutName(obj^.conval^.ext^) - | NilTyp: - ELSE err(127) - END - END OutConstant; - - PROCEDURE OutObj(obj: Object); - VAR i, j: INTEGER; ext: ConstExt; - BEGIN - IF obj # NIL THEN - OutObj(obj^.left); - IF obj^.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN - IF obj^.history = removed THEN FPrintErr(obj, 250) - ELSIF obj^.vis # internal THEN - CASE obj^.history OF - | inserted: FPrintErr(obj, 253) - | same: (* ok *) - | pbmodified: FPrintErr(obj, 252) - | pvmodified: FPrintErr(obj, 251) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; - END ; - CASE obj^.mode OF - | Con: - OutConstant(obj); OutName(obj^.name) - | Typ: - IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) - ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) - END - | Var: - IF obj^.vis = externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END ; - OutStr(obj^.typ); OutName(obj^.name); - IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN - (* compute fingerprint to avoid structural type equivalence *) - OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) - END - | XProc: - OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | IProc: - OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | CProc: - OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; - j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); - WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END ; - OutName(obj^.name) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; - END - END - END ; - OutObj(obj^.right) - END - END OutObj; - - PROCEDURE Export*(VAR ext, new: BOOLEAN); - VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; - BEGIN - symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; - Import("@self", SelfName, done); nofGmod := nofmod; - IF OPM.noerr THEN (* ~OPM.noerr => ~done *) - OPM.NewSym(SelfName); - IF OPM.noerr THEN - OPM.SymWInt(Smname); OutName(SelfName); - expCtxt.reffp := 0; expCtxt.ref := FirstRef(*Comp+1*); - expCtxt.nofm := 1; expCtxt.locmno[0] := 0; - i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; - OutObj(topScope^.right); - ext := sfpresent & symExtended; new := ~sfpresent OR symNew; - IF OPM.forceNewSym THEN - new := TRUE - END; (* for bootstrapping -- noch *) - IF OPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN - new := TRUE; - IF ~extsf THEN err(155) END - END ; - newsf := FALSE; symNew := FALSE; (* because of call to FPrintErr from OPL *) - IF ~OPM.noerr OR findpc THEN - OPM.DeleteNewSym - END - (* OPM.RegisterNewSym is called in OP2 after writing the object file *) - END - END - END Export; (* no new symbol file if ~OPM.noerr or findpc *) - - - PROCEDURE InitStruct(VAR typ: Struct; form: SHORTINT); - BEGIN - typ := NewStr(form, Basic); typ^.ref := form; typ^.size := OPM.ByteSize; typ^.allocated := TRUE; - typ^.strobj := NewObj(); typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; - typ^.idfp := form; typ^.idfpdone := TRUE - END InitStruct; - - PROCEDURE EnterBoolConst(name: OPS.Name; value: LONGINT); - VAR obj: Object; - BEGIN - Insert(name, obj); obj^.conval := NewConst(); - obj^.mode := Con; obj^.typ := booltyp; obj^.conval^.intval := value - END EnterBoolConst; - - PROCEDURE EnterTyp(name: OPS.Name; form: SHORTINT; size: INTEGER; VAR res: Struct); - VAR obj: Object; typ: Struct; - BEGIN - Insert(name, obj); - typ := NewStr(form, Basic); obj^.mode := Typ; obj^.typ := typ; obj^.vis := external; - typ^.strobj := obj; typ^.size := size; typ^.ref := form; typ^.allocated := TRUE; - typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; - typ^.idfp := form; typ^.idfpdone := TRUE; res := typ - END EnterTyp; - - PROCEDURE EnterProc(name: OPS.Name; num: INTEGER); - VAR obj: Object; - BEGIN Insert(name, obj); - obj^.mode := SProc; obj^.typ := notyp; obj^.adr := num - END EnterProc; - -BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0; - InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp); - InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp); - undftyp^.BaseTyp := undftyp; - - (*initialization of module SYSTEM*) - EnterTyp("BYTE", Byte, OPM.ByteSize, bytetyp); -(* - EnterTyp("INT8", Int8, OPM.Int8Size, int8typ); - EnterTyp("INT16", Int16, OPM.Int16Size, int16typ); - EnterTyp("INT32", Int32, OPM.Int32Size, int32typ); - EnterTyp("INT64", Int64, OPM.Int64Size, int64typ); -*) - EnterTyp("PTR", Pointer, OPM.PointerSize, sysptrtyp); - EnterProc("ADR", adrfn); - EnterProc("CC", ccfn); - EnterProc("LSH", lshfn); - EnterProc("ROT", rotfn); - EnterProc("GET", getfn); - EnterProc("PUT", putfn); - EnterProc("GETREG", getrfn); - EnterProc("PUTREG", putrfn); - EnterProc("BIT", bitfn); - EnterProc("VAL", valfn); - EnterProc("NEW", sysnewfn); - EnterProc("MOVE", movefn); - syslink := topScope^.right; - universe := topScope; topScope^.right := NIL; - - EnterTyp("CHAR", Char, OPM.CharSize, chartyp); - EnterTyp("SET", Set, OPM.SetSize, settyp); - EnterTyp("REAL", Real, OPM.RealSize, realtyp); - EnterTyp("INTEGER", Int, OPM.IntSize, inttyp); - EnterTyp("LONGINT", LInt, OPM.LIntSize, linttyp); - EnterTyp("LONGREAL", LReal, OPM.LRealSize, lrltyp); - EnterTyp("SHORTINT", SInt, OPM.SIntSize, sinttyp); - EnterTyp("BOOLEAN", Bool, OPM.BoolSize, booltyp); - EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) - EnterBoolConst("TRUE", 1); - EnterProc("HALT", haltfn); - EnterProc("NEW", newfn); - EnterProc("ABS", absfn); - EnterProc("CAP", capfn); - EnterProc("ORD", ordfn); - EnterProc("ENTIER", entierfn); - EnterProc("ODD", oddfn); - EnterProc("MIN", minfn); - EnterProc("MAX", maxfn); - EnterProc("CHR", chrfn); - EnterProc("SHORT", shortfn); - EnterProc("LONG", longfn); - EnterProc("SIZE", sizefn); - EnterProc("INC", incfn); - EnterProc("DEC", decfn); - EnterProc("INCL", inclfn); - EnterProc("EXCL", exclfn); - EnterProc("LEN", lenfn); - EnterProc("COPY", copyfn); - EnterProc("ASH", ashfn); - EnterProc("ASSERT", assertfn); - impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; -(* impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; - impCtxt.ref[Int32] := int32typ; impCtxt.ref[Int64] := int64typ;*) - impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char] := chartyp; - impCtxt.ref[SInt] := sinttyp; impCtxt.ref[Int] := inttyp; - impCtxt.ref[LInt] := linttyp; impCtxt.ref[Real] := realtyp; - impCtxt.ref[LReal] := lrltyp; impCtxt.ref[Set] := settyp; - impCtxt.ref[String] := stringtyp; impCtxt.ref[NilTyp] := niltyp; - impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp -END OPT. - -Objects: - - mode | adr conval link scope leaf - ------------------------------------------------ - Undef | Not used - Var | vadr next regopt Glob or loc var or proc value parameter - VarPar| vadr next regopt Procedure var parameter - Con | val Constant - Fld | off next Record field - Typ | Named type - LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end - XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end - SProc | fno sizes Standard procedure - CProc | code firstpar scope Code procedure - IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end - Mod | scope Module - Head | txtpos owner firstvar Scope anchor - TProc | index sizes firstpar scope leaf Bound procedure, index = 10000H*mthno+entry, entry adr set in back-end - - Structures: - - form comp | n BaseTyp link mno txtpos sysflag - ---------------------------------------------------------------------------------- - Undef Basic | - Byte Basic | - Bool Basic | - Char Basic | - SInt Basic | - Int Basic | - LInt Basic | - Real Basic | - LReal Basic | - Set Basic | - String Basic | - NilTyp Basic | - NoTyp Basic | - Pointer Basic | PBaseTyp mno txtpos sysflag - ProcTyp Basic | ResTyp params mno txtpos sysflag - Comp Array | nofel ElemTyp mno txtpos sysflag - Comp DynArr| dim ElemTyp mno txtpos sysflag - Comp Record| nofmth RBaseTyp fields mno txtpos sysflag - -Nodes: - -design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc. -expr = design|Nconst|Nupto|Nmop|Ndop|Ncall. -nextexpr = NIL|expr. -ifstat = NIL|Nif. -casestat = Ncaselse. -sglcase = NIL|Ncasedo. -stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat| - Nloop|Nexit|Nreturn|Nwith|Ntrap. - - - class subcl obj left right link - --------------------------------------------------------- - -design Nvar var nextexpr - Nvarpar varpar nextexpr - Nfield field design nextexpr - Nderef design nextexpr - Nindex design expr nextexpr - Nguard design nextexpr (typ = guard type) - Neguard design nextexpr (typ = guard type) - Ntype type nextexpr - Nproc normal proc nextexpr - super proc nextexpr - - -expr design - Nconst const (val = node^.conval) - Nupto expr expr nextexpr - Nmop not expr nextexpr - minus expr nextexpr - is tsttype expr nextexpr - conv expr nextexpr - abs expr nextexpr - cap expr nextexpr - odd expr nextexpr - adr expr nextexpr SYSTEM.ADR - cc Nconst nextexpr SYSTEM.CC - val expr nextexpr SYSTEM.VAL - Ndop times expr expr nextexpr - slash expr expr nextexpr - div expr expr nextexpr - mod expr expr nextexpr - and expr expr nextexpr - plus expr expr nextexpr - minus expr expr nextexpr - or expr expr nextexpr - eql expr expr nextexpr - neq expr expr nextexpr - lss expr expr nextexpr - leq expr expr nextexpr - grt expr expr nextexpr - geq expr expr nextexpr - in expr expr nextexpr - ash expr expr nextexpr - msk expr Nconst nextexpr - len design Nconst nextexpr - bit expr expr nextexpr SYSTEM.BIT - lsh expr expr nextexpr SYSTEM.LSH - rot expr expr nextexpr SYSTEM.ROT - Ncall fpar design nextexpr nextexpr - -nextexpr NIL - expr - -ifstat NIL - Nif expr stat ifstat - -casestat Ncaselse sglcase stat (minmax = node^.conval) - -sglcase NIL - Ncasedo Nconst stat sglcase - -stat NIL - Ninittd stat (of node^.typ) - Nenter proc stat stat stat (proc=NIL for mod) - Nassign assign design expr stat - newfn design stat - incfn design expr stat - decfn design expr stat - inclfn design expr stat - exclfn design expr stat - copyfn design expr stat - getfn design expr stat SYSTEM.GET - putfn expr expr stat SYSTEM.PUT - getrfn design Nconst stat SYSTEM.GETREG - putrfn Nconst expr stat SYSTEM.PUTREG - sysnewfn design expr stat SYSTEM.NEW - movefn expr expr stat SYSTEM.MOVE - (right^.link = 3rd par) - Ncall fpar design nextexpr stat - Nifelse ifstat stat stat - Ncase expr casestat stat - Nwhile expr stat stat - Nrepeat stat expr stat - Nloop stat stat - Nexit stat - Nreturn proc nextexpr stat (proc = NIL for mod) - Nwith ifstat stat stat - Ntrap expr stat - diff --git a/src/voc/OPV.Mod b/src/voc/OPV.Mod deleted file mode 100644 index 8e00879f..00000000 --- a/src/voc/OPV.Mod +++ /dev/null @@ -1,1066 +0,0 @@ -MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 - - 26.7.2002 jt bug fix in Len: wrong result if called for fixed Array - 31.1.2007 jt synchronized with BlackBox version, in particular: - various promotion rules changed (long) => (LONGINT), xxxL avoided -*) - - IMPORT OPT, OPC, OPM, OPS; - - CONST - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; IProc = 10; Mod = 11; TProc = 13; - - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nenter = 18; Nassign = 19; - Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; newfn = 1; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; - - (*SYSTEM function number*) - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; - - (*procedure flags*) - isRedef = 2; - - super = 1; - - UndefinedType = 0; (* named type not yet defined *) - ProcessingType = 1; (* pointer type is being processed *) - PredefinedType = 2; (* for all predefined types *) - DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) - DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) - - OpenParen = "("; - CloseParen = ")"; - OpenBracket = "["; - CloseBracket = "]"; - Blank = " "; - Comma = ", "; - Deref = "*"; - EntierFunc = "__ENTIER("; - IsFunc = "__IS("; - IsPFunc = "__ISP("; - GuardPtrFunc = "__GUARDP("; - GuardRecFunc = "__GUARDR("; - TypeFunc = "__TYPEOF("; - SetOfFunc = "__SETOF("; - SetRangeFunc = "__SETRNG("; - CopyFunc = "__COPY("; - MoveFunc = "__MOVE("; - GetFunc = "__GET("; - PutFunc = "__PUT("; - DynTypExt = "__typ"; - WithChk = "__WITHCHK"; - Break = "break"; - ElseStat = "else "; - - MinPrec = -1; - MaxPrec = 12; - ProcTypeVar = 11; (* precedence number when a call is made with a proc type variable *) - - internal = 0; - - TYPE - ExitInfo = RECORD level, label: INTEGER END ; - - - VAR - assert, inxchk, mainprog, ansi: BOOLEAN; - stamp: INTEGER; (* unique number for nested objects *) - (*recno: INTEGER;*) (* number of anonymous record types *) - recno: LONGINT; (* number of anonymous record types *) - - exit: ExitInfo; (* to check if EXIT is simply a break *) - nofExitLabels: INTEGER; - naturalAlignment: BOOLEAN; - - - PROCEDURE NaturalAlignment(size, max: LONGINT): LONGINT; - VAR i: LONGINT; - BEGIN - IF size >= max THEN RETURN max - ELSE i := 1; - WHILE i < size DO INC(i, i) END ; - RETURN i - END - END NaturalAlignment; - - PROCEDURE TypSize*(typ: OPT.Struct); - VAR f, c: INTEGER; offset, size, base, fbase, off0: LONGINT; - fld: OPT.Object; btyp: OPT.Struct; - BEGIN - IF typ = OPT.undftyp THEN OPM.err(58) - ELSIF typ^.size = -1 THEN - f := typ^.form; c := typ^.comp; - IF c = Record THEN btyp := typ^.BaseTyp; - IF btyp = NIL THEN offset := 0; base := OPM.RecAlign; - ELSE TypSize(btyp); offset := btyp^.size - btyp^.sysflag DIV 100H; base := btyp^.align; - END; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - btyp := fld^.typ; TypSize(btyp); - size := btyp^.size; fbase := OPC.Base(btyp); - OPC.Align(offset, fbase); - fld^.adr := offset; INC(offset, size); - IF fbase > base THEN base := fbase END ; - fld := fld^.link - END ; - off0 := offset; - IF offset = 0 THEN offset := 1 END ; (* 1 byte filler to avoid empty struct *) - IF OPM.RecSize = 0 THEN base := NaturalAlignment(offset, OPM.RecAlign) END ; - OPC.Align(offset, base); - IF (typ^.strobj = NIL) & (typ^.align MOD 10000H = 0) THEN INC(recno); INC(base, recno * 10000H) END ; - typ^.size := offset; typ^.align := base; - (* encode the trailing gap into the symbol table to allow dense packing of extended records *) - typ^.sysflag := typ^.sysflag MOD 100H + SHORT((offset - off0)*100H) - ELSIF c = Array THEN - TypSize(typ^.BaseTyp); - typ^.size := typ^.n * typ^.BaseTyp^.size; - ELSIF f = Pointer THEN - typ^.size := OPM.PointerSize; - IF typ^.BaseTyp = OPT.undftyp THEN OPM.Mark(128, typ^.n) - ELSE TypSize(typ^.BaseTyp) - END - ELSIF f = ProcTyp THEN - typ^.size := OPM.ProcSize; - ELSIF c = DynArr THEN - btyp := typ^.BaseTyp; TypSize(btyp); - IF btyp^.comp = DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *) - ELSE typ^.size := 8 - END ; - END - END - END TypSize; - - PROCEDURE Init*; - BEGIN - stamp := 0; recno := 0; nofExitLabels := 0; - assert := OPM.assert IN OPM.opt; - inxchk := OPM.inxchk IN OPM.opt; - mainprog := OPM.mainprog IN OPM.opt; - ansi := OPM.ansi IN OPM.opt - END Init; - - PROCEDURE ^Traverse (obj, outerScope: OPT.Object; exported: BOOLEAN); - - PROCEDURE GetTProcNum(obj: OPT.Object); - VAR oldPos: LONGINT; typ: OPT.Struct; redef: OPT.Object; - BEGIN - oldPos := OPM.errpos; OPM.errpos := obj^.scope^.adr; - typ := obj^.link^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - OPT.FindField(obj^.name, typ^.BaseTyp, redef); - IF redef # NIL THEN obj^.adr := 10000H*(redef^.adr DIV 10000H) (*mthno*); - IF ~(isRedef IN obj^.conval^.setval) THEN OPM.err(119) END - ELSE INC(obj^.adr, 10000H*typ^.n); INC(typ^.n) - END ; - OPM.errpos := oldPos - END GetTProcNum; - - PROCEDURE TraverseRecord(typ: OPT.Struct); - BEGIN - IF ~typ^.allocated THEN - IF typ^.BaseTyp # NIL THEN TraverseRecord(typ^.BaseTyp); typ^.n := typ^.BaseTyp^.n END ; - typ^.allocated := TRUE; Traverse(typ^.link, typ^.strobj, FALSE) - END - END TraverseRecord; - - PROCEDURE Stamp(VAR s: OPS.Name); - VAR i, j, k: INTEGER; n: ARRAY 10 OF CHAR; - BEGIN INC(stamp); - i := 0; j := stamp; - WHILE s[i] # 0X DO INC(i) END ; - IF i > 25 THEN i := 25 END ; - s[i] := "_"; s[i+1] := "_"; INC(i, 2); k := 0; - REPEAT n[k] := CHR((j MOD 10) + ORD("0")); j := j DIV 10; INC(k) UNTIL j = 0; - REPEAT DEC(k); s[i] := n[k]; INC(i) UNTIL k = 0; - s[i] := 0X; - END Stamp; - - PROCEDURE Traverse (obj, outerScope: OPT.Object; exported: BOOLEAN); - VAR mode: INTEGER; scope: OPT.Object; typ: OPT.Struct; - BEGIN - IF obj # NIL THEN - Traverse(obj^.left, outerScope, exported); - IF obj^.name[0] = "@" THEN obj^.name[0] := "_"; Stamp(obj^.name) END ; (* translate and make unique @for, ... *) - obj^.linkadr := UndefinedType; - mode := obj^.mode; - IF (mode = Typ) & ((obj^.vis # internal) = exported) THEN - typ := obj^.typ; TypSize(obj^.typ); - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - IF typ^.comp = Record THEN TraverseRecord(typ) END - ELSIF mode = TProc THEN GetTProcNum(obj) - ELSIF mode = Var THEN TypSize(obj^.typ) - END ; - IF ~exported THEN (* do this only once *) - IF (mode IN {LProc, Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; - IF mode IN {Var, VarPar, Typ} THEN - obj^.scope := outerScope - ELSIF mode IN {LProc, XProc, TProc, CProc, IProc} THEN - IF obj^.conval^.setval = {} THEN OPM.err(129) END ; - scope := obj^.scope; - scope^.leaf := TRUE; - scope^.name := obj^.name; Stamp(scope^.name); - IF mode = CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; - IF scope^.mnolev > 1 THEN outerScope^.leaf := FALSE END ; - Traverse (obj^.scope^.right, obj^.scope, FALSE) - END - END; - Traverse(obj^.right, outerScope, exported); - END - END Traverse; - - PROCEDURE AdrAndSize* (topScope: OPT.Object); - BEGIN - OPM.errpos := topScope^.adr; (* text position of scope used if error *) - topScope^.leaf := TRUE; - Traverse(topScope^.right, topScope, TRUE); (* first pass only on exported types and procedures *) - Traverse(topScope^.right, topScope, FALSE); (* second pass *) - (* mark basic types as predefined, OPC.Ident can avoid qualification*) - OPT.chartyp^.strobj^.linkadr := PredefinedType; - OPT.settyp^.strobj^.linkadr := PredefinedType; - OPT.realtyp^.strobj^.linkadr := PredefinedType; - OPT.inttyp^.strobj^.linkadr := PredefinedType; - OPT.linttyp^.strobj^.linkadr := PredefinedType; - OPT.lrltyp^.strobj^.linkadr := PredefinedType; - OPT.sinttyp^.strobj^.linkadr := PredefinedType; - OPT.booltyp^.strobj^.linkadr := PredefinedType; - OPT.bytetyp^.strobj^.linkadr := PredefinedType; - (*OPT.int8typ^.strobj^.linkadr := PredefinedType; - OPT.int16typ^.strobj^.linkadr := PredefinedType; - OPT.int32typ^.strobj^.linkadr := PredefinedType; - OPT.int64typ^.strobj^.linkadr := PredefinedType;*) - OPT.sysptrtyp^.strobj^.linkadr := PredefinedType; - END AdrAndSize; - -(* ____________________________________________________________________________________________________________________________________________________________________ *) - - PROCEDURE Precedence (class, subclass, form, comp: INTEGER): INTEGER; - BEGIN - CASE class OF - Nconst, Nvar, Nfield, Nindex, Nproc, Ncall: - RETURN 10 - | Nguard: IF OPM.typchk IN OPM.opt THEN RETURN 10 ELSE RETURN 9 (*cast*) END - | Nvarpar: - IF comp IN {Array, DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) - | Nderef: - RETURN 9 - | Nmop: - CASE subclass OF - not, minus, adr, val, conv: - RETURN 9 - | is, abs, cap, odd, cc: - RETURN 10 - END - | Ndop: - CASE subclass OF - times: - IF form = Set THEN RETURN 4 ELSE RETURN 8 END - | slash: - IF form = Set THEN RETURN 3 ELSE RETURN 8 END - | div, mod: - RETURN 10 (* div/mod are replaced by functions *) - | plus: - IF form = Set THEN RETURN 2 ELSE RETURN 7 END - | minus: - IF form = Set THEN RETURN 4 ELSE RETURN 7 END - | lss, leq, gtr, geq: - RETURN 6 - | eql, neq: - RETURN 5 - | and: - RETURN 1 - | or: - RETURN 0 - | len, in, ash, msk, bit, lsh, rot: - RETURN 10 - ELSE - OPM.LogWStr("unhandled case in OPV.Precedence, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END; - | Nupto: - RETURN 10 - | Ntype, Neguard: (* ignored anyway *) - RETURN MaxPrec - ELSE - OPM.LogWStr("unhandled case in OPV.Precedence, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; - END; - END Precedence; - - PROCEDURE^ expr (n: OPT.Node; prec: INTEGER); - PROCEDURE^ design(n: OPT.Node; prec: INTEGER); - - PROCEDURE Len(n: OPT.Node; dim: LONGINT); - BEGIN - WHILE (n^.class = Nindex) & (n^.typ^.comp = DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; - IF (n^.class = Nderef) & (n^.typ^.comp = DynArr) THEN - design(n^.left, 10); OPM.WriteString("->len["); OPM.WriteInt(dim); OPM.Write("]") - ELSE - OPC.Len(n^.obj, n^.typ, dim) - END - END Len; - - PROCEDURE SideEffects(n: OPT.Node): BOOLEAN; - BEGIN - IF n # NIL THEN RETURN (n^.class = Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) - ELSE RETURN FALSE - END - END SideEffects; - - PROCEDURE Entier(n: OPT.Node; prec: INTEGER); - BEGIN - IF n^.typ^.form IN {Real, LReal} THEN - OPM.WriteString(EntierFunc); expr(n, MinPrec); OPM.Write(CloseParen) - ELSE expr(n, prec) - END - END Entier; - - PROCEDURE Convert(n: OPT.Node; form, prec: INTEGER); - VAR from: INTEGER; - BEGIN from := n^.typ^.form; - IF form = Set THEN OPM.WriteString(SetOfFunc); Entier(n, MinPrec); OPM.Write(CloseParen) - ELSIF form = LInt THEN - IF from < LInt THEN OPM.WriteString("(LONGINT)") END ; - Entier(n, 9) - (*ELSIF form = Int64 THEN - IF (from >= SInt) & (from <= LInt) OR (from >= Int8) & (from < Int64) THEN OPM.WriteString("(SYSTEM_INT64)") END; - Entier(n, 9);*) - ELSIF form = Int THEN - IF from < Int THEN OPM.WriteString("(int)"); expr(n, 9) - ELSE - IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); - IF SideEffects(n) THEN OPM.Write("F") END ; - OPM.Write(OpenParen); Entier(n, MinPrec); - OPM.WriteString(Comma); OPM.WriteInt(OPM.MaxInt + 1); OPM.Write(CloseParen) - ELSE OPM.WriteString("(int)"); Entier(n, 9) - END - END - ELSIF form = SInt THEN - IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); - IF SideEffects(n) THEN OPM.Write("F") END ; - OPM.Write(OpenParen); Entier(n, MinPrec); - OPM.WriteString(Comma); OPM.WriteInt(OPM.MaxSInt + 1); OPM.Write(CloseParen) - ELSE OPM.WriteString("(int)"); Entier(n, 9) - END - ELSIF form = Char THEN - IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__CHR"); - IF SideEffects(n) THEN OPM.Write("F") END ; - OPM.Write(OpenParen); Entier(n, MinPrec); OPM.Write(CloseParen) - ELSE OPM.WriteString("(CHAR)"); Entier(n, 9) - END - ELSE expr(n, prec) - END - END Convert; - - PROCEDURE TypeOf(n: OPT.Node); - BEGIN - IF n^.typ^.form = Pointer THEN - OPM.WriteString(TypeFunc); expr(n, MinPrec); OPM.Write(")") - ELSIF n^.class IN {Nvar, Nindex, Nfield} THEN (* dyn rec type = stat rec type *) - OPC.Andent(n^.typ); OPM.WriteString(DynTypExt) - ELSIF n^.class = Nderef THEN (* p^ *) - OPM.WriteString(TypeFunc); expr(n^.left, MinPrec); OPM.Write(")") - ELSIF n^.class = Nguard THEN (* r(T) *) - TypeOf(n^.left) (* skip guard *) - ELSIF (n^.class = Nmop) & (n^.subcl = val) THEN - (*SYSTEM.VAL(typ, var par rec)*) - OPC.TypeOf(n^.left^.obj) - ELSE (* var par rec *) - OPC.TypeOf(n^.obj) - END - END TypeOf; - - PROCEDURE Index(n, d: OPT.Node; prec, dim: INTEGER); - BEGIN - IF ~inxchk - OR (n^.right^.class = Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # DynArr)) THEN - expr(n^.right, prec) - ELSE - IF SideEffects(n^.right) THEN OPM.WriteString("__XF(") ELSE OPM.WriteString("__X(") END ; - expr(n^.right, MinPrec); OPM.WriteString(Comma); Len(d, dim); OPM.Write(CloseParen) - END - END Index; - - PROCEDURE design(n: OPT.Node; prec: INTEGER); - VAR obj: OPT.Object; typ: OPT.Struct; - class, designPrec, comp: INTEGER; - d, x: OPT.Node; dims, i: INTEGER; - BEGIN - comp := n^.typ^.comp; obj := n^.obj; class := n^.class; - designPrec := Precedence(class, n^.subcl, n^.typ^.form, comp); - IF (class = Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; - IF prec > designPrec THEN OPM.Write(OpenParen) END; - IF prec = ProcTypeVar THEN OPM.Write(Deref) END; (* proc var calls must be dereferenced in K&R C *) - CASE class OF - Nproc: - OPC.Ident(n^.obj) - | Nvar: - OPC.CompleteIdent(n^.obj) - | Nvarpar: - IF ~(comp IN {Array, DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) - OPC.CompleteIdent(n^.obj) - | Nfield: - IF n^.left^.class = Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") - ELSE design(n^.left, designPrec); OPM.Write(".") - END ; - OPC.Ident(n^.obj) - | Nderef: - IF n^.typ^.comp = DynArr THEN design(n^.left, 10); OPM.WriteString("->data") - ELSE OPM.Write(Deref); design(n^.left, designPrec) - END - | Nindex: - d := n^.left; - IF d^.typ^.comp = DynArr THEN dims := 0; - WHILE d^.class = Nindex DO d := d^.left; INC(dims) END ; - IF n^.typ^.comp = DynArr THEN OPM.Write("&") END ; - design(d, designPrec); - OPM.Write(OpenBracket); - IF n^.typ^.comp = DynArr THEN OPM.Write("(") END ; - i := dims; x := n; - WHILE x # d DO (* apply Horner schema *) - IF x^.left # d THEN Index(x, d, 7, i); OPM.WriteString(" + "); Len(d, i); OPM.WriteString(" * ("); DEC(i) - ELSE Index(x, d, MinPrec, i) - END ; - x := x^.left - END ; - FOR i := 1 TO dims DO OPM.Write(")") END ; - IF n^.typ^.comp = DynArr THEN - (* element type is DynArr; finish Horner schema with virtual indices = 0*) - OPM.Write(")"); - WHILE i < (d^.typ^.size - 4) DIV 4 DO - OPM.WriteString(" * "); Len(d, i); - INC(i) - END - END ; - OPM.Write(CloseBracket) - ELSE - design(n^.left, designPrec); - OPM.Write(OpenBracket); - Index(n, n^.left, MinPrec, 0); - OPM.Write(CloseBracket) - END - | Nguard: - typ := n^.typ; obj := n^.left^.obj; - IF OPM.typchk IN OPM.opt THEN - IF typ^.comp = Record THEN OPM.WriteString(GuardRecFunc); - IF obj^.mnolev # OPM.level THEN (*intermediate level var-par record*) - OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString("__curr->"); OPC.Ident(obj) - ELSE (*local var-par record*) - OPC.Ident(obj) - END ; - ELSE (*Pointer*) - IF typ^.BaseTyp^.strobj = NIL THEN OPM.WriteString("__GUARDA(") ELSE OPM.WriteString(GuardPtrFunc) END ; - expr(n^.left, MinPrec); typ := typ^.BaseTyp - END ; - OPM.WriteString(Comma); - OPC.Andent(typ); OPM.WriteString(Comma); - OPM.WriteInt(typ^.extlev); OPM.Write(")") - ELSE - IF typ^.comp = Record THEN (* do not cast record directly, cast pointer to record *) - OPM.WriteString("*("); OPC.Ident(typ^.strobj); OPM.WriteString("*)"); OPC.CompleteIdent(obj) - ELSE (*simply cast pointer*) - OPM.Write("("); OPC.Ident(typ^.strobj); OPM.Write(")"); expr(n^.left, designPrec) - END - END - | Neguard: - IF OPM.typchk IN OPM.opt THEN - IF n^.left^.class = Nvarpar THEN OPM.WriteString("__GUARDEQR("); - OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left); - ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec) - END ; (* __GUARDEQx includes deref *) - OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(")") - ELSE - expr(n^.left, MinPrec) (* always lhs of assignment *) - END - | Nmop: - IF n^.subcl = val THEN design(n^.left, prec) END - ELSE - OPM.LogWStr("unhandled case in OPV.design, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; - END ; - IF prec > designPrec THEN OPM.Write(CloseParen) END - END design; - - PROCEDURE ActualPar(n: OPT.Node; fp: OPT.Object); - VAR typ, aptyp: OPT.Struct; comp, form, mode, prec, dim: INTEGER; - BEGIN - OPM.Write(OpenParen); - WHILE n # NIL DO typ := fp^.typ; - comp := typ^.comp; form := typ^.form; mode := fp^.mode; prec := MinPrec; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN (* avoid cast in lvalue *) - OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.WriteString("*)"); prec := 10 - END ; - IF ~(n^.typ^.comp IN {Array, DynArr}) THEN - IF mode = VarPar THEN - IF ansi & (typ # n^.typ) THEN OPM.WriteString("(void*)") END ; - OPM.Write("&"); prec := 9 - ELSIF ansi THEN - IF (comp IN {Array, DynArr}) & (n^.class = Nconst) THEN - OPM.WriteString("(CHAR*)") (* force to unsigned char *) - ELSIF (form = Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN - OPM.WriteString("(void*)") (* type extension *) - END - ELSE - IF (form IN {Real, LReal}) & (n^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN (* real promotion *) - OPM.WriteString("(double)"); prec := 9 - ELSIF (form = LInt) & (n^.typ^.form < LInt) THEN (* integral promotion *) - OPM.WriteString("(LONGINT)"); prec := 9 - (*ELSIF (form = Int64) & (n^.typ^.form < Int64) THEN - OPM.WriteString("(SYSTEM_INT64)"); prec := 9;*) - END - END - ELSIF ansi THEN - (* casting of params should be simplified eventually *) - IF (mode = VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END - END ; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN expr(n^.left, prec) (* avoid cast in lvalue *) - ELSE expr(n, prec) - END ; - IF (form = LInt) & (n^.class = Nconst) - & (n^.conval^.intval <= OPM.MaxInt) & (n^.conval^.intval >= OPM.MinInt) THEN - OPM.PromoteIntConstToLInt() - ELSIF (comp = Record) & (mode = VarPar) THEN - OPM.WriteString(", "); TypeOf(n) - ELSIF comp = DynArr THEN - IF n^.class = Nconst THEN (* ap is string constant *) - OPM.WriteString(Comma); OPM.WriteString("(LONGINT)"); OPM.WriteInt(n^.conval^.intval2) - ELSE - aptyp := n^.typ; dim := 0; - WHILE (typ^.comp = DynArr) & (typ^.BaseTyp^.form # Byte) DO - OPM.WriteString(Comma); Len(n, dim); - typ := typ^.BaseTyp; aptyp := aptyp^.BaseTyp; INC(dim) - END ; - IF (typ^.comp = DynArr) & (typ^.BaseTyp^.form = Byte) THEN - OPM.WriteString(Comma); - WHILE aptyp^.comp = DynArr DO - Len(n, dim); OPM.WriteString(" * "); INC(dim); aptyp := aptyp^.BaseTyp - END ; - OPM.WriteInt(aptyp^.size); OPM.PromoteIntConstToLInt() - END - END - END ; - n := n^.link; fp := fp^.link; - IF n # NIL THEN OPM.WriteString(Comma) END - END ; - OPM.Write(CloseParen) - END ActualPar; - - PROCEDURE SuperProc(n: OPT.Node): OPT.Object; - VAR obj: OPT.Object; typ: OPT.Struct; - BEGIN typ := n^.right^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - OPT.FindField(n^.left^.obj^.name, typ^.BaseTyp, obj); - RETURN obj - END SuperProc; - - PROCEDURE expr (n: OPT.Node; prec: INTEGER); - VAR - class: INTEGER; - subclass: INTEGER; - form: INTEGER; - exprPrec: INTEGER; - typ: OPT.Struct; - l, r: OPT.Node; - proc: OPT.Object; - BEGIN - class := n^.class; subclass := n^.subcl; form := n^.typ^.form; - l := n^.left; r := n^.right; - exprPrec := Precedence (class, subclass, form, n^.typ^.comp); - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard, Neguard}) THEN - OPM.Write(OpenParen); - END; - CASE class OF - Nconst: - OPC.Constant(n^.conval, form) - | Nupto: (* n^.typ = OPT.settyp *) - OPM.WriteString(SetRangeFunc); expr(l, MinPrec); OPM.WriteString(Comma); expr (r, MinPrec); - OPM.Write(CloseParen) - | Nmop: - CASE subclass OF - not: - OPM.Write("!"); expr(l, exprPrec) - | minus: - IF form = Set THEN OPM.Write("~") ELSE OPM.Write("-"); END ; - expr(l, exprPrec) - | is: - typ := n^.obj^.typ; - IF l^.typ^.comp = Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) - ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp - END ; - OPM.WriteString(Comma); - OPC.Andent(typ); OPM.WriteString(Comma); - OPM.WriteInt(typ^.extlev); OPM.Write(")") - | conv: - Convert(l, form, exprPrec) - | abs: - IF SideEffects(l) THEN - IF l^.typ^.form < Real THEN - IF l^.typ^.form < LInt THEN OPM.WriteString("(int)") END ; - OPM.WriteString("__ABSF(") - ELSE OPM.WriteString("__ABSFD(") - END - ELSE OPM.WriteString("__ABS(") - END ; - expr(l, MinPrec); OPM.Write(CloseParen) - | cap: - OPM.WriteString("__CAP("); expr(l, MinPrec); OPM.Write(CloseParen) - | odd: - OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen) - | adr: (*SYSTEM*) - OPM.WriteString("(LONGINT)"); - IF l^.class = Nvarpar THEN OPC.CompleteIdent(l^.obj) - ELSE - IF (l^.typ^.form # String) & ~(l^.typ^.comp IN {Array, DynArr}) THEN OPM.Write("&") END ; - expr(l, exprPrec) - END - | val: (*SYSTEM*) - IF (n^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) & (l^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) - & (n^.typ^.size = l^.typ^.size) OR ~(l^.class IN {Nvar, Nvarpar, Nfield, Nindex}) THEN - OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen); - expr(l, exprPrec) - ELSE - OPM.WriteString("__VAL("); OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma); - expr(l, MinPrec); OPM.Write(CloseParen) - END - ELSE OPM.err(200) - END - | Ndop: - CASE subclass OF - len: - Len(l, r^.conval^.intval) - | in, ash, msk, bit, lsh, rot, div, mod: - CASE subclass OF - | in: - OPM.WriteString("__IN(") - | ash: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ASHL(") - ELSE OPM.WriteString("__ASHR(") - END - ELSIF SideEffects(r) THEN OPM.WriteString("__ASHF(") - ELSE OPM.WriteString("__ASH(") - END - | msk: - OPM.WriteString("__MASK("); - | bit: - OPM.WriteString("__BIT(") - | lsh: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__LSHL(") - ELSE OPM.WriteString("__LSHR(") - END - ELSE OPM.WriteString("__LSH(") - END - | rot: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ROTL(") - ELSE OPM.WriteString("__ROTR(") - END - ELSE OPM.WriteString("__ROT(") - END - | div: - IF SideEffects(n) THEN - IF form < LInt THEN OPM.WriteString("(int)") END ; - OPM.WriteString("__DIVF(") - ELSE OPM.WriteString("__DIV(") - END - | mod: - IF form < LInt THEN OPM.WriteString("(int)") END ; - IF SideEffects(n) THEN OPM.WriteString("__MODF(") - ELSE OPM.WriteString("__MOD(") - END; - ELSE - OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END ; - expr(l, MinPrec); - OPM.WriteString(Comma); - IF (subclass IN {ash, lsh, rot}) & (r^.class = Nconst) & (r^.conval^.intval < 0) THEN - OPM.WriteInt(-r^.conval^.intval) - ELSE expr(r, MinPrec) - END ; - IF subclass IN {lsh, rot} THEN OPM.WriteString(Comma); OPC.Ident(l^.typ^.strobj) END ; - OPM.Write(CloseParen) - | eql .. geq: - IF l^.typ^.form IN {String, Comp} THEN - OPM.WriteString("__STRCMP("); - expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); OPM.Write(CloseParen); - OPC.Cmp(subclass); OPM.Write("0") - ELSE - expr(l, exprPrec); OPC.Cmp(subclass); - typ := l^.typ; - IF (typ^.form = Pointer) & (r^.typ.form # NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN - OPM.WriteString("(void *) ") - END ; - expr(r, exprPrec) - END - ELSE - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) - expr(l, exprPrec); - CASE subclass OF - times: - IF form = Set THEN OPM.WriteString(" & ") - ELSE OPM.WriteString(" * ") - END - | slash: - IF form = Set THEN OPM.WriteString(" ^ ") - ELSE OPM.WriteString(" / "); - IF (r^.obj = NIL) OR (r^.obj^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN - OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen) - END - END - | and: - OPM.WriteString(" && ") - | plus: - IF form = Set THEN OPM.WriteString(" | ") - ELSE OPM.WriteString(" + ") - END - | minus: - IF form = Set THEN OPM.WriteString(" & ~") - ELSE OPM.WriteString(" - ") - END; - | or: - OPM.WriteString(" || "); - ELSE - OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END; - expr(r, exprPrec); - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) - END - | Ncall: - IF (l^.obj # NIL) & (l^.obj^.mode = TProc) THEN - IF l^.subcl = super THEN proc := SuperProc(n) - ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj) - END ; - OPC.Ident(proc); - n^.obj := proc^.link - ELSIF l^.class = Nproc THEN design(l, 10) - ELSE design(l, ProcTypeVar) - END ; - ActualPar(r, n^.obj) - ELSE - design(n, prec); (* not exprPrec! *) - END ; - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard}) THEN - OPM.Write(CloseParen) - END - END expr; - - PROCEDURE^ stat(n: OPT.Node; outerProc: OPT.Object); - - PROCEDURE IfStat(n: OPT.Node; withtrap: BOOLEAN; outerProc: OPT.Object); - VAR if: OPT.Node; obj: OPT.Object; typ: OPT.Struct; adr: LONGINT; - BEGIN (* n^.class IN {Nifelse, Nwith} *) - if := n^.left; (* name := ""; *) - WHILE if # NIL DO - OPM.WriteString("if "); expr(if^.left, MaxPrec); (* if *) - OPM.Write(Blank); OPC.BegBlk; - IF (n^.class = Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) - obj := if^.left^.left^.obj; typ := obj^.typ; adr := obj^.adr; - IF typ^.comp = Record THEN - (* introduce alias pointer for var records; T1 *name__ = rec; *) - OPC.BegStat; OPC.Ident(if^.left^.obj); OPM.WriteString(" *"); - OPM.WriteString(obj.name); OPM.WriteString("__ = (void*)"); - obj^.adr := 0; (* for nested WITH with same variable; always take the original name *) - OPC.CompleteIdent(obj); - OPC.EndStat - END ; - obj^.adr := 1; (* signal special handling of variable name to OPC.CompleteIdent *) - obj^.typ := if^.left^.obj^.typ; - stat(if^.right, outerProc); - obj^.typ := typ; obj^.adr := adr - ELSE - stat(if^.right, outerProc) - END ; - if := if^.link; - IF (if # NIL) OR (n^.right # NIL) OR withtrap THEN OPC.EndBlk0(); OPM.WriteString(" else "); - ELSE OPC.EndBlk() - END - END ; - IF withtrap THEN OPM.WriteString(WithChk); OPC.EndStat() - ELSIF n^.right # NIL THEN OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk - END - END IfStat; - - PROCEDURE CaseStat(n: OPT.Node; outerProc: OPT.Object); - VAR switchCase, label: OPT.Node; - low, high: LONGINT; form, i: INTEGER; - BEGIN - OPM.WriteString("switch "); expr(n^.left, MaxPrec); - OPM.Write(Blank); OPC.BegBlk; - form := n^.left^.typ^.form; - switchCase := n^.right^.left; - WHILE switchCase # NIL DO (* switchCase^.class = Ncasedo *) - label := switchCase^.left; - i := 0; - WHILE label # NIL DO (* label^.class = NConst *) - low := label^.conval^.intval; - high := label^.conval^.intval2; - WHILE low <= high DO - IF i = 0 THEN OPC.BegStat END ; - OPC.Case(low, form); - INC(low); INC(i); - IF i = 5 THEN OPM.WriteLn; i := 0 END - END ; - label := label^.link - END ; - IF i > 0 THEN OPM.WriteLn END ; - OPC.Indent(1); - stat(switchCase^.right, outerProc); - OPC.BegStat; OPM.WriteString(Break); OPC.EndStat; - OPC.Indent(-1); - switchCase := switchCase^.link - END ; - OPC.BegStat; OPM.WriteString("default: "); - IF n^.right^.conval^.setval # {} THEN (* else branch *) - OPC.Indent(1); OPM.WriteLn; stat(n^.right^.right, outerProc); - OPC.BegStat; OPM.WriteString(Break); OPC.Indent(-1) - ELSE - OPM.WriteString("__CASECHK") - END ; - OPC.EndStat; OPC.EndBlk - END CaseStat; - - PROCEDURE ImplicitReturn(n: OPT.Node): BOOLEAN; - BEGIN - WHILE (n # NIL) & (n.class # Nreturn) DO n := n^.link END ; - RETURN n = NIL - END ImplicitReturn; - - PROCEDURE NewArr(d, x: OPT.Node); - VAR typ, base: OPT.Struct; nofdim, nofdyn: INTEGER; - BEGIN - typ := d^.typ^.BaseTyp; base := typ; nofdim := 0; nofdyn := 0; - WHILE base^.comp = DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; - design(d, MinPrec); OPM.WriteString(" = __NEWARR("); - WHILE base^.comp = Array DO INC(nofdim); base := base^.BaseTyp END ; - IF (base^.comp = Record) & (OPC.NofPtrs(base) # 0) THEN - OPC.Ident(base^.strobj); OPM.WriteString(DynTypExt) - ELSIF base^.form = Pointer THEN OPM.WriteString("POINTER__typ") - ELSE OPM.WriteString("NIL") - END ; - OPM.WriteString(", "); OPM.WriteInt(base^.size); OPM.PromoteIntConstToLInt(); (* element size *) - OPM.WriteString(", "); OPM.WriteInt(OPC.Base(base)); (* element alignment *) - OPM.WriteString(", "); OPM.WriteInt(nofdim); (* total number of dimensions = number of additional parameters *) - OPM.WriteString(", "); OPM.WriteInt(nofdyn); (* number of dynamic dimensions *) - WHILE typ # base DO - OPM.WriteString(", "); - IF typ^.comp = DynArr THEN - IF x^.class = Nconst THEN expr(x, MinPrec); OPM.PromoteIntConstToLInt() - ELSE OPM.WriteString("(LONGINT)"); expr(x, 10) - END ; - x := x^.link - ELSE OPM.WriteInt(typ^.n); OPM.PromoteIntConstToLInt() - END ; - typ := typ^.BaseTyp - END ; - OPM.Write(")") - END NewArr; - - PROCEDURE DefineTDescs(n: OPT.Node); - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END - END DefineTDescs; - - PROCEDURE InitTDescs(n: OPT.Node); - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END - END InitTDescs; - - PROCEDURE stat(n: OPT.Node; outerProc: OPT.Object); - VAR proc: OPT.Object; saved: ExitInfo; l, r: OPT.Node; - BEGIN - WHILE (n # NIL) & OPM.noerr DO - OPM.errpos := n^.conval^.intval; - IF n^.class # Ninittd THEN OPC.BegStat; END; - CASE n^.class OF - Nenter: - IF n^.obj = NIL THEN (* enter module *) - INC(OPM.level); stat(n^.left, outerProc); DEC(OPM.level); - OPC.GenEnumPtrs(OPT.topScope^.scope); - DefineTDescs(n^.right); OPC.EnterBody; InitTDescs(n^.right); - OPM.WriteString("/* BEGIN */"); OPM.WriteLn; - stat(n^.right, outerProc); OPC.ExitBody - ELSE (* enter proc *) - proc := n^.obj; - OPC.TypeDefs(proc^.scope^.right, 0); - IF ~proc^.scope^.leaf THEN OPC.DefineInter (proc) END ; (* define intermediate procedure scope *) - INC(OPM.level); stat(n^.left, proc); DEC(OPM.level); - OPC.EnterProc(proc); stat(n^.right, proc); - OPC.ExitProc(proc, TRUE, ImplicitReturn(n^.right)); - END - | Ninittd: (* done in enter module *) - | Nassign: - CASE n^.subcl OF - assign: - l := n^.left; r := n^.right; - IF l^.typ^.comp = Array THEN (* includes string assignment but not COPY *) - OPM.WriteString(MoveFunc); - expr(r, MinPrec); OPM.WriteString(Comma); expr(l, MinPrec); OPM.WriteString(Comma); - IF r^.typ = OPT.stringtyp THEN OPM.WriteInt(r^.conval^.intval2) - ELSE OPM.WriteInt(r^.typ^.size) - END ; - OPM.Write(CloseParen) - ELSE - IF (l^.typ^.form = Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = Var) THEN - l^.obj^.adr := 0; design(l, MinPrec); l^.obj^.adr := 1; (* avoid cast of WITH-variable *) - IF r^.typ^.form # NilTyp THEN OPM.WriteString(" = (void*)") - ELSE OPM.WriteString(" = ") - END - ELSE - design(l, MinPrec); OPM.WriteString(" = ") - END ; - IF l^.typ = r^.typ THEN expr(r, MinPrec) - ELSIF (l^.typ^.form = Pointer) & (r^.typ^.form # NilTyp) & (l^.typ^.strobj # NIL) THEN - OPM.Write("("); OPC.Ident(l^.typ^.strobj); OPM.Write(")"); expr(r, MinPrec) - ELSIF l^.typ^.comp = Record THEN - OPM.WriteString("*("); OPC.Andent(l^.typ); OPM.WriteString("*)&"); expr(r, 9) - ELSE expr(r, MinPrec) - END - END - | newfn: - IF n^.left^.typ^.BaseTyp^.comp = Record THEN - OPM.WriteString("__NEW("); design(n^.left, MinPrec); OPM.WriteString(", "); - OPC.Andent(n^.left^.typ^.BaseTyp); OPM.WriteString(")") - ELSIF n^.left^.typ^.BaseTyp^.comp IN {Array, DynArr} THEN - NewArr(n^.left, n^.right) - END - | incfn, decfn: - expr(n^.left, MinPrec); OPC.Increment(n^.subcl = decfn); expr(n^.right, MinPrec) - | inclfn, exclfn: - expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = exclfn); OPM.WriteString(SetOfFunc); expr(n^.right, MinPrec); - OPM.Write(CloseParen) - | copyfn: - OPM.WriteString(CopyFunc); - expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); - Len(n^.left, 0); OPM.Write(CloseParen) - | (*SYSTEM*)movefn: - OPM.WriteString(MoveFunc); - expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); - expr(n^.right^.link, MinPrec); - OPM.Write(CloseParen) - | (*SYSTEM*)getfn: - OPM.WriteString(GetFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); - OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)putfn: - OPM.WriteString(PutFunc); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right, MinPrec); - OPM.WriteString(Comma); OPC.Ident(n^.right^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)getrfn, putrfn: OPM.err(200) - | (*SYSTEM*)sysnewfn: - OPM.WriteString("__SYSNEW("); - design(n^.left, MinPrec); OPM.WriteString(", "); - expr(n^.right, MinPrec); - OPM.Write(")") - ELSE - OPM.LogWStr("unhandled case in OPV.expr, n^.subcl = "); OPM.LogWNum(n^.subcl, 0); OPM.LogWLn; - END - | Ncall: - IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = TProc) THEN - IF n^.left^.subcl = super THEN proc := SuperProc(n) - ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(n^.left^.obj) - END ; - OPC.Ident(proc); - n^.obj := proc^.link - ELSIF n^.left^.class = Nproc THEN design(n^.left, 10) - ELSE design(n^.left, ProcTypeVar) - END ; - ActualPar(n^.right, n^.obj) - | Nifelse: - IF n^.subcl # assertfn THEN IfStat(n, FALSE, outerProc) - ELSIF assert THEN OPM.WriteString("__ASSERT("); expr(n^.left^.left^.left, MinPrec); OPM.WriteString(Comma); - OPM.WriteInt(n^.left^.right^.right^.conval^.intval); OPM.Write(CloseParen); OPC.EndStat - END - | Ncase: - INC(exit.level); CaseStat(n, outerProc); DEC(exit.level) - | Nwhile: - INC(exit.level); OPM.WriteString("while "); expr(n^.left, MaxPrec); - OPM.Write(Blank); OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk; - DEC(exit.level) - | Nrepeat: - INC(exit.level); OPM.WriteString("do "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk0; - OPM.WriteString(" while (!"); expr(n^.right, 9); OPM.Write(CloseParen); - DEC(exit.level) - | Nloop: - saved := exit; exit.level := 0; exit.label := -1; - OPM.WriteString("for (;;) "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk; - IF exit.label # -1 THEN - OPC.BegStat; OPM.WriteString("exit__"); OPM.WriteInt(exit.label); OPM.Write(":"); OPC.EndStat - END ; - exit := saved - | Nexit: - IF exit.level = 0 THEN OPM.WriteString(Break) - ELSE - IF exit.label = -1 THEN exit.label := nofExitLabels; INC(nofExitLabels) END ; - OPM.WriteString("goto exit__"); OPM.WriteInt(exit.label) - END - | Nreturn: - IF OPM.level = 0 THEN - IF mainprog THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END - ELSE - OPC.ExitProc(outerProc, FALSE, FALSE); - OPM.WriteString("return"); - IF n^.left # NIL THEN OPM.Write(Blank); - IF (n^.left^.typ^.form = Pointer) & (n^.obj^.typ # n^.left^.typ) THEN - OPM.WriteString("(void*)"); expr(n^.left, 10) - ELSE - expr(n^.left, MinPrec) - END - END - END - | Nwith: - IfStat(n, n^.subcl = 0, outerProc) - | Ntrap: - OPC.Halt(n^.right^.conval^.intval) - ELSE - (* this else is necessary cause - it can happen that - n^.class is something which is not handled, - like Nconst (7) - which I actually experienced - when compiling Texts0.Mod on raspberry pi - it generates __CASECHK and cause Halt, - noch *) - OPM.LogWStr("unhandled case in OPV.expr, n^.class = "); OPM.LogWNum(n^.class, 0); OPM.LogWLn; - END ; - IF ~(n^.class IN {Nenter, Ninittd, Nifelse, Nwith, Ncase, Nwhile, Nloop}) THEN OPC.EndStat END ; - n := n^.link - END - END stat; - - PROCEDURE Module*(prog: OPT.Node); - BEGIN - IF ~mainprog THEN OPC.GenHdr(prog^.right); OPC.GenHdrIncludes END ; - OPC.GenBdy(prog^.right); stat(prog, NIL) - END Module; - -END OPV. diff --git a/src/voc/darwin/clang/extTools.Mod b/src/voc/darwin/clang/extTools.Mod deleted file mode 100644 index a26e83a5..00000000 --- a/src/voc/darwin/clang/extTools.Mod +++ /dev/null @@ -1,105 +0,0 @@ -MODULE extTools; - IMPORT Args, Unix, Strings, Console, version; -(* -INCLUDEPATH = -Isrc/lib/system/linux/gnuc/x86_64 -CCOPT = -fPIC $(INCLUDEPATH) -g -CLOBERONOPTS = -fPIC $(INCLUDEPATH) -L. -L/usr/lib -lVishapOberon -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; -cmd2 : ARRAY 1023 OF CHAR; -BEGIN -(* -gcc -g -o hello hello.c -I $RPATH/src/lib/system/linux/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); -Strings.Append(" ", cmd); -(*IF statically THEN Strings.Append(" -static ", cmd) END;*) -IF statically THEN - Strings.Append(version.prefix, cmd); - Strings.Append("/lib/libVishapOberon.a ", cmd); -END; -Strings.Append(" -o ", cmd); -Strings.Append(m, cmd); -Strings.Append(" ", cmd); -IF ~statically THEN -Strings.Append ("-lVishapOberon -L. -L", ccOpt); -Strings.Append (version.prefix, ccOpt); -Strings.Append ("/lib ", ccOpt); -END; -Strings.Append(ccOpt, cmd); - -Console.Ln; Console.String(cmd); Console.Ln; (* may be it's feasible to add debug mode later *) -Unix.system(cmd); - -IF ~statically THEN - cmd2 := ""; - COPY ("install_name_tool -change libVishapOberon.dylib ", cmd2); - Strings.Append(version.prefix, cmd2); - Strings.Append ("/lib/libVishapOberon.dylib ", cmd2); - Strings.Append (m, cmd2); - Console.String(cmd2); Console.Ln; - Unix.system(cmd2); - END -END LinkMain; - -BEGIN - -incPath0 := "src/lib/system/darwin/"; -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. diff --git a/src/voc/darwin/clang/x86_64/architecture.Mod b/src/voc/darwin/clang/x86_64/architecture.Mod deleted file mode 100644 index 1f95d2fd..00000000 --- a/src/voc/darwin/clang/x86_64/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86_64"; - -END architecture. diff --git a/src/voc/errors.Mod b/src/voc/errors.Mod deleted file mode 100644 index 1ccdcc92..00000000 --- a/src/voc/errors.Mod +++ /dev/null @@ -1,214 +0,0 @@ -MODULE errors; - -TYPE string* = ARRAY 128 OF CHAR; - -VAR errors- : ARRAY 350 OF string; - - -BEGIN -(* Incorrect use of the language Oberon *) -errors[0] := "undeclared identifier"; -errors[1] := "multiply defined identifier"; -errors[2] := "illegal character in number"; -errors[3] := "illegal character in string"; -errors[4] := "identifier does not match procedure name"; -errors[5] := "comment not closed"; -errors[6] := ""; -errors[6] := ""; -errors[6] := ""; -errors[9] := "'=' expected"; -errors[10] :=""; -errors[11] :=""; -errors[12] := "type definition starts with incorrect symbol"; -errors[13] := "factor starts with incorrect symbol"; -errors[14] := "statement starts with incorrect symbol"; -errors[15] := "declaration followed by incorrect symbol"; -errors[16] := "MODULE expected"; -errors[17] := ""; -errors[18] := "'.' missing"; -errors[19] := "',' missing"; -errors[20] := "':' missing"; -errors[21] := ""; -errors[22] := "')' missing"; -errors[23] := "']' missing"; -errors[24] := "'}' missing"; -errors[25] := "OF missing"; -errors[26] := "THEN missing"; -errors[27] := "DO missing"; -errors[28] := "TO missing"; -errors[29] := ""; -errors[30] := "'(' missing"; -errors[31] := ""; -errors[32] := ""; -errors[33] := ""; -errors[34] := "':=' missing"; -errors[35] := "',' or OF expected"; -errors[36] := ""; -errors[37] := ""; -errors[38] := "identifier expected"; -errors[39] := "';' missing"; -errors[40] := ""; -errors[41] := "END missing"; -errors[42] := ""; -errors[43] := ""; -errors[44] := "UNTIL missing"; -errors[45] := ""; -errors[46] := "EXIT not within loop statement"; -errors[47] := "illegally marked identifier"; -errors[48] := ""; -errors[49] := ""; -errors[50] := "expression should be constant"; -errors[51] := "constant not an integer"; -errors[52] := "identifier does not denote a type"; -errors[53] := "identifier does not denote a record type"; -errors[54] := "result type of procedure is not a basic type"; -errors[55] := "procedure call of a function"; -errors[56] := "assignment to non-variable"; -errors[57] := "pointer not bound to record or array type"; -errors[58] := "recursive type definition"; -errors[59] := "illegal open array parameter"; -errors[60] := "wrong type of case label"; -errors[61] := "inadmissible type of case label"; -errors[62] := "case label defined more than once"; -errors[63] := "illegal value of constant"; -errors[64] := "more actual than formal parameters"; -errors[65] := "fewer actual than formal parameters"; -errors[66] := "element types of actual array and formal open array differ"; -errors[67] := "actual parameter corresponding to open array is not an array"; -errors[68] := "control variable must be integer"; -errors[69] := "parameter must be an integer constant"; -errors[70] := "pointer or VAR record required as formal receiver"; -errors[71] := "pointer expected as actual receiver"; -errors[72] := "procedure must be bound to a record of the same scope"; -errors[73] := "procedure must have level 0"; -errors[74] := "procedure unknown in base type"; -errors[75] := "invalid call of base procedure"; -errors[76] := "this variable (field) is read only"; -errors[77] := "object is not a record"; -errors[78] := "dereferenced object is not a variable"; -errors[79] := "indexed object is not a variable"; -errors[80] := "index expression is not an integer"; -errors[81] := "index out of specified bounds"; -errors[82] := "indexed variable is not an array"; -errors[83] := "undefined record field"; -errors[84] := "dereferenced variable is not a pointer"; -errors[85] := "guard or test type is not an extension of variable type"; -errors[86] := "guard or testtype is not a pointer"; -errors[87] := "guarded or tested variable is neither a pointer nor a VAR-parameter record"; -errors[88] := "open array not allowed as variable, record field or array element"; -errors[89] := ""; -errors[90] := ""; -errors[91] := ""; -errors[92] := "operand of IN not an integer, or not a set"; -errors[93] := "set element type is not an integer"; -errors[94] := "operand of & is not of type BOOLEAN"; -errors[95] := "operand of OR is not of type BOOLEAN"; -errors[96] := "operand not applicable to (unary) +"; -errors[97] := "operand not applicable to (unary) -"; -errors[98] := "operand of ~ is not of type BOOLEAN"; -errors[99] := "ASSERT fault"; -errors[100] := "incompatible operands of dyadic operator"; -errors[101] := "operand type inapplicable to *"; -errors[102] := "operand type inapplicable to /"; -errors[103] := "operand type inapplicable to DIV"; -errors[104] := "operand type inapplicable to MOD"; -errors[105] := "operand type inapplicable to +"; -errors[106] := "operand type inapplicable to -"; -errors[107] := "operand type inapplicable to = or #"; -errors[108] := "operand type inapplicable to relation"; -errors[109] := "overriding method must be exported"; -errors[110] := "operand is not a type"; -errors[111] := "operand inapplicable to (this) function"; -errors[112] := "operand is not a variable"; -errors[113] := "incompatible assignment"; -errors[114] := "string too long to be assigned"; -errors[115] := "parameter doesn't match"; -errors[116] := "number of parameters doesn't match"; -errors[117] := "result type doesn't match"; -errors[118] := "export mark doesn't match with forward declaration"; -errors[119] := "redefinition textually precedes procedure bound to base type"; -errors[120] := "type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN"; -errors[121] := "called object is not a procedure (or is an interrupt procedure)"; -errors[122] := "actual VAR-parameter is not a variable"; -errors[123] := "type of actual parameter is not identical with that of formal VAR-parameter"; -errors[124] := "type of result expression differs from that of procedure"; -errors[125] := "type of case expression is neither INTEGER nor CHAR"; -errors[126] := "this expression cannot be a type or a procedure"; -errors[127] := "illegal use of object"; -errors[128] := "unsatisfied forward reference"; -errors[129] := "unsatisfied forward procedure"; -errors[130] := "WITH clause does not specify a variable"; -errors[131] := "LEN not applied to array"; -errors[132] := "dimension in LEN too large or negative"; -errors[135] := "SYSTEM not imported"; -errors[150] := "key inconsistency of imported module"; -errors[151] := "incorrect symbol file"; -errors[152] := "symbol file of imported module not found"; -errors[153] := "object or symbol file not opened (disk full?)"; -errors[154] := "recursive import not allowed"; -errors[155] := "generation of new symbol file not allowed"; -errors[156] := "parameter file not found"; -errors[157] := "syntax error in parameter file"; -(* Limitations of implementation*) -errors[200] := "not yet implemented"; -errors[201] := "lower bound of set range greater than higher bound"; -errors[202] := "set element greater than MAX(SET) or less than 0"; -errors[203] := "number too large"; -errors[204] := "product too large"; -errors[205] := "division by zero"; -errors[206] := "sum too large"; -errors[207] := "difference too large"; -errors[208] := "overflow in arithmetic shift"; -errors[209] := "case range too large"; -errors[213] := "too many cases in case statement"; -errors[218] := "illegal value of parameter (0 <= p < 256)"; -errors[219] := "machine registers cannot be accessed"; -errors[220] := "illegal value of parameter"; -errors[221] := "too many pointers in a record"; -errors[222] := "too many global pointers"; -errors[223] := "too many record types"; -errors[224] := "too many pointer types"; -errors[225] := "address of pointer variable too large (move forward in text)"; -errors[226] := "too many exported procedures"; -errors[227] := "too many imported modules"; -errors[228] := "too many exported structures"; -errors[229] := "too many nested records for import"; -errors[230] := "too many constants (strings) in module"; -errors[231] := "too many link table entries (external procedures)"; -errors[232] := "too many commands in module"; -errors[233] := "record extension hierarchy too high"; -errors[234] := "export of recursive type not allowed"; -errors[240] := "identifier too long"; -errors[241] := "string too long"; -errors[242] := "address overflow"; -errors[244] := "cyclic type definition not allowed"; -errors[245] := "guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable"; -(* Compiler Warnings *) - -errors[301] := "implicit type cast"; -errors[306] := "inappropriate symbol file ignored"; -errors[307] := "no ELSE symbol after CASE statement sequence may lead to trap"; (* new warning, -- noch *) - -END errors. -(* -Run-time Error Messages - SYSTEM_halt - 0 silent HALT(0) - 1..255 HALT(n), cf. SYSTEM_halt - -1 assertion failed, cf. SYSTEM_assert - -2 invalid array index - -3 function procedure without RETURN statement - -4 invalid case in CASE statement - -5 type guard failed - -6 implicit type guard in record assignment failed - -7 invalid case in WITH statement - -8 value out of range - -9 (delayed) interrupt - -10 NIL access - -11 alignment error - -12 zero divide - -13 arithmetic overflow/underflow - -14 invalid function argument - -15 internal error -*) - diff --git a/src/voc/freebsd/clang/extTools.Mod b/src/voc/freebsd/clang/extTools.Mod deleted file mode 100644 index 62f7368a..00000000 --- a/src/voc/freebsd/clang/extTools.Mod +++ /dev/null @@ -1,88 +0,0 @@ -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. diff --git a/src/voc/freebsd/clang/x86_64/architecture.Mod b/src/voc/freebsd/clang/x86_64/architecture.Mod deleted file mode 100644 index 1f95d2fd..00000000 --- a/src/voc/freebsd/clang/x86_64/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86_64"; - -END architecture. diff --git a/src/voc/linux/clang/armv6j/architecture.Mod b/src/voc/linux/clang/armv6j/architecture.Mod deleted file mode 100644 index d8409c34..00000000 --- a/src/voc/linux/clang/armv6j/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv6j"; - -END architecture. diff --git a/src/voc/linux/clang/armv6j_hardfp/architecture.Mod b/src/voc/linux/clang/armv6j_hardfp/architecture.Mod deleted file mode 100644 index 761f8c99..00000000 --- a/src/voc/linux/clang/armv6j_hardfp/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv6j_hardfp"; - -END architecture. diff --git a/src/voc/linux/clang/armv7a_hardfp/architecture.Mod b/src/voc/linux/clang/armv7a_hardfp/architecture.Mod deleted file mode 100644 index fab9a0e2..00000000 --- a/src/voc/linux/clang/armv7a_hardfp/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv7a_hardfp"; - -END architecture. diff --git a/src/voc/linux/clang/extTools.Mod b/src/voc/linux/clang/extTools.Mod deleted file mode 100644 index e18f3361..00000000 --- a/src/voc/linux/clang/extTools.Mod +++ /dev/null @@ -1,88 +0,0 @@ -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/linux/"; -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. diff --git a/src/voc/linux/clang/powerpc/architecture.Mod b/src/voc/linux/clang/powerpc/architecture.Mod deleted file mode 100644 index 1cd033d5..00000000 --- a/src/voc/linux/clang/powerpc/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "powerpc"; - -END architecture. diff --git a/src/voc/linux/clang/x86/architecture.Mod b/src/voc/linux/clang/x86/architecture.Mod deleted file mode 100644 index 84835238..00000000 --- a/src/voc/linux/clang/x86/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86"; - -END architecture. diff --git a/src/voc/linux/clang/x86_64/architecture.Mod b/src/voc/linux/clang/x86_64/architecture.Mod deleted file mode 100644 index 1f95d2fd..00000000 --- a/src/voc/linux/clang/x86_64/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86_64"; - -END architecture. diff --git a/src/voc/linux/gcc/armv6j/architecture.Mod b/src/voc/linux/gcc/armv6j/architecture.Mod deleted file mode 100644 index d8409c34..00000000 --- a/src/voc/linux/gcc/armv6j/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv6j"; - -END architecture. diff --git a/src/voc/linux/gcc/armv6j_hardfp/architecture.Mod b/src/voc/linux/gcc/armv6j_hardfp/architecture.Mod deleted file mode 100644 index 761f8c99..00000000 --- a/src/voc/linux/gcc/armv6j_hardfp/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv6j_hardfp"; - -END architecture. diff --git a/src/voc/linux/gcc/armv7a_hardfp/architecture.Mod b/src/voc/linux/gcc/armv7a_hardfp/architecture.Mod deleted file mode 100644 index fab9a0e2..00000000 --- a/src/voc/linux/gcc/armv7a_hardfp/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "armv7a_hardfp"; - -END architecture. diff --git a/src/voc/linux/gcc/extTools.Mod b/src/voc/linux/gcc/extTools.Mod deleted file mode 100644 index 30790878..00000000 --- a/src/voc/linux/gcc/extTools.Mod +++ /dev/null @@ -1,88 +0,0 @@ -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="gcc"; - -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/linux/"; -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. diff --git a/src/voc/linux/gcc/powerpc/architecture.Mod b/src/voc/linux/gcc/powerpc/architecture.Mod deleted file mode 100644 index 1cd033d5..00000000 --- a/src/voc/linux/gcc/powerpc/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "powerpc"; - -END architecture. diff --git a/src/voc/linux/gcc/x86/architecture.Mod b/src/voc/linux/gcc/x86/architecture.Mod deleted file mode 100644 index 84835238..00000000 --- a/src/voc/linux/gcc/x86/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86"; - -END architecture. diff --git a/src/voc/linux/gcc/x86_64/architecture.Mod b/src/voc/linux/gcc/x86_64/architecture.Mod deleted file mode 100644 index 1f95d2fd..00000000 --- a/src/voc/linux/gcc/x86_64/architecture.Mod +++ /dev/null @@ -1,4 +0,0 @@ -MODULE architecture; -CONST arch* = "x86_64"; - -END architecture. diff --git a/src/voc/prf.Mod b/src/voc/prf.Mod deleted file mode 100644 index 2f4d8f24..00000000 --- a/src/voc/prf.Mod +++ /dev/null @@ -1,5 +0,0 @@ -MODULE prf; - -CONST prefix* = "/opt"; - -END prf. diff --git a/src/voc/prf.Mod_default b/src/voc/prf.Mod_default deleted file mode 100644 index 2f4d8f24..00000000 --- a/src/voc/prf.Mod_default +++ /dev/null @@ -1,5 +0,0 @@ -MODULE prf; - -CONST prefix* = "/opt"; - -END prf. diff --git a/src/voc/version.Mod b/src/voc/version.Mod deleted file mode 100644 index 5edcd27e..00000000 --- a/src/voc/version.Mod +++ /dev/null @@ -1,41 +0,0 @@ -MODULE version; - IMPORT Strings, architecture, prf; -CONST -(* targets *) - gnux86* = 0; gnux8664* = 1; gnuarmv6j* = 2; gnuarmv6jhardfp* = 3; gnuarmv7ahardfp* = 4; gnupowerpc* = 5; - -VAR arch-, version-, date-, versionLong-, prefix0-, prefix- : ARRAY 256 OF CHAR; -defaultTarget* : INTEGER; -BEGIN -arch := architecture.arch; -date := " [2015/02/02]"; -version := "1.1"; -versionLong := ""; -COPY(version, versionLong); -Strings.Append (" ", versionLong); -Strings.Append(date, versionLong); - prefix := ""; - (*prefix0 := "/opt";*) - COPY(prf.prefix, prefix0); - COPY (prefix0, prefix); - Strings.Append ("/voc-", prefix); - Strings.Append(version, prefix); (* /opt/voc-x.x *) - (* will be used later in Kernel0.Mod to set OBERON default path *) - - IF arch = "x86_64" THEN - defaultTarget := gnux8664 - ELSIF arch = "x86" THEN - defaultTarget := gnux86 - ELSIF arch = "armv6j" THEN - defaultTarget := gnuarmv6j - ELSIF arch = "armv6j_hardfp" THEN - defaultTarget := gnuarmv6jhardfp - ELSIF arch = "armv7a_hardfp" THEN - defaultTarget := gnuarmv7ahardfp - ELSIF arch = "powerpc" THEN - defaultTarget := gnupowerpc - ELSE - defaultTarget := gnux8664 - END - -END version. diff --git a/src/voc/voc.Mod b/src/voc/voc.Mod deleted file mode 100644 index a375af43..00000000 --- a/src/voc/voc.Mod +++ /dev/null @@ -1,127 +0,0 @@ -MODULE voc; (* J. Templ 3.2.95 *) - - IMPORT - SYSTEM, Unix, Kernel := Kernel0, - OPP, OPB, OPT, - OPV, OPC, OPM, - extTools, Strings, vt100; - -VAR mname : ARRAY 256 OF CHAR; (* noch *) - - - PROCEDURE -signal(sig: LONGINT; func: Unix.SignalHandler) - "signal(sig, func)"; - - PROCEDURE -fin() - "SYSTEM_FINALL()"; - - PROCEDURE -halt(): LONGINT - "SYSTEM_halt"; - -(* - PROCEDURE -gclock() - "SYSTEM_gclock = 1"; -*) - - PROCEDURE Trap(sig, code: LONGINT; scp: Unix.SigCtxPtr); - BEGIN fin(); - IF sig = 3 THEN Unix.Exit(0) - ELSE - IF (sig = 4) & (halt() = -15) THEN OPM.LogWStr(" --- voc: internal error"); OPM.LogWLn END ; - Unix.Exit(2) - END - END Trap; - - PROCEDURE Module*(VAR done: BOOLEAN); - VAR ext, new: BOOLEAN; p: OPT.Node; - BEGIN - OPP.Module(p, OPM.opt); - IF OPM.noerr THEN - OPV.Init; - OPV.AdrAndSize(OPT.topScope); - OPT.Export(ext, new); - IF OPM.noerr THEN - OPM.OpenFiles(OPT.SelfName); - OPC.Init; - OPV.Module(p); - IF OPM.noerr THEN - (*IF (OPM.mainprog IN OPM.opt) & (OPM.modName # "SYSTEM") THEN*) - IF (OPM.mainProg OR OPM.mainLinkStat) & (OPM.modName # "SYSTEM") THEN - OPM.DeleteNewSym; - IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END; - OPM.LogWStr(" main program"); - IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - ELSE - IF new THEN - IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END; - OPM.LogWStr(" new symbol file"); - IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END; - OPM.RegisterNewSym - ELSIF ext THEN OPM.LogWStr(" extended symbol file"); OPM.RegisterNewSym - END - END; - - - ELSE OPM.DeleteNewSym - END - END - END ; - OPM.CloseFiles; OPT.Close; - OPM.LogWLn; done := OPM.noerr; - - - - END Module; - - PROCEDURE Translate*; - VAR done: BOOLEAN; - VAR modulesobj: ARRAY 2048 OF CHAR; (* here we hold all modules name given on the command line, to add corresponding .o files to the external compiler options *) - BEGIN - modulesobj := ""; - OPM.OpenPar; (* gclock(); slightly faste rtranslation but may lead to opening "too many files" *) - OPT.bytetyp.size := OPM.ByteSize; - (*OPT.int8typ.size := 1; - OPT.int16typ.size := 2; - OPT.int32typ.size := 4; - OPT.int64typ.size := 8;*) - OPT.sysptrtyp.size := OPM.PointerSize; - OPT.chartyp.size := OPM.CharSize; - OPT.settyp.size := OPM.SetSize; - OPT.realtyp.size := OPM.RealSize; - OPT.inttyp.size := OPM.IntSize; - OPT.linttyp.size := OPM.LIntSize; - OPT.lrltyp.size := OPM.LRealSize; - OPT.sinttyp.size := OPM.SIntSize; - OPT.booltyp.size := OPM.BoolSize; - LOOP - OPM.Init(done, mname); - IF ~done THEN EXIT END ; - OPM.InitOptions; - Kernel.GC(FALSE); - Module(done); - IF ~done THEN Unix.Exit(1) END; - - (* noch *) - IF done THEN - IF ~OPM.dontAsm THEN - extTools.Assemble(OPM.modName); - IF ~(OPM.mainProg OR OPM.mainLinkStat) THEN Strings.Append(" ",modulesobj); Strings.Append(OPM.modName, modulesobj); Strings.Append(".o ", modulesobj) END; - - IF ~OPM.dontLink & (OPM.mainProg OR OPM.mainLinkStat) THEN - extTools.LinkMain (OPM.modName, OPM.mainLinkStat, modulesobj); - END; - END; - END - - - - - END (* loop *) - END Translate; - -BEGIN - signal(2, Trap); (* interrupt *) - signal(3, Trap); (* quit *) - signal(4, Trap); (* illegal instruction, HALT *) - OPB.typSize := OPV.TypSize; OPT.typSize := OPV.TypSize; Translate -END voc. diff --git a/src/voc07R/CompatFiles.Mod b/src/voc07R/CompatFiles.Mod deleted file mode 100644 index d7a9c06e..00000000 --- a/src/voc07R/CompatFiles.Mod +++ /dev/null @@ -1,677 +0,0 @@ -MODULE CompatFiles; (* 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 - "(CompatFiles_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 ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE); - BEGIN - ReadBytes(r, x, 1); - END ReadByte; - - 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 ReadInt* (VAR R: Rider; VAR x: LONGINT); (* to compile OR compiler; -- noch *) - 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 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 WriteInt* (VAR R: Rider; x: LONGINT); (* to compile OR compiler; -- noch *) - 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 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 CompatFiles. diff --git a/src/voc07R/CompatTexts.Mod b/src/voc07R/CompatTexts.Mod deleted file mode 100644 index 62b9073a..00000000 --- a/src/voc07R/CompatTexts.Mod +++ /dev/null @@ -1,585 +0,0 @@ -MODULE CompatTexts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 26.3.2014*) - IMPORT Files := CompatFiles, Fonts; - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST (*scanner symbol classes*) - Inval* = 0; (*invalid symbol*) - Name* = 1; (*name s (length len)*) - String* = 2; (*literal string s (length len)*) - Int* = 3; (*integer i (decimal or hexadecimal)*) - Real* = 4; (*real number x*) - Char* = 6; (*special character c*) - - (* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}. - run = fnt [name] col voff len. *) - - TAB = 9X; CR = 0DX; maxD = 9; - TextTag = 0F1X; - replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*op-codes*) - - TYPE Piece = POINTER TO PieceDesc; - PieceDesc = RECORD - f: Files.File; - off, len: LONGINT; - fnt: Fonts.Font; - col, voff: INTEGER; - prev, next: Piece - END; - - Text* = POINTER TO TextDesc; - Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); - TextDesc* = RECORD - len*: LONGINT; - changed*: BOOLEAN; - notify*: Notifier; - trailer: Piece; - pce: Piece; (*cache*) - org: LONGINT; (*cache*) - END; - - Reader* = RECORD - eot*: BOOLEAN; - fnt*: Fonts.Font; - col*, voff*: INTEGER; - ref: Piece; - org: LONGINT; - off: LONGINT; - rider: Files.Rider - END; - - Scanner* = RECORD (Reader) - nextCh*: CHAR; - line*, class*: INTEGER; - i*: LONGINT; - x*: REAL; - y*: LONGREAL; - c*: CHAR; - len*: INTEGER; - s*: ARRAY 32 OF CHAR - END; - - Buffer* = POINTER TO BufDesc; - BufDesc* = RECORD - len*: LONGINT; - header, last: Piece - END; - - Writer* = RECORD - buf*: Buffer; - fnt*: Fonts.Font; - col*, voff*: INTEGER; - rider: Files.Rider - END; - - VAR TrailerFile: Files.File; - - (* voc adaptation by noch *) - PROCEDURE FLOOR(x : REAL): INTEGER; - BEGIN - RETURN ENTIER(x) - END FLOOR; - - PROCEDURE LSL (x, n : INTEGER): INTEGER; - BEGIN - RETURN ASH(x, n); - END LSL; - - PROCEDURE ASR (x, n : INTEGER): INTEGER; - BEGIN - RETURN ASH(x, n); - END ASR; - - - (* -------------------- Filing ------------------------*) - - PROCEDURE Trailer(): Piece; - VAR Q: Piece; - BEGIN NEW(Q); - Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q - END Trailer; - - PROCEDURE Load* (VAR R: Files.Rider; T: Text); - VAR Q, q, p: Piece; - off: LONGINT; - N, fno: INTEGER; bt: BYTE; - f: Files.File; - FName: ARRAY 32 OF CHAR; - Dict: ARRAY 32 OF Fonts.Font; - BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q; - Files.ReadInt(R, off); Files.ReadByte(R, bt); - (*fno := bt;*) - fno := ORD(bt); (* voc adaptation by noch *) - WHILE fno # 0 DO - IF fno = N THEN - Files.ReadString(R, FName); - Dict[N] := Fonts.This(FName); INC(N) - END; - NEW(q); q.fnt := Dict[fno]; - Files.ReadByte(R, bt); - (*q.col := bt;*) - q.col := ORD(bt); (* voc adaptation by noch *) - Files.ReadByte(R, bt); - (*q.voff := ASR(LSL(bt, -24), 24);*) - q.voff := ASR(LSL(ORD(bt), -24), 24); (* voc adaptation by noch *) - Files.ReadInt(R, q.len); - Files.ReadByte(R, bt); - (*fno := bt;*) - fno := ORD(bt); (* voc adaptation by noch *) - q.f := f; q.off := off; off := off + q.len; - p.next := q; q.prev := p; p := q - END; - p.next := Q; Q.prev := p; - T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*) - END Load; - - PROCEDURE Open* (T: Text; name: ARRAY OF CHAR); - VAR f: Files.File; R: Files.Rider; Q, q: Piece; - tag: CHAR; len: LONGINT; - BEGIN f := Files.Old(name); - IF f # NIL THEN - Files.Set(R, f, 0); Files.Read(R, tag); - IF tag = TextTag THEN Load(R, T) - ELSE (*Ascii file*) - len := Files.Length(f); Q := Trailer(); - NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len; - Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len - END - ELSE (*create new text*) - Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0 - END ; - T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*) - END Open; - - PROCEDURE Store* (VAR W: Files.Rider; T: Text); - VAR p, q: Piece; - R: Files.Rider; - off, rlen, pos: LONGINT; - N, n: INTEGER; - ch: CHAR; - Dict: ARRAY 32, 32 OF CHAR; - BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*) - N := 1; p := T.trailer.next; - WHILE p # T.trailer DO - rlen := p.len; q := p.next; - WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO - rlen := rlen + q.len; q := q.next - END; - (*Dict[N] := p.fnt.name;*) - IF p.fnt # NIL THEN COPY(p.fnt.name, Dict[N]) END; (* voc adaptation by noch *) - n := 1; - IF p.fnt # NIL THEN (* voc adaptation by noch *) - WHILE Dict[n] # p.fnt.name DO INC(n) END; - END; - (*Files.WriteByte(W, n);*) - Files.WriteByte(W, SHORT(SHORT(n))); (* voc adaptation by noch *) - IF p.fnt # NIL THEN (* voc adaptation by noch *) - IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END; - END; - (*Files.WriteByte(W, p.col);*) - Files.WriteByte(W, SHORT(SHORT(p.col))); (* voc adaptation by noch *) - (*Files.WriteByte(W, p.voff);*) - Files.WriteByte(W, SHORT(SHORT(p.voff))); (* voc adaptation by noch *) - Files.WriteInt(W, rlen); - p := q - END; - Files.WriteByte(W, 0); Files.WriteInt(W, T.len); - off := Files.Pos(W); p := T.trailer.next; - WHILE p # T.trailer DO - rlen := p.len; Files.Set(R, p.f, p.off); - WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ; - p := p.next - END ; - Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*) - T.changed := FALSE; - IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END - END Store; - - PROCEDURE Close*(T: Text; name: ARRAY OF CHAR); - VAR f: Files.File; w: Files.Rider; - BEGIN f := Files.New(name); Files.Set(w, f, 0); - Files.Write(w, TextTag); Store(w, T); Files.Register(f) - END Close; - - (* -------------------- Editing ----------------------- *) - - PROCEDURE OpenBuf* (B: Buffer); - BEGIN NEW(B.header); (*null piece*) - B.last := B.header; B.len := 0 - END OpenBuf; - - PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece); - VAR p: Piece; porg: LONGINT; - BEGIN p := T.pce; porg := T.org; - IF pos >= porg THEN - WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END - ELSE p := p.prev; DEC(porg, p.len); - WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END - END ; - T.pce := p; T.org := porg; (*update cache*) - pce := p; org := porg - END FindPiece; - - PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece); - VAR q: Piece; - BEGIN - IF off > 0 THEN NEW(q); - q.fnt := p.fnt; q.col := p.col; q.voff := p.voff; - q.len := p.len - off; - q.f := p.f; q.off := p.off + off; - p.len := off; - q.next := p.next; p.next := q; - q.prev := p; q.next.prev := q; - pr := q - ELSE pr := p - END - END SplitPiece; - - PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer); - VAR p, q, qb, qe: Piece; org: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, org, p); - NEW(qb); qb^ := p^; - qb.len := qb.len - (beg - org); - qb.off := qb.off + (beg - org); - qe := qb; - WHILE end > org + p.len DO - org := org + p.len; p := p.next; - NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q - END; - qe.next := NIL; qe.len := qe.len - (org + p.len - end); - B.last.next := qb; qb.prev := B.last; B.last := qe; - B.len := B.len + (end - beg) - END Save; - - PROCEDURE Copy* (SB, DB: Buffer); - VAR Q, q, p: Piece; - BEGIN p := SB.header; Q := DB.last; - WHILE p # SB.last DO p := p.next; - NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q - END; - DB.last := Q; DB.len := DB.len + SB.len - END Copy; - - PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer); - VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT; - BEGIN - FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr); - IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ; - pl := pr.prev; qb := B.header.next; - IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len) - & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN - pl.len := pl.len + qb.len; qb := qb.next - END; - IF qb # NIL THEN qe := B.last; - qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe - END; - T.len := T.len + B.len; end := pos + B.len; - B.last := B.header; B.last.next := NIL; B.len := 0; - T.changed := TRUE; - (*T.notify(T, insert, pos, end)*) - IF T.notify # NIL THEN - T.notify(T, insert, pos, end) - END(* voc adaptation by noch *) - END Insert; - - PROCEDURE Append* (T: Text; B: Buffer); - BEGIN Insert(T, T.len, B) - END Append; - - PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer); - VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr); - FindPiece(T, end, orge, pe); - SplitPiece(pe, end - orge, per); - IF T.org >= orgb THEN (*adjust cache*) - T.org := orgb - pb.prev.len; T.pce := pb.prev - END; - B.header.next := pbr; B.last := per.prev; - B.last.next := NIL; B.len := end - beg; - per.prev := pbr.prev; pbr.prev.next := per; - T.len := T.len - B.len; - T.changed := TRUE; - IF T.notify # NIL THEN (* noch *) - T.notify(T, delete, beg, end) - END - END Delete; - - PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER); - VAR pb, pe, p: Piece; org: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb); - FindPiece(T, end, org, p); SplitPiece(p, end - org, pe); - p := pb; - REPEAT - IF 0 IN sel THEN p.fnt := fnt END; - IF 1 IN sel THEN p.col := col END; - IF 2 IN sel THEN p.voff := voff END; - p := p.next - UNTIL p = pe; - T.changed := TRUE; - IF T.notify # NIL THEN (* noch *) - T.notify(T, replace, beg, end) - END - END ChangeLooks; - - PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER); - VAR p: Piece; org: LONGINT; - BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff - END Attributes; - - (* ------------------ Access: Readers ------------------------- *) - - PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT); - VAR p: Piece; org: LONGINT; - BEGIN FindPiece(T, pos, org, p); - R.ref := p; R.org := org; R.off := pos - org; - Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE - END OpenReader; - - PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR); - BEGIN Files.Read(R.rider, ch); - R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff; - INC(R.off); - IF R.off = R.ref.len THEN - IF R.ref.f = TrailerFile THEN R.eot := TRUE END; - R.org := R.org + R.off; R.off := 0; - R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0; - Files.Set(R.rider, R.ref.f, R.ref.off) - END - END Read; - - PROCEDURE Pos* (VAR R: Reader): LONGINT; - BEGIN RETURN R.org + R.off - END Pos; - - (* ------------------ Access: Scanners (NW) ------------------------- *) - - PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT); - BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " " - END OpenScanner; - - (*floating point formats: - x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m - x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *) - - PROCEDURE Ten(n: INTEGER): REAL; - VAR t, p: REAL; - BEGIN t := 1.0; p := 10.0; (*compute 10^n *) - WHILE n > 0 DO - IF ODD(n) THEN t := p * t END ; - p := p*p; n := n DIV 2 - END ; - RETURN t - END Ten; - - PROCEDURE Scan* (VAR S: Scanner); - CONST maxExp = 38; maxM = 16777216; (*2^24*) - VAR ch, term: CHAR; - neg, negE, hex: BOOLEAN; - i, j, h, d, e, n, s: INTEGER; - k: LONGINT; - x: REAL; - BEGIN ch := S.nextCh; i := 0; - WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO - IF ch = CR THEN INC(S.line) END ; - Read(S, ch) - END ; - IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*) - REPEAT S.s[i] := ch; INC(i); Read(S, ch) - UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31); - S.s[i] := 0X; S.len := i; S.class := Name - ELSIF ch = 22X THEN (*string*) - Read(S, ch); - WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END; - S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String - ELSE hex := FALSE; - IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ; - IF ("0" <= ch) & (ch <= "9") THEN (*number*) - n := ORD(ch) - 30H; h := n; Read(S, ch); - WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO - IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ; - n := 10*n + d; h := 10H*h + d; Read(S, ch) - END ; - IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int (*neg?*) - ELSIF ch = "." THEN (*real number*) - Read(S, ch); x := 0.0; e := 0; j := 0; - WHILE ("0" <= ch) & (ch <= "9") DO (*fraction*) - h := 10*n + (ORD(ch) - 30H); - IF h < maxM THEN n := h; INC(j) END ; - Read(S, ch) - END ; - IF ch = "E" THEN (*scale factor*) - s := 0; 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 - s := s*10 + ORD(ch) - 30H; Read(S, ch) - END ; - IF negE THEN DEC(e, s) ELSE INC(e, s) END ; - END ; - (*x := FLT(n);*) - x := n; (* voc adaptation by noch *) - DEC(e, j); - IF e < 0 THEN - IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END - ELSIF e > 0 THEN - IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END - END ; - IF neg THEN S.x := -x ELSE S.x := x END ; - IF hex THEN S.class := 0 ELSE S.class := Real END - ELSE (*decimal integer*) - IF neg THEN S.i := -n ELSE S.i := n END; - IF hex THEN S.class := Inval ELSE S.class := Int END - END - ELSE (*spectal character*) S.class := Char; - IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END - END - END ; - S.nextCh := ch - END Scan; - - (* --------------- Access: Writers (NW) ------------------ *) - - PROCEDURE OpenWriter* (VAR W: Writer); - BEGIN NEW(W.buf); - OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0; - Files.Set(W.rider, Files.New(""), 0) - END OpenWriter; - - PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font); - BEGIN W.fnt := fnt - END SetFont; - - PROCEDURE SetColor* (VAR W: Writer; col: INTEGER); - BEGIN W.col := col - END SetColor; - - PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER); - BEGIN W.voff := voff - END SetOffset; - - PROCEDURE Write* (VAR W: Writer; ch: CHAR); - VAR p: Piece; - BEGIN - IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN - NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0; - p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff; - p.next := NIL; W.buf.last.next := p; - p.prev := W.buf.last; W.buf.last := p - END; - Files.Write(W.rider, ch); - INC(W.buf.last.len); INC(W.buf.len) - END Write; - - 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 10 OF CHAR; - BEGIN - (*IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648") - ELSE*) i := 0; (* voc adaptation by noch *) - IF x < 0 THEN DEC(n); x0 := -x 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*) - 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; -(* commented out because it's not necessary to compile OR compiler; -- noch - PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER); - VAR e, i, m: INTEGER; x0: REAL; neg: BOOLEAN; - d: ARRAY 16 OF CHAR; - BEGIN - IF x = 0.0 THEN - WriteString(W, " 0.0"); i := 5; - WHILE i < n DO Write(W, " "); INC(i) END - ELSE - IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; - x0 := x; UNPK(x0, e); - IF e = 255 THEN WriteString(W, " NaN") - ELSE - REPEAT Write(W, " "); DEC(n) UNTIL n <= 14; - IF neg THEN Write(W, "-") ELSE Write(W, " ") END ; - e := e * 77 DIV 256 - 6; - IF e >= 0 THEN x := x / Ten(e) ELSE x := x * Ten(-e) END ; - IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; - m := FLOOR(x + 0.5); i := 0; - IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; - REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; - DEC(i); Write(W, d[i]); Write(W, "."); - IF i < n-6 THEN n := 0 ELSE n := 13-n END ; - WHILE i > n DO DEC(i); Write(W, d[i]) END ; - Write(W, "E"); INC(e, 6); - 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 - END WriteReal; - *) - PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER); - VAR i, m: INTEGER; neg: BOOLEAN; - d: ARRAY 12 OF CHAR; - BEGIN - IF x = 0.0 THEN WriteString(W, " 0") - ELSE - IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; - IF k > 7 THEN k := 7 END ; - x := Ten(k) * x; m := FLOOR(x + 0.5); - i := 0; - REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; - REPEAT Write(W, " "); DEC(n) UNTIL n <= i+3; - IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ; - WHILE i > k DO DEC(i); Write(W, d[i]) END ; - Write(W, "."); - WHILE k > i DO DEC(k); Write(W, "0") END ; - WHILE i > 0 DO DEC(i); Write(W, d[i]) END - END - END WriteRealFix; - - PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT); - BEGIN Write(W, ch); - Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H)) - END WritePair; - - PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT); - BEGIN - WritePair(W, " ", d DIV 20000H MOD 20H); (*day*) - WritePair(W, ".", d DIV 400000H MOD 10H); (*month*) - WritePair(W, ".", d DIV 4000000H MOD 40H); (*year*) - WritePair(W, " ", d DIV 1000H MOD 20H); (*hour*) - WritePair(W, ":", d DIV 40H MOD 40H); (*min*) - WritePair(W, ":", d MOD 40H) (*sec*) - END WriteClock; - -BEGIN TrailerFile := Files.New("") -END CompatTexts. diff --git a/src/voc07R/Fonts.Mod b/src/voc07R/Fonts.Mod deleted file mode 100644 index 1798cfb6..00000000 --- a/src/voc07R/Fonts.Mod +++ /dev/null @@ -1,146 +0,0 @@ -MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*) - IMPORT SYSTEM, Files := CompatFiles; - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST FontFileId = 0DBH; - - TYPE Font* = POINTER TO FontDesc; - FontDesc* = RECORD - name*: ARRAY 32 OF CHAR; - height*, minX*, maxX*, minY*, maxY*: INTEGER; - next*: Font; - T: ARRAY 128 OF INTEGER; - raster: ARRAY 2360 OF BYTE - END ; - - LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ; - LargeFont = POINTER TO LargeFontDesc; - - (* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983, - Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302 *) - -VAR Default*, root*: Font; - -PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER); - VAR pa: INTEGER; dxb, xb, yb, wb, hb: BYTE; -BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa; - SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb); - (*dx := dxb;*) - dx := ORD(dxb); (* voc adaptation by noch *) - (*x := xb;*) - x := ORD(xb); (* voc adaptation by noch *) - (*y := yb;*) - y := ORD(yb); (* voc adaptation by noch *) - (*w := wb;*) - w := ORD(wb); (* voc adaptation by noch *) - (*h := hb;*) - h := ORD(hb); (* voc adaptation by noch *) - (*IF yb < 128 THEN y := yb ELSE y := yb - 256 END*) - IF ORD(yb) < 128 THEN y := ORD(yb) ELSE y := ORD(yb) - 256 END (* voc adaptation by noch *) -END GetPat; - -PROCEDURE This*(name: ARRAY OF CHAR): Font; - - TYPE RunRec = RECORD beg, end: BYTE END ; - BoxRec = RECORD dx, x, y, w, h: BYTE END ; - - VAR F: Font; LF: LargeFont; - f: Files.File; R: Files.Rider; - NofRuns, NofBoxes: BYTE; - NofBytes: INTEGER; - height, minX, maxX, minY, maxY: BYTE; - i, j, k, m, n: INTEGER; - a, a0: INTEGER; - b, beg, end: BYTE; - run: ARRAY 16 OF RunRec; - box: ARRAY 512 OF BoxRec; - - PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE); - VAR b1: BYTE; - BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1) - END RdInt16; - -BEGIN F := root; - WHILE (F # NIL) & (name # F.name) DO F := F.next END; - IF F = NIL THEN - f := Files.Old(name); - IF f # NIL THEN - Files.Set(R, f, 0); Files.ReadByte(R, b); - (*IF b = FontFileId THEN*) - IF ORD(b) = FontFileId THEN (* voc adaptation by noch *) - Files.ReadByte(R, b); (*abstraction*) - Files.ReadByte(R, b); (*family*) - Files.ReadByte(R, b); (*variant*) - NEW(F); - (*F.name := name;*) - COPY(name, F.name); (* voc adaptation by noch *) - RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns); - (*NofBoxes := 0;*) (* voc adaptation by noch *) - NofBoxes := 0X; - k := 0; - (*WHILE k # NofRuns DO*) - WHILE k # ORD(NofRuns) DO (* voc adaptation by noch *) - RdInt16(R, beg); - run[k].beg := beg; RdInt16(R, end); - run[k].end := end; - (*NofBoxes := NofBoxes + end - beg;*) - NofBoxes := CHR(ORD(NofBoxes) + ORD(end) - ORD(beg)); (* voc adaptation by noch *) - INC(k) - END; - NofBytes := 5; j := 0; - (*WHILE j # NofBoxes DO*) - WHILE j # ORD(NofBoxes) DO (* voc adaptation by noch *) - RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y); - RdInt16(R, box[j].w); RdInt16(R, box[j].h); - (*NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;*) - NofBytes := (NofBytes + 5 + (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h)); (* voc adaptation by noch *) - INC(j) - END; - IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ; - (*F.name := name;*) - COPY(name, F.name); (* voc adaptation by noch *) - (*F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;*) - F.height := ORD(height); F.minX := ORD(minX); F.maxX := ORD(maxX); F.maxY := ORD(maxY); (* voc adaptation by noch *) - (*IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;*) - IF ORD(minY) >= 80H THEN F.minY := ORD(minY) - 100H ELSE F.minY := ORD(minY) END ; (* voc adaptation by noch *) - a0 := SYSTEM.ADR(F.raster); - SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X); - (*null pattern for characters not in a run*) - INC(a0, 2); a := a0+3; j := 0; k := 0; m := 0; - (*WHILE k < NofRuns DO*) - WHILE k < ORD(NofRuns) DO - (*WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;*) - WHILE (m < ORD(run[k].beg)) & (m < 128) DO F.T[m] := a0; INC(m) END; (* voc adaptation by noch *) - (*WHILE (m < run[k].end) & (m < 128) DO*) (* voc adaptation by noch *) - WHILE (m < ORD(run[k].end)) & (m < 128) DO - F.T[m] := a+3; - SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y); - SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5); - (*n := (box[j].w + 7) DIV 8 * box[j].h;*) - n := (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h); (* voc adaptation by noch *) - WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ; - INC(j); INC(m) - END; - INC(k) - END; - WHILE m < 128 DO F.T[m] := a0; INC(m) END ; - F.next := root; root := F - ELSE (*bad file id*) F := Default - END - ELSE (*font file not available*) F := Default - END - END; - RETURN F -END This; - -PROCEDURE Free*; (*remove all but first two from font list*) - VAR f: Font; -BEGIN f := root.next; - IF f # NIL THEN f := f.next END ; - f.next := NIL -END Free; - -BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt") -END Fonts. diff --git a/src/voc07R/ORB.Mod b/src/voc07R/ORB.Mod deleted file mode 100644 index 61d23f4f..00000000 --- a/src/voc07R/ORB.Mod +++ /dev/null @@ -1,447 +0,0 @@ -MODULE ORB; (*NW 25.6.2014 in Oberon-07*) - IMPORT Files := CompatFiles (* voc adaptation by noch *) - , ORS; - (*Definition of data types Object and Type, which together form the data structure - called "symbol table". Contains procedures for creation of Objects, and for search: - NewObj, this, thisimport, thisfield (and OpenScope, CloseScope). - Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures - Import and Export. This module contains the list of standard identifiers, with which - the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *) - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST versionkey* = 1; maxTypTab = 64; - (* class values*) Head* = 0; - Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5; - SProc* = 6; SFunc* = 7; Mod* = 8; - - (* form values*) - Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6; - Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; - String* = 11; Array* = 12; Record* = 13; - - TYPE Object* = POINTER TO ObjDesc; - Module* = POINTER TO ModDesc; - Type* = POINTER TO TypeDesc; - - ObjDesc*= RECORD - class*, lev*, exno*: INTEGER; - expo*, rdo*: BOOLEAN; (*exported / read-only*) - next*, dsc*: Object; - type*: Type; - name*: ORS.Ident; - val*: LONGINT - END ; - - ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ; - - TypeDesc* = RECORD - form*, ref*, mno*: INTEGER; (*ref is only used for import/export*) - nofpar*: INTEGER; (*for procedures, extension level for records*) - len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*) - dsc*, typobj*: Object; - base*: Type; (*for arrays, records, pointers*) - size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*) - END ; - - (* Object classes and the meaning of "val": - class val - ---------- - Var address - Par address - Const value - Fld offset - Typ type descriptor (TD) address - SProc inline code number - SFunc inline code number - Mod key - - Type forms and the meaning of "dsc" and "base": - form dsc base - ------------------------ - Pointer - type of dereferenced object - Proc params result type - Array - type of elements - Record fields extension *) - - VAR topScope*, universe, system*: Object; - byteType*, boolType*, charType*: Type; - intType*, realType*, setType*, nilType*, noType*, strType*: Type; - nofmod, Ref: INTEGER; - typtab: ARRAY maxTypTab OF Type; - - PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*) - VAR new, x: Object; - BEGIN x := topScope; - WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ; - IF x.next = NIL THEN - NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL; - x.next := new; obj := new - ELSE obj := x.next; ORS.Mark("mult def") - END - END NewObj; - - PROCEDURE thisObj*(): Object; - VAR s, x: Object; - BEGIN s := topScope; - REPEAT x := s.next; - WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ; - s := s.dsc - UNTIL (x # NIL) OR (s = NIL); - RETURN x - END thisObj; - - PROCEDURE thisimport*(mod: Object): Object; - VAR obj: Object; - BEGIN - IF mod.rdo THEN - IF mod.name[0] # 0X THEN - obj := mod.dsc; - WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END - ELSE obj := NIL - END - ELSE obj := NIL - END ; - RETURN obj - END thisimport; - - PROCEDURE thisfield*(rec: Type): Object; - VAR fld: Object; - BEGIN fld := rec.dsc; - WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ; - RETURN fld - END thisfield; - - PROCEDURE OpenScope*; - VAR s: Object; - BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s - END OpenScope; - - PROCEDURE CloseScope*; - BEGIN topScope := topScope.dsc - END CloseScope; - - (*------------------------------- Import ---------------------------------*) - - PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR); - VAR i, j: INTEGER; - BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*) - WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ; - REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X; - FName[i] := 0X - END MakeFileName; - - PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object; - VAR mod: Module; obj, obj1: Object; - BEGIN obj1 := topScope; obj := obj1.next; (*search for module*) - WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ; - IF obj = NIL THEN (*insert new module*) - NEW(mod); mod.class := Mod; mod.rdo := FALSE; - mod.name := name; mod.orgname := orgname; mod.val := key; - mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL; - obj1.next := mod; obj := mod - ELSE (*module already present*) - IF non THEN ORS.Mark("invalid import order") END - END ; - RETURN obj - END ThisModule; - - PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER); - VAR b: BYTE; - BEGIN Files.ReadByte(R, b); - (*IF b < 80H THEN x := b ELSE x := b - 100H END*) - IF b < 80X THEN x := ORD(b) ELSE x := ORD(b) - 100H END (* voc adaptation by noch *) - END Read; - - PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type); - VAR key: LONGINT; - ref, class, mno, form, np, readonly: INTEGER; - new, fld, par, obj, mod, impmod: Object; - t: Type; - name, modname: ORS.Ident; - BEGIN Read(R, ref); - IF ref < 0 THEN T := typtab[-ref] (*already read*) - ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev; - Read(R, form); t.form := form; - IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4 - ELSIF form = Array THEN - InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size) - ELSIF form = Record THEN - InType(R, thismod, t.base); - IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ; - Files.ReadNum(R, t.len); (*TD adr/exno*) - Files.ReadNum(R, t.nofpar); (*ext level*) - Files.ReadNum(R, t.size); - Read(R, class); - WHILE class # 0 DO (*fields*) - NEW(fld); fld.class := class; Files.ReadString(R, fld.name); - IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ; - Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class) - END ; - t.dsc := obj - ELSIF form = Proc THEN - InType(R, thismod, t.base); - obj := NIL; np := 0; Read(R, class); - WHILE class # 0 DO (*parameters*) - NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; - InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class) - END ; - t.dsc := obj; t.nofpar := np; t.size := 4 - END ; - Files.ReadString(R, modname); - IF modname[0] # 0X THEN (*re-import*) - Files.ReadInt(R, key); Files.ReadString(R, name); - mod := ThisModule(modname, modname, FALSE, key); - obj := mod.dsc; (*search type*) - WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ; - IF obj # NIL THEN T := obj.type (*type object found in object list of mod*) - ELSE (*insert new type object in object list of mod*) - NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t; - t.mno := mod.lev; t.typobj := obj; T := t - END ; - typtab[ref] := T - END - END - END InType; - - PROCEDURE Import*(VAR modid, modid1: ORS.Ident); - VAR key: LONGINT; class, k: INTEGER; - obj: Object; t: Type; - thismod: Object; - modname, fname: ORS.Ident; - F: Files.File; R: Files.Rider; - BEGIN - IF modid1 = "SYSTEM" THEN - thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod); - thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE - ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname); - thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE; - Read(R, class); (*version key*) - IF class # versionkey THEN ORS.Mark("wrong version") END ; - Read(R, class); - WHILE class # 0 DO - NEW(obj); obj.class := class; Files.ReadString(R, obj.name); - InType(R, thismod, obj.type); obj.lev := -thismod.lev; - IF class = Typ THEN - t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*) - WHILE k # 0 DO typtab[k].base := t; Read(R, k) END - ELSE - IF class = Const THEN - IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END - ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE - END - END ; - obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class) - END ; - ELSE ORS.Mark("import not available") - END - END - END Import; - - (*-------------------------------- Export ---------------------------------*) - - PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); - BEGIN - (*Files.WriteByte(R, x)*) - Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *) - END Write; - - PROCEDURE OutType(VAR R: Files.Rider; t: Type); - VAR obj, mod, fld: Object; - - PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER); - VAR cl: INTEGER; - BEGIN - IF n > 0 THEN - OutPar(R, par.next, n-1); cl := par.class; - Write(R, cl); - IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ; - OutType(R, par.type) - END - END OutPar; - - PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT); - VAR fld: Object; i, n: LONGINT; - BEGIN - IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset) - ELSIF typ.form = Record THEN fld := typ.dsc; - WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END - ELSIF typ.form = Array THEN i := 0; n := typ.len; - WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END - END - END FindHiddenPointers; - - BEGIN - IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref) - ELSE obj := t.typobj; - IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ; - Write(R, t.form); - IF t.form = Pointer THEN OutType(R, t.base) - ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size) - ELSIF t.form = Record THEN - IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ; - IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ; - Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size); - fld := t.dsc; - WHILE fld # NIL DO (*fields*) - IF fld.expo THEN - Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val) - ELSE FindHiddenPointers(R, fld.type, fld.val) (*offset*) - END ; - fld := fld.next - END ; - Write(R, 0) - ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0) - END ; - IF (t.mno > 0) & (obj # NIL) THEN (*re-export, output name*) - mod := topScope.next; - WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ; - IF mod # NIL THEN Files.WriteString(R, mod.name); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name) - ELSE ORS.Mark("re-export not found"); Write(R, 0) - END - ELSE Write(R, 0) - END - END - END OutType; - - PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT); - VAR x, sum, oldkey: LONGINT; - obj, obj0: Object; - filename: ORS.Ident; - F, F1: Files.File; R, R1: Files.Rider; - BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb"); - F := Files.New(filename); Files.Set(R, F, 0); - Files.WriteInt(R, 0); (*placeholder*) - Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*) - Files.WriteString(R, modid); Write(R, versionkey); - obj := topScope.next; - WHILE obj # NIL DO - IF obj.expo THEN - Write(R, obj.class); Files.WriteString(R, obj.name); - OutType(R, obj.type); - IF obj.class = Typ THEN - IF obj.type.form = Record THEN - obj0 := topScope.next; (*check whether this is base of previously declared pointer types*) - WHILE obj0 # obj DO - IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ; - obj0 := obj0.next - END - END ; - Write(R, 0) - ELSIF obj.class = Const THEN - IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno) - ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val) - ELSE Files.WriteNum(R, obj.val) - END - ELSIF obj.class = Var THEN - Files.WriteNum(R, obj.exno); - IF obj.type.form = String THEN - Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H - END - END - END ; - obj := obj.next - END ; - REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0; - FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ; - Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x); (* compute key (checksum) *) - WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ; - F1 := Files.Old(filename); (*sum is new key*) - IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ; - IF sum # oldkey THEN - IF newSF OR (F1 = NIL) THEN - key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F) (*insert checksum*) - ELSE ORS.Mark("new symbol file inhibited") - END - ELSE newSF := FALSE; key := sum - END - END Export; - - PROCEDURE Init*; - BEGIN topScope := universe; nofmod := 1 - END Init; - - PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type; - VAR tp: Type; - BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL; - typtab[ref] := tp; RETURN tp - END type; - - PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT); - VAR obj: Object; - BEGIN - NEW(obj); - (*obj.name := name; *) - COPY(name, obj.name); (* voc adaptation by noch *) - obj.class := cl; - obj.type := type; - obj.val := n; - obj.dsc := NIL; - IF cl = Typ THEN type.typobj := obj END ; - obj.next := system; system := obj - END enter; - -BEGIN - byteType := type(Byte, Int, 1); - boolType := type(Bool, Bool, 1); - charType := type(Char, Char,1); - intType := type(Int, Int, 4); - realType := type(Real, Real, 4); - setType := type(Set, Set,4); - nilType := type(NilTyp, NilTyp, 4); - noType := type(NoTyp, NoTyp, 4); - strType := type(String, String, 8); - - (*initialize universe with data types and in-line procedures; - LONGINT is synonym to INTEGER, LONGREAL to REAL. - LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*) - system := NIL; (*n = procno*10 + nofpar*) - enter("UML", SFunc, intType, 132); (*functions*) - enter("SBC", SFunc, intType, 122); - enter("ADC", SFunc, intType, 112); - enter("ROR", SFunc, intType, 92); - enter("ASR", SFunc, intType, 82); - enter("LSL", SFunc, intType, 72); - enter("LEN", SFunc, intType, 61); - enter("CHR", SFunc, charType, 51); - enter("ORD", SFunc, intType, 41); - enter("FLT", SFunc, realType, 31); - enter("FLOOR", SFunc, intType, 21); - enter("ODD", SFunc, boolType, 11); - enter("ABS", SFunc, intType, 1); - enter("LED", SProc, noType, 81); (*procedures*) - enter("UNPK", SProc, noType, 72); - enter("PACK", SProc, noType, 62); - enter("NEW", SProc, noType, 51); - enter("ASSERT", SProc, noType, 41); - enter("EXCL", SProc, noType, 32); - enter("INCL", SProc, noType, 22); - enter("DEC", SProc, noType, 11); - enter("INC", SProc, noType, 1); - enter("SET", Typ, setType, 0); (*types*) - enter("BOOLEAN", Typ, boolType, 0); - enter("BYTE", Typ, byteType, 0); - enter("CHAR", Typ, charType, 0); - enter("LONGREAL", Typ, realType, 0); - enter("REAL", Typ, realType, 0); - enter("LONGINT", Typ, intType, 0); - enter("INTEGER", Typ, intType, 0); - topScope := NIL; OpenScope; topScope.next := system; universe := topScope; - - system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*) - enter("H", SFunc, intType, 201); (*functions*) - enter("COND", SFunc, boolType, 191); - enter("SIZE", SFunc, intType, 181); - enter("ADR", SFunc, intType, 171); - enter("VAL", SFunc, intType, 162); - enter("REG", SFunc, intType, 151); - enter("BIT", SFunc, boolType, 142); - enter("LDREG", SProc, noType, 142); (*procedures*) - enter("LDPSR", SProc, noType, 131); - enter("COPY", SProc, noType, 123); - enter("PUT", SProc, noType, 112); - enter("GET", SProc, noType, 102); -END ORB. diff --git a/src/voc07R/ORG.Mod b/src/voc07R/ORG.Mod deleted file mode 100644 index 9495337c..00000000 --- a/src/voc07R/ORG.Mod +++ /dev/null @@ -1,1134 +0,0 @@ -MODULE ORG; (* NW 24.6.2014 code generator in Oberon-07 for RISC*) - IMPORT SYSTEM, Files := CompatFiles, ORS, ORB; - (*Code generator for Oberon compiler for RISC processor. - Procedural interface to Parser OSAP; result in array "code". - Procedure Close writes code-files*) - - (* voc adaptation by noch *) - TYPE INTEGER = LONGINT; - BYTE = CHAR; - - CONST WordSize* = 4; - StkOrg0 = -64; VarOrg0 = 0; (*for RISC-0 only*) - MT = 12; SB = 13; SP = 14; LNK = 15; (*dedicated registers*) - maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H; - Reg = 10; RegI = 11; Cond = 12; (*internal item modes*) - - (*frequently used opcodes*) U = 2000H; V = 1000H; - Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7; - Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11; - Fad = 12; Fsb = 13; Fml = 14; Fdv = 15; - Ldr = 8; Str = 10; - BR = 0; BLR = 1; BC = 2; BL = 3; - MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14; - - TYPE Item* = RECORD - mode*: INTEGER; - type*: ORB.Type; - a*, b*, r: LONGINT; - rdo*: BOOLEAN (*read only*) - END ; - - (* Item forms and meaning of fields: - mode r a b - -------------------------------- - Const - value (proc adr) (immediate value) - Var base off - (direct adr) - Par - off0 off1 (indirect adr) - Reg regno - RegI regno off - - Cond cond Fchain Tchain *) - - VAR pc*, varsize: LONGINT; (*program counter, data index*) - tdx, strx: LONGINT; - entry: LONGINT; (*main entry point*) - RH: LONGINT; (*available registers R[0] ... R[H-1]*) - curSB: LONGINT; (*current static base in SB*) - frame: LONGINT; (*frame offset changed in SaveRegs and RestoreRegs*) - fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*) - check: BOOLEAN; (*emit run-time checks*) - version: INTEGER; (* 0 = RISC-0, 1 = RISC-5 *) - - relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*) - code: ARRAY maxCode OF LONGINT; - data: ARRAY maxTD OF LONGINT; (*type descriptors*) - str: ARRAY maxStrx OF CHAR; - - (* voc adaptation by noch *) - PROCEDURE LSL (x, n : INTEGER): INTEGER; - - BEGIN - - RETURN ASH(x, n); - END LSL; - - - (*instruction assemblers according to formats*) - - PROCEDURE Put0(op, a, b, c: LONGINT); - BEGIN (*emit format-0 instruction*) - code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc) - END Put0; - - PROCEDURE Put1(op, a, b, im: LONGINT); - BEGIN (*emit format-1 instruction, -10000H <= im < 10000H*) - IF im < 0 THEN INC(op, V) END ; - code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc) - END Put1; - - PROCEDURE Put1a(op, a, b, im: LONGINT); - BEGIN (*same as Pu1, but with range test -10000H <= im < 10000H*) - IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im) - ELSE Put1(Mov+U, RH, 0, im DIV 10000H); - IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ; - Put0(op, a, b, RH) - END - END Put1a; - - PROCEDURE Put2(op, a, b, off: LONGINT); - BEGIN (*emit load/store instruction*) - code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc) - END Put2; - - PROCEDURE Put3(op, cond, off: LONGINT); - BEGIN (*emit branch instruction*) - code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc) - END Put3; - - PROCEDURE incR; - BEGIN - IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END - END incR; - - PROCEDURE CheckRegs*; - BEGIN - IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ; - IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END - END CheckRegs; - - PROCEDURE SetCC(VAR x: Item; n: LONGINT); - BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n - END SetCC; - - PROCEDURE Trap(cond, num: LONGINT); - BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num) - END Trap; - - (*handling of forward reference, fixups of branch addresses and constant tables*) - - PROCEDURE negated(cond: LONGINT): LONGINT; - BEGIN - IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ; - RETURN cond - END negated; - - PROCEDURE invalSB; - BEGIN curSB := 1 - END invalSB; - - PROCEDURE fix(at, with: LONGINT); - BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24) - END fix; - - PROCEDURE FixLink*(L: LONGINT); - VAR L1: LONGINT; - BEGIN invalSB; - WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END - END FixLink; - - PROCEDURE FixLinkWith(L0, dst: LONGINT); - VAR L1: LONGINT; - BEGIN - WHILE L0 # 0 DO - L1 := code[L0] MOD C24; - code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1 - END - END FixLinkWith; - - PROCEDURE merged(L0, L1: LONGINT): LONGINT; - VAR L2, L3: LONGINT; - BEGIN - IF L0 # 0 THEN L3 := L0; - REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0; - code[L2] := code[L2] + L1; L1 := L0 - END ; - RETURN L1 - END merged; - - (* loading of operands and addresses into registers *) - - PROCEDURE GetSB(base: LONGINT); - BEGIN - IF (version # 0) & ((base # curSB) OR (base # 0)) THEN - Put2(Ldr, SB, -base, pc-fixorgD); fixorgD := pc-1; curSB := base - END - END GetSB; - - PROCEDURE NilCheck; - BEGIN IF check THEN Trap(EQ, 4) END - END NilCheck; - - PROCEDURE load(VAR x: Item); - VAR op: LONGINT; - BEGIN - IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ; - IF x.mode # Reg THEN - IF x.mode = ORB.Const THEN - IF x.type.form = ORB.Proc THEN - IF x.r > 0 THEN ORS.Mark("not allowed") - ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a) - ELSE GetSB(x.r); Put1(Add, RH, SB, x.a + 100H) (*mark as progbase-relative*) - END - ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a) - ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H); - IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a) - ELSIF x.mode = Cond THEN - Put3(BC, negated(x.r), 2); - FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1); - FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR - END ; - x.mode := Reg - END - END load; - - PROCEDURE loadAdr(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); - IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ; - x.r := RH; incR - ELSIF x.mode = RegI THEN - IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END - ELSE ORS.Mark("address error") - END ; - x.mode := Reg - END loadAdr; - - PROCEDURE loadCond(VAR x: Item); - BEGIN - IF x.type.form = ORB.Bool THEN - IF x.mode = ORB.Const THEN x.r := 15 - x.a*8 - ELSE load(x); - IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ; - x.r := NE; DEC(RH) - END ; - x.mode := Cond; x.a := 0; x.b := 0 - ELSE ORS.Mark("not Boolean?") - END - END loadCond; - - PROCEDURE loadTypTagAdr(T: ORB.Type); - VAR x: Item; - BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x) - END loadTypTagAdr; - - PROCEDURE loadStringAdr(VAR x: Item); - BEGIN GetSB(0); Put1a(Add, RH, SB, varsize+x.a); x.mode := Reg; x.r := RH; incR - END loadStringAdr; - - (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*) - - PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT); - BEGIN x.mode := ORB.Const; x.type := typ; x.a := val - END MakeConstItem; - - PROCEDURE MakeRealItem*(VAR x: Item; val: REAL); - BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val) - END MakeRealItem; - - PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*) - VAR i: LONGINT; - BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0; - IF strx + len + 4 < maxStrx THEN - WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ; - WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END - ELSE ORS.Mark("too many strings") - END - END MakeStringItem; - - PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT); - BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; - IF y.class = ORB.Par THEN x.b := 0 - ELSIF y.class = ORB.Typ THEN x.a := y.type.len; x.r := -y.lev - ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev (*len*) - ELSE x.r := y.lev - END ; - IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("level error, not accessible") END - END MakeItem; - - (* Code generation for Selectors, Variables, Constants *) - - PROCEDURE Field*(VAR x: Item; y: ORB.Object); (* x := x.y *) - BEGIN; - IF x.mode = ORB.Var THEN - IF x.r >= 0 THEN x.a := x.a + y.val - ELSE loadAdr(x); x.mode := RegI; x.a := y.val - END - ELSIF x.mode = RegI THEN x.a := x.a + y.val - ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val - END - END Field; - - PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) - VAR s, lim: LONGINT; - BEGIN s := x.type.base.size; lim := x.type.len; - IF (y.mode = ORB.Const) & (lim >= 0) THEN - IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ; - IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a - ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b - END - ELSE load(y); - IF check THEN (*check array bounds*) - IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim) - ELSE (*open array*) - IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH) - ELSE ORS.Mark("error in Index") - END - END ; - Trap(10, 1) (*BCC*) - END ; - IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame) - ELSE GetSB(x.r); - IF x.r = 0 THEN Put0(Add, y.r, SB, y.r) - ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0 - END - END ; - x.r := y.r; x.mode := RegI - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); - Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b - ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH) - END - END - END Index; - - PROCEDURE DeRef*(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ; - NilCheck; x.r := RH; incR - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck - ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef") - END ; - x.mode := RegI; x.a := 0; x.b := 0 - END DeRef; - - PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT); - BEGIN (*one entry of type descriptor extension table*) - IF T.base # NIL THEN - Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT; - fixorgT := dcw; INC(dcw) - END - END Q; - - PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END - END - END FindPtrFlds; - - PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT); - VAR dcw, k, s: LONGINT; (*dcw = word address*) - BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*) - IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128 - ELSE s := (s+263) DIV 256 * 256 - END ; - T.len := dc; data[dcw] := s; INC(dcw); - k := T.nofpar; (*extension level!*) - IF k > 3 THEN ORS.Mark("ext level too large") - ELSE Q(T, dcw); - WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END - END ; - FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4; - IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END - END BuildTD; - - PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN); - VAR pc0: LONGINT; - BEGIN (*fetch tag into RH*) - IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame) - ELSE load(x); - pc0 := pc; Put3(BC, EQ, 0); (*NIL belongs to every pointer type*) - Put2(Ldr, RH, x.r, -8) - END ; - Put2(Ldr, RH, RH, T.nofpar*4); incR; - loadTypTagAdr(T); (*tag of T*) - Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2); - IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ; - IF isguard THEN - IF check THEN Trap(NE, 2) END - ELSE SetCC(x, EQ); - IF ~varpar THEN DEC(RH) END - END - END TypeTest; - - (* Code generation for Boolean operators *) - - PROCEDURE Not*(VAR x: Item); (* x := ~x *) - VAR t: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t - END Not; - - PROCEDURE And1*(VAR x: Item); (* x := x & *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0 - END And1; - - PROCEDURE And2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r - END And2; - - PROCEDURE Or1*(VAR x: Item); (* x := x OR *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, x.r, x.b); x.b := pc-1; FixLink(x.a); x.a := 0 - END Or1; - - PROCEDURE Or2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r - END Or2; - - (* Code generation for arithmetic operators *) - - PROCEDURE Neg*(VAR x: Item); (* x := -x *) - BEGIN - IF x.type.form = ORB.Int THEN - IF x.mode = ORB.Const THEN x.a := -x.a - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - ELSIF x.type.form = ORB.Real THEN - IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1 - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r) - END - ELSE (*form = Set*) - IF x.mode = ORB.Const THEN x.a := -x.a-1 - ELSE load(x); Put1(Xor, x.r, x.r, -1) - END - END - END Neg; - - PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item); (* x := x +- y *) - BEGIN - IF op = ORS.plus THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.minus*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END - END AddOp; - - PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT; - BEGIN e := 0; - WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ; - RETURN m - END log2; - - PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *) - VAR e: LONGINT; - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a) - ELSIF (x.mode = ORB.Const) & (x.a >= 2) & (log2(x.a, e) = 1) THEN load(y); Put1(Lsl, y.r, y.r, e); x.mode := Reg; x.r := y.r - ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r - ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END MulOp; - - PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR e: LONGINT; - BEGIN - IF op = ORS.div THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.mod*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); - IF e <= 16 THEN Put1(And, x.r, x.r, y.a-1) ELSE Put1(Lsl, x.r, x.r, 32-e); Put1(Ror, x.r, x.r, 32-e) END - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE ORS.Mark("bad modulus") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1 - END - END - END DivOp; - - (* Code generation for REAL operators *) - - PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) - BEGIN load(x); load(y); - IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END RealOp; - - (* Code generation for set operators *) - - PROCEDURE Singleton*(VAR x: Item); (* x := {x} *) - BEGIN - IF x.mode = ORB.Const THEN - x.a := LSL(1, x.a) - ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r) - END - END Singleton; - - PROCEDURE Set*(VAR x, y: Item); (* x := {x .. y} *) - BEGIN - IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN - IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END - ELSE - IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a) - ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r) - END ; - IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR - ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r) - END ; - IF x.mode = ORB.Const THEN - IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ; - x.mode := Reg; x.r := RH-1 - ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r) - END - END - END Set; - - PROCEDURE In*(VAR x, y: Item); (* x := x IN y *) - BEGIN load(y); - IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH) - ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END In; - - PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR xset, yset: SET; (*x.type.form = Set*) - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a); - IF op = ORS.plus THEN xset := xset + yset - ELSIF op = ORS.minus THEN xset := xset - yset - ELSIF op = ORS.times THEN xset := xset * yset - ELSIF op = ORS.rdiv THEN xset := xset / yset - END ; - x.a := SYSTEM.VAL(LONGINT, xset) - ELSIF y.mode = ORB.Const THEN - load(x); - IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a) - ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a) - ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a) - ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a) - END ; - ELSE load(x); load(y); - IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END - END SetOp; - - (* Code generation for relations *) - - PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN - IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN - load(x); - IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ; - DEC(RH) - ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END IntRelation; - - PROCEDURE SetRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (op = ORS.eql) OR (op = ORS.neq) THEN - IF y.mode = ORB.Const THEN Put1a(Cmp, x.r, x.r, y.a); DEC(RH) - ELSE load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - ELSE ORS.Mark("illegal relation") - END - END SetRelation; - - PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH) - ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END RealRelation; - - PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - (*x, y are char arrays or strings*) - BEGIN - IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ; - IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ; - Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1); - Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1); - Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2); - Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8); - DEC(RH, 2); SetCC(x, relmap[op - ORS.eql]) - END StringRelation; - - (* Code generation of Assignments *) - - PROCEDURE StrToChar*(VAR x: Item); - BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a]) - END StrToChar; - - PROCEDURE Store*(VAR x, y: Item); (* x := y *) - VAR op: LONGINT; - BEGIN load(y); - IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, y.r, SB, x.a) - END - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b); - ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH); - ELSE ORS.Mark("bad mode in Store") - END ; - DEC(RH) - END Store; - - PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *) - VAR s, pc0: LONGINT; - BEGIN loadAdr(x); loadAdr(y); - IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN - IF y.type.len >= 0 THEN - IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4) - ELSE ORS.Mark("source array too long") - END - ELSE (*y is open array*) - Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size; (*element size*) - pc0 := pc; Put3(BC, EQ, 0); - IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2) - ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4) - END ; - IF check THEN - Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3) - END ; - fix(pc0, pc + 5 - pc0) - END - ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4) - ELSE ORS.Mark("inadmissible assignment") - END ; - Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4); - Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4); - Put1(Sub, RH, RH, 1); Put3(BC, NE, -6); DEC(RH, 2) - END StoreStruct; - - PROCEDURE CopyString*(VAR x, y: Item); (*from x to y*) - VAR len: LONGINT; - BEGIN loadAdr(y); len := y.type.len; - IF len >= 0 THEN - IF x.b > len THEN ORS.Mark("string too long") END - ELSIF check THEN Put2(Ldr, RH, y.r, 4); (*array length check*) - Put1(Cmp, RH, RH, x.b); Trap(NE, 3) - END ; - loadStringAdr(x); - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Asr, RH, RH, 24); Put3(BC, NE, -6); DEC(RH, 2) - END CopyString; - - (* Code generation for parameters *) - - PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type); - VAR xmd: INTEGER; - BEGIN xmd := x.mode; loadAdr(x); - IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*) - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - ELSIF ftype.form = ORB.Record THEN - IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END - END - END VarParam; - - PROCEDURE ValueParam*(VAR x: Item); - BEGIN load(x) - END ValueParam; - - PROCEDURE OpenArrayParam*(VAR x: Item); - BEGIN loadAdr(x); - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - END OpenArrayParam; - - PROCEDURE StringParam*(VAR x: Item); - BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR (*len*) - END StringParam; - - (*For Statements*) - - PROCEDURE For0*(VAR x, y: Item); - BEGIN load(y) - END For0; - - PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT); - BEGIN - IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a) - ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH) - END ; - L := pc; - IF w.a > 0 THEN Put3(BC, GT, 0) - ELSIF w.a < 0 THEN Put3(BC, LT, 0) - ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0) - END ; - Store(x, y) - END For1; - - PROCEDURE For2*(VAR x, y, w: Item); - BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a) - END For2; - - (* Branches, procedure calls, procedure prolog and epilog *) - - PROCEDURE Here*(): LONGINT; - BEGIN invalSB; RETURN pc - END Here; - - PROCEDURE FJump*(VAR L: LONGINT); - BEGIN Put3(BC, 7, L); L := pc-1 - END FJump; - - PROCEDURE CFJump*(VAR x: Item); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1 - END CFJump; - - PROCEDURE BJump*(L: LONGINT); - BEGIN Put3(BC, 7, L-pc-1) - END BJump; - - PROCEDURE CBJump*(VAR x: Item; L: LONGINT); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L) - END CBJump; - - PROCEDURE Fixup*(VAR x: Item); - BEGIN FixLink(x.a) - END Fixup; - - PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := 0; - Put1(Sub, SP, SP, r*4); INC(frame, 4*r); - REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r - END SaveRegs; - - PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := r; - REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0; - Put1(Add, SP, SP, r*4); DEC(frame, 4*r) - END RestoreRegs; - - PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode > ORB.Par THEN load(x) END ; - r := RH; - IF RH > 0 THEN SaveRegs(RH); RH := 0 END - END PrepCall; - - PROCEDURE Call*(VAR x: Item; r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode = ORB.Const THEN - IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1) - ELSE (*imported*) - IF pc - fixorgP < 1000H THEN - Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1 - ELSE ORS.Mark("fixup impossible") - END - END - ELSE - IF x.mode <= ORB.Par THEN load(x); DEC(RH) - ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4) - END ; - IF check THEN Trap(EQ, 5) END ; - Put3(BLR, 7, RH) - END ; - IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0 - ELSE (*function*) - IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ; - x.mode := Reg; x.r := r; RH := r+1 - END ; - invalSB - END Call; - - PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN); - VAR a, r: LONGINT; - BEGIN invalSB; frame := 0; - IF ~int THEN (*procedure prolog*) - a := 4; r := 0; - Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0); - WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END - ELSE (*interrupt procedure*) - Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8) - (*R0, R1, SB saved os stack*) - END - END Enter; - - PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN); - BEGIN - IF form # ORB.NoTyp THEN load(x) END ; - IF ~int THEN (*procedure epilog*) - Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK) - ELSE (*interrupt return, restore SB, R1, R0*) - Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H) - END ; - RH := 0 - END Return; - - (* In-line code procedures*) - - PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item); - VAR op, zr, v: LONGINT; - BEGIN (*frame = 0*) - IF upordown = 0 THEN op := Add ELSE op := Sub END ; - IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ; - IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ; - IF (x.mode = ORB.Var) & (x.r > 0) THEN - zr := RH; Put2(Ldr+v, zr, SP, x.a); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, SP, x.a); DEC(RH) - ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, x.r, 0); DEC(RH, 2) - END - END Increment; - - PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item); - VAR op, zr: LONGINT; - BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR; - IF inorex = 0 THEN op := Ior ELSE op := Ann END ; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a)) - ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH) - END ; - Put2(Str, zr, x.r, 0); DEC(RH, 2) - END Include; - - PROCEDURE Assert*(VAR x: Item); - VAR cond: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - IF x.a = 0 THEN cond := negated(x.r) - ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7 - END ; - Trap(cond, 7); FixLink(x.b) - END Assert; - - PROCEDURE New*(VAR x: Item); - BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Put3(BLR, 7, MT); RH := 0; invalSB - END New; - - PROCEDURE Pack*(VAR x, y: Item); - VAR z: Item; - BEGIN z := x; load(x); load(y); - Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x) - END Pack; - - PROCEDURE Unpk*(VAR x, y: Item); - VAR z, e0: Item; - BEGIN z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType; - Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR; - Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x) - END Unpk; - - PROCEDURE Led*(VAR x: Item); - BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH) - END Led; - - PROCEDURE Get*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x) - END Get; - - PROCEDURE Put*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y) - END Put; - - PROCEDURE Copy*(VAR x, y, z: Item); - BEGIN load(x); load(y); - IF z.mode = ORB.Const THEN - IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END - ELSE load(z); - IF check THEN Trap(LT, 3) END ; - Put3(BC, EQ, 6) - END ; - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3) - END Copy; - - PROCEDURE LDPSR*(VAR x: Item); - BEGIN (*x.mode = Const*) Put3(0, 15, x.a + 20H) - END LDPSR; - - PROCEDURE LDREG*(VAR x, y: Item); - BEGIN - IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a) - ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH) - END - END LDREG; - - (*In-line code functions*) - - PROCEDURE Abs*(VAR x: Item); - BEGIN - IF x.mode = ORB.Const THEN x.a := ABS(x.a) - ELSE load(x); - IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1) - ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - END - END Abs; - - PROCEDURE Odd*(VAR x: Item); - BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH) - END Odd; - - PROCEDURE Floor*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH) - END Floor; - - PROCEDURE Float*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+U, x.r, x.r, RH) - END Float; - - PROCEDURE Ord*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN load(x) END - END Ord; - - PROCEDURE Len*(VAR x: Item); - BEGIN - IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len - ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR - END - END Len; - - PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item); - VAR op: LONGINT; - BEGIN load(x); - IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ; - IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H) - ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END Shift; - - PROCEDURE ADC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH) - END ADC; - - PROCEDURE SBC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH) - END SBC; - - PROCEDURE UML*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH) - END UML; - - PROCEDURE Bit*(VAR x, y: Item); - BEGIN load(x); Put2(Ldr, x.r, x.r, 0); - IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH) - ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END Bit; - - PROCEDURE Register*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR - END Register; - - PROCEDURE H*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR - END H; - - PROCEDURE Adr*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x) - ELSE ORS.Mark("not addressable") - END - END Adr; - - PROCEDURE Condition*(VAR x: Item); - BEGIN (*x.mode = Const*) SetCC(x, x.a) - END Condition; - - PROCEDURE Open*(v: INTEGER); - BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v; - IF v = 0 THEN pc := 8 END - END Open; - - PROCEDURE SetDataSize*(dc: LONGINT); - BEGIN varsize := dc - END SetDataSize; - - PROCEDURE Header*; - BEGIN entry := pc*4; - IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0) (*RISC-0*) - ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB - END - END Header; - - PROCEDURE NofPtrs(typ: ORB.Type): LONGINT; - VAR fld: ORB.Object; n: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1 - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; n := 0; - WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END - ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len - ELSE n := 0 - END ; - RETURN n - END NofPtrs; - - PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END - END - END FindPtrs; - - PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT); - VAR obj: ORB.Object; - i, comsize, nofimps, nofptrs, size: LONGINT; - name: ORS.Ident; - F: Files.File; R: Files.Rider; - BEGIN (*exit code*) - IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0) (*RISC-0*) - ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK) - END ; - obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0; - WHILE obj # NIL DO - IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*) - ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) - & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*) - WHILE obj.name[i] # 0X DO INC(i) END ; - i := (i+4) DIV 4 * 4; INC(comsize, i+4) - ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type)) (*count pointers*) - END ; - obj := obj.next - END ; - size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4; (*varsize includes type descriptors*) - - ORB.MakeFileName(name, modid, ".rsc"); (*write code file*) - F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); - (*Files.WriteByte(R, version);*) (* who writes like that? -- noch *) - Files.WriteByte(R, SHORT(SHORT(version))); (* voc adaptation by noch *) - Files.WriteInt(R, size); - obj := ORB.topScope.next; - WHILE (obj # NIL) & (obj.class = ORB.Mod) DO (*imports*) - IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, tdx*4); - i := 0; - WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*) - Files.WriteInt(R, varsize - tdx*4); (*data*) - Files.WriteInt(R, strx); - FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ; (*strings*) - Files.WriteInt(R, pc); (*code len*) - FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*) - obj := ORB.topScope.next; - WHILE obj # NIL DO (*commands*) - IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) & - (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN - Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) - END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, nofent); Files.WriteInt(R, entry); - obj := ORB.topScope.next; - WHILE obj # NIL DO (*entries*) - IF obj.exno # 0 THEN - IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN - Files.WriteInt(R, obj.val) - ELSIF obj.class = ORB.Typ THEN - IF obj.type.form = ORB.Record THEN Files.WriteInt(R, obj.type.len MOD 10000H) - ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN - Files.WriteInt(R, obj.type.base.len MOD 10000H) - END - END - END ; - obj := obj.next - END ; - obj := ORB.topScope.next; - WHILE obj # NIL DO (*pointer variables*) - IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ; - obj := obj.next - END ; - Files.WriteInt(R, -1); - Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry); - Files.Write(R, "O"); Files.Register(F) - END Close; - -BEGIN - relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13 -END ORG. diff --git a/src/voc07R/ORP.Mod b/src/voc07R/ORP.Mod deleted file mode 100644 index 7c59e50f..00000000 --- a/src/voc07R/ORP.Mod +++ /dev/null @@ -1,997 +0,0 @@ -MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014 Oberon compiler for RISC in Oberon-07*) - IMPORT Texts := CompatTexts, Oberon, ORS, ORB, ORG; - (*Author: Niklaus Wirth, 2014. - Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens), - ORB for definition of data structures and for handling import and export, and - ORG to produce binary code. ORP performs type checking and data allocation. - Parser is target-independent, except for part of the handling of allocations.*) - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - - TYPE PtrBase = POINTER TO PtrBaseDesc; - PtrBaseDesc = RECORD (*list of names of pointer base types*) - name: ORS.Ident; type: ORB.Type; next: PtrBase - END ; - - VAR sym: INTEGER; (*last symbol read*) - dc: LONGINT; (*data counter*) - level, exno, version: INTEGER; - newSF: BOOLEAN; (*option flag*) - expression: PROCEDURE (VAR x: ORG.Item); (*to avoid forward reference*) - Type: PROCEDURE (VAR type: ORB.Type); - FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER); - modid: ORS.Ident; - pbsList: PtrBase; (*list of names of pointer base types*) - dummy: ORB.Object; - W: Texts.Writer; - - PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR); - BEGIN - IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END - END Check; - - PROCEDURE qualident(VAR obj: ORB.Object); - BEGIN obj := ORB.thisObj(); ORS.Get(sym); - IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ; - IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN - ORS.Get(sym); - IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym); - IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END - ELSE ORS.Mark("identifier expected"); obj := dummy - END - END - END qualident; - - PROCEDURE CheckBool(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END - END CheckBool; - - PROCEDURE CheckInt(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END - END CheckInt; - - PROCEDURE CheckReal(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END - END CheckReal; - - PROCEDURE CheckSet(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END - END CheckSet; - - PROCEDURE CheckSetVal(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType - ELSIF x.mode = ORB.Const THEN - IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END - END - END CheckSetVal; - - PROCEDURE CheckConst(VAR x: ORG.Item); - BEGIN - IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END - END CheckConst; - - PROCEDURE CheckReadOnly(VAR x: ORG.Item); - BEGIN - IF x.rdo THEN ORS.Mark("read-only") END - END CheckReadOnly; - - PROCEDURE CheckExport(VAR expo: BOOLEAN); - BEGIN - IF sym = ORS.times THEN - expo := TRUE; ORS.Get(sym); - IF level # 0 THEN ORS.Mark("remove asterisk") END - ELSE expo := FALSE - END - END CheckExport; - - PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN; - BEGIN (*t1 is an extension of t0*) - RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base) - END IsExtension; - - (* expressions *) - - PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN); - VAR xt: ORB.Type; - BEGIN xt := x.type; - WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ; - IF xt # T THEN xt := x.type; - IF (xt.form = ORB.Pointer) & (T.form = ORB.Pointer) THEN - IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T - ELSE ORS.Mark("not an extension") - END - ELSIF (xt.form = ORB.Record) & (T.form = ORB.Record) & (x.mode = ORB.Par) THEN - IF IsExtension(xt, T) THEN ORG.TypeTest(x, T, TRUE, guard); x.type := T - ELSE ORS.Mark("not an extension") - END - ELSE ORS.Mark("incompatible types") - END - ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1) - END ; - IF ~guard THEN x.type := ORB.boolType END - END TypeTest; - - PROCEDURE selector(VAR x: ORG.Item); - VAR y: ORG.Item; obj: ORB.Object; - BEGIN - WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow) - OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO - IF sym = ORS.lbrak THEN - REPEAT ORS.Get(sym); expression(y); - IF x.type.form = ORB.Array THEN - CheckInt(y); ORG.Index(x, y); x.type := x.type.base - ELSE ORS.Mark("not an array") - END - UNTIL sym # ORS.comma; - Check(ORS.rbrak, "no ]") - ELSIF sym = ORS.period THEN ORS.Get(sym); - IF sym = ORS.ident THEN - IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ; - IF x.type.form = ORB.Record THEN - obj := ORB.thisfield(x.type); ORS.Get(sym); - IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type - ELSE ORS.Mark("undef") - END - ELSE ORS.Mark("not a record") - END - ELSE ORS.Mark("ident?") - END - ELSIF sym = ORS.arrow THEN - ORS.Get(sym); - IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base - ELSE ORS.Mark("not a pointer") - END - ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*) - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE) - ELSE ORS.Mark("guard type expected") - END - ELSE ORS.Mark("not an identifier") - END ; - Check(ORS.rparen, " ) missing") - END - END - END selector; - - PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN; - - PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN; - VAR p0, p1: ORB.Object; com: BOOLEAN; - BEGIN com := TRUE; - IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN - p0 := t0.dsc; p1 := t1.dsc; - WHILE p0 # NIL DO - IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) & - (*(ORD(p0.rdo) = ORD(p1.rdo))*) - (p0.rdo = p1.rdo) (* voc adaptation by noch *) - THEN - IF p0.type.form >= ORB.Array THEN com := CompTypes(p0.type, p1.type, (p0.class = ORB.Par)) END ; - p0 := p0.next; p1 := p1.next - ELSE p0 := NIL; com := FALSE - END - END - ELSE com := FALSE - END ; - RETURN com - END EqualSignatures; - - BEGIN (*Compatible Types*) - RETURN (t0 = t1) - OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & CompTypes(t0.base, t1.base, varpar) - OR (t0.form = ORB.Pointer) & (t1.form = ORB.Pointer) & IsExtension(t0.base, t1.base) - OR (t0.form = ORB.Record) & (t1.form = ORB.Record) & IsExtension(t0, t1) - OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1) - OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp) - OR (t0.form = ORB.NilTyp) & (t1.form IN {ORB.Pointer, ORB.Proc}) - OR ~varpar & (t0.form = ORB.Int) & (t1.form = ORB.Int) - END CompTypes; - - PROCEDURE Parameter(par: ORB.Object); - VAR x: ORG.Item; varpar: BOOLEAN; - BEGIN expression(x); - IF par # NIL THEN - varpar := par.class = ORB.Par; - IF CompTypes(par.type, x.type, varpar) THEN - IF ~varpar THEN ORG.ValueParam(x) - ELSE (*par.class = Par*) - IF ~par.rdo THEN CheckReadOnly(x) END ; - ORG.VarParam(x, par.type) - END - ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN - ORG.ValueParam(x) - ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN - ORG.StrToChar(x); ORG.ValueParam(x) - ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) & - (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN - ORG.OpenArrayParam(x); - ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & - (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x) - ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN - ORG.VarParam(x, par.type) - ELSE ORS.Mark("incompatible parameters") - END - END - END Parameter; - - PROCEDURE ParamList(VAR x: ORG.Item); - VAR n: INTEGER; par: ORB.Object; - BEGIN par := x.type.dsc; n := 0; - IF sym # ORS.rparen THEN - Parameter(par); n := 1; - WHILE sym <= ORS.comma DO - Check(sym, "comma?"); - IF par # NIL THEN par := par.next END ; - INC(n); Parameter(par) - END ; - Check(ORS.rparen, ") missing") - ELSE ORS.Get(sym); - END ; - IF n < x.type.nofpar THEN ORS.Mark("too few params") - ELSIF n > x.type.nofpar THEN ORS.Mark("too many params") - END - END ParamList; - - PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type); - VAR y: ORG.Item; n, npar: LONGINT; - BEGIN Check(ORS.lparen, "no ("); - npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1; - WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ; - Check(ORS.rparen, "no )"); - IF n = npar THEN - IF fct = 0 THEN (*ABS*) - IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END - ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x) - ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x) - ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x) - ELSIF fct = 4 THEN (*ORD*) - IF x.type.form <= ORB.Proc THEN ORG.Ord(x) - ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) - ELSE ORS.Mark("bad type") - END - ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x) - ELSIF fct = 6 THEN (*LEN*) - IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END - ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y); - IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END - ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y) - ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y) - ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y) - ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y) - ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x) - ELSIF fct = 16 THEN (*VAL*) - IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y - ELSE ORS.Mark("casting not allowed") - END - ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x) - ELSIF fct = 18 THEN (*SIZE*) - IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size) - ELSE ORS.Mark("must be a type") - END - ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x) - ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x) - END ; - x.type := restyp - ELSE ORS.Mark("wrong nof params") - END - END StandFunc; - - PROCEDURE element(VAR x: ORG.Item); - VAR y: ORG.Item; - BEGIN expression(x); CheckSetVal(x); - IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y) - ELSE ORG.Singleton(x) - END ; - x.type := ORB.setType - END element; - - PROCEDURE set(VAR x: ORG.Item); - VAR y: ORG.Item; - BEGIN - IF sym >= ORS.if THEN - IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ; - ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*) - ELSE element(x); - WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO - IF sym = ORS.comma THEN ORS.Get(sym) - ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma") - END ; - element(y); ORG.SetOp(ORS.plus, x, y) - END - END - END set; - - PROCEDURE factor(VAR x: ORG.Item); - VAR obj: ORB.Object; rx: LONGINT; - BEGIN (*sync*) - IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected"); - REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.ident) - END ; - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type) - ELSE ORG.MakeItem(x, obj, level); selector(x); - IF sym = ORS.lparen THEN - ORS.Get(sym); - IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN - ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base - ELSE ORS.Mark("not a function"); ParamList(x) - END - END - END - ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym) - ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym) - ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym) - ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0) - ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym) - ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )") - ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }") - ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x) - ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0) - ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1) - ELSE ORS.Mark("not a factor"); ORG.MakeItem(x, NIL, level) - END - END factor; - - PROCEDURE term(VAR x: ORG.Item); - VAR y: ORG.Item; op, f: INTEGER; - BEGIN factor(x); f := x.type.form; - WHILE (sym >= ORS.times) & (sym <= ORS.and) DO - op := sym; ORS.Get(sym); - IF op = ORS.times THEN - IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y) - ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) - ELSE ORS.Mark("bad type") - END - ELSIF (op = ORS.div) OR (op = ORS.mod) THEN - CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y) - ELSIF op = ORS.rdiv THEN - IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) - ELSE ORS.Mark("bad type") - END - ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y) - END - END - END term; - - PROCEDURE SimpleExpression(VAR x: ORG.Item); - VAR y: ORG.Item; op: INTEGER; - BEGIN - IF sym = ORS.minus THEN ORS.Get(sym); term(x); - IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END - ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x); - ELSE term(x) - END ; - WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO - op := sym; ORS.Get(sym); - IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y) - ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y) - ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y) - END - END - END SimpleExpression; - - PROCEDURE expression0(VAR x: ORG.Item); - VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER; - BEGIN SimpleExpression(x); - IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN - rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form; - IF CompTypes(x.type, y.type, FALSE) OR - (xf = ORB.Pointer) & (yf = ORB.Pointer) & IsExtension(y.type.base, x.type.base) THEN - IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y) - ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y) - ELSIF xf = ORB.Set THEN ORG.SetRelation(rel, x, y) - ELSIF (xf IN {ORB.Pointer, ORB.Proc, ORB.NilTyp}) THEN - IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END - ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN - ORG.StringRelation(rel, x, y) - ELSE ORS.Mark("illegal comparison") - END - ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) & - ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char)) - OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN - ORG.StringRelation(rel, x, y) - ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN - ORG.StrToChar(y); ORG.IntRelation(rel, x, y) - ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN - ORG.StrToChar(x); ORG.IntRelation(rel, x, y) - ELSE ORS.Mark("illegal comparison") - END ; - x.type := ORB.boolType - ELSIF sym = ORS.in THEN - ORS.Get(sym); SimpleExpression(y); - IF (x.type.form = ORB.Int) & (y.type.form = ORB.Set) THEN ORG.In(x, y) - ELSE ORS.Mark("illegal operands of IN") - END ; - x.type := ORB.boolType - ELSIF sym = ORS.is THEN - ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ; - x.type := ORB.boolType - END - END expression0; - - (* statements *) - - PROCEDURE StandProc(pno: LONGINT); - VAR nap, npar: LONGINT; (*nof actual/formal parameters*) - x, y, z: ORG.Item; - BEGIN Check(ORS.lparen, "no ("); - npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1; - IF sym = ORS.comma THEN - ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType; - WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END - ELSE y.type := ORB.noType - END ; - Check(ORS.rparen, "no )"); - IF (npar = nap) OR (pno IN {0, 1}) THEN - IF pno IN {0, 1} THEN (*INC, DEC*) - CheckInt(x); CheckReadOnly(x); - IF y.type # ORB.noType THEN CheckInt(y) END ; - ORG.Increment(pno, x, y) - ELSIF pno IN {2, 3} THEN (*INCL, EXCL*) - CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y) - ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x) - ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x); - IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x) - ELSE ORS.Mark("not a pointer to record") - END - ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y) - ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y) - ELSIF pno = 8 THEN - IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END - ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y) - ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y) - ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z) - ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x) - ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y) - END - ELSE ORS.Mark("wrong nof parameters") - END - END StandProc; - - PROCEDURE StatSequence; - VAR obj: ORB.Object; - orgtype: ORB.Type; (*original type of case var*) - x, y, z, w: ORG.Item; - L0, L1, rx: LONGINT; - - PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item); - VAR typobj: ORB.Object; - BEGIN - IF sym = ORS.ident THEN - qualident(typobj); ORG.MakeItem(x, obj, level); - IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ; - TypeTest(x, typobj.type, FALSE); obj.type := typobj.type; - ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence - ELSE ORG.CFJump(x); ORS.Mark("type id expected") - END - END TypeCase; - - PROCEDURE SkipCase; - BEGIN - WHILE sym # ORS.colon DO ORS.Get(sym) END ; - ORS.Get(sym); StatSequence - END SkipCase; - - BEGIN (* StatSequence *) - REPEAT (*sync*) obj := NIL; - IF ~((sym = ORS.ident) OR (sym >= ORS.if) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN - ORS.Mark("statement expected"); - REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.if) - END ; - IF sym = ORS.ident THEN - qualident(obj); ORG.MakeItem(x, obj, level); - IF x.mode = ORB.SProc THEN StandProc(obj.val) - ELSE selector(x); - IF sym = ORS.becomes THEN (*assignment*) - ORS.Get(sym); CheckReadOnly(x); expression(y); - IF CompTypes(x.type, y.type, FALSE) OR (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN - IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y) - ELSIF y.type.size # 0 THEN ORG.StoreStruct(x, y) - END - ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN - ORG.StrToChar(y); ORG.Store(x, y) - ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & - (y.type.form = ORB.String) THEN ORG.CopyString(y, x) - ELSE ORS.Mark("illegal assignment") - END - ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y) - ELSIF sym = ORS.lparen THEN (*procedure call*) - ORS.Get(sym); - IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN - ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx) - ELSE ORS.Mark("not a procedure"); ParamList(x) - END - ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*) - IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ; - IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END - ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment") - ELSE ORS.Mark("not a procedure") - END - END - ELSIF sym = ORS.if THEN - ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.then, "no THEN"); - StatSequence; L0 := 0; - WHILE sym = ORS.elsif DO - ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x); - ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence - END ; - IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence - ELSE ORG.Fixup(x) - END ; - ORG.FixLink(L0); Check(ORS.end, "no END") - ELSIF sym = ORS.while THEN - ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0); - WHILE sym = ORS.elsif DO - ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0) - END ; - ORG.Fixup(x); Check(ORS.end, "no END") - ELSIF sym = ORS.repeat THEN - ORS.Get(sym); L0 := ORG.Here(); StatSequence; - IF sym = ORS.until THEN - ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0) - ELSE ORS.Mark("missing UNTIL") - END - ELSIF sym = ORS.for THEN - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x); - IF sym = ORS.becomes THEN - ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here(); - Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE; - IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w) - ELSE ORG.MakeConstItem(w, ORB.intType, 1) - END ; - Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1); - StatSequence; Check(ORS.end, "no END"); - ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE - ELSE ORS.Mark(":= expected") - END - ELSE ORS.Mark("identifier expected") - END - ELSIF sym = ORS.case THEN - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); orgtype := obj.type; - IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN - Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0; - WHILE sym = ORS.bar DO - ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x) - END ; - ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype - ELSE ORS.Mark("numeric case not implemented"); - Check(ORS.of, "OF expected"); SkipCase; - WHILE sym = ORS.bar DO SkipCase END - END - ELSE ORS.Mark("ident expected") - END ; - Check(ORS.end, "no END") - END ; - ORG.CheckRegs; - IF sym = ORS.semicolon THEN ORS.Get(sym) - ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?") - END - UNTIL sym > ORS.semicolon - END StatSequence; - - (* Types and declarations *) - - PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object); - VAR obj: ORB.Object; - BEGIN - IF sym = ORS.ident THEN - ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo); - WHILE sym = ORS.comma DO - ORS.Get(sym); - IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo) - ELSE ORS.Mark("ident?") - END - END; - IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END - ELSE first := NIL - END - END IdentList; - - PROCEDURE ArrayType(VAR type: ORB.Type); - VAR x: ORG.Item; typ: ORB.Type; len: LONGINT; - BEGIN NEW(typ); typ.form := ORB.NoTyp; - IF sym = ORS.of THEN (*dynamic array*) len := -1 - ELSE expression(x); - IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a - ELSE len := 0; ORS.Mark("not a valid length") - END - END ; - IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base); - IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END - ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base) - ELSE ORS.Mark("missing OF"); typ.base := ORB.intType - END ; - IF len >= 0 THEN typ.size := (len * typ.base.size + 3) DIV 4 * 4 ELSE typ.size := 2*ORG.WordSize (*array desc*) END ; - typ.form := ORB.Array; typ.len := len; type := typ - END ArrayType; - - PROCEDURE RecordType(VAR type: ORB.Type); - VAR obj, obj0, new, bot, base: ORB.Object; - typ, tp: ORB.Type; - offset, off, n: LONGINT; - BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL; - IF sym = ORS.lparen THEN - ORS.Get(sym); (*record extension*) - IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ; - IF sym = ORS.ident THEN - qualident(base); - IF base.class = ORB.Typ THEN - IF base.type.form = ORB.Record THEN typ.base := base.type - ELSE typ.base := ORB.intType; ORS.Mark("invalid extension") - END ; - typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*) - bot := typ.base.dsc; offset := typ.base.size - ELSE ORS.Mark("type expected") - END - ELSE ORS.Mark("ident expected") - END ; - Check(ORS.rparen, "no )") - END ; - WHILE sym = ORS.ident DO (*fields*) - n := 0; obj := bot; - WHILE sym = ORS.ident DO - obj0 := obj; - WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ; - IF obj0 # NIL THEN ORS.Mark("mult def") END ; - NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n); - ORS.Get(sym); CheckExport(new.expo); - IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected") - ELSIF sym = ORS.comma THEN ORS.Get(sym) - END - END ; - Check(ORS.colon, "colon expected"); Type(tp); - IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ; - IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ; - offset := offset + n * tp.size; off := offset; obj0 := obj; - WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ; - bot := obj; - IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END - END ; - typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ - END RecordType; - - PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER); - VAR obj, first: ORB.Object; tp: ORB.Type; - parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN; - BEGIN - IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ; - IdentList(cl, first); FormalType(tp, 0); rdo := FALSE; - IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ; - IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN - parsize := 2*ORG.WordSize (*open array or record, needs second word for length or type tag*) - ELSE parsize := ORG.WordSize - END ; - obj := first; - WHILE obj # NIL DO - INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr; - adr := adr + parsize; obj := obj.next - END ; - IF adr >= 52 THEN ORS.Mark("too many parameters") END - END FPSection; - - PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT); - VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER; - BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL; - IF sym = ORS.lparen THEN - ORS.Get(sym); - IF sym = ORS.rparen THEN ORS.Get(sym) - ELSE FPSection(size, nofpar); - WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ; - Check(ORS.rparen, "no )") - END ; - ptype.nofpar := nofpar; parblksize := size; - IF sym = ORS.colon THEN (*function*) - ORS.Get(sym); - IF sym = ORS.ident THEN qualident(obj); - IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc}) THEN ptype.base := obj.type - ELSE ORS.Mark("illegal function type") - END - ELSE ORS.Mark("type identifier expected") - END - END - END - END ProcedureType; - - PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER); - VAR obj: ORB.Object; dmy: LONGINT; - BEGIN - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END - ELSIF sym = ORS.array THEN - ORS.Get(sym); Check(ORS.of, "OF ?"); - IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ; - NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; - FormalType(typ.base, dim+1) - ELSIF sym = ORS.procedure THEN - ORS.Get(sym); ORB.OpenScope; - NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy); - typ.dsc := ORB.topScope.next; ORB.CloseScope - ELSE ORS.Mark("identifier expected"); typ := ORB.noType - END - END FormalType0; - - PROCEDURE CheckRecLevel(lev: INTEGER); - BEGIN - IF lev # 0 THEN ORS.Mark("ptr base must be global") END - END CheckRecLevel; - - PROCEDURE Type0(VAR type: ORB.Type); - VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase; - BEGIN type := ORB.intType; (*sync*) - IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type"); - REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array) - END ; - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN - IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END - ELSE ORS.Mark("not a type or undefined") - END - ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type) - ELSIF sym = ORS.record THEN - ORS.Get(sym); RecordType(type); Check(ORS.end, "no END") - ELSIF sym = ORS.pointer THEN - ORS.Get(sym); Check(ORS.to, "no TO"); - NEW(type); type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType; - IF sym = ORS.ident THEN - obj := ORB.thisObj(); ORS.Get(sym); - IF obj # NIL THEN - IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN - CheckRecLevel(obj.lev); type.base := obj.type - ELSE ORS.Mark("no valid base type") - END - ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*) - NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase - END - ELSE Type(type.base); - IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ; - CheckRecLevel(level) - END - ELSIF sym = ORS.procedure THEN - ORS.Get(sym); ORB.OpenScope; - NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0; - ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope - ELSE ORS.Mark("illegal type") - END - END Type0; - - PROCEDURE Declarations(VAR varsize: LONGINT); - VAR obj, first: ORB.Object; - x: ORG.Item; tp: ORB.Type; ptbase: PtrBase; - expo: BOOLEAN; id: ORS.Ident; - BEGIN (*sync*) pbsList := NIL; - IF (sym < ORS.const) & (sym # ORS.end) THEN ORS.Mark("declaration?"); - REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) - END ; - IF sym = ORS.const THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); - IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END; - expression(x); - IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ; - ORB.NewObj(obj, id, ORB.Const); obj.expo := expo; - IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type - ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType - END; - Check(ORS.semicolon, "; missing") - END - END ; - IF sym = ORS.type THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); - IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ; - Type(tp); - ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level; tp.typobj := obj; - IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ; - IF tp.form = ORB.Record THEN - ptbase := pbsList; (*check whether this is base of a pointer type; search and fixup*) - WHILE ptbase # NIL DO - IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ; - ptbase := ptbase.next - END ; - IF level = 0 THEN ORG.BuildTD(tp, dc) END (*type descriptor; len used as its address*) - END ; - Check(ORS.semicolon, "; missing") - END - END ; - IF sym = ORS.var THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - IdentList(ORB.Var, first); Type(tp); - obj := first; - WHILE obj # NIL DO - obj.type := tp; obj.lev := level; - IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ; - obj.val := varsize; varsize := varsize + obj.type.size; - IF obj.expo THEN obj.exno := exno; INC(exno) END ; - obj := obj.next - END ; - Check(ORS.semicolon, "; missing") - END - END ; - varsize := (varsize + 3) DIV 4 * 4; - ptbase := pbsList; - WHILE ptbase # NIL DO - IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ; - ptbase := ptbase.next - END ; - IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END - END Declarations; - - PROCEDURE ProcedureDecl; - VAR proc: ORB.Object; - type: ORB.Type; - procid: ORS.Ident; - x: ORG.Item; - locblksize, parblksize, L: LONGINT; - int: BOOLEAN; - BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym); - IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ; - IF sym = ORS.ident THEN - ORS.CopyId(procid); ORS.Get(sym); - ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4; - NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type; - CheckExport(proc.expo); - IF proc.expo THEN proc.exno := exno; INC(exno) END ; - ORB.OpenScope; INC(level); proc.val := -1; type.base := ORB.noType; - ProcedureType(type, parblksize); (*formal parameter list*) - Check(ORS.semicolon, "no ;"); locblksize := parblksize; - Declarations(locblksize); - proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next; - IF sym = ORS.procedure THEN - L := 0; ORG.FJump(L); - REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure; - ORG.FixLink(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next - END ; - ORG.Enter(parblksize, locblksize, int); - IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; - IF sym = ORS.return THEN - ORS.Get(sym); expression(x); - IF type.base = ORB.noType THEN ORS.Mark("this is not a function") - ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type") - END - ELSIF type.base.form # ORB.NoTyp THEN - ORS.Mark("function without result"); type.base := ORB.noType - END ; - ORG.Return(type.base.form, x, locblksize, int); - ORB.CloseScope; DEC(level); Check(ORS.end, "no END"); - IF sym = ORS.ident THEN - IF ORS.id # procid THEN ORS.Mark("no match") END ; - ORS.Get(sym) - ELSE ORS.Mark("no proc id") - END - END ; - int := FALSE - END ProcedureDecl; - - PROCEDURE Module; - VAR key: LONGINT; - obj: ORB.Object; - impid, impid1: ORS.Ident; - BEGIN Texts.WriteString(W, " compiling "); ORS.Get(sym); - IF sym = ORS.module THEN - ORS.Get(sym); - IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ; - ORB.Init; ORB.OpenScope; - IF sym = ORS.ident THEN - ORS.CopyId(modid); ORS.Get(sym); - Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - ELSE ORS.Mark("identifier expected") - END ; - Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0; - IF sym = ORS.import THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(impid); ORS.Get(sym); - IF sym = ORS.becomes THEN - ORS.Get(sym); - IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym) - ELSE ORS.Mark("id expected") - END - ELSE impid1 := impid - END ; - ORB.Import(impid, impid1); - IF sym = ORS.comma THEN ORS.Get(sym) - ELSIF sym = ORS.ident THEN ORS.Mark("comma missing") - END - END ; - Check(ORS.semicolon, "no ;") - END ; - obj := ORB.topScope.next; - ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4); - WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ; - ORG.Header; - IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; - Check(ORS.end, "no END"); - IF sym = ORS.ident THEN - IF ORS.id # modid THEN ORS.Mark("no match") END ; - ORS.Get(sym) - ELSE ORS.Mark("identifier missing") - END ; - IF sym # ORS.period THEN ORS.Mark("period missing") END ; - IF (ORS.errcnt = 0) & (version # 0) THEN - ORB.Export(modid, newSF, key); - IF newSF THEN Texts.WriteString(W, " new symbol file") END - END ; - IF ORS.errcnt = 0 THEN - ORG.Close(modid, key, exno); - Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key) - ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED") - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - ORB.CloseScope; pbsList := NIL - ELSE ORS.Mark("must start with MODULE") - END - END Module; - - PROCEDURE Option(VAR S: Texts.Scanner); - BEGIN newSF := FALSE; - IF S.nextCh = "/" THEN - Texts.Scan(S); Texts.Scan(S); - IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END - END - END Option; - - PROCEDURE Compile*; - VAR beg, end, time: LONGINT; - T: Texts.Text; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Char THEN - IF S.c = "@" THEN - Option(S); Oberon.GetSelection(T, beg, end, time); - IF time >= 0 THEN ORS.Init(T, beg); Module END - ELSIF S.c = "^" THEN - Option(S); Oberon.GetSelection(T, beg, end, time); - IF time >= 0 THEN - Texts.OpenScanner(S, T, beg); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s); - IF T.len > 0 THEN ORS.Init(T, 0); Module END - END - END - END - ELSE - WHILE S.class = Texts.Name DO - NEW(T); Texts.Open(T, S.s); - IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module - ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - END ; - IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END - END - END ; - Oberon.Collect(0) - END Compile; - -BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 7.6.2014"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType; - expression := expression0; Type := Type0; FormalType := FormalType0; - - Compile (* voc adaptation; -- noch *) -END ORP. diff --git a/src/voc07R/ORS.Mod b/src/voc07R/ORS.Mod deleted file mode 100644 index c6909944..00000000 --- a/src/voc07R/ORS.Mod +++ /dev/null @@ -1,325 +0,0 @@ -MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*) - IMPORT SYSTEM, Texts := CompatTexts, Oberon; - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - -(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is - sequence of symbols, i.e identifiers, numbers, strings, and special symbols. - Recognises all Oberon keywords and skips comments. The keywords are - recorded in a table. - Get(sym) delivers next symbol from input text with Reader R. - Mark(msg) records error and delivers error message with Writer W. - If Get delivers ident, then the identifier (a string) is in variable id, if int or char - in ival, if real in rval, and if string in str (and slen) *) - - CONST IdLen* = 32; - NKW = 34; (*nof keywords*) - maxExp = 38; stringBufSize = 256; - - (*lexical symbols*) - null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4; - and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; - neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; - in* = 15; is* = 16; arrow* = 17; period* = 18; - char* = 20; int* = 21; real* = 22; false* = 23; true* = 24; - nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29; - lbrace* = 30; ident* = 31; - if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37; - comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44; - rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49; - to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54; - else* = 55; elsif* = 56; until* = 57; return* = 58; - array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64; - var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; - - TYPE Ident* = ARRAY IdLen OF CHAR; - - VAR ival*, slen*: LONGINT; (*results of Get*) - rval*: REAL; - id*: Ident; (*for identifiers*) - str*: ARRAY stringBufSize OF CHAR; - errcnt*: INTEGER; - - ch: CHAR; (*last character read*) - errpos: LONGINT; - R: Texts.Reader; - W: Texts.Writer; - k: INTEGER; - KWX: ARRAY 10 OF INTEGER; - keyTab: ARRAY NKW OF - RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END; - - PROCEDURE CopyId*(VAR ident: Ident); - BEGIN ident := id - END CopyId; - - PROCEDURE Pos*(): LONGINT; - BEGIN RETURN Texts.Pos(R) - 1 - END Pos; - - PROCEDURE Mark*(msg: ARRAY OF CHAR); - VAR p: LONGINT; - BEGIN p := Pos(); - IF (p > errpos) & (errcnt < 25) THEN - Texts.WriteLn(W); Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " "); - Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; - END ; - INC(errcnt); errpos := p + 4 - END Mark; - - PROCEDURE Identifier(VAR sym: INTEGER); - VAR i, k: INTEGER; - BEGIN i := 0; - REPEAT - IF i < IdLen-1 THEN id[i] := ch; INC(i) END ; - Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z"); - id[i] := 0X; - IF i < 10 THEN k := KWX[i-1]; (*search for keyword*) - WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ; - IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END - ELSE sym := ident - END - END Identifier; - - PROCEDURE String; - VAR i: INTEGER; - BEGIN i := 0; Texts.Read(R, ch); - WHILE ~R.eot & (ch # 22X) DO - IF ch >= " " THEN - IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ; - END ; - Texts.Read(R, ch) - END ; - str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i - END String; - - PROCEDURE HexString; - VAR i, m, n: INTEGER; - BEGIN i := 0; Texts.Read(R, ch); - WHILE ~R.eot & (ch # "$") DO - WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*) - IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H - ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H - ELSE m := 0; Mark("hexdig expected") - END ; - Texts.Read(R, ch); - IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H - ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H - ELSE n := 0; Mark("hexdig expected") - END ; - IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ; - Texts.Read(R, ch) - END ; - Texts.Read(R, ch); slen := i (*no 0X appended!*) - END HexString; - - PROCEDURE Ten(e: LONGINT): REAL; - VAR x, t: REAL; - BEGIN x := 1.0; t := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN x := t * x END ; - t := t * t; e := e DIV 2 - END ; - RETURN x - END Ten; - - PROCEDURE Number(VAR sym: INTEGER); - CONST max = 2147483647 (*2^31 - 1*); - VAR i, k, e, n, s, h: LONGINT; x: REAL; - d: ARRAY 16 OF INTEGER; - negE: BOOLEAN; - BEGIN ival := 0; i := 0; n := 0; k := 0; - REPEAT - IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ; - Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); - IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*) - REPEAT h := d[i]; - IF h >= 10 THEN h := h-7 END ; - k := k*10H + h; INC(i) (*no overflow check*) - UNTIL i = n; - IF ch = "X" THEN sym := char; - IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END - ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k) - ELSE sym := int; ival := k - END ; - Texts.Read(R, ch) - ELSIF ch = "." THEN - Texts.Read(R, ch); - IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*) - REPEAT - IF d[i] < 10 THEN - IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END - ELSE Mark("bad integer") - END ; - INC(i) - UNTIL i = n; - sym := int; ival := k - ELSE (*real number*) x := 0.0; e := 0; - REPEAT (*integer part*) - (*x := x * 10.0 + FLT(d[i]); *) - x := x * 10.0 + (d[i]); (* voc adaptation by noch *) - INC(i) - UNTIL i = n; - WHILE (ch >= "0") & (ch <= "9") DO (*fraction*) - (*x := x * 10.0 + FLT(ORD(ch) - 30H);*) - x := x * 10.0 + (ORD(ch) - 30H); (* voc adaptation by noch *) - DEC(e); - Texts.Read(R, ch) - END ; - IF (ch = "E") OR (ch = "D") THEN (*scale factor*) - Texts.Read(R, ch); s := 0; - IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch) - ELSE negE := FALSE; - IF ch = "+" THEN Texts.Read(R, ch) END - END ; - IF (ch >= "0") & (ch <= "9") THEN - REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch >"9"); - IF negE THEN e := e-s ELSE e := e+s END - ELSE Mark("digit?") - END - END ; - IF e < 0 THEN - IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END - ELSIF e > 0 THEN - IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END - END ; - sym := real; rval := x - END - ELSE (*decimal integer*) - REPEAT - IF d[i] < 10 THEN - IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END - ELSE Mark("bad integer") - END ; - INC(i) - UNTIL i = n; - sym := int; ival := k - END - END Number; - - PROCEDURE comment; - BEGIN Texts.Read(R, ch); - REPEAT - WHILE ~R.eot & (ch # "*") DO - IF ch = "(" THEN Texts.Read(R, ch); - IF ch = "*" THEN comment END - ELSE Texts.Read(R, ch) - END - END ; - WHILE ch = "*" DO Texts.Read(R, ch) END - UNTIL (ch = ")") OR R.eot; - IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END - END comment; - - PROCEDURE Get*(VAR sym: INTEGER); - BEGIN - REPEAT - WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; - IF ch < "A" THEN - IF ch < "0" THEN - IF ch = 22X THEN String; sym := string - ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq - ELSIF ch = "$" THEN HexString; sym := string - ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and - ELSIF ch = "(" THEN Texts.Read(R, ch); - IF ch = "*" THEN sym := null; comment ELSE sym := lparen END - ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen - ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times - ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus - ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma - ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus - ELSIF ch = "." THEN Texts.Read(R, ch); - IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END - ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv - ELSE Texts.Read(R, ch); (* ! % ' *) sym := null - END - ELSIF ch < ":" THEN Number(sym) - ELSIF ch = ":" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END - ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon - ELSIF ch = "<" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END - ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql - ELSIF ch = ">" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END - ELSE (* ? @ *) Texts.Read(R, ch); sym := null - END - ELSIF ch < "[" THEN Identifier(sym) - ELSIF ch < "a" THEN - IF ch = "[" THEN sym := lbrak - ELSIF ch = "]" THEN sym := rbrak - ELSIF ch = "^" THEN sym := arrow - ELSE (* _ ` *) sym := null - END ; - Texts.Read(R, ch) - ELSIF ch < "{" THEN Identifier(sym) ELSE - IF ch = "{" THEN sym := lbrace - ELSIF ch = "}" THEN sym := rbrace - ELSIF ch = "|" THEN sym := bar - ELSIF ch = "~" THEN sym := not - ELSIF ch = 7FX THEN sym := upto - ELSE sym := null - END ; - Texts.Read(R, ch) - END - UNTIL sym # null - END Get; - - PROCEDURE Init*(T: Texts.Text; pos: LONGINT); - BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch) - END Init; - - PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); - BEGIN - (*keyTab[k].id := name; *) - COPY(name, keyTab[k].id); (* voc adaptation by noch *) - keyTab[k].sym := sym; - INC(k) - END EnterKW; - -BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0; - EnterKW(if, "IF"); - EnterKW(do, "DO"); - EnterKW(of, "OF"); - EnterKW(or, "OR"); - EnterKW(to, "TO"); - EnterKW(in, "IN"); - EnterKW(is, "IS"); - EnterKW(by, "BY"); - KWX[2] := k; - EnterKW(end, "END"); - EnterKW(nil, "NIL"); - EnterKW(var, "VAR"); - EnterKW(div, "DIV"); - EnterKW(mod, "MOD"); - EnterKW(for, "FOR"); - KWX[3] := k; - EnterKW(else, "ELSE"); - EnterKW(then, "THEN"); - EnterKW(true, "TRUE"); - EnterKW(type, "TYPE"); - EnterKW(case, "CASE"); - KWX[4] := k; - EnterKW(elsif, "ELSIF"); - EnterKW(false, "FALSE"); - EnterKW(array, "ARRAY"); - EnterKW(begin, "BEGIN"); - EnterKW(const, "CONST"); - EnterKW(until, "UNTIL"); - EnterKW(while, "WHILE"); - KWX[5] := k; - EnterKW(record, "RECORD"); - EnterKW(repeat, "REPEAT"); - EnterKW(return, "RETURN"); - EnterKW(import, "IMPORT"); - EnterKW(module, "MODULE"); - KWX[6] := k; - EnterKW(pointer, "POINTER"); - KWX[7] := k; KWX[8] := k; - EnterKW(procedure, "PROCEDURE"); - KWX[9] := k -END ORS. diff --git a/src/voc07R/ORTool.Mod b/src/voc07R/ORTool.Mod deleted file mode 100644 index 3c3f9411..00000000 --- a/src/voc07R/ORTool.Mod +++ /dev/null @@ -1,251 +0,0 @@ -MODULE ORTool; (*NW 18.2.2013*) - IMPORT SYSTEM, Files, Texts, Oberon, ORB; - VAR W: Texts.Writer; - Form: INTEGER; (*result of ReadType*) - mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*) - - PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER); - VAR b: BYTE; - BEGIN Files.ReadByte(R, b); - IF b < 80H THEN n := b ELSE n := b - 100H END - END Read; - - PROCEDURE ReadType(VAR R: Files.Rider); - VAR key, len, lev, size, off: INTEGER; - ref, mno, class, form, readonly: INTEGER; - name, modname: ARRAY 32 OF CHAR; - BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "["); - IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1) - ELSE Texts.WriteInt(W, ref, 1); - Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1); - IF form = ORB.Pointer THEN ReadType(R) - ELSIF form = ORB.Array THEN - ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size); - Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1); - Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1) - ELSIF form = ORB.Record THEN - ReadType(R); (*base type*) - Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1); - Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1); - Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1); - Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class); - WHILE class # 0 DO (*fields*) - Files.ReadString(R, name); - IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R) - ELSE Texts.WriteString(W, " --") - END ; - Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class) - END ; - Texts.Write(W, "}") - ELSIF form = ORB.Proc THEN - ReadType(R); Texts.Write(W, "("); Read(R, class); - WHILE class # 0 DO - Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly); - IF readonly = 1 THEN Texts.Write(W, "#") END ; - ReadType(R); Read(R, class) - END ; - Texts.Write(W, ")") - END ; - Files.ReadString(R, modname); - IF modname[0] # 0X THEN - Files.ReadInt(R, key); Files.ReadString(R, name); - Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name); - Texts.WriteHex(W, key) - END - END ; - Form := form; Texts.Write(W, "]") - END ReadType; - - PROCEDURE DecSym*; (*decode symbol file*) - VAR class, typno, k: INTEGER; - name: ARRAY 32 OF CHAR; - F: Files.File; R: Files.Rider; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - F := Files.Old(S.s); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k); - Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k); - Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*) - IF class = ORB.versionkey THEN - Texts.WriteLn(W); Read(R, class); - WHILE class # 0 DO - Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name); - ReadType(R); - IF class = ORB.Typ THEN - Texts.Write(W, "("); Read(R, class); - WHILE class # 0 DO (*pointer base fixup*) - Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class) - END ; - Texts.Write(W, ")") - ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN - Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*) - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Read(R, class) - END - ELSE Texts.WriteString(W, " bad symfile version") - END - ELSE Texts.WriteString(W, " not found") - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) - END - END DecSym; - -(* ---------------------------------------------------*) - - PROCEDURE WriteReg(r: LONGINT); - BEGIN Texts.Write(W, " "); - IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1) - ELSIF r = 12 THEN Texts.WriteString(W, "MT") - ELSIF r = 13 THEN Texts.WriteString(W, "SB") - ELSIF r = 14 THEN Texts.WriteString(W, "SP") - ELSE Texts.WriteString(W, "LNK") - END - END WriteReg; - - PROCEDURE opcode(w: LONGINT); - VAR k, op, u, a, b, c: LONGINT; - BEGIN - k := w DIV 40000000H MOD 4; - a := w DIV 1000000H MOD 10H; - b := w DIV 100000H MOD 10H; - op := w DIV 10000H MOD 10H; - u := w DIV 20000000H MOD 2; - IF k = 0 THEN - Texts.WriteString(W, mnemo0[op]); - IF u = 1 THEN Texts.Write(W, "'") END ; - WriteReg(a); WriteReg(b); WriteReg(w MOD 10H) - ELSIF k = 1 THEN - Texts.WriteString(W, mnemo0[op]); - IF u = 1 THEN Texts.Write(W, "'") END ; - WriteReg(a); WriteReg(b); w := w MOD 10000H; - IF w >= 8000H THEN w := w - 10000H END ; - Texts.WriteInt(W, w, 7) - ELSIF k = 2 THEN (*LDR/STR*) - IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ; - WriteReg(a); WriteReg(b); w := w MOD 100000H; - IF w >= 80000H THEN w := w - 100000H END ; - Texts.WriteInt(W, w, 8) - ELSIF k = 3 THEN (*Branch instr*) - Texts.Write(W, "B"); - IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ; - Texts.WriteString(W, mnemo1[a]); - IF u = 0 THEN WriteReg(w MOD 10H) ELSE - w := w MOD 100000H; - IF w >= 80000H THEN w := w - 100000H END ; - Texts.WriteInt(W, w, 8) - END - END - END opcode; - - PROCEDURE Sync(VAR R: Files.Rider); - VAR ch: CHAR; - BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W) - END Sync; - - PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); - BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *) - END Write; - - PROCEDURE DecObj*; (*decode object file*) - VAR class, i, n, key, size, fix, adr, data, len: INTEGER; - ch: CHAR; - name: ARRAY 32 OF CHAR; - F: Files.File; R: Files.Rider; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name); - Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*) - Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W); - Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name); - WHILE name[0] # 0X DO - Texts.Write(W, 9X); Texts.WriteString(W, name); - Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W); - Files.ReadString(R, name) - END ; - (* Sync(R); *) - Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W); - Files.ReadInt(R, n); n := n DIV 4; i := 0; - WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ; - Texts.WriteLn(W); - Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W); - Texts.WriteString(W, "strings"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ; - Texts.WriteLn(W); - Texts.WriteString(W, "code"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO - Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data); - Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i) - END ; - (* Sync(R); *) - Texts.WriteString(W, "commands:"); Texts.WriteLn(W); - Files.ReadString(R, name); - WHILE name[0] # 0X DO - Texts.Write(W, 9X); Texts.WriteString(W, name); - Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W); - Files.ReadString(R, name) - END ; - (* Sync(R); *) - Texts.WriteString(W, "entries"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO - Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i) - END ; - Texts.WriteLn(W); - (* Sync(R); *) - Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr); - WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ; - Texts.WriteLn(W); - (* Sync(R); *) - Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.Read(R, ch); - IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END - (* Sync(R); *) - ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W) - END ; - Texts.Append(Oberon.Log, W.buf) - END - END DecObj; - -BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - mnemo0[0] := "MOV"; - mnemo0[1] := "LSL"; - mnemo0[2] := "ASR"; - mnemo0[3] := "ROR"; - mnemo0[4] := "AND"; - mnemo0[5] := "ANN"; - mnemo0[6] := "IOR"; - mnemo0[7] := "XOR"; - mnemo0[8] := "ADD"; - mnemo0[9] := "SUB"; - mnemo0[10] := "MUL"; - mnemo0[11] := "DIV"; - mnemo0[12] := "FAD"; - mnemo0[13] := "FSB"; - mnemo0[14] := "FML"; - mnemo0[15] := "FDV"; - mnemo1[0] := "MI "; - mnemo1[8] := "PL"; - mnemo1[1] := "EQ "; - mnemo1[9] := "NE "; - mnemo1[2] := "LS "; - mnemo1[10] := "HI "; - mnemo1[5] := "LT "; - mnemo1[13] := "GE "; - mnemo1[6] := "LE "; - mnemo1[14] := "GT "; - mnemo1[15] := "NO "; -END ORTool. diff --git a/src/voc07R/Oberon.Mod b/src/voc07R/Oberon.Mod deleted file mode 100644 index b2da7dee..00000000 --- a/src/voc07R/Oberon.Mod +++ /dev/null @@ -1,111 +0,0 @@ -MODULE Oberon; - -(* this module emulates Oberon.Log and Oberon.Par in order to pass agruments to Oberon programs, as it's in Oberon environment; - it creates Oberon.Par from command line arguments; - procedure Dump dumps Oberon.Log to standard output. - - -- noch *) - -(* Files are commented out, because it's not necessary for work, but can be very useful for debug. See WriteTextToFile procedure; -- noch *) -IMPORT Args, Strings, Texts := CompatTexts, (*Files := CompatFiles,*) Out := Console; - -VAR Log*: Texts.Text; - - Par*: RECORD - text*: Texts.Text; - pos* : LONGINT; - END; - -arguments : ARRAY 2048 OF CHAR; - -PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT); - (*VAR M: SelectionMsg;*) - BEGIN - (*M.time := -1; Viewers.Broadcast(M); time := M.time; - IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END*) - END GetSelection; - -PROCEDURE Collect*( count : LONGINT); -BEGIN - -END Collect; - -PROCEDURE ArgsToString(VAR opts : ARRAY OF CHAR); -VAR i : INTEGER; - opt : ARRAY 256 OF CHAR; -BEGIN - - i := 1; - opt := ""; COPY ("", opts); - - WHILE i < Args.argc DO - Args.Get(i, opt); - Strings.Append(opt, opts);(* Strings.Append (" ", opts);*) - (* ORP calls Texts.Scan, which returns filename, and nextCh would be set to " " if we append here " ". However after that ORP will check nextCh, and if it finds that nextCh is not "/" it's not gonna parse options. That's why Strings.Append is commented out; -- noch *) - INC(i) - END; - -END ArgsToString; - -PROCEDURE StringToText(VAR arguments : ARRAY OF CHAR; VAR T : Texts.Text); -VAR - W : Texts.Writer; -BEGIN - Texts.OpenWriter(W); - Texts.WriteString(W, arguments); - Texts.Append (T, W.buf); -END StringToText; -(* -PROCEDURE WriteTextToFile(VAR T : Texts.Text; filename : ARRAY OF CHAR); - VAR f : Files.File; r : Files.Rider; -BEGIN - f := Files.New(filename); - Files.Set(r, f, 0); - Texts.Store(r, T); - Files.Register(f); -END WriteTextToFile; -*) -PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR); - VAR R : Texts.Reader; - ch : CHAR; - i : LONGINT; -BEGIN - COPY("", string); - Texts.OpenReader(R, T, 0); - i := 0; - WHILE Texts.Pos(R) < T.len DO - Texts.Read(R, ch); - string[i] := ch; - INC(i); - END; - (*string[i] := 0X;*) -END TextToString; - -PROCEDURE DumpLog*; -VAR s : POINTER TO ARRAY OF CHAR; -BEGIN - NEW(s, Log.len + 1); - COPY("", s^); - TextToString(Log, s^); - Out.String(s^); Out.Ln; - - NEW(Log); - Texts.Open(Log, ""); -END DumpLog; - - -BEGIN - NEW(Log); - Texts.Open(Log, ""); - - NEW(Par.text); - Texts.Open(Par.text, ""); - Par.pos := 0; - - COPY("", arguments); - ArgsToString(arguments); - StringToText(arguments, Par.text); - (*WriteTextToFile(Par.text, "params.txt");*) - (*WriteTextToFile(Log, "log.txt");*) - (*DumpLog;*) -END Oberon. diff --git a/src/voc07R/Oberon10.Scn.Fnt b/src/voc07R/Oberon10.Scn.Fnt deleted file mode 100644 index 15f99921..00000000 Binary files a/src/voc07R/Oberon10.Scn.Fnt and /dev/null differ diff --git a/src/voc07R/README.md b/src/voc07R/README.md deleted file mode 100644 index 6b4cf474..00000000 --- a/src/voc07R/README.md +++ /dev/null @@ -1,29 +0,0 @@ - -RISC crosscompiler -================== - -This is a version of re re revised Oberon compiler for Wirth's RISC machine which can be compiled and run with VOC (Vishap Oberon Compiler) on supported platforms. - -Files generated can be transferred to RISC machine or emulator and be run there. - -Compile -======= - -If you have vishap oberon compiler installed, just type ->make - -Run -=== - ->./ORP test.Mod /s - -like that. - -you may need symbol (.smb) files from RISC Oberon system in order to write programs that import some modules. - -some answers -============ - -- why Oberon10.Scn.Fnt ? -- it's actually not really necessary. because Texts are patched (test for NIL) to not crash if this file does not exist. however, unless I remove dependency from Fonts.Mod I have decided to keep this file here, and thus my added test for NIL is not necessary, and generated output file is completely correct Oberon Text file. Otherwise it would not contain the font name, for instance. - diff --git a/src/voc07R/makefile b/src/voc07R/makefile deleted file mode 100644 index 7f9f03bd..00000000 --- a/src/voc07R/makefile +++ /dev/null @@ -1,22 +0,0 @@ - -SETPATH = MODULES=".:gcc:gcc/x86_64" - -VOC0 = $(SETPATH) /opt/voc/bin/voc - -all: - #$(VOC0) -s ORS.Mod - #$(VOC0) -s ORB.Mod - #$(VOC0) -s ORG.Mod - $(VOC0) -s CompatFiles.Mod \ - Fonts.Mod CompatTexts.Mod Oberon.Mod \ - ORS.Mod ORB.Mod ORG.Mod ORP.Mod -M - -test: - ./ORP -s test.Mod - -clean: - rm *.sym - rm *.o - rm *.h - rm *.c - diff --git a/src/voc07R/test/Oberon.rsc b/src/voc07R/test/Oberon.rsc deleted file mode 100644 index d0e49fa8..00000000 Binary files a/src/voc07R/test/Oberon.rsc and /dev/null differ diff --git a/src/voc07R/test/Oberon.smb b/src/voc07R/test/Oberon.smb deleted file mode 100644 index 148bd414..00000000 Binary files a/src/voc07R/test/Oberon.smb and /dev/null differ diff --git a/src/voc07R/test/Test.Mod b/src/voc07R/test/Test.Mod deleted file mode 100644 index 34c85704..00000000 Binary files a/src/voc07R/test/Test.Mod and /dev/null differ diff --git a/src/voc07R/test/Texts.rsc b/src/voc07R/test/Texts.rsc deleted file mode 100644 index a1d32e38..00000000 Binary files a/src/voc07R/test/Texts.rsc and /dev/null differ diff --git a/src/voc07R/test/Texts.smb b/src/voc07R/test/Texts.smb deleted file mode 100644 index 9c97e0d9..00000000 Binary files a/src/voc07R/test/Texts.smb and /dev/null differ diff --git a/src/voc07R/test/readme b/src/voc07R/test/readme deleted file mode 100644 index 9108c517..00000000 --- a/src/voc07R/test/readme +++ /dev/null @@ -1,3 +0,0 @@ -put ORP binary here and run - -> ./ORP Test.Mod diff --git a/05vishap.conf b/triage/05vishap.conf similarity index 100% rename from 05vishap.conf rename to triage/05vishap.conf diff --git a/CHANGES.md b/triage/CHANGES.md similarity index 100% rename from CHANGES.md rename to triage/CHANGES.md diff --git a/CHANGES0.md b/triage/CHANGES0.md similarity index 100% rename from CHANGES0.md rename to triage/CHANGES0.md diff --git a/triage/COMPILE b/triage/COMPILE new file mode 100644 index 00000000..ac194fd7 --- /dev/null +++ b/triage/COMPILE @@ -0,0 +1,71 @@ +Platforms +=======: +several bootstrap static binaries provided, for + +gnu/linux on x86_64 +gnu/linux on x86 +gnu/linux on armv6j_hardfp (i. e. raspberry pi) +darwin on x86_64 (read osx) +freebsd on x86_64 +openbsd on x86_64 + +Prerequisites: +========== +on Debian GNU/Linux: + +gcc, libc6-dev on debian + +on RHEL/CentOS/Fedora: + +gcc, glibc-devel, glibc-static + +on OSX: +clang, Xcode. + +How to install +============== + +By default, voc will be installed to /opt/voc- and /opt/voc symlink to it will be created. +If you want it in other prefix, then edit makefile for your platform, and change PRF = "/opt" to the path you need. + +Then just cd into source directory and type + +>make -f makefile.linux.gcc.x86_64 + +if you are on GNU/Linux x86_64 platform and you want voc to use gcc as backend. + +otherwise use corresponding makefile. + +Note for FreeBSD, OpenBSD and OSX users: +use gmake instead of make, i. e. + +>gmake -f makefile.darwin.clang.x86_64 + +then type + +>sudo make install + +or +>sudo gmake -f makefile.darwin.clang.x86_64 install + +on MacOSX/Darwin. + +build rpm +========= + +if you'd like to build an rpm installer, then + +* compress sources as voc-1.0.src.tar.bz2 + assuming you in voc directory +> cd .. +> tar -jcvpf voc-1.0.src.tar.bz2 voc +* put them to ~/rpmbuild/SOURCES (on some systems as root to /usr/src/redhat/SOURCES/) or other similar location. +> mkdir -p ~/rpmbuild/SOURCES +> cp voc-1.0.src.tar.bz2 ~/rpmbuild/SOURCES +* cd to voc directory and run +> rpmbuild -ba voc.spec + +this should create voc rpm installers. + + +-- noch diff --git a/FAQ.md b/triage/FAQ.md similarity index 70% rename from FAQ.md rename to triage/FAQ.md index 0420f66b..805f2bec 100644 --- a/FAQ.md +++ b/triage/FAQ.md @@ -10,13 +10,18 @@ In case you still want to use line numbers then pass -l option to voc voc -ls m.Mod -compilation crashes on ARM or Raspberry Pi with recent (like 3.12) kernels. +compilation crashes on Ubuntu 15.10 x86_64 or latest Raspbians on Raspberry Pi with recent (like 3.12) kernels. =========================================================================== > echo 1 > /proc/sys/vm/legacy_va_layout should fix that. +compilation crashes with "cannot find -lc" on recent fedoras +============================================================ + +remove -static from makefile on the line where voc binary created (first -static you'll find) + make errors on freebsd ====================== diff --git a/triage/README.md b/triage/README.md new file mode 100644 index 00000000..c090fcc6 --- /dev/null +++ b/triage/README.md @@ -0,0 +1,128 @@ + +Vishap oberon compiler +====================== + +[ⱱishap Oberon Compiler](http://oberon.vishap.am) (voc) is a free (GPLv3) professional oberon-2 compiler. + +Platforms: +========= +voc produces x86_64, x86, ppc, armv{4-7} binaries and works on those platforms. +On x86_64 it supports 64bit LONGINT and 64bit SET types. +By using currently stable C backend voc is relatively easy to port to any platform for which C compiler exists. + +Operating Systems: +================== +Currently GNU/Linux, Mac OS X, FreeBSD and OpenBSD sources (with bootstrap binaries) are published. + +Ports to Solaris, AIX will be made and published in case there is an interest from community. +voc should work on MS Windows/ReactOS via Cygwin/gcc, however we did not test it on Windows compatible machine. + +Backends: +========= +voc has stable C backend, which generates human readable and easily debuggable C code. +Generated C code is fairly efficient and does not cause a noticeable overhead. voc was used to generate code even for low end 8 bit devices like nmos6502 and AVR micros. + +Work on native backends for arm and x86_64 is in progress. + +Libraries: +========== +voc comes with a useful set of libraries, in particular: +– Oberon V4 and S3 compatible library set. +– ooc (optimizing oberon-2 compiler) library port. +– Ulm’s Oberon system library port. + +This makes it easier to compile/port software which was developed by using those compilers. + +Work on other compatibility layers is in progress. +voc team also works on bindings to existing C/Pascal libraries. + +Some other freely redistributable libraries are available as a part of voc distribution. + +Licensing: +========== +voc’s frontend and C backend engine is a fork of Josef Templ’s Ofront, which has been released under FreeBSD License. Unlike Ofront, it does not include Oberon v4 environment. +Ulm Oberon Library is distributed under GPL. +ooc library is distributed under GPL. + +voc tools are distributed under GPLv3. +most of the runtime in libVishapOberon is distributed under GPLv3 with runtime exception. +ulm and ooc libraries were distributed under GPL, thus static linking to those modules from libVishapOberon.a to proprietary code is disallowed. + +Naming: +======= +Vishaps are dragons inhabited in Armenian Highlands. +We decided to name the project “Vishap” because ties between compilers and dragons have ancient traditions. + +Also, Vishaps are known in tales, fiction. [This page](http://blog.fogus.me/2015/04/27/six-works-of-computer-science-fiction/) refers to some technologies as “computer science fiction”. Among them to Oberon. This brings another meaning, Oberon is like aliens, ghosts. And Vishaps. + + +How to use +========== + +First you need to [build](https://github.com/norayr/voc/blob/master/COMPILE) it. + +As it is stated in [COMPILE](https://github.com/norayr/voc/blob/master/COMPILE) page, voc is installed in /opt/voc/bin if you did not change the prefix. +So, in order to run voc you need to type + +>/opt/voc/bin/voc + +or add /opt/voc/bin to you PATH environment variable, and then just typing voc will execute it. For that you have to know how to work in Unix shell, and this knowledge is out of the scope of this document. + +Type voc and it'll show you help. + +Simple example +============ + +Let's write hello world file: + +>$ cat hey.Mod + + +MODULE hey; + + IMPORT Console; + +BEGIN + + Console.String("hey there"); Console.Ln + +END hey. + + +>voc -M hey.Mod + +will compile your module and link it statically to libVishapOberon. + +>voc -m hey.Mod + +will link the module dynamically. + +Example with two modules +==================== + +If you have more than one module, and you want them to be compiled in to elf file then: +Let's assume we have module M0 which imports M1; + +>voc -l M1.Mod -s M0.Mod -M + +Here -l is a global option. +Module M1 will be compiled with -s option, i. e. sym file will be generated. + +Module M0 will be compiled and linked statically. + +Example with many modules +====================== + +In case you have modules in different directories, like "ui", "logic", "math", then you need to export MODULES environment variable like this: + +>export MODULES=".:ui:logic:math" + +and after call voc + +>voc -s ui0.Mod + +Otherwise you can use full path: + +>voc -s ui/ui0.Mod + + diff --git a/triage/V2CHANGES.md b/triage/V2CHANGES.md new file mode 100644 index 00000000..65c9de8e --- /dev/null +++ b/triage/V2CHANGES.md @@ -0,0 +1,185 @@ +### Vishap Oberon - Cross-platform Oberon language compiler. + +This is Norayr Chilingarian's Vishap Oberon adapted to build a little more easily on a wider variety of modern platforms, including Linuxes, BSDs, MAC OSx Darwin, Cygwin on Windows, Mingw on Cygwin on Windows, Microsoft Visual C++ and even Android under Termux. See 'Changes relative to Vishap Oberon' below. + +#### How make adapts to each platform + +On all platforms other than Visual C on Windows, make runs from a bash shell, +using makefile in the enlistment root, and vishap.make in the src/tools/make +directory. + +For Visual C only, there is a slightly cut down implementation of the same +functionality in the file 'make.cmd' in the enlistment root. + +In all cases src/tools/make/configure.c is executed to determine all +platform dependent parameters: it generates two files: + + - Configuration.Make: a set of environment variables included by the makefile + - Configuration.Mod: An Oberon MODULE containing just configuraton constants. + +The following examples correspond to a 32 bit Ubuntu build using GCC: + +Configuration.Make: + + OLANGDIR=/home/dave/projects/oberon/olang + COMPILER=gcc + OS=ubuntu + VERSION=1.2 + ONAME=voc + DATAMODEL=ILP32 + INTSIZE=2 + ADRSIZE=4 + ALIGNMENT=4 + INSTALLDIR=/opt/voc + PLATFORM=unix + BINEXT= + COMPILE=gcc -fPIC -g + STATICLINK=-static + LDCONFIG=if echo "/opt/voc/lib" >/etc/ld.so.conf.d/libvoc.conf; then ldconfig; fi + +Configuration.Mod: + + MODULE Configuration; + CONST + name* = 'voc'; + versionLong* = '1.2 [2016/06/11] for gcc ILP32 on ubuntu'; + intsize* = 2; + addressSize* = 4; + alignment* = 4; + objext* = '.o'; + objflag* = ' -o '; + linkflags* = ' -L"'; + libspec* = ' -l voc'; + compile* = 'gcc -fPIC -g'; + dataModel* = 'ILP32'; + installdir* = '/opt/voc'; + staticLink* = '-static'; + END Configuration. + + +#### Changes relative to Vishap Oberon + +The biggest changes relative to Vishap Oberon are in the build system and in the implementation of platform specific support. Where possible platform specific code has removed or replaced by platform agnostic code. + + - The same make commands are used for all platforms, Linux, BSD, Darwin and Windows. In particular 'make full' +builds the compiler, library and tools, installs the compiler and tools, and runs a couple of confidence tests. + + - The C program 'configure.c', a much expanded version of vocparam.c, generates all the platform specific make variables, and the configuration constants compiled into the compiler. Configure.c is compiled and executed at the start of every make command. + + - Both makefiles are platform independent, compatible with both BSD make and GNU make. (For Visual C builds on Windows a separate make.cmd contains the equivalent functionality expressed as a Windows .cmd file.) + + - All duplicate files required to build Linux/BSD/Darwin variants have been removed by refactoring them to be platform independent: + - Rather than accessing Linux structures through Oberon RECORDs intended to match their memory layout, code procedures are used to reference C constants and struct fields directly. (This resolves a number of complexities with structure field order and layout variations across operating systems.) + - Size dependent code is abstracted into simple definitions in SYSTEM.h and referenced from code procedures. + - Files.Mod is extended with a file search path feature removing the need for Files0.Mod, Text0.Mod and Kernel0.Mod. Instead OPM.cmdln.Mod calls the new Files.SetSearchPath. + - Kernel.Mod, Unix.Mod and SYSTEM.Mod are refactored into Heap.Mod and PlatformUnix.Mod. An alternate Platform module implementation PlatformWindows.Mod is used for Microsoft C based builds, using the Win32 API directly. + - All use of the LONGINT type in C source, including in code procedures, now explicitly specify 'LONGINT'. Previously the code often used 'long' instead, assuming it was interchangeable with 'LONGINT', but for some platforms LONGINT is 'long long', not 'long'. + + - The enlistment no longer includes compiled binaries. Instead it includes pre-translated sets of C source covering both platforms and the three C data model variants. (See directory 'bootstrap'.) + + - The bootstrap sources are used on any fresh enlistment or clean build ('make full' is always a clean build). These sources, combined with the platform independence improvements outlined above, have built correctly from a fresh enlistment on all Linux, BSD and cygwin platforms that I have tried, including the raspberry pi under raspbian, and in the termux terminal emulator on android. + +The result is that there is now a single version of earch Oberon source file, with the exceptions only of PlatformUnix.Mod/PlatformWindows.Mod in the compiler, and oocCILP32.Mod/oocCLP64.Mod/oocCLLP64.Mod in the ooc library. + +The full build is now free of warnings: + + - Missing ELSE warnings solved by adding ELSE. + + - C code conversion between integer and pointer of different size solved by casting with with uintptr_t as an intermediate type. + + - C code conversion between signed and unsigned char types solved by explicitly casting 'CHAR's passed to system APIs in code procedures to 'char'. + +The full build now includes a few confidence tests to make sure that the basics work OK. + +HALT/exit code has been simplified. Exit now just calls the system exit API rather than calling the kill API and passing our own process ID. For runtime errors it now displayes the appropriate error message (e.g. Index out of range). + +The jump buffer was not used by any code and has been removed. (It seems from a comment to have been intended for use during some termination code, but the termination code does not use it.) + +Compilation errors now include the line number at the start of the displayed source line. The pos (character offset) is still displayed on the error message line. The error handling code was already doing some walking of the source file to find start and end of line - I changed this to walk through the source file from the start identifying line end positions, counting lines and caching the position at the start of the last error line. The resultant code is simpler, and displays the line number without losing the pos. The performance cost of walking the source file is not an issue. + +##### A few bug fix details: + + - There was a problem with the dynamic array size parameter passed to NEW when expressed as a literal on 64 bit builds. This happens a number of times in the compiler and library. Now in theory it is not necessary to specify the size of numeric literals on parameters to ANSI C functions as the compiler should know the size from the declaration of the called function. (i.e. it shouldn't matter whether one passes '1', '1l', or '1ll'.) +Therefore while OPM.PromoteIntConstToLInt was coded to generate 'l' at the end of long literal parameters on K&R C, it intentionally omitted the 'l' when the compiler was known to be ANSI - and all currently supported compilers are ANSI. +**But** it is not safe to omit the 'l' in literal parameters to C vararg functions: the C compiler cannot get the vararg parameter size from the declaration, and so uses the literal size. Thus only 32 bits are pushed to the stack where 64 bits are required. On a 64 bit Oberon, the implementation of SYSTEM\_NEWARR then reads a full 64 bits. Often the uninitialised 32 bits are zero, and everything works correctly. Rarely they are a very small integer and the system thrashes a while allocating page tables and then continues normally. Other times a segmentation fault or out of memery error is generated. +Removing the test for ANSI and thus always generating the trailing 'l' for LONGINTs is a sufficient fix for the data models supported by the previous versions of Vishap Oberon. +However there is a further complication - this is not sufficient for the LLP64 C data model used by 64 bit Windows. In LLP64, 'long' is only 32 bit. The 64 bit integer type is 'long long' and literal numerics of this type would require an 'll' suffix. +The simple solution was to generate a (LONGINT)(n) typecast, which forces n to the correct size in all cases. + + - SYSTEM.H __VAL(t, x) was defined as (\*(t\*)&(x)) which maps the new type onto the memory of the old. This produces the wrong result if the new type is larger than the old type, because it includes memory that does not belong to the variable into the result. This has been corrected to the simpler ((t)(x)) which will do the appropriate signed or unsigned extension. + + - There was a serious issue with accessing free'd memory in RETURN expressions. Oberon generates code to create local copies of dynamic strings passed by value (so that code is free to change the value parameter without affecting the original string). +The copy is not allocated from the Oberon Heap, but direct from the OS (e.g. via malloc on Linux/Unix). At function return the compiler inserts a call to C's free before the return statement. +The problem comes when the expression on the Oberon RETURN statement references the local string copy. This gets compiled to a C 'return' statement that references the free'd memory. Sometimes the C free will not have modified the string copy, and no error is seen. However all bets are off - the OS or C runtime could have done anything to this memory as part of heap management (e.g. used it for free chain linkage), and with pre-emptive multitasking it may have been reallocated and used for another purpose before the return expression refers to it. This bug hit me occasionally and took a while to find. +The solution I have implemented is to generate declaration of a return value variable at the entry of every function, and to generate code to evaluate the return expression into the variable *before* generating the code to free the local string copy. +In theory the Oberon compiler could inspect the return value for reference to a local copy and only generate the result variable when necessary, however this considerably complicate the Oberon compiler source code for procedure entry and would be of questionalble value, as the C compiler should be able to optimize code with a result variable much the same as code without it. + + - Texts.WriteInt corrected to work with both 4 and 8 byte LONGINTs. Previously values with more than 11 digits caused an index out of range error. + + - Between voc.Translate and extTools.Mod, the main program was being compiled twice by the C compiler. It is now compiled once. + +#### Other changes: + + - In his latest specs (around 2013) Wirth removed the 'COPY(a, b)' character array copy procedure, replacing it with 'b := a'. I have accordingly enabled 'b := a' in voc as an alternative to 'COPY(a, b)' (COPY is still supported.). + + - Oberon code often writes to Oberon.Log expecting the text to appear on the screen. While voc has an Oberon.DumpLog procedure, I looked into making the behaviour automatic. Interestingly the voc source declares the Text notifier constants replace, insert and delete, but omits implementation of the notifier calls. The implementation turned out to be very little code, and I have used it to echo all text written to Oberon.Log to the console. This has the advantage over DumpLog that text is written immediately rather than only when DumpLog is called, and allows existing program source to work unchanged. + + - While working on Vishap Oberon I have been using the name 'olang' rather than 'voc', partly to avoid mixing up binary files, and partly because I had not (re)reached compatability with voc. Since I reckon I'm close to complete, I have now parameterised the code to allow any file name for the compiler and install dir, and switched it back to 'voc' by default. src/tools/make/configure.c line 12 specifies the name that will be built. + + - I experimented with making INTEGER always 32 bit and LONGINT always 64 bit (i.e. even on 32 bit platfroms), but soon found that the libraries assume 16 bit INTEGER and 32 bit LONGINT all over the place. This experimental behaviour is still available by uncommenting the '#define LARGE' in src/tools/make/configure.c line 14. + +#### Machine size issues + +I don't see any really good solutions to different machine sizes. Existing code, such as the libraries, assumes that INTEGER is 16 bit and LONGINT is 32 bit and so is broken on 64 bit builds of voc. + +Looking at the voc source I see an unfinished implementaton of built-in types INT8, INT16, INT32 and INT64. Since this code is neither complete nor tested and I have not retained where it has been in the way of changes. + +Could the implementation of INTxx help? It does not solve (for example) the need for a type that always matches address size. Nor does it provide unsigned types. Implementation of low level memory management ideally needs both. + +Wirth's latest spec includes a BYTE type (not SYSTEM.BYTE, just BYTE) that behaves as an unsigned 8 bit integer, for use in low level code. BYTE thus avoids the need for SYSTEM.VAL when manipulating 8 bit unsigned numeric values, making code easier to write and, more importantly, easier to read. A BYTE type would be useful for microcontroller C support. So I believe it makes sense to add Wirths's BYTE to voc. (I have not done so yet). + +Linux/Unix specifies many API datatypes and structure fields in terms of named C numeric types, with the result that they vary in size between implementations. This is perhaps the strongest driving force for adding support for various numeric types to voc - but they would better match the C types than be of fixed size. + +So maybe one could provide Platform.int, Platform.long, Platform.longlong, Platform.unsignedint, Platform.unsignedlong, Platform.unsignedlonglong and, importantly for memory management, Platform.uintptr. + +Personally I miss Pascal and Modula's subrange variables. As well as being great for error detection (assuming value checking code is generated), they can also be used to imply variables of arbitrary sizes (e.g. 'VAR mybyte = 0..255;'). With these one could remove the Platform.int* types and replace them with constants Platform.MaxInt, Platform.MaxLong etc. I think this would be a cleaner more generalised option - but maybe, probably, it is a step too far. Always beware of over-generalising. Wirth found that most programmers did not use, or very rarely used, subrange types. + +#### A feature I'd really like to see + +When exiting abnormally, e.g. due to index out of range, report .Mod file name and line number at fault. Preferably include a stack trace. Wirth's original Pascal (Pascal 6000 on the CDC mainframe at ETHZ) had this at least by 1975 when I first used it. This could be achieved by including a table of line number (in .Mod file) vs code address, and having the runtime seach this table for the failure address. It would be quite a lot of work! + +#### Norayr/voc issues addressed + +The following issues are taken from https://github.com/norayr/voc/issues. + +##### Issue 7 - 'silence ccomp warnings'. +This has been done. + +##### Issue 9 - 'oberon.par arguments'. +Done for all supported platforms including Ubuntu, FreeBSD, OpenBSD, Raspbian, Darwin, Cygwin and MS C, on a mixture of 32 and 64 bit architectures. + +The vast majority of info in the .par file is redundant. For example the size and alignment of char, unsigned char, int and float is independent of platform. + +A single value is sufficient to specify alignment: above this size this value is the alignment, below this size, the alignment is the same as the type size. (Actually the latter is the type size rounded up to the enclosing power of two, but as all the Oberon type sizes are powers of two this step is unecessary.) + +The only platform differences come around the meaning of 'long' vs 'long long', pointer size and alignment of 64 bit values. These are just 3 possible combinations: + +| Pointer size | Alignment | Used on | Bootstrap directories | +| ------------ | --------- | ---------------- | --------------------- | +| 32 bit | 32 bit | Unix | unix-44 | +| 32 bit | 64 bit | Unix and Windows | unix-48, windows-48 | +| 64 bit | 64 bit | Unix and Windows | unix-88, windows-88 | + +The various C data models are named using common C compiler terminology as follows: + +| Name | 'int' size | 'long' size | 'long long' size | pointer size | +| ----- | ---------- | ----------- | ---------------- | ------------ | +| ILP32 | 32 | 32 | 64 | 32 | +| LLP64 | 32 | 32 | 64 | 64 | +| LP64 | 32 | 64 | 64 | 64 | + +##### Issue 13 - 'prepare Linux/x86asm target'. +Linux is currently compiled using PlatfromUnix.Mod, but the integration of Windows support has made the Platform interface reasonably OS independent, so implementing a PlatformLinux.Mod using Linux kernel calls directly should be straightforward. + +##### Issue 14 - 'separate rtl from SYSTEM?'. +OS specific code is now all in Platformxxx.Mod. Memory management (including the loaded module list) is now in Heap.Mod. SYSTEM.h is platform independent, with minimal ifdefs to allow compiling on all platforms. For example, when SYSTEM.h/SYSTEM.c need to allocate memory, or to halt, they call into Platform.Mod. diff --git a/gen_changelog.sh b/triage/gen_changelog.sh old mode 100755 new mode 100644 similarity index 100% rename from gen_changelog.sh rename to triage/gen_changelog.sh diff --git a/hints b/triage/hints similarity index 93% rename from hints rename to triage/hints index 29585f90..2722e294 100644 --- a/hints +++ b/triage/hints @@ -27,13 +27,13 @@ add it in OPC.GenHeaderMsg function. ==known bugs== -when using SYSTEM.LSH(s, n) where s is SET, +when using SYSTEM.LSH(s, n) where s is SET, c compiler generates an error like -"error: duplicate 'unsigned'", +"error: duplicate 'unsigned'", that's because SET is defined as unsigned in SYSTEM.h, -while LSH is defined in SYSTEM.h as ((t)((unsigned t)(x)<<(n))), +while LSH is defined in SYSTEM.h as ((t)((unsigned t)(x)<<(n))), and it makes not possible to make SYSTEM.LSH with type SET. -I don't want to prohibit it at the parser level +I don't want to prohibit it at the parser level because C backend is only one of possible backends. The solution currently is to cast set type to longint before lsh-ing it. And then casting it back to set if necessary. diff --git a/makefile.linux.gcc.x86_64 b/triage/makefile similarity index 95% rename from makefile.linux.gcc.x86_64 rename to triage/makefile index 60f338e3..e0513400 100644 --- a/makefile.linux.gcc.x86_64 +++ b/triage/makefile @@ -9,7 +9,7 @@ RELEASE = 1.1 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/lib/s3/$(TARCH):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 +SETPATH = CFLAGS=$(INCLUDEPATH) PATH=.:/bin:/usr/bin MODULES=.:src/lib:src/lib/v4:src/lib/v4/$(TARCH):src/lib/v4_compat: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/lib/s3/$(TARCH):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) @@ -25,7 +25,7 @@ endif PREFIX = $(PRF)/voc-$(RELEASE) PREFIXLN = $(PRF)/voc -CCOPT = -fPIC $(INCLUDEPATH) -g +CCOPT = -fPIC $(INCLUDEPATH) -g -fno-stack-protector SHRLIBEXT = so CC = $(CCOMP) $(CCOPT) -c CL = $(CCOMP) $(CCOPT) diff --git a/quick_start b/triage/quick_start similarity index 100% rename from quick_start rename to triage/quick_start diff --git a/voc.spec b/triage/voc.spec similarity index 100% rename from voc.spec rename to triage/voc.spec diff --git a/vocstatic.darwin.clang.x86_64.REMOVED.git-id b/vocstatic.darwin.clang.x86_64.REMOVED.git-id deleted file mode 100644 index 67681f22..00000000 --- a/vocstatic.darwin.clang.x86_64.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -d1de9860a41f9745ed7c65ba12a72d48b027254b \ No newline at end of file diff --git a/vocstatic.freebsd.clang.x86_64.REMOVED.git-id b/vocstatic.freebsd.clang.x86_64.REMOVED.git-id deleted file mode 100644 index 37650040..00000000 --- a/vocstatic.freebsd.clang.x86_64.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -ec008a6f32a2574154feb12f998db0e80033d6f6 \ No newline at end of file diff --git a/vocstatic.linux.clang.powerpc.REMOVED.git-id b/vocstatic.linux.clang.powerpc.REMOVED.git-id deleted file mode 100644 index 89beeed3..00000000 --- a/vocstatic.linux.clang.powerpc.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -2f4dc20af5c16d407874c567be2a8e38066415a5 \ No newline at end of file diff --git a/vocstatic.linux.clang.x86_64.REMOVED.git-id b/vocstatic.linux.clang.x86_64.REMOVED.git-id deleted file mode 100644 index c5568552..00000000 --- a/vocstatic.linux.clang.x86_64.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -60f429e97d6f7f05367e3cb1a2b8ac20f78add86 \ No newline at end of file diff --git a/vocstatic.linux.gcc.armv6j_hardfp.REMOVED.git-id b/vocstatic.linux.gcc.armv6j_hardfp.REMOVED.git-id deleted file mode 100644 index 140444df..00000000 --- a/vocstatic.linux.gcc.armv6j_hardfp.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -4e13e8eb6afaaa783a650a7a9b305c092511996f \ No newline at end of file diff --git a/vocstatic.linux.gcc.powerpc.REMOVED.git-id b/vocstatic.linux.gcc.powerpc.REMOVED.git-id deleted file mode 100644 index 48ac8ce1..00000000 --- a/vocstatic.linux.gcc.powerpc.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -a5546b6a3b8c855488524311e30f59082e8b0896 \ No newline at end of file diff --git a/vocstatic.linux.gcc.x86.REMOVED.git-id b/vocstatic.linux.gcc.x86.REMOVED.git-id deleted file mode 100644 index 73263b3c..00000000 --- a/vocstatic.linux.gcc.x86.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -aa000f8331215f4a722bf96a6914775e7b9a037f \ No newline at end of file diff --git a/vocstatic.linux.gcc.x86_64.REMOVED.git-id b/vocstatic.linux.gcc.x86_64.REMOVED.git-id deleted file mode 100644 index 8a6ca190..00000000 --- a/vocstatic.linux.gcc.x86_64.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -924b37cbff137a08805e86eb63403bda0495cf16 \ No newline at end of file