first commit

BlackBox/BlackBox

@@ -0,0 +1 @@
+../c/BlackBox

BlackBox/Init-Interp.txt

@@ -0,0 +1,7 @@
+MODULE Init;
+
+	IMPORT Interp;
+
+BEGIN
+	Interp.Init
+END Init.

BlackBox/Interp.txt

@@ -0,0 +1,54 @@
+MODULE Interp;
+
+	(*
+		A. V. Shiryaev, 2012.09
+
+		(Std)Interpreter on (Lin)Console
+	*)
+
+	IMPORT Console, LinConsole (* required *), Strings, Dialog, StdInterpreter (* required (Dialog.SetCallHook) *);
+
+	PROCEDURE WriteInt (x: INTEGER);
+		VAR s: ARRAY 16 OF CHAR;
+	BEGIN
+		Strings.IntToString(x, s);
+		Console.WriteStr(s)
+	END WriteInt;
+
+	PROCEDURE Call (VAR s: ARRAY OF CHAR): BOOLEAN;
+		VAR i: INTEGER;
+			res: BOOLEAN;
+	BEGIN
+		i := 0;
+		WHILE (i < LEN(s)) & (s[i] # 0AX) & (s[i] # 0DX) & (s[i] # 0X) DO
+			INC(i)
+		END;
+		IF (i < LEN(s)) & (s[i] # 0X) THEN
+			IF (i > 0) & (s[0] # '#') THEN
+				s[i] := 0X;
+				Dialog.Call(s, "", i);
+				IF i = 0 THEN
+					res := TRUE
+				ELSE
+					WriteInt(i); Console.WriteLn;
+					res := FALSE (* stop on Dialog.Call error *)
+				END
+			ELSE (* skip empty strings and comments *)
+				res := TRUE
+			END
+		ELSE (* end of input *)
+			res := FALSE
+		END;
+	RETURN res
+	END Call;
+
+	PROCEDURE Init*;
+		VAR s: ARRAY 1024 OF CHAR;
+	BEGIN
+		Console.ReadLn(s);
+		WHILE Call(s) DO
+			Console.ReadLn(s)
+		END
+	END Init;
+
+END Interp.

BlackBox/Lin/Mod/Console.txt

@@ -0,0 +1,113 @@
+MODULE LinConsole;
+
+	(* THIS IS TEXT COPY OF OpenBUGS Lin/Mod/Console.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT
+		SYSTEM,
+		Console,
+		LinLibc;
+
+	TYPE
+		LinCons = POINTER TO RECORD (Console.Console) END;
+
+		LinProcess = POINTER TO RECORD (Console.Process) END;
+
+	CONST
+		strLen = 1024;
+
+	VAR
+		s: ARRAY strLen OF CHAR;
+		ss: ARRAY strLen OF SHORTCHAR;
+		linCons: LinCons;
+		version-: INTEGER;
+		maintainer-: ARRAY 40 OF CHAR;
+
+	PROCEDURE (cons: LinCons) ReadLn (OUT text: ARRAY OF CHAR);
+		VAR
+			i: INTEGER;
+			str: POINTER TO ARRAY [untagged] OF SHORTCHAR; 
+	BEGIN
+		str := LinLibc.fgets(ss, strLen, LinLibc.stdin);
+		IF (str = NIL) THEN 
+			(* if end of file, then ss is not changed by fgets and NIL is returned. 
+			    We return an empty string here *)
+			text[0] := 0X;
+			RETURN
+		END;			
+		i := 0;
+		REPEAT
+			text[i] := ss[i];
+			INC(i)
+		UNTIL (ss[i] = 0X) OR (i = LEN(text) - 1);
+		text[i] := 0X 
+	END ReadLn;
+
+	PROCEDURE Printf;
+		VAR res: INTEGER;
+	BEGIN
+		res := LinLibc.printf(ss);
+		res := LinLibc.fflush(LinLibc.NULL)
+	END Printf;
+
+	PROCEDURE (cons: LinCons) WriteChar (c: CHAR);
+	BEGIN
+		s[0] := c;
+		s[1] := 0X;
+		ss := SHORT(s);
+		Printf()
+	END WriteChar;
+
+	PROCEDURE (cons: LinCons) WriteStr (IN text: ARRAY OF CHAR);
+	BEGIN
+		ss := SHORT(text);
+		Printf()
+	END WriteStr;
+
+	PROCEDURE (cons: LinCons) WriteLn;
+	BEGIN
+		ss[0] := 0AX;
+		ss[1] := 0X;
+		Printf()
+	END WriteLn;
+
+	PROCEDURE (cons: LinCons) Open;
+	BEGIN
+	END Open;
+
+	PROCEDURE (cons: LinCons) Close;
+	BEGIN
+	END Close;
+
+	PROCEDURE (cons: LinCons) CreateProcess (cmdLine: ARRAY OF CHAR): Console.Process;
+	BEGIN
+		(*	needs coding	*)
+		RETURN NIL
+	END CreateProcess;
+
+	PROCEDURE (cons: LinCons) CommandLine (OUT cmdLine: ARRAY OF CHAR);
+	BEGIN
+
+	END CommandLine;
+
+	PROCEDURE (p: LinProcess) Terminate;
+	BEGIN
+		(*	needs coding	*)
+	END Terminate;
+
+	PROCEDURE Maintainer;
+	BEGIN
+		version := 303;
+		maintainer := "A.Thomas"
+	END Maintainer;
+
+	PROCEDURE Init;
+	BEGIN
+		Maintainer;
+		NEW(linCons);
+		Console.SetConsole(linCons)
+	END Init;
+
+BEGIN
+	Init
+END LinConsole.

BlackBox/Lin/Mod/Kernel_so_init.txt

@@ -0,0 +1,27 @@
+MODULE Kernel_so_init;
+
+	(* THIS IS TEXT COPY OF Kernel_so_init.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT Kernel, SYSTEM;
+
+	PROCEDURE SetKernelBaseStack* (x: INTEGER);
+		VAR
+			m: Kernel.Module;
+			ref, adr: INTEGER; mode, form: SHORTCHAR; desc: Kernel.Type; name: Kernel.Name;
+	BEGIN
+		m := Kernel.modList;
+		WHILE (m # NIL) & ~(m.name = "Kernel") DO
+			m := m.next
+		END;
+		ASSERT(m # NIL, 100);
+		ref := m.refs; Kernel.GetRefProc(ref, adr, name); ASSERT(adr # 0, 101);
+		Kernel.GetRefVar(ref, mode, form, desc, adr, name);
+		WHILE (mode = 1X) & ~(name = "baseStack") DO
+			Kernel.GetRefVar(ref, mode, form, desc, adr, name)
+		END;
+		ASSERT(mode = 1X, 102); ASSERT(form = 6X, 103);
+		SYSTEM.PUT(m.data + adr, x)
+	END SetKernelBaseStack;
+
+END Kernel_so_init.

BlackBox/Lin/Mod/Obsd.Dl.txt

@@ -0,0 +1,35 @@
+MODULE LinDl ["libc.so.66.0"];
+
+	(*
+		A. V. Shiryaev, 2012.09
+
+		OpenBSD 5.2
+		32-bit
+	*)
+
+	IMPORT SYSTEM;
+
+	CONST
+		NULL* = 0H;
+
+		(* from OpenBSD 5.2 /usr/include/dlfcn.h *)
+			RTLD_LAZY* = 1;
+			(* DL_LAZY* = RTLD_LAZY; *) (* compat *)
+			RTLD_NOW* = 2;
+
+			RTLD_GLOBAL* = 100H;
+			RTLD_LOCAL* = 000H;
+			RTLD_TRACE* = 200H;
+
+	TYPE
+		PtrVoid* = INTEGER;
+		HANDLE* = PtrVoid;
+		PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR;
+
+	PROCEDURE [ccall] dlopen* (file: PtrSTR; mode: INTEGER): HANDLE;
+	PROCEDURE [ccall] dlclose* (handle: HANDLE): INTEGER;
+	PROCEDURE [ccall] dlsym* (handle: HANDLE; symbol: PtrSTR): HANDLE;
+
+	PROCEDURE [ccall] dlerror* (): PtrSTR;
+
+END LinDl.

BlackBox/Lin/Mod/Obsd.Libc.txt

@@ -0,0 +1,531 @@
+MODULE LinLibc ["libc.so.66.0"];
+
+	(*
+		A. V. Shiryaev, 2012.09
+
+		Based on Linux' LinLibc (OpenBUGS Lin/Mod/Libc.odc)
+
+		OpenBSD 5.2
+		32-bit
+	*)
+
+	IMPORT SYSTEM;
+
+	CONST
+		NULL* = 0H;
+		TRUE* = 1;
+		FALSE* = 0;
+
+		(* file constants *)
+		SEEK_SET* = 0;
+		SEEK_CUR* = 1;
+		SEEK_END* = 2;
+		NAME_MAX* = 255; (* OpenBSD /usr/include/sys/syslimits.h *)
+
+		(* The value of CLOCKS_PER_SEC is required to be 1 million on all   XSI-conformant systems.*)
+		CLOCKS_PER_SEC* = 100; (* OpenBSD 5.2 /usr/include/time.h CLOCKS_PER_SEC *)
+
+		(* temp directory defined in stdio.h *)
+		P_tmpdir* = "/tmp";
+
+		(* signal constants *)	(* Fake signal functions.  *)
+		(* OpenBSD 5.2 /usr/include/sys/signal.h *)
+		SIG_ERR* = -1; 	(* Error return.  *)
+		SIG_DFL* = 0;   	(* Default action.  *)
+		SIG_IGN* = 1;    	(* Ignore signal.  *)
+		SIG_HOLD* = 3;	(* Add signal to hold mask.  *) (* OpenBSD 5.2 /usr/include/sys/signalvar.h *)
+
+		(* Signals.  *)
+		(* OpenBSD /usr/include/sys/signal.h *)
+		_NSIG* = 33; (* counting 0 (mask is 1-32) *)
+		SIGHUP* = 1; (* hangup *)
+		SIGINT* = 2; (* interrupt *)
+		SIGQUIT* = 3; (* quit *)
+		SIGILL* = 4; (* illegal instruction (not reset when caught) *)
+		SIGTRAP* = 5; (* trace trap (not reset when caught) *)
+		SIGABRT* = 6; (* abort() *)
+		SIGFPE* = 8; (* floating point exception *)
+		SIGKILL* = 9; (* kill (cannot be caught or ignored) *)
+		SIGBUS* = 10; (* bus error *)
+		SIGSEGV* = 11; (* segmentation violation *)
+		SIGSYS* = 12; (* bad argument to system call *)
+		SIGPIPE* = 13; (* write on a pipe with no one to read it *)
+		SIGALRM* = 14; (* alarm clock *)
+		SIGTERM* = 15; (* software termination signal from kill *)
+		SIGURG* = 16; (* urgent condition on IO channel *)
+		SIGSTOP* = 17; (* sendable stop signal not from tty *)
+		SIGTSTP* = 18; (* stop signal from tty *)
+		SIGCONT* = 19; (* continue a stopped process *)
+		SIGCHLD* = 20; (* to parent on child stop or exit *)
+		SIGTTIN* = 21; (* to readers pgrp upon background tty read *)
+		SIGTTOU* = 22; (* like TTIN for output if (tp->t_local&LTOSTOP) *)
+		SIGXCPU* = 24; (* exceeded CPU time limit *)
+		SIGXFSZ* = 25; (* exceeded file size limit *)
+		SIGVTALRM* = 26; (* virtual time alarm *)
+		SIGPROF* = 27; (* profiling time alarm *)
+		SIGUSR1* = 30; (* user defined signal 1 *)
+		SIGUSR2* = 31; (* user defined signal 2 *)
+		SIGWINCH* = 28; (* window size changes *)
+
+
+		(* Bits in `sa_flags'.  *)
+		SA_NOCLDSTOP* = {3}; 	(* = 1 Don't send SIGCHLD when children stop.  *) (* OpenBSD *)
+		SA_NOCLDWAIT* = {5}; 	(* = 2 Don't create zombie on child death.  *) (* OpenBSD *)
+		SA_SIGINFO* = {6}; 	(* = 4 Invoke signal-catching function wth three arguments instead of one.  *) (* OpenBSD *)
+		SA_ONSTACK* = {0};	(* = 0x08000000 Use signal stack by using `sa_restorer'. *) (* OpenBSD *)
+		SA_RESTART* = {1};	(* = 0x10000000 Restart syscall on signal return.  *) (* OpenBSD *)
+		SA_NODEFER* = {4};	(* = 0x40000000 Don't automatically block the signal when its handler is being executed. *) (* OpenBSD *)
+		SA_RESETHAND* = {2};	(* = 0x80000000 Reset to SIG_DFL on entry to handler.  *) (* OpenBSD *)
+		(* SA_INTERRUPT* = {29};	(* = 0x20000000  Historical no-op.  *) *) (* OpenBSD *)
+		(* Some aliases for the SA_ constants.  *)
+		SA_NOMASK* = SA_NODEFER;
+		SA_ONESHOT* = SA_RESETHAND;
+		SA_STACK* = SA_ONSTACK;
+
+		(* code values for siginfo_t.si_code when sig = SIGFPE *)
+		(* OpenBSD 5.2: OK, the same *)
+		FPE_INTDIV* = 1;	(* Integer divide by zero.  *)
+		FPE_INTOVF* = 2;	(* Integer overflow.  *)
+		FPE_FLTDIV* = 3;	(* Floating point divide by zero.  *)
+		FPE_FLTOVF* = 4;	(* Floating point overflow.  *)
+		FPE_FLTUND* = 5;	(* Floating point underflow.  *)
+		FPE_FLTRES* =6;	(* Floating point inexact result.  *)
+		FPE_FLTINV* = 7;	(* Floating point invalid operation.  *)
+		FPE_FLTSUB* = 8;	(* Subscript out of range.  *)
+
+		(* possible error constants for errno *)
+		(* OpenBSD /usr/include/sys/errno.h *)
+		EPERM* = 1; (* Operation not permitted *)
+		ENOENT* = 2; (* No such file or directory *)
+		ESRCH* = 3; (* No such process *)
+		EINTR* = 4; (* Interrupted system call *)
+		EIO* = 5; (* Input/output error *)
+		ENXIO* = 6; (* Device not configured *)
+		E2BIG* = 7; (* Argument list too long *)
+		ENOEXEC* = 8; (* Exec format error *)
+		EBADF* = 9; (* Bad file descriptor *)
+		ECHILD* = 10; (* No child processes *)
+		EDEADLK* = 11; (* Resource deadlock avoided *)
+		ENOMEM* = 12; (* Cannot allocate memory *)
+		EACCES* = 13; (* Permission denied *)
+		EFAULT* = 14; (* Bad address *)
+		EBUSY* = 16; (* Device busy *)
+		EEXIST* = 17; (* File exists *)
+		EXDEV* = 18; (* Cross-device link *)
+		ENODEV* = 19; (* Operation not supported by device *)
+		ENOTDIR* = 20; (* Not a directory *)
+		EISDIR* = 21; (* Is a directory *)
+		EINVAL* = 22; (* Invalid argument *)
+		ENFILE* = 23; (* Too many open files in system *)
+		EMFILE* = 24; (* Too many open files *)
+		ENOTTY* = 25; (* Inappropriate ioctl for device *)
+		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; (* Numerical argument out of domain *)
+		ERANGE* = 34; (* Result too large *)
+		EAGAIN* = 35; (* Resource temporarily unavailable *)
+		EWOULDBLOCK* = EAGAIN; (* Operation would block *)
+		EINPROGRESS* = 36; (* Operation now in progress *)
+		EALREADY* = 37; (* Operation already in progress *)
+		ENOTSOCK* = 38; (* Socket operation on non-socket *)
+		EDESTADDRREQ* = 39; (* Destination address required *)
+		EMSGSIZE* = 40; (* Message too long *)
+		EPROTOTYPE* = 41; (* Protocol wrong type for socket *)
+		ENOPROTOOPT* = 42; (* Protocol not available *)
+		EPROTONOSUPPORT* = 43; (* Protocol not supported *)
+		EOPNOTSUPP* = 45; (* Operation not supported *)
+		EAFNOSUPPORT* = 47; (* Address family not supported by protocol family *)
+		EADDRINUSE* = 48; (* Address already in use *)
+		EADDRNOTAVAIL* = 49; (* Can't assign requested address *)
+		ENETDOWN* = 50; (* Network is down *)
+		ENETUNREACH* = 51; (* Network is unreachable *)
+		ENETRESET* = 52; (* Network dropped connection on reset *)
+		ECONNABORTED* = 53; (* Software caused connection abort *)
+		ECONNRESET* = 54; (* Connection reset by peer *)
+		ENOBUFS* = 55; (* No buffer space available *)
+		EISCONN* = 56; (* Socket is already connected *)
+		ENOTCONN* = 57; (* Socket is not connected *)
+		ETIMEDOUT* = 60; (* Operation timed out *)
+		ECONNREFUSED* = 61; (* Connection refused *)
+		ELOOP* = 62; (* Too many levels of symbolic links *)
+		ENAMETOOLONG* = 63; (* File name too long *)
+		ENOTEMPTY* = 66; (* Directory not empty *)
+		EDQUOT* = 69; (* Disk quota exceeded *)
+		ESTALE* = 70; (* Stale NFS file handle *)
+		ENOLCK* = 77; (* No locks available *)
+		ENOSYS* = 78; (* Function not implemented *)
+		EILSEQ* = 84; (* Illegal byte sequence *)
+		EIDRM* = 89; (* Identifier removed *)
+		ENOMSG* = 90; (* No message of desired type *)
+		ENOTSUP* = 91; (* Not supported *)
+
+
+		(* OpenBSD 5.2 /usr/include/i386/setjmp.h *)
+		_JBLEN = 10;
+
+		(* OpenBSD 5.2 /usr/include/sys/mman.h *)
+		PROT_NONE* = {}; (* no permission *)
+		PROT_READ* = {0}; (* pages can be read *)
+		PROT_WRITE* = {1}; (* pages can be written *)
+		PROT_EXEC* = {2}; (* pages can be executed *)
+
+		(* OpenBSD 5.2 /usr/include/i386/param.h *)
+		PAGE_SHIFT* = 12;
+		PAGE_SIZE* = 4096; (* LSL(1, PAGE_SHIFT) *)
+		PAGE_MASK* = PAGE_SIZE - 1;
+
+	TYPE
+		(* OpenBSD OK *)
+		__ftw_func_t* = PROCEDURE (fileName: PtrSTR; VAR [nil] stat: stat_t; flag: INTEGER): INTEGER; (* OpenBSD 5.2: OK *)
+		PtrVoid* = INTEGER;
+		PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR;
+		PtrWSTR* = POINTER TO ARRAY [untagged] OF CHAR;
+		PtrInt* = INTEGER;
+		StrArray* = POINTER TO ARRAY [untagged] OF PtrSTR;
+		PtrFILE* = INTEGER;
+		PtrDIR* = INTEGER;
+		PtrProc* = INTEGER;
+		clock_t* = INTEGER; (* OpenBSD 5.2 /usr/include/i386/_types.h: 32-bit *)
+
+		(* jmp_buf* = ARRAY [untagged] 6 OF INTEGER; (* bx, si, di, bp, sp, pc *) *)
+		jmp_buf* = ARRAY [untagged] _JBLEN OF INTEGER; (* OpenBSD 5.2 *)
+
+		mode_t* = SET; (* OpenBSD 5.2: 32-bit *)
+		off_t* = LONGINT; (* OpenBSD 5.2: 64-bit *)
+
+		SelectorFunc* = PROCEDURE (dirent: Dirent): INTEGER; (* OpenBSD 5.2: OK *)
+		CmpFunc* = PROCEDURE (VAR [nil] dirent1, dirent2: PtrDirent): INTEGER; (* OpenBSD 5.2: OK *)
+
+		size_t* = INTEGER; (* should be unsigned int *) (* OpenBSD 5.2: /usr/include/i386/_types.h: 32-bit *)
+
+		sigjmp_buf* = RECORD [untagged] (* OpenBSD 5.2 *)
+			buf*: jmp_buf;
+
+			(* mask_was_saved*: INTEGER;
+			saved_mask*: sigset_t; *) (* OpenBSD *)
+
+			xxx: INTEGER;
+		END;
+
+		PtrDirent* = POINTER TO Dirent;
+		PtrDirentArray* = POINTER TO ARRAY [untagged] OF Dirent;
+
+		Dirent* = RECORD  [untagged] (* OpenBSD 5.2 /usr/include/sys/dirent.h *)
+			(*
+			d_ino*: INTEGER;	(* inode number *)
+			d_off*: off_t;	(* offset to this dirent *)
+			d_reclen*: SHORTINT;	(* length of this d_name *)
+			d_type*: BYTE;
+			d_name*: ARRAY[untagged]  NAME_MAX+1 OF SHORTCHAR;		(* file name (null-terminated) *)
+			*)
+
+			d_fileno*: INTEGER;
+			d_reclen*: SHORTINT;
+			d_type*: BYTE;
+			d_namlen*: BYTE;
+			d_name*: ARRAY [untagged] NAME_MAX + 1 (* 256 *) OF SHORTCHAR;
+		END;
+
+		pid_t* = INTEGER; (* OpenBSD 5.2: 32-bit *)
+		uid_t* = INTEGER; (* OpenBSD 5.2: 32-bit *)
+
+		sigval_t* = INTEGER; (* OpenBSD: 32-bit (union sigval) *)
+
+		siginfo_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/siginfo.h *)
+			si_signo*: INTEGER; 	(* Signal number *) (* OpenBSD: 32-bit *)
+			si_code*: INTEGER;   	(* Signal code *) (* OpenBSD: 32-bit *)
+			si_errno*: INTEGER;  	(* An errno value *) (* OpenBSD: 32-bit *)
+
+			(* OpenBSD 5.2: 29 * 4 B below *)
+
+			si_pid*: pid_t;    	(* Sending process ID *)
+			si_uid*: uid_t;    	(* Real user ID of sending process *)
+			si_status*: INTEGER; 	(* Exit value or signal *) (* OpenBSD 5.2: 32-bit *)
+
+			(* si_utime*: clock_t;  	(* User time consumed *) *) (* OpenBSD: XXX *)
+			si_stime*: clock_t;  	(* System time consumed *)
+			(* si_value*: sigval_t;  	(* Signal value *) *) (* OpenBSD: XXX *)
+			(* si_int*: INTEGER;    	(* POSIX.1b signal *) *) (* OpenBSD: XXX *)
+			(* si_ptr*: PtrVoid;    	(* POSIX.1b signal *) *) (* OpenBSD: XXX *)
+			(* si_addr*: PtrVoid;   	(* Memory location which caused fault *) *) (* OpenBSD: XXX *)
+			(* si_band*: INTEGER;   	(* Band event *) *) (* OpenBSD: XXX *)
+			(* si_fd*: INTEGER;     	(* File descriptor *) *) (* OpenBSD: XXX *)
+
+			xxx: ARRAY [untagged] 25 OF INTEGER; (* OpenBSD *)
+		END;
+		Ptrsiginfo_t* = POINTER TO siginfo_t;
+
+		(* sigset_t* = ARRAY [untagged] 128 OF BYTE; *)
+		sigset_t* = ARRAY [untagged] 4 OF BYTE; (* OpenBSD 5.2 /usr/include/sys/signal.h *)
+
+		Ptrsigset_t* = INTEGER;
+		sigaction_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/signal.h *)
+			sa_sigaction*: PROCEDURE (sig: INTEGER; siginfo: Ptrsiginfo_t; ptr: Ptrucontext_t); (* union with sa_handler*: PtrProc;*)
+			sa_mask*: sigset_t;
+			sa_flags*: SET;
+			(* sa_restorer*: LONGINT; *) (* OpenBSD *)
+		END;
+
+		stack_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/signal.h *)
+			ss_sp*: PtrVoid;
+			ss_size*: size_t; (* OpenBSD *)
+			ss_flags*: INTEGER; (* OpenBSD *)
+		END;
+
+		dev_t* = INTEGER; (* OpenBSD: 32-bit *)
+		gid_t* = INTEGER; (* OpenBSD: 32-bit *)
+
+		stat_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/stat.h *)
+			st_dev*: dev_t;	(* device *) (* OpenBSD: 32-bit *)
+			(* __pad1: SHORTINT; *) (* OpenBSD *)
+			st_ino*: INTEGER;	(* 64? inode *) (* OpenBSD: 32-bit *)
+			st_mode*: mode_t;	(* protection *) (* OpenBSD: 32-bit *)
+			st_nlink*: INTEGER; 	(* number of hard links *) (* OpenBSD: 32-bit *)
+			st_uid*: uid_t;	(* user ID of owner *) (* OpenBSD: 32-bit *)
+			st_gid*: gid_t;	(* group ID of owner *) (* OpenBSD: 32-bit *)
+			st_rdev*: dev_t;	(* device type (if inode device) *) (* OpenBSD: 32-bit *)
+			st_lspare0*: INTEGER; (* OpenBSD *)
+			(* __pad2: SHORTINT; *) (* OpenBSD *)
+
+			(* OpenBSD *)
+			st_atime*: time_t;
+			st_atimensec*: INTEGER;
+			st_mtime*: time_t;
+			st_mtimensec*: INTEGER;
+			st_ctime*: time_t;
+			st_ctimensec*: INTEGER;
+
+			st_size*: off_t;	(* 64? total size, in bytes *) (* OpenBSD *)
+			st_blocks*: LONGINT; (* OpenBSD: 64-bit *)
+			st_blksize*: INTEGER;	(* blocksize for filesystem I/O *)
+			(* st_blocks*: INTEGER;	(* 64? number of blocks allocated *) *) (* OpenBSD *)
+			st_flags*: INTEGER; (* OpenBSD: 32-bit *)
+			st_gen*: INTEGER; (* OpenBSD: 32-bit *)
+			st_lspare1*: INTEGER; (* OpenBSD: 32-bit *)
+
+			(* OpenBSD
+			st_atime*: INTEGER;	(* time of last access *)
+			__unused1:  INTEGER;
+			st_mtime*: INTEGER;	(* time of last modification *)
+			__unused2:  INTEGER;
+			st_ctime*: INTEGER;	(* time of last change *)
+			__unused3:  INTEGER;
+			__unused4:  INTEGER;
+			__unused5:  INTEGER;
+			*)
+
+			(* OpenBSD *)
+			__st_birthtime*: time_t;
+			__st_birthtimensec*: INTEGER;
+			st_qspare*: ARRAY [untagged] 2 OF LONGINT;
+		END;
+
+		(* OpenBSD
+		fpreg* = RECORD [untagged]
+			significand*: ARRAY [untagged] 4 OF CHAR;
+			exponent*: CHAR;
+		END;
+		*)
+
+		(* OpenBSD *)
+		(*
+		fpstate* = RECORD [untagged]
+			cw*: INTEGER; 	(* unsigned long int *)
+			sw*: INTEGER; 	(* unsigned long int *)
+			tag*: INTEGER; 	(* unsigned long int *)
+			ipoff*: INTEGER; 	(* unsigned long int *)
+			cssel*: INTEGER; 	(* unsigned long int *)
+			dataoff*: INTEGER; 	(* unsigned long int *)
+			datasel*: INTEGER; 	(* unsigned long int *)
+			_st: ARRAY [untagged] 8 OF fpreg;
+			status*: INTEGER; 	(* unsigned long int *)
+		END;
+		*)
+		envxmm* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *)
+			(*0*)
+				en_cw*: SHORTINT; (* FPU Control Word *)
+				en_sw*: SHORTINT; (* FPU Status Word *)
+				en_tw*: BYTE; (* FPU Tag Word (abridged) *)
+				en_rsvd0*: BYTE;
+				en_opcode*: SHORTINT; (* FPU Opcode *)
+				en_fip*: INTEGER; (* FPU Instruction Pointer *)
+				en_fcs*: SHORTINT; (* FPU IP selector *)
+				en_rsvd1*: SHORTINT;
+			(*16*)
+				en_foo*: INTEGER; (* FPU Data pointer *)
+				en_fos*: SHORTINT; (* FPU Data pointer selector *)
+				en_rsvd2*: SHORTINT;
+				en_mxcsr*: INTEGER; (* MXCSR Register State *)
+				en_mxcsr_mask*: INTEGER; (* Mask for valid MXCSR bits (may be 0) *)
+		END;
+		(* FPU regsters in the extended save format. *)
+		fpaccxmm* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *)
+			fp_bytes*: ARRAY [untagged] 10 OF BYTE;
+			fp_rsvd*: ARRAY [untagged] 6 OF BYTE;
+		END;
+		(* SSE/SSE2 registers. *)
+		xmmreg* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *)
+			sse_bytes*: ARRAY [untagged] 16 OF BYTE;
+		END;
+		fpstate* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h savefpu.savexmm *)
+			sv_env*: envxmm; (* control/status context *)
+			sv_ac*: ARRAY [untagged] 8 OF fpaccxmm; (* ST/MM regs *)
+			sv_xmmregs*: ARRAY [untagged] 8 OF xmmreg; (* XMM regs *)
+			sv_rsvd*: ARRAY [untagged] 16 * 14 OF BYTE;
+			(* 512-bytes --- end of hardware portion of save area *)
+			sv_ex_sw*: INTEGER; (* saved SW from last exception *)
+			sv_ex_tw*: INTEGER; (* saved TW from last exception *)
+		END;
+
+		(* OpenBSD
+		gregset_t* = ARRAY [untagged] 19 OF INTEGER;
+		*)
+		fpregset_t* = POINTER TO fpstate;
+
+		(* OpenBSD
+		mcontext_t*  = RECORD [untagged]
+			gregs*: gregset_t;
+			fpregs*: fpregset_t;
+			oldmask*: INTEGER;	(* unsigned long int *)
+			cr2*: INTEGER; 	(* unsigned long int *)
+		END;
+		*)
+
+		Ptrucontext_t* = POINTER TO ucontext_t;
+		ucontext_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/signal.h struct sigcontext *)
+			(*
+			uc_flags*: INTEGER;	(* unsigned long int *)
+			uc_link*: Ptrucontext_t;
+			uc_stack*: stack_t;
+			uc_mcontext*: mcontext_t;
+			uc_sigmask: sigset_t;
+			__fpregs_mem*: fpstate;
+			*)
+
+			sc_gs*: INTEGER;
+			sc_fs*: INTEGER;
+			sc_es*: INTEGER;
+			sc_ds*: INTEGER;
+			sc_edi*: INTEGER;
+			sc_esi*: INTEGER;
+			sc_ebp*: INTEGER;
+			sc_ebx*: INTEGER;
+			sc_edx*: INTEGER;
+			sc_ecx*: INTEGER;
+			sc_eax*: INTEGER;
+			(* XXX *)
+			sc_eip*: INTEGER;
+			sc_cs*: INTEGER;
+			sc_eflags*: INTEGER;
+			sc_esp*: INTEGER;
+			sc_ss*: INTEGER;
+
+			sc_onstack*: INTEGER; (* sigstack state to restore *)
+			sc_mask*: INTEGER; (* signal mask to restore *)
+			sc_trapno*: INTEGER; (* XXX should be above *)
+			sc_err*: INTEGER;
+
+			sc_fpstate*: fpregset_t; (* POINTER TO savefpu *)
+		END;
+
+		(* Times and Dates *)
+
+		tm* = POINTER TO tmDesc;
+		tmDesc* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/time.h *)
+			tm_sec*: INTEGER;	(* seconds *)
+			tm_min*: INTEGER;	(* minutes *)
+			tm_hour*: INTEGER;	(* hours *)
+			tm_mday*: INTEGER;	(* day of the month *)
+			tm_mon*: INTEGER;	(* month *)
+			tm_year*: INTEGER;	(* year *)
+			tm_wday*: INTEGER;	(* day of the week *)
+			tm_yday*: INTEGER;	(* day in the year *)
+			tm_isdst*: INTEGER;	(* daylight saving time *)
+
+			tm_gmtoff*: INTEGER; (* OpenBSD *)
+			tm_zone*: PtrSTR; (* OpenBSD *)
+		END;
+
+		time_t* = INTEGER; (* OpenBSD 5.2 /usr/include/i386/_types.h: 32-bit *)
+
+	VAR
+		(* timezone*: INTEGER; (* seconds from GMT *) *) (* OpenBSD *)
+		stdin*, stdout*, stderr* : PtrFILE; (* OpenBSD: wrapper *)
+
+	PROCEDURE [ccall] calloc* (nmemb, size: size_t): PtrVoid;
+	PROCEDURE [ccall] clock* (): clock_t;
+
+	PROCEDURE [ccall] closedir* (dir: PtrDIR): INTEGER;
+
+	PROCEDURE [ccall] chmod* (path: PtrSTR; mode: mode_t);
+	PROCEDURE [ccall] exit* (status: INTEGER);
+
+	PROCEDURE [ccall] fclose* (fp: PtrFILE): INTEGER;
+	PROCEDURE [ccall] fflush* (fp: PtrFILE): INTEGER;
+	PROCEDURE [ccall] fopen* (filename, mode: PtrSTR): PtrFILE;
+	PROCEDURE [ccall] feof* (fp: PtrFILE): INTEGER;
+	PROCEDURE [ccall] fread* (ptr: PtrVoid; size, nmemb: size_t; stream: PtrFILE): size_t;
+	PROCEDURE [ccall] fseek* (stream: PtrFILE; offset, origin: INTEGER): INTEGER;
+	PROCEDURE [ccall] free* (p: PtrVoid);
+
+	PROCEDURE [ccall] ftell* (stream: PtrFILE): (* LONGINT; *) INTEGER; (* OpenBSD 5.2 *)
+
+	PROCEDURE [ccall] ftw* (filename: PtrSTR; func: __ftw_func_t; maxfds: INTEGER): INTEGER;
+	PROCEDURE [ccall] fwrite* (ptr: PtrVoid; size, nmemb: size_t; stream: PtrFILE): size_t;
+	PROCEDURE [ccall] getcwd* (buf: PtrSTR; size: size_t): PtrSTR;
+
+	(* PROCEDURE [ccall] getcontext* (ucontext_t: Ptrucontext_t): INTEGER; *) (* OpenBSD *)
+
+	(* PROCEDURE [ccall] gets* (s: PtrSTR); *)
+	PROCEDURE [ccall] gets* (s: PtrSTR): PtrSTR; (* OpenBSD 5.2 *)
+
+	PROCEDURE [ccall] fgets* (s: PtrSTR; n: INTEGER; fp: PtrFILE): PtrSTR;
+	PROCEDURE [ccall] gmtime* (VAR timep: time_t): tm;
+	PROCEDURE [ccall] kill* (pid: pid_t; sig: INTEGER): INTEGER;
+	PROCEDURE [ccall] localtime* (VAR timep: time_t): tm;
+	PROCEDURE [ccall] malloc* (size: size_t): PtrVoid;
+	PROCEDURE [ccall] mkdir* (path: PtrSTR; mode: mode_t): INTEGER;
+	PROCEDURE [ccall] mktime* (timeptr: tm): time_t;
+	PROCEDURE [ccall] opendir* (filename: PtrSTR): PtrDIR;
+	PROCEDURE [ccall] printf* (s: PtrSTR): INTEGER;
+	PROCEDURE [ccall] readdir* (dir: PtrDIR): PtrDirent;
+	PROCEDURE [ccall] remove* (path: PtrSTR): INTEGER;
+	PROCEDURE [ccall] rename* (from, to: PtrSTR): INTEGER;
+	PROCEDURE [ccall] scandir* (dir: PtrDIR; namelist: PtrDirentArray; selector: SelectorFunc; cmp: CmpFunc): INTEGER;
+
+	(* PROCEDURE [ccall] setcontext* (ucontext_t: Ptrucontext_t): INTEGER; *) (* OpenBSD *)
+
+	PROCEDURE [ccall] setjmp* (VAR env: jmp_buf): INTEGER;
+	PROCEDURE [ccall] sigaction* (sig_num: INTEGER; VAR [nil] act: sigaction_t; VAR [nil] oldact: sigaction_t): INTEGER;
+	PROCEDURE [ccall] sigaddset* (set: Ptrsigset_t; sig: INTEGER): INTEGER;
+	PROCEDURE [ccall] sigdelset* (set: Ptrsigset_t; sig: INTEGER): INTEGER;
+	PROCEDURE [ccall] sigemptyset* (set: Ptrsigset_t): INTEGER;
+	PROCEDURE [ccall] sigfillset* (set: Ptrsigset_t): INTEGER;
+	PROCEDURE [ccall] sigismemeber* (set: Ptrsigset_t; sig: INTEGER): INTEGER;
+	PROCEDURE [ccall] siglongjmp* (VAR env: sigjmp_buf; val: INTEGER);
+
+	PROCEDURE [ccall] signal* (sig_num: INTEGER; sighandler: PtrProc): PtrProc;
+	(* PROCEDURE [ccall] sigsetjmp* ["__sigsetjmp"] (VAR env: sigjmp_buf; savemask: INTEGER): INTEGER; *)
+	PROCEDURE [ccall] sigsetjmp* (VAR env: sigjmp_buf; savemask: INTEGER): INTEGER; (* OpenBSD *)
+
+(*
+	PROCEDURE [ccall] stat* (filename: PtrSTR; VAR buf: stat_t): INTEGER;   stat is a macro and expands to __xstat(3, filename, buf)
+*)
+	(* OpenBSD: wrapper *)
+	PROCEDURE [ccall] __xstat* (version: INTEGER; filename: PtrSTR; VAR buf: stat_t): INTEGER;
+
+	PROCEDURE [ccall] strftime* (s: PtrSTR; max: size_t; format: PtrSTR; ptm: tm): size_t;
+	PROCEDURE [ccall] time* (VAR [nil] t: time_t): time_t;
+
+	(* OpenBSD: wrapper *)
+	PROCEDURE [ccall] __errno_location*(): INTEGER;
+
+	(* OpenBSD *)
+	PROCEDURE [ccall] mprotect* (addr: PtrVoid; len: size_t; prot: SET): INTEGER;
+
+END LinLibc.

BlackBox/Lin/Mod/Obsd.linHostFiles.txt

@@ -0,0 +1,1304 @@
+MODULE HostFiles;
+
+	(* THIS IS TEXT COPY OF Obsd.linHostFiles.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, Kernel, Files, LinLibc;
+
+	CONST
+		tempName = "odcxxxxx";
+		docType = "odc";
+		
+		serverVersion = TRUE;
+
+		pathLen* = 260;
+
+		nofbufs = 4;	(* max number of buffers per file *)
+		bufsize = 2 * 1024;	(* size of each buffer *)
+
+		invalid = LinLibc.NULL;
+		
+		temp = 0; new = 1; shared = 2; hidden = 3; exclusive = 4; closed = 5;	(* file states *)
+		create = -1;
+		
+		ok = 0;
+		invalidName = 1;
+		invalidNameErr = MAX(INTEGER); (* On Windows this is 123 *)
+		notFound = 2;
+		fileNotFoundErr = LinLibc.ENOENT;
+		pathNotFoundErr = LinLibc.ENOENT;
+		existsAlready = 3;
+		fileExistsErr = LinLibc.EEXIST;
+		alreadyExistsErr = LinLibc.EEXIST; (* is alreadyExistsErr needed? *)
+		writeProtected = 4;
+		writeProtectedErr = LinLibc.EACCES;
+		ioError = 5; (* same as LinLibc.EIO *)
+		accessDenied = 6;
+		accessDeniedErr = LinLibc.EACCES;
+		sharingErr = LinLibc.EACCES;
+		netAccessDeniedErr = LinLibc.EACCES;
+		notEnoughMem = 80;
+		notEnoughMemoryErr = LinLibc.ENOMEM;
+		notEnoughDisk = 81;
+		diskFullErr = LinLibc.EDQUOT;
+		tooManyOpenFilesErr = LinLibc.EMFILE;
+		
+		noMoreFilesErr = 18;
+		
+		cancel = -8; retry = -9;
+
+	TYPE
+		FullName* = ARRAY pathLen OF CHAR;
+
+		Locator* = POINTER TO RECORD (Files.Locator)
+			path-: FullName;	(* without trailing "/" *)
+			maxLen-: INTEGER;	(* maximum name length *)
+			caseSens-: BOOLEAN;	(* case sensitive file compares *)
+			rootLen-: INTEGER	(* for network version *)
+		END;
+
+		Buffer = POINTER TO RECORD
+			dirty: BOOLEAN;
+			org, len: INTEGER;
+			data: ARRAY bufsize OF BYTE
+		END;
+
+		File = POINTER TO RECORD (Files.File)
+			state: INTEGER;
+			name: FullName;
+			ref: LinLibc.PtrFILE;
+			loc: Locator;
+			swapper: INTEGER;	(* index into file table / next buffer to swap *)
+			len: INTEGER;
+			bufs: ARRAY nofbufs OF Buffer;
+			t: LONGINT	(* time stamp of last file operation *)
+		END;
+
+		Reader = POINTER TO RECORD (Files.Reader)
+			base: File;
+			org, offset: INTEGER;
+			buf: Buffer
+		END;
+
+		Writer = POINTER TO RECORD (Files.Writer)
+			base: File;
+			org, offset: INTEGER;
+			buf: Buffer
+		END;
+
+		Directory = POINTER TO RECORD (Files.Directory)
+			temp, startup: Locator
+		END;
+
+		Identifier = RECORD (Kernel.Identifier)
+			name: FullName
+		END;
+		
+		Searcher = RECORD (Kernel.Identifier)
+			t0: INTEGER;
+			f: File
+		END;
+		
+		Counter = RECORD (Kernel.Identifier)
+			count: INTEGER
+		END;
+		
+		ShortName = ARRAY pathLen OF SHORTCHAR;
+		
+	VAR
+		MapParamString*: PROCEDURE(in, p0, p1, p2: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+		appName-: FullName;
+		dir: Directory;
+		wildcard: Files.Type;
+		startupDir: FullName;
+		startupLen: INTEGER;
+		res: INTEGER;
+		
+	(* debugging functions *)
+
+	PROCEDURE Msg (IN str: ARRAY OF CHAR);
+		VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER;
+	BEGIN
+		ss := SHORT(str);
+		l := LEN(ss$);
+		ss[l] := 0AX; ss[l + 1] := 0X;
+		res := LinLibc.printf(ss);
+		res := LinLibc.fflush(0)
+	END Msg;
+	
+	PROCEDURE Int (x: LONGINT);
+		VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR;
+	BEGIN
+		IF x # MIN(LONGINT) THEN
+			IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
+			j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
+		ELSE
+			a := "8085774586302733229"; s[0] := "-"; k := 1;
+			j := 0; WHILE a[j] # 0X DO INC(j) END
+		END;
+		ASSERT(k + j < LEN(s), 20);
+		REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
+		s[k] := 0X;
+		Msg(s);
+	END Int;
+	
+	(* end of debugging functions *)
+	
+	(*	get error num from linux	*)
+	PROCEDURE LinLibc_errno (): INTEGER;
+		VAR
+			addr, errno: INTEGER;
+	BEGIN
+		addr := LinLibc.__errno_location();
+		SYSTEM.GET(addr, errno);
+		RETURN errno
+	END LinLibc_errno;
+	
+	PROCEDURE Error (n: INTEGER): INTEGER;
+		VAR res: INTEGER;
+	BEGIN
+		IF n = ok THEN res := ok
+		ELSIF n = invalidNameErr THEN res := invalidName
+		ELSIF (n = fileNotFoundErr) OR (n = pathNotFoundErr) THEN res := notFound
+		ELSIF (n = fileExistsErr) OR (n = alreadyExistsErr) THEN res := existsAlready
+		ELSIF n = writeProtectedErr THEN res := writeProtected
+		ELSIF (n = sharingErr) OR (n = accessDeniedErr) OR (n = netAccessDeniedErr) THEN res := accessDenied
+		ELSIF n = notEnoughMemoryErr THEN res := notEnoughMem
+		ELSIF (n = diskFullErr) OR (n = tooManyOpenFilesErr) THEN res := notEnoughDisk
+		ELSE res := -n
+		END;
+		RETURN res
+	END Error;
+
+	PROCEDURE Diff (VAR a, b: ARRAY OF CHAR; caseSens: BOOLEAN): INTEGER;
+		VAR i: INTEGER; cha, chb: CHAR;
+	BEGIN
+		i := 0;
+		REPEAT
+			cha := a[i]; chb := b[i]; INC(i);
+			IF cha # chb THEN
+				IF ~caseSens THEN
+					IF (cha >= "a") & ((cha <= "z") OR (cha >= 0E0X) & (cha <= 0FEX) & (cha # 0F7X)) THEN
+						cha := CAP(cha)
+					END;
+					IF (chb >= "a") & ((chb <= "z") OR (chb >= 0E0X) & (chb <= 0FEX) & (chb # 0F7X)) THEN
+						chb := CAP(chb)
+					END
+				END;
+				IF cha = "\" THEN cha := "/" END;
+				IF chb = "\" THEN chb := "/" END;
+				IF cha # chb THEN RETURN ORD(cha) - ORD(chb) END
+			END
+		UNTIL cha = 0X;
+		RETURN 0
+	END Diff;
+	
+	PROCEDURE Stat (IN fname: FullName; VAR buf: LinLibc.stat_t; OUT res: INTEGER);
+		VAR s: ShortName;
+	BEGIN
+		s := SHORT(fname);
+		res := LinLibc.__xstat(3, s, buf); (* macro expansion of "stat" *)
+	END Stat;
+	
+	PROCEDURE ModeToAttr (mode: SET; OUT attr: SET; OUT isDir: BOOLEAN);
+		CONST read = 8; write = 7; execute = 6; file = 15; (* bits for permissions for the current user (see man chmod) *)
+	BEGIN
+		attr := {};
+		IF ~(write IN mode) THEN INCL(attr, Files.readOnly) END;
+		isDir := ~(file IN mode) (* see "man 2 stat" for details *)
+	END ModeToAttr;	
+							
+	PROCEDURE NewLocator* (IN fname: ARRAY OF CHAR): Locator;
+		VAR loc: Locator; i: INTEGER;
+	BEGIN
+		NEW(loc); loc.path := fname$; i := 0;
+		WHILE loc.path[i] # 0X DO INC(i) END;
+		IF (loc.path[i-1] = "/") OR (loc.path[i-1] = "\") THEN loc.path[i-1] := 0X END;
+		loc.maxLen := LinLibc.NAME_MAX; loc.caseSens := TRUE;
+		RETURN loc
+	END NewLocator;
+	
+	PROCEDURE GetType (IN name: ARRAY OF CHAR; VAR type: Files.Type);
+		VAR i, j: INTEGER; ch: CHAR;
+	BEGIN
+		i := 0; j := 0;
+		WHILE name[i] # 0X DO INC(i) END;
+		WHILE (i > 0) & (name[i] # ".") DO DEC(i) END;
+		IF i > 0 THEN
+			INC(i); ch := name[i];
+			WHILE (j < LEN(type) - 1) & (ch # 0X) DO
+				IF (ch >= "A") & (ch <= "Z") THEN ch := CHR(ORD(ch) + (ORD("a") - ORD("A"))) END;
+				type[j] := ch; INC(j);
+				INC(i); ch := name[i]
+			END
+		END;
+		type[j] := 0X
+	END GetType;
+
+	PROCEDURE Append (IN path, name: ARRAY OF CHAR; type: Files.Type; max: INTEGER;
+		VAR res: ARRAY OF CHAR
+	);
+		VAR i, j, n, m, dot: INTEGER; ch: CHAR;
+	BEGIN
+		i := 0;
+		WHILE path[i] # 0X DO res[i] := path[i]; INC(i) END;
+		IF path # "" THEN
+			ASSERT((res[i-1] # "/") & (res[i-1] # "\"), 100);
+			res[i] := "/"; INC(i)
+		END;
+		j := 0; ch := name[0]; n := 0; m := max; dot := -1;
+		IF max = 12 THEN m := 8 END;
+		WHILE (i < LEN(res) - 1) & (ch # 0X) DO
+			IF (ch = "/") OR (ch = "\") THEN
+				res[i] := ch; INC(i); n := 0; m := max; dot := -1;
+				IF max = 12 THEN m := 8 END
+			ELSIF (n < m) OR (ch = ".") & (n = 8) THEN
+				res[i] := ch; INC(i); INC(n);
+				IF ch = "." THEN dot := n;
+					IF max = 12 THEN m := n + 3 END
+				END
+			END;
+			INC(j); ch := name[j]
+		END;
+		IF (dot = -1) & (type # "") THEN
+			IF max = 12 THEN m := n + 4 END;
+			IF (n < m) & (i < LEN(res) - 1) THEN res[i] := "."; INC(i); INC(n); dot := n END
+		END;
+		IF n = dot THEN j := 0;
+			WHILE (n < m) & (i < LEN(res) - 1) & (type[j] # 0X) DO res[i] := type[j]; INC(i); INC(j) END
+		END;
+		res[i] := 0X
+	END Append;
+	
+	PROCEDURE CloseFileHandle (f: File; VAR res: INTEGER);
+	BEGIN
+		IF (f.ref = invalid) OR (LinLibc.fclose(f.ref) = 0) THEN res := ok	(* !!! *)
+		ELSE res := LinLibc_errno()
+		END;
+		f.ref := invalid
+	END CloseFileHandle;
+
+	PROCEDURE CloseFile (f: File; VAR res: INTEGER);
+		VAR s: INTEGER; n: ShortName;
+	BEGIN
+		IF f.state = exclusive THEN 
+			f.Flush;
+			res := LinLibc.fflush(f.ref)
+		 END;
+		s := f.state; f.state := closed;
+		CloseFileHandle (f, res);
+		IF (s IN {temp, new, hidden}) & (f.name # "") THEN
+			n := SHORT(f.name$);
+			res := LinLibc.remove(n)
+		END
+	END CloseFile;
+
+	PROCEDURE (f: File) FINALIZE;
+		VAR res: INTEGER;
+	BEGIN
+		IF f.state # closed THEN CloseFile(f, res) END
+	END FINALIZE;
+	
+	PROCEDURE (VAR id: Identifier) Identified (): BOOLEAN;
+		VAR f: File;
+	BEGIN
+		f := id.obj(File);
+		RETURN (f.state IN {shared, exclusive}) & (Diff(f.name, id.name, f.loc.caseSens) = 0)
+	END Identified;
+
+	PROCEDURE ThisFile (VAR name: FullName): File;
+		VAR id: Identifier; p: ANYPTR;
+	BEGIN
+		id.typ := SYSTEM.TYP(File); id.name := name$;
+		p := Kernel.ThisFinObj(id);
+		IF p # NIL THEN RETURN p(File)
+		ELSE RETURN NIL
+		END
+	END ThisFile;
+
+	PROCEDURE (VAR s: Searcher) Identified (): BOOLEAN;
+		VAR f: File;
+	BEGIN
+		f := s.obj(File);
+		IF (f.ref # invalid) & ((s.f = NIL) OR (f.t < s.f.t)) THEN s.f := f END;
+		RETURN FALSE
+	END Identified;
+	
+	PROCEDURE SearchFileToClose;
+		VAR s: Searcher; p: ANYPTR; (* res: LONGINT; *)
+	BEGIN
+		s.typ := SYSTEM.TYP(File); s.f := NIL;
+		p := Kernel.ThisFinObj(s);
+		IF s.f # NIL THEN
+			res := LinLibc.fclose(s.f.ref); s.f.ref := invalid;
+			IF res = 0 THEN res := LinLibc_errno(); HALT(100) END
+		END
+	END SearchFileToClose;
+	
+	PROCEDURE ExistingFile (VAR n: ShortName): BOOLEAN;
+		VAR f: LinLibc.PtrFILE; ret: BOOLEAN; res: INTEGER;
+	BEGIN
+		f := LinLibc.fopen(n, "r");
+		IF f  # LinLibc.NULL THEN
+			res := LinLibc.fclose(f); 
+			ret := TRUE
+		ELSE
+			ret := FALSE
+		END;
+		RETURN ret
+	END ExistingFile;
+	
+	PROCEDURE MoveFile (VAR old, new: ShortName; VAR res: INTEGER); (* as the WinApi.MoveFile *)
+	BEGIN
+		IF ExistingFile(new) THEN
+			res := fileExistsErr
+		ELSE
+			IF LinLibc.rename(old, new) = 0 THEN res := ok
+			ELSE res := LinLibc_errno();
+			END
+		END
+	END MoveFile;
+	
+	PROCEDURE NewFileRef (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER);
+		VAR n: ShortName;
+	BEGIN
+		n := SHORT(name$);
+		IF state = create THEN (* Create should fail if file already exists *)
+			IF ExistingFile(n) THEN
+				ref := invalid; res := fileExistsErr
+			ELSE
+				ref := LinLibc.fopen(n, "w+");
+				IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END
+			END
+		ELSIF state = shared THEN
+			ref := LinLibc.fopen(n, "r");
+			IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END
+		ELSE
+			ref := LinLibc.fopen(n, "r+");
+			IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END
+		END
+	END NewFileRef;
+	
+	PROCEDURE OpenFile (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER);
+	BEGIN
+		NewFileRef(state, name, ref, res);
+		IF ref = invalid THEN
+			IF res = tooManyOpenFilesErr THEN
+				Kernel.Collect;
+				NewFileRef(state, name, ref, res);
+				IF ref = invalid THEN
+					res := LinLibc_errno();
+					IF res = tooManyOpenFilesErr THEN
+						SearchFileToClose;
+						NewFileRef(state, name, ref, res);
+					END
+				ELSE res := ok
+				END
+			END
+		ELSE res := ok
+		END
+	END OpenFile;
+	
+	PROCEDURE GetTempFileName (VAR path, name: FullName; num: INTEGER);
+		VAR i: INTEGER; str: ARRAY 16 OF CHAR;
+	BEGIN
+		str := tempName; i := 7;
+		WHILE i > 2 DO
+			str[i] := CHR(num MOD 10 + ORD("0")); DEC(i); num := num DIV 10
+		END;
+		Append(path, str, "", 8, name)
+	END GetTempFileName;
+	
+	PROCEDURE CreateFile (f: File; VAR res: INTEGER);
+		VAR num, n: INTEGER;
+	BEGIN
+		IF f.name = "" THEN
+			num := LinLibc.clock(); n := 200;
+			REPEAT
+				GetTempFileName(f.loc.path, f.name, num); INC(num); DEC(n);
+				OpenFile(create, f.name, f.ref, res)
+			UNTIL (res # fileExistsErr) OR (n = 0)
+		ELSE
+			OpenFile(f.state, f.name, f.ref, res)
+		END
+	END CreateFile;
+
+	PROCEDURE Delete (VAR fname, path: FullName; VAR res: INTEGER); 
+		VAR num, n: INTEGER; f: File; new: FullName; attr: SET; fn, nn: ShortName; buf: LinLibc.stat_t; isDir: BOOLEAN;
+	BEGIN
+		ASSERT(fname # "", 100);
+		f := ThisFile(fname); fn := SHORT(fname$);
+		IF f = NIL THEN
+			IF LinLibc.remove(fn) = 0 THEN 
+				res := ok
+			ELSE 
+				res := LinLibc.fflush(0);
+				IF LinLibc.remove(fn) = 0 THEN res := ok ELSE res := LinLibc_errno() END
+			END
+		ELSE (* still in use => make it anonymous *)
+			IF f.ref # invalid THEN res := LinLibc.fclose(f.ref); f.ref := invalid END;	(* !!! *)
+			Stat(f.name, buf, res);
+			ModeToAttr(buf.st_mode, attr, isDir);
+			IF (res = ok) & ~(Files.readOnly IN attr) THEN
+				num := LinLibc.clock(); n := 200;
+				REPEAT
+					GetTempFileName(path, new, num); INC(num); DEC(n);
+					nn := SHORT(new$);
+					MoveFile(fn, nn, res);
+				UNTIL (res # fileExistsErr) OR (n = 0);
+				IF res = ok THEN
+					f.state := hidden; f.name := new$
+				END
+			ELSE
+				res := writeProtectedErr
+			END
+		END
+	END Delete;
+
+	PROCEDURE FlushBuffer (f: File; i: INTEGER);
+		VAR buf: Buffer; res: INTEGER;
+	BEGIN
+		buf := f.bufs[i];
+		IF (buf # NIL) & buf.dirty THEN
+			IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END;
+			IF f.ref # invalid THEN
+				res := LinLibc.fseek(f.ref, buf.org, LinLibc.SEEK_SET);
+				IF LinLibc.fwrite(SYSTEM.ADR(buf.data), 1, buf.len, f.ref) < buf.len THEN
+					res := LinLibc_errno(); HALT(101)
+				END;
+				res := LinLibc.fflush(f.ref);
+				buf.dirty := FALSE; f.t := Kernel.Time()
+			END
+		END
+	END FlushBuffer;
+
+	(* File *)
+
+	PROCEDURE (f: File) NewReader (old: Files.Reader): Files.Reader;
+		VAR r: Reader;
+	BEGIN	(* portable *)
+		ASSERT(f.state # closed, 20);
+		IF (old # NIL) & (old IS Reader) THEN r := old(Reader) ELSE NEW(r) END;
+		IF r.base # f THEN
+			r.base := f; r.buf := NIL; r.SetPos(0)
+		END;
+		r.eof := FALSE;
+		RETURN r
+	END NewReader;
+
+	PROCEDURE (f: File) NewWriter (old: Files.Writer): Files.Writer;
+		VAR w: Writer;
+	BEGIN	(* portable *)
+		ASSERT(f.state # closed, 20);
+		IF (old # NIL) & (old IS Writer) THEN w := old(Writer) ELSE NEW(w) END;
+		IF w.base # f THEN
+			w.base := f; w.buf := NIL; w.SetPos(f.len)
+		END;
+		RETURN w
+	END NewWriter;
+
+	PROCEDURE (f: File) Length (): INTEGER;
+	BEGIN	(* portable *)
+		RETURN f.len
+	END Length;
+	
+	PROCEDURE (f: File) Flush;
+		VAR i: INTEGER;
+	BEGIN	(* portable *)
+		i := 0; WHILE i # nofbufs DO FlushBuffer(f, i); INC(i) END
+	END Flush;
+	
+	PROCEDURE GetPath (VAR fname, path: FullName);
+		VAR i: INTEGER;
+	BEGIN
+		path := fname$; i := 0;
+		WHILE path[i] # 0X DO INC(i) END;
+		WHILE (i > 0) & (path[i] # "\") & (path[i] # "/") & (path[i-1] # ":") DO DEC(i) END;
+		path[i] := 0X
+	END GetPath;
+	
+	PROCEDURE CreateDir (VAR path: FullName; VAR res: INTEGER);
+		VAR (*sec: KERNEL32.SecurityAttributes;*) p: FullName; s: ShortName;
+	BEGIN
+		ASSERT(path # "", 100);
+		s := SHORT(path$);
+		res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *)
+		IF res # ok THEN
+			res := LinLibc_errno();
+			IF (res = LinLibc.ENOTDIR) OR (res = LinLibc.ENOENT) THEN
+				GetPath(path, p);
+				CreateDir(p, res);	(* recursive call *)
+				IF res = ok THEN
+					res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *)
+					IF res # ok THEN res := LinLibc_errno() END
+				END
+			END
+		END
+	END CreateDir;
+	
+	PROCEDURE CheckPath (VAR path: FullName; ask: BOOLEAN; VAR res: INTEGER);
+		VAR s: ARRAY 300 OF CHAR; t: ARRAY 32 OF CHAR; 
+	BEGIN
+		(*IF ask THEN
+			IF MapParamString # NIL THEN
+				MapParamString("#Host:CreateDir", path, "", "", s);
+				MapParamString("#Host:MissingDirectory", "", "", "", t)
+			ELSE
+				s := path$; t := "Missing Directory"
+			END;
+			res := Kernel.MessageBox(t, s, {Kernel.mbOk, Kernel.mbCancel})
+		ELSE
+			res := Kernel.mbOk
+		END;*)
+		(*IF res = Kernel.mbOk THEN*) CreateDir(path, res)
+		(*ELSIF res = Kernel.mbCancel THEN res := cancel
+		END*)
+	END CheckPath;
+
+	PROCEDURE CheckDelete (VAR fname, path: FullName; ask: BOOLEAN; VAR res: INTEGER);
+		VAR s: ARRAY 300 OF CHAR; t: ARRAY 16 OF CHAR; 
+	BEGIN
+		REPEAT
+			Delete(fname, path, res);
+			IF (res = writeProtectedErr)
+				OR (res = sharingErr)
+				OR (res = accessDeniedErr)
+				OR (res = netAccessDeniedErr)
+			THEN
+				(*IF ask THEN
+					IF MapParamString # NIL THEN
+						IF res = writeProtectedErr THEN
+							MapParamString("#Host:ReplaceWriteProtected", fname, 0DX, "", s)
+						ELSIF (res = accessDeniedErr) OR (res = netAccessDeniedErr) THEN
+							MapParamString("#Host:ReplaceAccessDenied", fname, 0DX, "", s)
+						ELSE
+							MapParamString("#Host:ReplaceInUse", fname, 0DX, "", s)
+						END;
+						MapParamString("#Host:FileError", "", "", "", t)
+					ELSE
+						s := fname$; t := "File Error"
+					END;
+					res := Kernel.MessageBox(t, s, {Kernel.mbRetry, Kernel.mbCancel});
+					IF res = Kernel.mbCancel THEN res := cancel
+					ELSIF res = Kernel.mbRetry THEN res := retry
+					END
+				ELSE*)
+					res := cancel
+				(*END*)
+			ELSE
+				res := ok
+			END
+		UNTIL res # retry
+	END CheckDelete;
+
+	PROCEDURE (f: File) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER);
+		VAR b: INTEGER; fname: FullName; fn, nn: ShortName;
+	BEGIN
+		ASSERT(f.state = new, 20); ASSERT(name # "", 21);
+		Append(f.loc.path, name, type, f.loc.maxLen, fname);
+		CheckDelete(fname, f.loc.path, ask,  res);
+		ASSERT(res # 87, 100);
+		IF res = ok THEN
+			IF f.name = "" THEN
+				f.name := fname$;
+				OpenFile(create, f.name, f.ref, res);
+				IF res = ok THEN
+					f.state := exclusive; CloseFile(f, res);
+					fn := SHORT(f.name$);
+				END
+			ELSE
+				f.state := exclusive; CloseFile(f, res);
+				fn := SHORT(f.name$); nn := SHORT(fname$);
+				MoveFile(fn, nn, res);
+				IF res = ok THEN
+					f.name := fname$;
+					fn := SHORT(f.name$);
+				ELSE
+					ASSERT(res # 87, 101);
+					fn := SHORT(f.name$);
+					b := LinLibc.remove(fn);
+				END
+			END
+		END;
+		res := Error(res)
+	END Register;
+		
+	PROCEDURE (f: File) Close;
+		VAR res: INTEGER;
+	BEGIN	(* portable *)
+		IF f.state # closed THEN
+			IF f.state = exclusive THEN
+				CloseFile(f, res) 
+			ELSE
+				CloseFileHandle(f, res)
+			END
+		END
+	END Close;
+
+	(* Locator *)
+	
+	PROCEDURE (loc: Locator) This* (IN path: ARRAY OF CHAR): Locator;
+		VAR new: Locator; i: INTEGER;
+	BEGIN
+		IF path = "" THEN
+			NEW(new); new^ := loc^
+		ELSIF path[0] = "/" THEN	(* absolute path *)
+			new := NewLocator(path);
+			new.rootLen := 0
+		ELSIF (path[0] = "\") OR (path[0] = "/") THEN
+			IF (path[1] = "\") OR (path[1] = "/") THEN	(* network path *)
+				new := NewLocator(path);
+				new.rootLen := 0
+			ELSE
+				NEW(new); new^ := dir.startup^;
+				new.res := invalidName;
+				RETURN new
+			END
+		ELSE
+			NEW(new); Append(loc.path, path, "", loc.maxLen, new.path);
+			i := 0; WHILE new.path[i] # 0X DO INC(i) END;
+			IF (new.path[i-1] = "/") OR (new.path[i-1] = "\") THEN new.path[i-1] := 0X END;
+			new.maxLen := loc.maxLen;
+			new.caseSens := loc.caseSens;
+			new.rootLen := loc.rootLen
+		END;
+		new.res := ok;
+		RETURN new
+	END This;
+
+	(* Reader *)
+
+	PROCEDURE (r: Reader) Base (): Files.File;
+	BEGIN	(* portable *)
+		RETURN r.base
+	END Base;
+
+	PROCEDURE (r: Reader) SetPos (pos: INTEGER);
+		VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer; 
+	BEGIN
+		f := r.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25);
+		ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21);
+		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
+			buf := f.bufs[i];
+			IF buf = NIL THEN	(* create new buffer *)
+				NEW(buf); f.bufs[i] := buf; buf.org := -1
+			END
+		ELSE	(* choose an existing buffer *)
+			f.swapper := (f.swapper + 1) MOD nofbufs;
+			FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1
+		END;
+		IF buf.org # org THEN
+			IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END;
+			count := buf.len;
+			IF count > 0 THEN
+				IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END;
+				IF f.ref # invalid THEN
+					IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN
+						res := LinLibc_errno(); HALT(101)
+					END;
+					IF  LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN
+						res := LinLibc_errno();  HALT(102)
+					END;
+					f.t := Kernel.Time()
+				END
+			END;
+			buf.org := org; buf.dirty := FALSE
+		END;
+		r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE
+		(* 0<= r.org <= r.base.len *)
+		(* 0 <= r.offset < bufsize *)
+		(* 0 <= r.buf.len <= bufsize *)
+		(* r.offset <= r.base.len *)
+		(* r.offset <= r.buf.len *)
+	END SetPos;
+
+	PROCEDURE (r: Reader) Pos (): INTEGER;
+	BEGIN	(* portable *)
+		ASSERT(r.base # NIL, 20);
+		RETURN r.org + r.offset
+	END Pos;
+
+	PROCEDURE (r: Reader) ReadByte (OUT x: BYTE);
+	BEGIN	(* portable *)
+		IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END;
+		IF r.offset < r.buf.len THEN
+			x := r.buf.data[r.offset]; INC(r.offset)
+		ELSE
+			x := 0; r.eof := TRUE
+		END
+	END ReadByte;
+
+	PROCEDURE (r: Reader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER);
+		VAR from, to, count, restInBuf: INTEGER;
+	BEGIN	(* portable *)
+		ASSERT(beg >= 0, 21);
+		IF len > 0 THEN
+			ASSERT(beg + len <= LEN(x), 23);
+			WHILE len # 0 DO
+				IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END;
+				restInBuf := r.buf.len - r.offset; 
+				IF restInBuf = 0 THEN r.eof := TRUE; RETURN
+				ELSIF restInBuf <= len THEN count := restInBuf
+				ELSE count := len
+				END;
+				from := SYSTEM.ADR(r.buf.data[r.offset]); to := SYSTEM.ADR(x) + beg;
+				SYSTEM.MOVE(from, to, count);
+				INC(r.offset, count); INC(beg, count); DEC(len, count)
+			END;
+			r.eof := FALSE
+		ELSE ASSERT(len = 0, 22)
+		END
+	END ReadBytes;
+
+	(* Writer *)
+
+	PROCEDURE (w: Writer) Base (): Files.File;
+	BEGIN	(* portable *)
+		RETURN w.base
+	END Base;
+
+	PROCEDURE (w: Writer) SetPos (pos: INTEGER);
+		VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer;
+	BEGIN
+		f := w.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25);
+		ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21);
+		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
+			buf := f.bufs[i];
+			IF buf = NIL THEN	(* create new buffer *)
+				NEW(buf); f.bufs[i] := buf; buf.org := -1
+			END
+		ELSE	(* choose an existing buffer *)
+			f.swapper := (f.swapper + 1) MOD nofbufs;
+			FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1
+		END;
+		IF buf.org # org THEN
+			IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END;
+			count := buf.len;
+			IF count > 0 THEN
+				IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END;
+				IF f.ref # invalid THEN
+					IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN
+						res := LinLibc_errno(); HALT(101)
+					END;
+					IF  LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN
+						res := LinLibc_errno();  HALT(102)
+					END;
+					f.t := Kernel.Time()
+				END
+			END;
+			buf.org := org; buf.dirty := FALSE
+		END;
+		w.buf := buf; w.org := org; w.offset := offset
+		(* 0<= w.org <= w.base.len *)
+		(* 0 <= w.offset < bufsize *)
+		(* 0 <= w.buf.len <= bufsize *)
+		(* w.offset <= w.base.len *)
+		(* w.offset <= w.buf.len *)
+	END SetPos;
+
+	PROCEDURE (w: Writer) Pos (): INTEGER;
+	BEGIN	(* portable *)
+		ASSERT(w.base # NIL, 20);
+		RETURN w.org + w.offset
+	END Pos;
+
+	PROCEDURE (w: Writer) WriteByte (x: BYTE);
+	BEGIN	(* portable *)
+		ASSERT(w.base.state # closed, 25);
+		IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END;
+		w.buf.data[w.offset] := x; w.buf.dirty := TRUE;
+		IF w.offset = w.buf.len THEN INC(w.buf.len); INC(w.base.len) END;
+		INC(w.offset)
+	END WriteByte;
+
+	PROCEDURE (w: Writer) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER);
+		VAR from, to, count, restInBuf: INTEGER;
+	BEGIN	(* portable *)
+		ASSERT(beg >= 0, 21); ASSERT(w.base.state # closed, 25);
+		IF len > 0 THEN
+			ASSERT(beg + len <= LEN(x), 23);
+			WHILE len # 0 DO
+				IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END;
+				restInBuf := bufsize - w.offset;
+				IF restInBuf <= len THEN count := restInBuf ELSE count := len END;
+				from := SYSTEM.ADR(x) + beg; to := SYSTEM.ADR(w.buf.data[w.offset]);
+				SYSTEM.MOVE(from, to, count);
+				INC(w.offset, count); INC(beg, count); DEC(len, count);
+				IF w.offset > w.buf.len THEN INC(w.base.len, w.offset - w.buf.len); w.buf.len := w.offset END;
+				w.buf.dirty := TRUE
+			END
+		ELSE ASSERT(len = 0, 22)
+		END
+	END WriteBytes;
+
+	(* Directory *)
+
+	PROCEDURE (d: Directory) This (IN path: ARRAY OF CHAR): Files.Locator;
+	BEGIN
+		RETURN d.startup.This(path)
+	END This;
+
+	PROCEDURE (d: Directory) New (loc: Files.Locator; ask: BOOLEAN): Files.File;
+		VAR f: File; res: INTEGER; attr: SET; isDir: BOOLEAN; buf: LinLibc.stat_t;
+	BEGIN
+		ASSERT(loc # NIL, 20); f := NIL; res := ok;
+		WITH loc: Locator DO
+			IF loc.path # "" THEN
+				Stat(loc.path, buf, res);
+				IF res # ok THEN
+					IF loc.res = 76 THEN CreateDir(loc.path, res)
+					ELSE CheckPath(loc.path, ask, res)
+					END
+				ELSE
+					ModeToAttr(buf.st_mode, attr, isDir); 
+					IF  ~isDir THEN res := fileExistsErr END
+				END
+			END;
+			IF res = ok THEN
+				NEW(f); f.loc := loc; f.name := "";
+				f.state := new; f.swapper := -1; f.len := 0; f.ref := invalid
+			END
+		ELSE res := invalidNameErr
+		END;
+		loc.res := Error(res);
+		RETURN f
+	END New;
+	
+	PROCEDURE (d: Directory) Temp (): Files.File;
+		VAR f: File;
+	BEGIN
+		NEW(f); f.loc := d.temp; f.name := "";
+		f.state := temp; f.swapper := -1; f.len := 0; f.ref := invalid;
+		RETURN f
+	END Temp;
+	
+	PROCEDURE GetShadowDir (loc: Locator; OUT dir: FullName);
+		VAR i, j: INTEGER;
+	BEGIN
+		dir := startupDir$; i := startupLen; j := loc.rootLen;
+		WHILE loc.path[j] # 0X DO dir[i] := loc.path[j]; INC(i); INC(j) END;
+		dir[i] := 0X
+	END GetShadowDir;
+
+	PROCEDURE (d: Directory) Old (loc: Files.Locator; name: Files.Name; shrd: BOOLEAN): Files.File;
+		VAR res: INTEGER; f: File; ref: LinLibc.PtrFILE; fname: FullName; type: Files.Type; s: BYTE; buf: LinLibc.stat_t;
+	BEGIN
+		ASSERT(loc # NIL, 20); ASSERT(name # "", 21);
+		res := ok; f := NIL;
+		WITH loc: Locator DO
+			Append(loc.path, name, "", loc.maxLen, fname);
+			f := ThisFile(fname);
+			IF f # NIL THEN
+				IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL
+				ELSE loc.res := ok; RETURN f
+				END
+			END;
+			IF shrd THEN s := shared ELSE s := exclusive END;
+			OpenFile(s, fname, ref, res);
+			IF ((res = fileNotFoundErr) OR (res = pathNotFoundErr)) & (loc.rootLen > 0) THEN
+				GetShadowDir(loc, fname);
+				Append(fname, name, "", loc.maxLen, fname);
+				f := ThisFile(fname);
+				IF f # NIL THEN
+					IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL
+					ELSE loc.res := ok; RETURN f
+					END
+				END;
+				OpenFile(s, fname, ref, res)
+			END;
+			IF res = ok THEN
+				NEW(f); f.loc := loc;
+				f.swapper := -1; 
+				GetType(name, type);
+				f.InitType(type);
+				ASSERT(ref # invalid, 107);
+				f.ref := ref; f.name := fname$; f.state := s; f.t := Kernel.Time();
+				Stat(f.name, buf, res);
+				f.len := SHORT(buf.st_size); (* A. V. Shiryaev *)
+				res := LinLibc.fseek(ref, 0, LinLibc.SEEK_SET);
+			END
+		END;
+		loc.res := Error(res);
+		RETURN f
+	END Old;
+
+	PROCEDURE (d: Directory) Delete* (loc: Files.Locator; name: Files.Name);
+		VAR res: INTEGER; fname: FullName;
+	BEGIN
+		ASSERT(loc # NIL, 20);
+		WITH loc: Locator DO
+			Append(loc.path, name, "", loc.maxLen, fname);
+			Delete(fname, loc.path, res)
+		ELSE res := invalidNameErr
+		END;
+		loc.res := Error(res)
+	END Delete;
+
+	PROCEDURE (d: Directory) Rename* (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN);
+		VAR res, i: INTEGER; oldname, newname: FullName; f: File; on, nn, tn: ShortName; buf: LinLibc.stat_t;
+	BEGIN
+		ASSERT(loc # NIL, 20);
+		WITH loc: Locator DO
+			Append(loc.path, old, "", loc.maxLen, oldname); Append(loc.path, new, "", loc.maxLen, newname);
+			on := SHORT(oldname$); nn := SHORT(newname$);
+			Stat(oldname, buf, res);
+			IF res = ok THEN
+				f := ThisFile(oldname);
+				IF (f # NIL) & (f.ref # invalid) THEN res := LinLibc.fclose(f.ref); f.ref := invalid END;
+				IF Diff(oldname, newname, loc.caseSens) # 0 THEN
+					CheckDelete(newname, loc.path, ask, res);
+					IF res = ok THEN
+						IF LinLibc.rename(on, nn) = 0 THEN
+							IF f # NIL THEN	(* still in use => update file table *)
+								f.name := newname$
+							END
+						ELSE res := LinLibc_errno()
+						END
+					END
+				ELSE	(* destination is same file as source *)
+					tn := on$; i := LEN(tn$) - 1;
+					REPEAT
+						tn[i] := SHORT(CHR(ORD(tn[i]) + 1));
+						MoveFile(on, tn, res);
+					UNTIL (res # fileExistsErr) & (res # alreadyExistsErr) & (res # 87);
+					IF res = ok THEN
+						MoveFile(tn, nn, res)
+					END
+				END
+			ELSE res := fileNotFoundErr
+			END
+		ELSE res := invalidNameErr
+		END;
+		loc.res := Error(res)
+	END Rename;
+
+	PROCEDURE (d: Directory) SameFile* (loc0: Files.Locator; name0: Files.Name;
+		loc1: Files.Locator; name1: Files.Name
+	): BOOLEAN;
+		VAR p0, p1: FullName;
+	BEGIN
+		ASSERT(loc0 # NIL, 20); ASSERT(loc1 # NIL, 21);
+		WITH loc0: Locator DO Append(loc0.path, name0, "", loc0.maxLen, p0) END;
+		WITH loc1: Locator DO Append(loc1.path, name1, "", loc1.maxLen, p1) END;
+		RETURN Diff(p0, p1, loc0(Locator).caseSens) = 0
+	END SameFile;
+
+	PROCEDURE (d: Directory) FileList* (loc: Files.Locator): Files.FileInfo;
+		VAR diff, res: INTEGER; first, last, info: Files.FileInfo; s: FullName;
+			ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t; tm: LinLibc.tm;
+			isDir: BOOLEAN; attr: SET;
+	BEGIN
+		ASSERT(loc # NIL, 20);
+		first := NIL; last :=NIL;
+		WITH loc: Locator DO
+			ss := SHORT(loc.path);
+			dirp := LinLibc.opendir(ss);
+			IF dirp # LinLibc.NULL THEN
+				dp := LinLibc.readdir(dirp);
+				WHILE dp # NIL DO
+					IF (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dp.d_name$) < LEN(info.name)) THEN
+						fname := ss + "/" + dp.d_name;
+						res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *)
+						ModeToAttr(buf.st_mode, attr, isDir);
+						IF ~isDir THEN	
+							info := first; last := NIL; s := dp.d_name$;
+							WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END;
+							NEW(info);
+							info.name := dp.d_name$;
+							GetType(info.name, info.type);
+							info.length := SHORT(buf.st_size); (* A. V. Shiryaev *)
+							tm := LinLibc.localtime(buf.st_mtime);
+							IF tm # NIL THEN 
+								info.modified.year := tm.tm_year  + 1900;
+								info.modified.month := tm.tm_mon + 1;
+								info.modified.day := tm.tm_mday;
+								info.modified.hour := tm.tm_hour;
+								info.modified.minute := tm.tm_min;
+								info.modified.second := tm.tm_sec
+							END;
+							info.attr := attr;
+							IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END
+						END
+					END;
+					dp := LinLibc.readdir(dirp)
+				END;
+				res := LinLibc.closedir(dirp)
+			ELSE res := LinLibc_errno()
+			END;
+			(* check startup directory *)
+			IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN
+				GetShadowDir(loc, s);
+				ss := SHORT(s$);
+				dirp := LinLibc.opendir(ss);
+				IF dirp # LinLibc.NULL THEN
+					dp := LinLibc.readdir(dirp);
+					WHILE dp # NIL DO
+						IF (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dp.d_name$) < LEN(info.name)) THEN
+							fname := ss + "/" + dp.d_name;
+							res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *)
+							ModeToAttr(buf.st_mode, attr, isDir);
+							IF ~isDir THEN	
+								info := first; last := NIL; s := dp.d_name$;
+								IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END;
+								WHILE (info # NIL) & (diff < 0) DO 
+									last := info; info := info.next; 
+									IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END
+								END;
+								IF (info = NIL) OR (diff # 0) THEN
+									NEW(info);
+									info.name := dp.d_name$;
+									GetType(info.name, info.type);
+									info.length := SHORT(buf.st_size); (* A. V. Shiryaev *)
+									tm := LinLibc.localtime(buf.st_mtime);
+									IF tm # NIL THEN 
+										info.modified.year := tm.tm_year  + 1900;
+										info.modified.month := tm.tm_mon + 1;
+										info.modified.day := tm.tm_mday;
+										info.modified.hour := tm.tm_hour;
+										info.modified.minute := tm.tm_min;
+										info.modified.second := tm.tm_sec
+									END;
+									info.attr := attr;
+									IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END
+								END
+							END
+						END;
+						dp := LinLibc.readdir(dirp)
+					END;
+					res := LinLibc.closedir(dirp)
+				ELSE res := LinLibc_errno()
+				END
+			END;
+			loc.res := Error(res)
+		ELSE loc.res := invalidName
+		END;
+		RETURN first
+	END FileList;
+	
+	PROCEDURE (d: Directory) LocList* (loc: Files.Locator): Files.LocInfo;
+		VAR diff, res: INTEGER; first, last, info: Files.LocInfo; s: FullName; isDir: BOOLEAN; attr: SET;
+			ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t;
+	BEGIN
+		ASSERT(loc # NIL, 20);
+		first := NIL; last :=NIL;
+		WITH loc: Locator DO
+			ss := SHORT(loc.path);
+			dirp := LinLibc.opendir(ss);
+			IF dirp # LinLibc.NULL THEN
+				dp := LinLibc.readdir(dirp);
+				WHILE dp # NIL DO
+					IF (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dp.d_name$) < LEN(info.name)) THEN
+						fname := ss + "/" + dp.d_name;
+						res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *)
+						ModeToAttr(buf.st_mode, attr, isDir);
+						IF isDir THEN	
+							info := first; last := NIL; s := dp.d_name$;
+							WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END;
+							NEW(info);
+							info.name := dp.d_name$;
+							info.attr := attr;
+							IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END
+						END
+					END;
+					dp := LinLibc.readdir(dirp)
+				END;
+				res := LinLibc.closedir(dirp)
+			ELSE res := LinLibc_errno()
+			END;
+			(* check startup directory *)
+			IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN
+				GetShadowDir(loc, s);
+				ss := SHORT(s$);
+				dirp := LinLibc.opendir(ss);
+				IF dirp # LinLibc.NULL THEN
+					dp := LinLibc.readdir(dirp);
+					WHILE dp # NIL DO
+						IF (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dp.d_name$) < LEN(info.name)) THEN
+							fname := ss + "/" + dp.d_name;
+							res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *)
+							ModeToAttr(buf.st_mode, attr, isDir);
+							IF isDir THEN	
+								info := first; last := NIL; s := dp.d_name$;
+								IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END;
+								WHILE (info # NIL) & (diff < 0) DO 
+									last := info; info := info.next; 
+									IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END
+								END;
+								IF (info = NIL) OR (diff # 0) THEN
+									NEW(info);
+									info.name := dp.d_name$;
+									info.attr := attr;
+									IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END
+								END
+							END
+						END;
+						dp := LinLibc.readdir(dirp)
+					END;
+					res := LinLibc.closedir(dirp)
+				ELSE res := LinLibc_errno()
+				END
+			END;
+			loc.res := Error(res)
+		ELSE loc.res := invalidName
+		END;
+		RETURN first
+	END LocList;
+
+	PROCEDURE (d: Directory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name);
+	BEGIN
+		Append("", name, type, LEN(filename), filename)
+	END GetFileName;
+
+	(** Miscellaneous **)
+	
+	PROCEDURE (VAR id: Counter) Identified (): BOOLEAN;
+		VAR f: File;
+	BEGIN
+		f := id.obj(File);
+		IF f.state # closed THEN INC(id.count) END;
+		RETURN FALSE
+	END Identified;
+
+	PROCEDURE NofFiles* (): INTEGER;
+		VAR p: ANYPTR; cnt: Counter;
+	BEGIN
+		cnt.typ := SYSTEM.TYP(File);
+		cnt.count := 0; p := Kernel.ThisFinObj(cnt);
+		RETURN cnt.count
+	END NofFiles;
+	
+	PROCEDURE GetModDate* (f: Files.File; VAR year, month, day, hour, minute, second: INTEGER);
+		VAR buf: LinLibc.stat_t; tm: LinLibc.tm;
+	BEGIN
+		ASSERT(f IS File, 20);
+		Stat(f(File).name, buf, res);
+		IF res = ok THEN
+			tm := LinLibc.localtime(buf.st_mtime);
+			IF tm # NIL THEN 
+				year := tm.tm_year  + 1900; month := tm.tm_mon + 1; day := tm.tm_mday;
+				hour := tm.tm_hour; minute := tm.tm_min; second := tm.tm_sec
+			ELSE
+				res := -1
+			END
+		END;
+		IF res # ok THEN year := 0; month := 0; day := 0; hour := 0; minute := 0; second := 0 END
+	END GetModDate;
+	
+	PROCEDURE SetRootDir* (path: ARRAY OF CHAR);
+		VAR i: INTEGER;
+	BEGIN
+		dir.startup := NewLocator(path);
+		dir.startup.rootLen := 0; i := 0;
+		WHILE startupDir[i] # 0X DO INC(i) END;
+		startupLen := i
+	END SetRootDir;
+
+	PROCEDURE GetName (VAR p: ARRAY OF CHAR; VAR i: INTEGER; VAR name, opt: FullName);
+		VAR ch, tch: CHAR; j: INTEGER;
+	BEGIN
+		j := 0; ch := p[i]; tch := " ";
+		WHILE ch = " " DO INC(i); ch := p[i] END;
+		IF (ch = "'") OR (ch = '"') THEN tch := ch; INC(i); ch := p[i] END;
+		WHILE (ch >= " ") & (ch # tch) DO
+			name[j] := ch;
+			IF (ch >= "a") & (ch <= "z") OR (ch >= "à") & (ch <= "ö") OR (ch >= "ø") & (ch <= "þ") THEN ch := CAP(ch)
+			ELSIF ch = "-" THEN ch := "/"
+			END;
+			opt[j] := ch; INC(j); INC(i); ch := p[i]
+		END;
+		IF ch > " " THEN INC(i); ch := p[i] END;
+		WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := p[i] END;
+		name[j] := 0X; opt[j] := 0X
+	END GetName;
+	
+	PROCEDURE Init;
+		VAR res, i, slp: INTEGER; path, opt: FullName; attr: SET; p: LinLibc.PtrSTR; str: ARRAY 256 OF CHAR;
+			buf: LinLibc.stat_t; isDir: BOOLEAN;
+	BEGIN
+(*
+		TODO: 
+		Instead of using getcwd below to find the local path it would be better to use Kernel.bootinfo.argv[0].
+		But this only works if the PATH variable of the shell is not set to hold the BlackBox directory. In that
+		case all directories in the PATH variable has to be searched for the blackbox executable: 
+			if (argv[0][0] == '/')
+				s = argv[0]
+			else {
+				str = getenv( "PATH" ); len = strlen( str );
+				for ( i = 0, s = 0; i < len; i++ )
+					if ( str[i] == ':' ) {
+						str[i] = '\0';
+					if ( checkpath( str + s, argv[0] ) ) break;
+					else s = i + 1;
+				}
+			}
+*)
+		wildcard := "*"; NEW(dir);
+		(*str := Kernel.cmdLine$;*) str := "";
+		i := 0; slp := -1;
+		WHILE (str[i] # " ") & (str[i] # 0X) DO 
+			startupDir[i] := str[i]; 
+			IF str[i] = "/" THEN slp := i END; 
+			INC(i) 
+		END;
+		startupDir[i] := 0X; 
+		IF slp < 0 THEN 
+			appName := startupDir;
+			p := NIL;
+			p := LinLibc.getcwd(p, 0);
+			startupDir := p$; 
+			LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p));
+			i := 0;
+			WHILE startupDir[i] # 0X DO INC(i) END;
+			startupLen := i;
+		ELSE
+			i := slp  + 1;
+			WHILE startupDir[i] # 0X DO appName[i - slp - 1] := startupDir[i]; INC(i) END;
+			startupDir[slp] := 0X;
+			startupLen := slp;
+		END;
+		dir.startup := NewLocator(startupDir);
+		dir.startup.rootLen := 0; 
+(*
+		p := NIL;
+		p := LinLibc.getcwd(p, 0);
+		startupDir := p$; LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p));
+		dir.startup := NewLocator(startupDir);
+		dir.startup.rootLen := 0; i := 0;
+		WHILE startupDir[i] # 0X DO INC(i) END;
+		startupLen := i;
+		str := Kernel.cmdLine$;
+*)
+(*
+		i := 0;
+		WHILE (str[i] # " ") & (str[i] # 0X) DO appName[i] := str[i]; INC(i) END;
+		appName[i] := 0X; 
+*)
+		i := 0; res := 1;
+		REPEAT
+			GetName(str, i, path, opt);
+			IF opt = "/USE" THEN 
+				GetName(str, i, path, opt); 
+				Stat(path, buf, res);
+				IF res =ok THEN
+					ModeToAttr(buf.st_mode, attr, isDir);
+					IF isDir THEN res := ok ELSE res := invalidName END
+				END
+			END
+		UNTIL (res = 0) OR (str[i] < " ");
+		IF serverVersion & (res = 0) THEN
+			i := 0; WHILE path[i] # 0X DO INC(i) END;
+			IF (path[i-1] = "/") OR (path[i-1] = "\") THEN DEC(i); path[i] := 0X END;
+			dir.startup := NewLocator(path); 
+			dir.startup.rootLen := SHORT(i)
+		END;
+		dir.temp := NewLocator(LinLibc.P_tmpdir);
+		Files.SetDir(dir)
+	END Init;
+	
+BEGIN
+	Init
+END HostFiles.

BlackBox/Lin/Mod/Obsd.linKernel.txt

@@ -0,0 +1,2573 @@
+MODULE Kernel;
+
+	(* THIS IS TEXT COPY OF Obsd.linKernel.odc *)
+	(* DO NOT EDIT *)
+
+	(* TODO: Stack overflow is not cought *)
+
+	IMPORT SYSTEM, LinDl, LinLibc;
+	
+	CONST
+		dllMem = TRUE; (* should be a variable, but for easier memory managment it is always true. *)
+	
+		strictStackSweep = TRUE;
+		
+		nameLen* = 256;
+
+		littleEndian* = TRUE;
+		timeResolution* = 1000;	(* ticks per second *)
+		
+		processor* = 10;	(* i386 *)
+
+		objType* = "ocf";	(* file types *)
+		symType* = "osf";
+		docType* = "odc";
+		
+		(* loader constants *)
+		done* = 0;
+		fileNotFound* = 1;
+		syntaxError* = 2;
+		objNotFound* = 3;
+		illegalFPrint* = 4;
+		cyclicImport* = 5;
+		noMem* = 6;
+		commNotFound* = 7;
+		commSyntaxError* = 8;
+		moduleNotFound* = 9;
+
+		any = 1000000;
+		
+		CX = 1;
+		SP = 4;	(* register number of stack pointer *)
+		FP = 5;	(* register number of frame pointer *)
+		ML = 3;	(* register which holds the module list at program start *)
+		
+		N = 128 DIV 16;	(* free lists *)
+		
+		(* kernel flags in module desc *)
+		init = 16; dyn = 17; dll = 24; iptrs = 30;
+		
+		(* meta interface consts *)
+		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+		
+		debug = FALSE;
+		
+		trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *)
+
+		(* constants for the message boxes *) 
+		mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5;
+	
+	TYPE
+		Name* = ARRAY nameLen OF SHORTCHAR;
+		Command* = PROCEDURE;
+		Module* = POINTER TO RECORD [untagged]
+			next-: Module;
+			opts-: SET;	(* 0..15: compiler opts, 16..31: kernel flags *)
+			refcnt-: INTEGER;	(* <0: module invalidated *)
+			compTime-, loadTime-: ARRAY 6 OF SHORTINT;
+			ext-: INTEGER;	(* currently not used *)
+			term-: Command;	(* terminator *)
+			nofimps-, nofptrs-: INTEGER;
+			csize-, dsize-, rsize-: INTEGER;
+			code-, data-, refs-: INTEGER;
+			procBase-, varBase-: INTEGER;	(* meta base addresses *)
+			names-: POINTER TO ARRAY [untagged] OF SHORTCHAR;	(* names[0] = 0X *)
+			ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
+			imports-: POINTER TO ARRAY [untagged] OF Module;
+			export-: Directory;	(* exported objects (name sorted) *)
+			name-: Name
+		END;
+		Type* = POINTER TO RECORD [untagged]
+			(* record: ptr to method n at offset - 4 * (n+1) *)
+			size-: INTEGER;	(* record: size, array: #elem, dyn array: 0, proc: sigfp *)
+			mod-: Module;
+			id-: INTEGER;	(* name idx * 256 + lev * 16 + attr * 4 + form *)
+			base-: ARRAY 16 OF Type;
+			fields-: Directory;	(* new fields (declaration order) *)
+			ptroffs-: ARRAY any OF INTEGER	(* array of any length *)
+		END;
+		Object* = POINTER TO ObjDesc;
+		ObjDesc* = RECORD [untagged]
+			fprint-: INTEGER;
+			offs-: INTEGER;	(* pvfprint for record types *)
+			id-: INTEGER;	(* name idx * 256 + vis * 16 + mode *)
+			struct-: Type	(* id of basic type or pointer to typedesc *)
+		END;
+		Directory* = POINTER TO RECORD [untagged]
+			num-: INTEGER;	(* number of entries *)
+			obj-: ARRAY any OF ObjDesc	(* array of any length *)
+		END;
+		
+		Signature* = POINTER TO RECORD [untagged]
+			retStruct-: Type;	(* id of basic type or pointer to typedesc or 0 *)
+			num-: INTEGER;	(* number of parameters *)
+			par-: ARRAY any OF RECORD [untagged]	(* parameters *)
+				id-: INTEGER;	(* name idx * 256 + kind *)
+				struct-: Type	(* id of basic type or pointer to typedesc *)
+			END
+		END;
+
+		Handler* = PROCEDURE;
+		
+		Reducer* = POINTER TO ABSTRACT RECORD
+			next: Reducer
+		END;
+
+		Identifier* = ABSTRACT RECORD
+			typ*: INTEGER;
+			obj-: ANYPTR
+		END;
+		
+		TrapCleaner* = POINTER TO ABSTRACT RECORD
+			next: TrapCleaner
+		END;
+		
+		TryHandler* = PROCEDURE (a, b, c: INTEGER);
+		
+		(* meta extension suport *)
+		
+		ItemExt* = POINTER TO ABSTRACT RECORD END;
+		
+		ItemAttr* = RECORD
+			obj*, vis*, typ*, adr*: INTEGER;
+			mod*: Module;
+			desc*: Type;
+			ptr*: SYSTEM.PTR;
+			ext*: ItemExt
+		END;
+	
+		Hook* = POINTER TO ABSTRACT RECORD END;
+		
+		LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) 
+			res*: INTEGER;
+			importing*, imported*, object*: ARRAY 256 OF CHAR
+		END;
+
+		GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *)
+		
+		Block = POINTER TO RECORD [untagged]
+			tag: Type;
+			last: INTEGER;		(* arrays: last element *)
+			actual: INTEGER;	(* arrays: used during mark phase *)
+			first: INTEGER		(* arrays: first element *)
+		END;
+		FreeBlock = POINTER TO FreeDesc;
+		FreeDesc = RECORD [untagged]
+			tag: Type;		(* f.tag = ADR(f.size) *)
+			size: INTEGER;
+			next: FreeBlock
+		END;
+		Cluster = POINTER TO RECORD [untagged]
+			size: INTEGER;	(* total size *)
+			next: Cluster;
+			max: INTEGER
+			(* start of first block *)
+		END;
+
+		FList = POINTER TO RECORD
+			next: FList;
+			blk: Block;
+			iptr, aiptr: BOOLEAN
+		END;
+
+		CList = POINTER TO RECORD
+			next: CList;
+			do: Command;
+			trapped: BOOLEAN
+		END;
+
+		PtrType = RECORD v: SYSTEM.PTR END;	(* used for array of pointer *)
+		Char8Type = RECORD v: SHORTCHAR END;
+		Char16Type = RECORD v: CHAR END;
+		Int8Type = RECORD v: BYTE END;
+		Int16Type = RECORD v: SHORTINT END;
+		Int32Type = RECORD v: INTEGER END;
+		Int64Type = RECORD v: LONGINT END;
+		BoolType = RECORD v: BOOLEAN END;
+		SetType = RECORD v: SET END;
+		Real32Type = RECORD v: SHORTREAL END;
+		Real64Type = RECORD v: REAL END;
+		ProcType = RECORD v: PROCEDURE END;
+		UPtrType = RECORD v: INTEGER END;
+
+		StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;
+(*
+		IntPtrType = RECORD p: COM.IUnknown END;	(* used for array of interface pointer *)
+		IntPtr = POINTER TO RECORD [untagged] p: COM.IUnknown END;
+		ExcpFramePtr = POINTER TO RECORD (KERNEL32.ExcpFrm)
+			par: INTEGER
+		END;
+		Interface = POINTER TO RECORD	(* COMPILER DEPENDENT *)
+			vtab: INTEGER;
+			ref: INTEGER;	(* must correspond to Block.actual *)
+			unk: COM.IUnknown
+		END;
+*)
+
+		(* Linux specific boot loader info. Record must be identical to struct in the loader. *)
+		BootInfo* = POINTER TO RECORD [untagged]
+			modList: Module;
+			argc-: INTEGER;
+			argv-: LinLibc.StrArray
+		END;
+
+	VAR
+		baseStack: INTEGER;	(* modList, root, and baseStack must be together for remote debugging *)
+		root: Cluster;	(* cluster list *)
+		modList-: Module; (* root of module list *)
+		trapCount-: INTEGER;
+		err-, pc-, sp-, fp-, stack-, val-: INTEGER;
+		comSig-: INTEGER;	(* command signature *)
+		
+		free: ARRAY N OF FreeBlock;	(* free list *)
+		sentinelBlock: FreeDesc;
+		sentinel: FreeBlock;
+		candidates: ARRAY 1024 OF INTEGER;
+		nofcand: INTEGER;
+		allocated: INTEGER;	(* bytes allocated on BlackBox heap *)
+		total: INTEGER;	(* current total size of BlackBox heap *)
+		used: INTEGER;	(* bytes allocated on system heap *)
+		finalizers: FList;
+		hotFinalizers: FList;
+		cleaners: CList;
+		reducers: Reducer;
+		trapStack: TrapCleaner;
+		actual: Module;	(* valid during module initialization *)
+		
+		res: INTEGER;	(* auxiliary global variables used for trap handling *)
+		old: SET;
+		
+		trapViewer, trapChecker: Handler;
+		trapped, guarded, secondTrap: BOOLEAN;
+		interrupted: BOOLEAN;
+		static, inDll, terminating: BOOLEAN;
+		retAd: INTEGER;
+		restart: Command;
+		
+(*
+		heap: LinLibc.PtrVoid;  (*heap: KERNEL32.Handle;*)
+		excpPtr: KERNEL32.ExcpFrmPtr;
+		mainThread: KERNEL32.Handle;
+*)
+		
+		told, shift: INTEGER; (* used in Time() *)
+		
+		loader: LoaderHook;
+		loadres: INTEGER;
+		
+		wouldFinalize: BOOLEAN;
+		
+		watcher*: PROCEDURE (event: INTEGER);	(* for debug *)
+		
+		loopContext: LinLibc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *)
+		currentTryContext: POINTER TO LinLibc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *)
+		
+		guiHook: GuiHook;
+		
+		cmdLine-: ARRAY 1024 OF CHAR;
+
+		(* !!! This variable has to be the last variable in the list.  !!! *)
+		bootInfo-: BootInfo;
+	
+	(* code procedures for exception handling *)
+		
+	PROCEDURE [1] PushFP 055H;
+	PROCEDURE [1] PopFP 05DH;
+	PROCEDURE [1] PushBX 053H;
+	PROCEDURE [1] PopBX 05BH;
+	PROCEDURE [1] PushSI 056H;
+	PROCEDURE [1] PopSI 05EH;
+	PROCEDURE [1] PushDI 057H;
+	PROCEDURE [1] PopDI 05FH;
+	PROCEDURE [1] LdSP8 08DH, 065H, 0F8H;
+	PROCEDURE [1] Return0 (ret: INTEGER) 0C3H;
+	PROCEDURE [1] ReturnCX (ret: INTEGER) 05AH, 001H, 0CCH, 0FFH, 0E2H; (* POP DX; ADD SP,CX; JP DX *)
+	PROCEDURE [1] FPageWord (offs: INTEGER): INTEGER 64H, 8BH, 0H;	(* MOV EAX,FS:[EAX] *)
+	
+	(* code procedures for fpu *)
+	
+	PROCEDURE [1] FINIT 0DBH, 0E3H;
+	PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH;	(* -4, FP *)
+	PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH;	(* -4, FP *)
+	
+	(* code procedure for memory erase *)
+	
+	PROCEDURE [code] Erase (adr, words: INTEGER)	
+		089H, 0C7H,	(* MOV EDI, EAX *)
+		031H, 0C0H,	(* XOR EAX, EAX *)
+		059H,			(* POP ECX *)
+		0F2H, 0ABH;	(* REP STOS *)
+		
+	(* code procedure for stack allocate *)
+	
+	PROCEDURE [code] ALLOC (* argument in CX *)
+(*
+	PUSH	EAX
+	ADD	ECX,-5
+	JNS	L0
+	XOR	ECX,ECX
+L0: AND	ECX,-4	(n-8+3)/4*4
+	MOV	EAX,ECX
+	AND	EAX,4095
+	SUB	ESP,EAX
+	MOV	EAX,ECX
+	SHR	EAX,12
+	JEQ	L2
+L1: PUSH	0
+	SUB	ESP,4092
+	DEC	EAX
+	JNE	L1
+L2: ADD	ECX,8
+	MOV	EAX,[ESP,ECX,-4]
+	PUSH	EAX
+	MOV	EAX,[ESP,ECX,-4]
+	SHR	ECX,2
+	RET
+*);
+		
+	(* code procedures for COM support *)
+	
+	PROCEDURE [code] ADDREF
+(*
+	MOV	ECX,[ESP,4]
+	INC	[ECX,4]
+	MOV	EAX,[ECX,8]
+	OR	EAX,EAX
+	JE	L1
+	PUSH	EAX
+	MOV	EAX,[EAX]
+	CALL	[EAX,4]
+	MOV	ECX,[ESP,4]
+L1: MOV	EAX,[ECX,4]
+	RET	4
+*)
+		08BH, 04CH, 024H, 004H,
+		0FFH, 041H, 004H,
+		08BH, 041H, 008H,
+		009H, 0C0H,
+		074H, 00AH,
+		050H,
+		08BH, 000H,
+		0FFH, 050H, 004H,
+		08BH, 04CH, 024H, 004H,
+		08BH, 041H, 004H,
+		0C2H, 004H, 000H;
+
+	PROCEDURE [code] RELEASE
+(*	
+	MOV	ECX,[ESP,4]
+	MOV	EAX,[ECX,8]
+	OR	EAX,EAX
+	JE	L1
+	PUSH	EAX
+	MOV	EAX,[EAX]
+	CALL	[EAX,8]
+	MOV	ECX,[ESP,4]
+L1: DEC	[ECX,4]
+	MOV	EAX,[ECX,4]
+	RET	4
+*)
+		08BH, 04CH, 024H, 004H,
+		08BH, 041H, 008H,
+		009H, 0C0H,
+		074H, 00AH,
+		050H,
+		08BH, 000H,
+		0FFH, 050H, 008H,
+		08BH, 04CH, 024H, 004H,
+		0FFH, 049H, 004H,
+		08BH, 041H, 004H,
+		0C2H, 004H, 000H;
+		
+	PROCEDURE [code] CALLREL
+(*
+	MOV     EAX,[ESP,4]
+	CMP     [EAX,4],1
+	JNE     L1
+	PUSH    ESI
+	PUSH    EDI
+	PUSH    EAX
+	MOV	EAX,[EAX,-4]
+	CALL    [EAX,-8]
+	POP     EDI
+	POP     ESI
+L1:
+*)
+		08BH, 044H, 024H, 004H,
+		083H, 078H, 004H, 001H,
+		075H, 00BH,
+		056H,
+		057H,
+		050H,
+		08BH, 040H, 0FCH,
+		0FFH, 050H, 0F8H,
+		05FH,
+		05EH;
+	
+	PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN,	NEW, ABSTRACT;
+	PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN),	NEW, ABSTRACT;
+	PROCEDURE (c: TrapCleaner) Cleanup*,	NEW, EMPTY;
+	
+	(* meta extension suport *)
+		
+	PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT;
+	
+	PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT;
+	
+	PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) GetSStringVal* (
+		OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutSStringVal* (
+		IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+	
+	(* -------------------- miscellaneous tools -------------------- *)
+	
+	PROCEDURE Msg (IN str: ARRAY OF CHAR);
+		VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER;
+	BEGIN
+		ss := SHORT(str);
+		l := LEN(ss$);
+		ss[l] := 0AX; ss[l + 1] := 0X;
+		res := LinLibc.printf(ss);
+	END Msg;
+	
+	PROCEDURE Int (x: LONGINT);
+		VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR;
+	BEGIN
+		IF x # MIN(LONGINT) THEN
+			IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
+			j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
+		ELSE
+			a := "8085774586302733229"; s[0] := "-"; k := 1;
+			j := 0; WHILE a[j] # 0X DO INC(j) END
+		END;
+		ASSERT(k + j < LEN(s), 20);
+		REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
+		s[k] := 0X;
+		Msg(s);
+	END Int;
+	
+	PROCEDURE (h: GuiHook)  MessageBox* (
+		title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (h: GuiHook)  Beep*, NEW, ABSTRACT;
+	
+	(* Is extended by HostGnome to show dialogs. If no dialog is present or
+	    if the dialog is not closed by using one button, then "mbClose" is returned *)
+	PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER;
+		VAR res: INTEGER;
+	BEGIN
+		IF guiHook # NIL THEN
+			res := guiHook.MessageBox(title, msg, buttons)
+		ELSE
+			Msg(" ");
+			Msg("****");
+			Msg("* " + title);
+			Msg("* " + msg);
+			Msg("****");
+			res := mbClose;
+		END;
+		RETURN res
+	END MessageBox;
+	
+	PROCEDURE SetGuiHook* (hook: GuiHook);
+	BEGIN
+		guiHook := hook
+	END SetGuiHook;
+
+	PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR);
+		(* portable *)
+		VAR i, j: INTEGER; ch, lch: CHAR;
+	BEGIN
+		i := 0; ch := name[0];
+		REPEAT
+			head[i] := ch; lch := ch; INC(i); ch := name[i]
+		UNTIL (ch = 0X)
+			OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ"))
+				& ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ"));
+		head[i] := 0X; j := 0;
+		WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END;
+		tail[j] := 0X;
+		IF tail = "" THEN tail := head$; head := "" END
+	END SplitName;
+	
+	PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
+		VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR;
+	BEGIN
+		i := 0;
+		WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
+		IF name[i] = "." THEN
+			IF name[i + 1] = 0X THEN name[i] := 0X END
+		ELSIF i < LEN(name) - 4 THEN
+			IF type = "" THEN ext := docType ELSE ext := type$ END;
+			name[i] := "."; INC(i); j := 0; ch := ext[0];
+			WHILE ch # 0X DO
+				IF (ch >= "A") & (ch <= "Z") THEN
+					ch := CHR(ORD(ch) + ORD("a") - ORD("A"))
+				END;
+				name[i] := ch; INC(i); INC(j); ch := ext[j]
+			END;
+			name[i] := 0X
+		END
+	END MakeFileName;
+	
+	PROCEDURE Time* (): LONGINT;
+		VAR t: INTEGER;
+	BEGIN
+		(* A. V. Shiryaev *)
+		(* processor time to milliseconds *)
+		t := (1000 * LinLibc.clock()) DIV LinLibc.CLOCKS_PER_SEC;
+
+		IF t < told THEN INC(shift) END;
+		told := t;
+		RETURN shift * 100000000L + t
+	END Time;
+	
+	PROCEDURE Beep* ();
+		VAR ss: ARRAY 2 OF SHORTCHAR;
+	BEGIN
+		IF guiHook # NIL THEN
+			guiHook.Beep
+		ELSE
+			ss[0] := 007X; ss[1] := 0X;
+			res := LinLibc.printf(ss); res := LinLibc.fflush(LinLibc.NULL)
+		END
+	END Beep;
+	
+	PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER);
+	BEGIN
+		adr := var; m := NIL;
+		IF var # 0 THEN
+			m := modList;
+			WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END;
+			IF m # NIL THEN DEC(adr, m.code) END
+		END
+	END SearchProcVar;
+
+	(* -------------------- system memory management --------------------- *)
+	
+	PROCEDURE GrowHeapMem (size: INTEGER; VAR c: Cluster);
+		(* grow to at least size bytes, typically at least 256 kbytes are allocated *)
+		CONST N = 262144;
+		VAR adr, s: INTEGER;
+	BEGIN
+		ASSERT(size >= c.size, 100); 
+		IF size <= c.max THEN
+			s := (size + (N - 1)) DIV N * N;
+(*
+			adr := KERNEL32.VirtualAlloc(SYSTEM.VAL(INTEGER, c), s, {12}, {6});	(* commit; exec, read, write *)
+*)
+			adr := LinLibc.calloc(1, s);
+			IF adr # 0 THEN
+				INC(used, s - c.size); INC(total, s - c.size); c.size := s
+			END
+		END
+		(* post: (c.size unchanged) OR (c.size >= size) *)
+	END GrowHeapMem;
+
+	PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
+		(* allocate at least size bytes, typically at least 256 kbytes are allocated *)
+		CONST M = 1536 * 100000H;	(* 1.5 GByte *)
+		CONST N = 65536;	(* cluster size for dll *)
+		VAR adr, s: INTEGER;
+	BEGIN
+		IF dllMem THEN
+			INC(size, 16);
+			ASSERT(size > 0, 100); adr := 0;
+			(*
+			IF size < N THEN adr := KERNEL32.HeapAlloc(heap, {0}, N) END;
+			IF adr = 0 THEN adr := KERNEL32.HeapAlloc(heap, {0}, size) END;
+			*)
+			IF size < N THEN adr := LinLibc.calloc(1, N) END; 
+			IF adr = 0 THEN adr := LinLibc.calloc(1, size)
+			ELSE size := N
+			END;
+			
+			IF adr = 0 THEN c := NIL
+			ELSE
+				c := SYSTEM.VAL(Cluster, ((adr + 15) DIV 16) * 16); c.max := adr;
+(*
+				c.size := KERNEL32.HeapSize(heap, {0}, adr) - (SYSTEM.VAL(INTEGER, c) - adr);
+*)
+				c.size := size - (SYSTEM.VAL(INTEGER, c) - adr);
+				INC(used, c.size); INC(total, c.size)
+			END;
+		ELSE
+			adr := 0; s := M;
+			REPEAT
+(*
+				adr := KERNEL32.VirtualAlloc(01000000H, s, {13}, {6});	(* reserve; exec, read, write *)
+*)
+				IF adr = 0 THEN
+(*
+					adr := KERNEL32.VirtualAlloc(0, s, {13}, {6})	(* reserve; exec, read, write *)
+*)
+				END;
+				s := s DIV 2
+			UNTIL adr # 0;
+			IF adr = 0 THEN c := NIL
+			ELSE
+(*
+				adr := KERNEL32.VirtualAlloc(adr, 1024, {12}, {6});	(* commit; exec, read, write *)
+*)
+				c := SYSTEM.VAL(Cluster, adr);
+				c.max := s * 2; c.size := 0; c.next := NIL;
+				GrowHeapMem(size, c);
+				IF c.size < size THEN c := NIL END
+			END
+		END 
+		(* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
+	END AllocHeapMem;
+
+	PROCEDURE FreeHeapMem (c: Cluster);
+		VAR res: INTEGER;
+	BEGIN
+		DEC(used, c.size); DEC(total, c.size);
+		IF dllMem THEN
+(*
+			res := KERNEL32.HeapFree(heap, {0}, c.max)
+*)
+			LinLibc.free(c.max)
+		END
+	END FreeHeapMem;
+	
+	PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
+(*
+		VAR ms: KERNEL32.MemStatus;
+*)
+	BEGIN
+		RETURN used + size > 4000000 (* TODO: Do this right!!! Well, maybe not, since it isn't used for dllMem *)
+(*
+		ms.size := SIZE(KERNEL32.MemStatus);
+		ms.memLoad := -1;
+		KERNEL32.GlobalMemoryStatus(ms);
+		IF ms.memLoad >= 0 THEN
+			RETURN used + size > ms.totPhys
+		ELSE	(* old win32s *)
+			RETURN used + size > 4000000
+		END
+*)
+	END HeapFull;
+	
+	PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
+		VAR res: INTEGER;
+	BEGIN
+		(*
+		descAdr := KERNEL32.VirtualAlloc(0, descSize, {12, 13}, {6});	(* reserve & commit; exec, read, write *)
+		IF descAdr # 0 THEN
+			modAdr := KERNEL32.VirtualAlloc(0, modSize, {12, 13}, {6});	(* reserve & commit; exec, read, write *)
+			IF modAdr # 0 THEN INC(used, descSize + modSize)
+			ELSE res := KERNEL32.VirtualFree(descAdr, 0, {15}); descAdr := 0
+			END
+		ELSE modAdr := 0
+		END
+		*)
+		descAdr := LinLibc.calloc(1, descSize); 
+		IF descAdr # LinLibc.NULL THEN
+			modAdr := LinLibc.calloc(1, modSize);
+			IF modAdr # LinLibc.NULL THEN INC(used, descSize + modSize)
+			ELSE LinLibc.free(descAdr); descAdr := 0
+			END
+		ELSE modAdr := 0
+		END
+	END AllocModMem;
+	
+	PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
+		VAR res: INTEGER;
+	BEGIN
+		DEC(used, descSize + modSize);
+(*
+		res := KERNEL32.VirtualFree(descAdr, 0, {15});	(* release *)
+		res := KERNEL32.VirtualFree(modAdr, 0, {15})	(* release *)
+*)
+		LinLibc.free(descAdr);
+		LinLibc.free(modAdr)
+	END DeallocModMem;
+	
+	PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
+		VAR res: INTEGER;
+	BEGIN
+		DEC(used, modSize);
+(*
+		res := KERNEL32.VirtualFree(modAdr, modSize, {14})	(* decommit *)
+*)
+		LinLibc.free(modAdr)
+	END InvalModMem;
+	
+	PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
+		(* check wether memory between from (incl.) and to (excl.) may be read *)
+	BEGIN
+(*
+		RETURN KERNEL32.IsBadReadPtr(from, to - from) = 0
+*)
+		RETURN TRUE (* TODO: Do this correct!!! *)
+	END IsReadable;
+	
+
+	(* --------------------- COM reference counting -------------------- *)
+	
+	PROCEDURE [noframe] AddRef* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
+	BEGIN
+		ADDREF
+(*
+		INC(p.ref);
+		IF p.unk # NIL THEN p.unk.AddRef() END;
+		RETURN p.ref
+*)
+	END AddRef;
+	
+	PROCEDURE [noframe] Release* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
+	BEGIN
+		RELEASE
+(*
+		IF p.unk # NIL THEN p.unk.Release() END;
+		DEC(p.ref);
+		RETURN p.ref
+*)
+	END Release;
+	
+	PROCEDURE [noframe] Release2* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
+	BEGIN
+		CALLREL;
+		RELEASE
+(*
+		IF p.ref = 1 THEN p.RELEASE END;
+		IF p.unk # NIL THEN p.unk.Release() END;
+		DEC(p.ref);
+		RETURN p.ref
+*)
+	END Release2;
+
+(*	
+	PROCEDURE RecFinalizer (obj: ANYPTR);
+		VAR i: INTEGER; type: Type; p: IntPtr;
+	BEGIN
+		SYSTEM.GET(SYSTEM.VAL(INTEGER, obj) - 4, type);
+		i := 0;
+		WHILE type.ptroffs[i] >= 0 DO INC(i) END;
+		INC(i);
+		WHILE type.ptroffs[i] >= 0 DO
+			p := SYSTEM.VAL(IntPtr, SYSTEM.VAL(INTEGER, obj) + type.ptroffs[i]); INC(i);
+			p.p := NIL	(* calls p.p.Release *)
+		END
+	END RecFinalizer;
+*)
+	
+(*
+	PROCEDURE ArrFinalizer (obj: SYSTEM.PTR);
+		VAR last, adr, i, j: INTEGER; type: Type; p: IntPtr;
+	BEGIN
+		SYSTEM.GET(SYSTEM.VAL(INTEGER, obj) - 4, type);
+		type := SYSTEM.VAL(Type, SYSTEM.VAL(INTEGER, type) - 2);	(* remove array flag *)
+		SYSTEM.GET(SYSTEM.VAL(INTEGER, obj), last);
+		SYSTEM.GET(SYSTEM.VAL(INTEGER, obj) + 8, adr);
+		j := 0;
+		WHILE type.ptroffs[j] >= 0 DO INC(j) END;
+		INC(j);
+		WHILE adr <= last DO
+			i := j;
+			WHILE type.ptroffs[i] >= 0 DO
+				p := SYSTEM.VAL(IntPtr, adr + type.ptroffs[i]); INC(i);
+				p.p := NIL	(* calls p.p.Release *)
+			END;
+			INC(adr, type.size)
+		END
+	END ArrFinalizer;
+*)
+
+(*	
+	PROCEDURE ReleaseIPtrs (mod: Module);
+		VAR i: INTEGER; p: IntPtr;
+	BEGIN
+		IF iptrs IN mod.opts THEN
+			EXCL(mod.opts, iptrs);
+			i := mod.nofptrs;
+			WHILE mod.ptrs[i] # -1 DO
+				p := SYSTEM.VAL(IntPtr, mod.varBase + mod.ptrs[i]); INC(i);
+				p.p := NIL	(* calls p.p.Release *)
+			END
+		END
+	END ReleaseIPtrs;
+*)
+
+	(* --------------------- NEW implementation (portable) -------------------- *)
+
+	PROCEDURE^ NewBlock (size: INTEGER): Block;
+
+	PROCEDURE NewRec* (typ: INTEGER): INTEGER;	(* implementation of NEW(ptr) *)
+		VAR size: INTEGER; b: Block; tag: Type; l: FList;
+	BEGIN
+		IF ODD(typ) THEN	(* record contains interface pointers *)
+			tag := SYSTEM.VAL(Type, typ - 1);
+			b := NewBlock(tag.size);
+			IF b = NIL THEN RETURN 0 END;
+			b.tag := tag;
+			l := SYSTEM.VAL(FList, NewRec(SYSTEM.TYP(FList)));	(* NEW(l) *)
+			l.blk := b; l.iptr := TRUE; l.next := finalizers; finalizers := l;
+			RETURN SYSTEM.ADR(b.last)
+		ELSE
+			tag := SYSTEM.VAL(Type, typ);
+			b := NewBlock(tag.size);
+			IF b = NIL THEN RETURN 0 END;
+			b.tag := tag; SYSTEM.GET(typ - 4, size);
+			IF size # 0 THEN	(* record uses a finalizer *)
+				l := SYSTEM.VAL(FList, NewRec(SYSTEM.TYP(FList)));	(* NEW(l) *)
+				l.blk := b; l.next := finalizers; finalizers := l
+			END;
+			RETURN SYSTEM.ADR(b.last)
+		END
+	END NewRec;
+	
+	PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER;	(* impl. of NEW(ptr, dim0, dim1, ...) *)
+		VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList;
+	BEGIN
+		headSize := 4 * nofdim + 12; fin := FALSE;
+		CASE eltyp OF
+(*
+		| -1: eltyp := SYSTEM.ADR(IntPtrType); fin := TRUE
+*)
+		| 0: eltyp := SYSTEM.ADR(PtrType)
+		| 1: eltyp := SYSTEM.ADR(Char8Type)
+		| 2: eltyp := SYSTEM.ADR(Int16Type)
+		| 3: eltyp := SYSTEM.ADR(Int8Type)
+		| 4: eltyp := SYSTEM.ADR(Int32Type)
+		| 5: eltyp := SYSTEM.ADR(BoolType)
+		| 6: eltyp := SYSTEM.ADR(SetType)
+		| 7: eltyp := SYSTEM.ADR(Real32Type)
+		| 8: eltyp := SYSTEM.ADR(Real64Type)
+		| 9: eltyp := SYSTEM.ADR(Char16Type)
+		| 10: eltyp := SYSTEM.ADR(Int64Type)
+		| 11: eltyp := SYSTEM.ADR(ProcType)
+		| 12: eltyp := SYSTEM.ADR(UPtrType)
+		ELSE	(* eltyp is desc *)
+			IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END
+		END;
+		t := SYSTEM.VAL(Type, eltyp);
+		size := headSize + nofelem * t.size;
+		b := NewBlock(size);
+		IF b = NIL THEN RETURN 0 END;
+		b.tag := SYSTEM.VAL(Type, eltyp + 2);	(* tag + array mark *)
+		b.last := SYSTEM.ADR(b.last) + size - t.size;	(* pointer to last elem *)
+		b.first := SYSTEM.ADR(b.last) + headSize;	(* pointer to first elem *)
+		IF fin THEN
+			l := SYSTEM.VAL(FList, NewRec(SYSTEM.TYP(FList)));	(* NEW(l) *)
+			l.blk := b; l.aiptr := TRUE; l.next := finalizers; finalizers := l
+		END;
+		RETURN SYSTEM.ADR(b.last)
+	END NewArr;
+
+	(* -------------------- handler installation (portable) --------------------- *)
+
+	PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
+		VAR l: FList;
+	BEGIN
+		ASSERT(id.typ # 0, 100); ASSERT(hotFinalizers = NIL, 101);
+		l := finalizers;
+		WHILE l # NIL DO
+			IF SYSTEM.VAL(INTEGER, l.blk.tag) = id.typ THEN
+				id.obj := SYSTEM.VAL(ANYPTR, SYSTEM.ADR(l.blk.last));
+				IF id.Identified() THEN RETURN id.obj END
+			END;
+			l := l.next
+		END;
+		RETURN NIL
+	END ThisFinObj;
+	
+	PROCEDURE InstallReducer* (r: Reducer);
+	BEGIN
+		r.next := reducers; reducers := r
+	END InstallReducer;
+
+	PROCEDURE InstallTrapViewer* (h: Handler);
+	BEGIN
+		trapViewer := h
+	END InstallTrapViewer;
+	
+	PROCEDURE InstallTrapChecker* (h: Handler);
+	BEGIN
+		trapChecker := h
+	END InstallTrapChecker;
+	
+	PROCEDURE PushTrapCleaner* (c: TrapCleaner);
+		VAR t: TrapCleaner;
+	BEGIN
+		t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
+		ASSERT(t = NIL, 20);
+		c.next := trapStack; trapStack := c
+	END PushTrapCleaner;
+	
+	PROCEDURE PopTrapCleaner* (c: TrapCleaner);
+		VAR t: TrapCleaner;
+	BEGIN
+		t := NIL;
+		WHILE (trapStack # NIL) & (t # c) DO
+			t := trapStack; trapStack := trapStack.next
+		END
+	END PopTrapCleaner;
+	
+	PROCEDURE InstallCleaner* (p: Command);
+		VAR c: CList;
+	BEGIN
+		c := SYSTEM.VAL(CList, NewRec(SYSTEM.TYP(CList)));	(* NEW(c) *)
+		c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
+	END InstallCleaner;
+	
+	PROCEDURE RemoveCleaner* (p: Command);
+		VAR c0, c: CList;
+	BEGIN
+		c := cleaners; c0 := NIL;
+		WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
+		IF c # NIL THEN
+			IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
+		END
+	END RemoveCleaner;
+	
+	PROCEDURE Cleanup*;
+		VAR c, c0: CList;
+	BEGIN
+		c := cleaners; c0 := NIL;
+		WHILE c # NIL DO
+			IF ~c.trapped THEN
+				c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
+			ELSE
+				IF c0 = NIL THEN cleaners := cleaners.next
+				ELSE c0.next := c.next
+				END
+			END;
+			c := c.next
+		END
+	END Cleanup;
+
+	(* -------------------- meta information (portable) --------------------- *)
+	
+	PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF SHORTCHAR): Module, NEW, ABSTRACT;
+	
+	PROCEDURE SetLoaderHook*(h: LoaderHook);
+	BEGIN
+		loader := h
+	END SetLoaderHook;
+
+	PROCEDURE InitModule (mod: Module);	(* initialize linked modules *)
+		VAR body: Command;
+			res, errno: INTEGER;
+	BEGIN
+		IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
+		IF ~(init IN mod.opts) THEN
+			body := SYSTEM.VAL(Command, mod.code);
+			INCL(mod.opts, init);
+			actual := mod;
+
+			(* A. V. Shiryaev: OpenBSD-specific *)
+				(*
+				res := LinLibc.mprotect(
+					(mod.code DIV LinLibc.PAGE_SIZE) * LinLibc.PAGE_SIZE,
+					((mod.csize + mod.code MOD LinLibc.PAGE_SIZE - 1) DIV LinLibc.PAGE_SIZE) * LinLibc.PAGE_SIZE + LinLibc.PAGE_SIZE,
+					LinLibc.PROT_READ + LinLibc.PROT_WRITE + LinLibc.PROT_EXEC);
+				*)
+				res := LinLibc.mprotect(mod.code, mod.csize,
+					LinLibc.PROT_READ + LinLibc.PROT_WRITE + LinLibc.PROT_EXEC);
+				IF res = -1 THEN
+					SYSTEM.GET( LinLibc.__errno_location(), errno );
+
+					res := LinLibc.printf("Kernel.InitModule('"); res := LinLibc.printf(mod.name);
+					res := LinLibc.printf("'): mprotect("); Int(mod.code);
+					res := LinLibc.printf(", "); Int(mod.csize);
+					res := LinLibc.printf(", R|W|E) failed: errno = "); Int(errno);
+					res := LinLibc.printf(0AX);
+					
+					(* HALT(100) *)
+				ELSE ASSERT(res = 0)
+				END;
+
+			body();
+			actual := NIL
+		END
+	END InitModule;
+
+	PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module;	(* loaded modules only *)
+		VAR m: Module;
+	BEGIN
+		loadres := done;
+		m := modList;
+		WHILE (m # NIL) & ((m.name # name) OR (m.refcnt < 0)) DO m := m.next END;
+		IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
+		IF m = NIL THEN loadres := moduleNotFound END;
+		RETURN m
+	END ThisLoadedMod;
+	
+	PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
+		VAR n : Name;
+	BEGIN
+		n := SHORT(name$);
+		IF loader # NIL THEN
+			loader.res := done;
+			RETURN loader.ThisMod(n)
+		ELSE
+			RETURN ThisLoadedMod(n)
+		END
+	END ThisMod;
+	
+	PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
+		VAR m: Module;
+	BEGIN
+		m := ThisMod(name)
+	END LoadMod;
+	
+	PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
+	BEGIN
+		IF loader # NIL THEN
+			res := loader.res;
+			importing := loader.importing$;
+			imported := loader.imported$;
+			object := loader.object$
+		ELSE
+			res := loadres;
+			importing := "";
+			imported := "";
+			object := ""
+		END
+	END GetLoaderResult;
+		
+	PROCEDURE ThisObject* (mod: Module; name: ARRAY OF SHORTCHAR): Object;
+		VAR l, r, m: INTEGER; p: StrPtr;
+	BEGIN
+		l := 0; r := mod.export.num;
+		WHILE l < r DO	(* binary search *)
+			m := (l + r) DIV 2;
+			p := SYSTEM.VAL(StrPtr, SYSTEM.ADR(mod.names[mod.export.obj[m].id DIV 256]));
+			IF p^ = name THEN RETURN SYSTEM.VAL(Object, SYSTEM.ADR(mod.export.obj[m])) END;
+			IF p^ < name THEN l := m + 1 ELSE r := m END
+		END;
+		RETURN NIL
+	END ThisObject;
+	
+	PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
+		VAR i, n: INTEGER;
+	BEGIN
+		i := 0; n := mod.export.num;
+		WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO 
+			IF mod.export.obj[i].offs = fprint THEN
+				RETURN SYSTEM.VAL(Object, SYSTEM.ADR(mod.export.obj[i]))
+			END;
+			INC(i)
+		END;
+		RETURN NIL
+	END ThisDesc;
+	
+	PROCEDURE ThisField* (rec: Type; name: ARRAY OF SHORTCHAR): Object;
+		VAR n: INTEGER; p: StrPtr; obj: Object; m: Module;
+	BEGIN
+		m := rec.mod;
+		obj := SYSTEM.VAL(Object, SYSTEM.ADR(rec.fields.obj[0])); n := rec.fields.num;
+		WHILE n > 0 DO
+			p := SYSTEM.VAL(StrPtr, SYSTEM.ADR(m.names[obj.id DIV 256]));
+			IF p^ = name THEN RETURN obj END;
+			DEC(n); INC(SYSTEM.VAL(INTEGER, obj), 16)
+		END;
+		RETURN NIL
+	END ThisField;
+
+	(*PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command;
+		VAR x: Object;
+	BEGIN
+		x := ThisObject(mod, name);
+		IF (x # NIL) & (x.id MOD 16 = mProc) & (x.fprint = comSig) THEN
+			RETURN SYSTEM.VAL(Command, mod.procBase + x.offs)
+		ELSE
+			RETURN NIL
+		END
+	END ThisCommand;*)
+
+	PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command;
+		VAR x: Object; sig: Signature;
+	BEGIN
+		x := ThisObject(mod, name);
+		IF (x # NIL) & (x.id MOD 16 = mProc) THEN
+			sig := SYSTEM.VAL(Signature, x.struct);
+			IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN SYSTEM.VAL(Command, mod.procBase + x.offs) END
+		END;
+		RETURN NIL
+	END ThisCommand;
+
+	PROCEDURE ThisType* (mod: Module; name: ARRAY OF SHORTCHAR): Type;
+		VAR x: Object;
+	BEGIN
+		x := ThisObject(mod, name);
+		IF (x # NIL) & (x.id MOD 16 = mTyp) & (SYSTEM.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
+			RETURN x.struct
+		ELSE
+			RETURN NIL
+		END
+	END ThisType;
+
+	PROCEDURE TypeOf* (IN rec: ANYREC): Type;
+	BEGIN
+		RETURN SYSTEM.VAL(Type, SYSTEM.TYP(rec))
+	END TypeOf;
+
+	PROCEDURE LevelOf* (t: Type): SHORTINT;
+	BEGIN
+		RETURN SHORT(t.id DIV 16 MOD 16)
+	END LevelOf;
+	
+	PROCEDURE NewObj* (VAR o: SYSTEM.PTR; t: Type);
+		VAR i: INTEGER;
+	BEGIN
+		IF t.size = -1 THEN o := NIL
+		ELSE
+			i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
+			IF t.ptroffs[i+1] >= 0 THEN INC(SYSTEM.VAL(INTEGER, t)) END;	(* with interface pointers *)
+			o := SYSTEM.VAL(SYSTEM.PTR, NewRec(SYSTEM.VAL(INTEGER, t)))	(* generic NEW *)
+		END
+	END NewObj;
+
+	PROCEDURE GetObjName* (mod: Module; obj: Object; VAR name: Name);
+		VAR p: StrPtr;
+	BEGIN
+		p := SYSTEM.VAL(StrPtr, SYSTEM.ADR(mod.names[obj.id DIV 256]));
+		name := p^$
+	END GetObjName;
+	
+	PROCEDURE GetTypeName* (t: Type; VAR name: Name);
+		VAR p: StrPtr;
+	BEGIN
+		p := SYSTEM.VAL(StrPtr, SYSTEM.ADR(t.mod.names[t.id DIV 256]));
+		name := p^$
+	END GetTypeName;
+	
+	PROCEDURE RegisterMod* (mod: Module);
+		VAR i: INTEGER;(* t: KERNEL32.SystemTime;*) obj: Object; s: SET; c: Command; str: Name;
+			t: LinLibc.time_t; tm: LinLibc.tm;
+	BEGIN
+		mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
+		WHILE i < mod.nofimps DO
+			IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
+			INC(i)
+		END;
+		t := LinLibc.time(NIL);
+		tm := LinLibc.localtime(t);
+		mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *)
+		mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *);
+		mod.loadTime[2] := SHORT(tm.tm_mday);
+		mod.loadTime[3] := SHORT(tm.tm_hour);
+		mod.loadTime[4] := SHORT(tm.tm_min);
+		mod.loadTime[5] := SHORT(tm.tm_sec); 
+		tm := NIL;
+		IF ~(init IN mod.opts) THEN InitModule(mod) END
+	END RegisterMod;
+	
+	PROCEDURE^ Collect*;
+	
+	PROCEDURE UnloadMod* (mod: Module);
+		VAR i: INTEGER; t: Command;
+	BEGIN
+		IF mod.refcnt = 0 THEN
+			t := mod.term; mod.term := NIL;
+			IF t # NIL THEN t() END;	(* terminate module *)
+			i := 0;
+			WHILE i < mod.nofptrs DO	(* release global pointers *)
+				SYSTEM.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
+			END;
+(*
+			ReleaseIPtrs(mod);	(* release global interface pointers *)
+*)
+			Collect;	(* call finalizers *)
+			i := 0;
+			WHILE i < mod.nofimps DO	(* release imported modules *)
+				IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
+				INC(i)
+			END;
+			mod.refcnt := -1;
+			IF dyn IN mod.opts THEN	(* release memory *)
+				InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
+			END
+		END
+	END UnloadMod;
+	(* -------------------- dynamic procedure call  --------------------- *)	(* COMPILER DEPENDENT *)
+
+	PROCEDURE [1] PUSH (p: INTEGER) 050H;	(* push AX *)
+	PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H;	(* call AX *)
+	PROCEDURE [1] RETI (): LONGINT;
+	PROCEDURE [1] RETR (): REAL;
+	
+	(*
+		type				par
+		32 bit scalar	value
+		64 bit scalar	low hi
+		var scalar		address
+		record			address tag
+		array			  address size
+		open array	   address length .. length
+	*)
+	
+	PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
+		VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL;
+	BEGIN
+		p := sig.num;
+		WHILE p > 0 DO	(* push parameters from right to left *)
+			DEC(p);
+			typ := sig.par[p].struct;
+			kind := sig.par[p].id MOD 16;
+			IF (SYSTEM.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN	(* scalar *)
+				IF (kind = 10) & ((SYSTEM.VAL(INTEGER, typ) = 8) OR (SYSTEM.VAL(INTEGER, typ) = 10)) THEN	(* 64 bit *)
+					DEC(n); PUSH(par[n])	(* push hi word *)
+				END;
+				DEC(n); PUSH(par[n])	(* push value/address *)
+			ELSIF typ.id MOD 4 = 1 THEN	(* record *)
+				IF kind # 10 THEN	(* var par *)
+					DEC(n); PUSH(par[n]);	(* push tag *)
+					DEC(n); PUSH(par[n])	(* push address *)
+				ELSE
+					DEC(n, 2);	(* skip tag *)
+					SYSTEM.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; SYSTEM.PUTREG(SP, sp);	(* allocate space *)
+					SYSTEM.MOVE(par[n], sp, typ.size)	(* copy to stack *)
+				END
+			ELSIF typ.size = 0 THEN	(* open array *)
+				size := typ.id DIV 16 MOD 16;	(* number of open dimensions *)
+				WHILE size > 0 DO
+					DEC(size); DEC(n); PUSH(par[n])	(* push length *)
+				END;
+				DEC(n); PUSH(par[n])	(* push address *)
+			ELSE	(* fix array *)
+				IF kind # 10 THEN	(* var par *)
+					DEC(n, 2); PUSH(par[n])	(* push address *)
+				ELSE
+					DEC(n); size := par[n]; DEC(n);
+					SYSTEM.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; SYSTEM.PUTREG(SP, sp);	(* allocate space *)
+					SYSTEM.MOVE(par[n], sp, size)	(* copy to stack *)
+				END
+			END
+		END;
+		ASSERT(n = 0);
+		IF SYSTEM.VAL(INTEGER, sig.retStruct) = 7 THEN	(* shortreal *)
+			CALL(adr);
+			RETURN SYSTEM.VAL(INTEGER, SHORT(RETR()))	(* return value in fpu register *)
+		ELSIF SYSTEM.VAL(INTEGER, sig.retStruct) = 8 THEN	(* real *)
+			CALL(adr); r := RETR(); 
+			RETURN SYSTEM.VAL(LONGINT, r)	(* return value in fpu register *)
+		ELSE
+			CALL(adr);
+			RETURN RETI()	(* return value in integer registers *)
+		END
+	END Call;
+
+	(* -------------------- reference information (portable) --------------------- *)
+
+	PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR);
+	BEGIN
+		SYSTEM.GET(ref, ch); INC(ref)
+	END RefCh;
+	
+	PROCEDURE RefNum (VAR ref: INTEGER; VAR x: INTEGER);
+		VAR s, n: INTEGER; ch: SHORTCHAR;
+	BEGIN
+		s := 0; n := 0; RefCh(ref, ch);
+		WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
+		x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
+	END RefNum;
+	
+	PROCEDURE RefName (VAR ref: INTEGER; VAR n: Name);
+		VAR i: INTEGER; ch: SHORTCHAR;
+	BEGIN
+		i := 0; RefCh(ref, ch);
+		WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
+		n[i] := 0X
+	END RefName;
+	
+	PROCEDURE GetRefProc* (VAR ref: INTEGER; VAR adr: INTEGER; VAR name: Name);
+		VAR ch: SHORTCHAR;
+	BEGIN
+		SYSTEM.GET(ref, ch);
+		WHILE ch >= 0FDX DO	(* skip variables *)
+			INC(ref); RefCh(ref, ch);
+			IF ch = 10X THEN INC(ref, 4) END;
+			RefNum(ref, adr); RefName(ref, name); SYSTEM.GET(ref, ch)
+		END;
+		WHILE (ch > 0X) & (ch < 0FCX) DO	(* skip source refs *)
+			INC(ref); RefNum(ref, adr); SYSTEM.GET(ref, ch)
+		END;
+		IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
+		ELSE adr := 0
+		END
+	END GetRefProc;
+	
+	PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type;
+		VAR adr: INTEGER; VAR name: Name
+	);
+	BEGIN
+		SYSTEM.GET(ref, mode); desc := NIL;
+		IF mode >= 0FDX THEN
+			mode := SHORT(CHR(ORD(mode) - 0FCH));
+			INC(ref); RefCh(ref, form);
+			IF form = 10X THEN
+				SYSTEM.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
+			END;
+			RefNum(ref, adr); RefName(ref, name)
+		ELSE
+			mode := 0X; form := 0X; adr := 0
+		END
+	END GetRefVar;
+	
+	PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
+		VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Name;
+	BEGIN
+		ref := mod.refs; pos := 0; ad := 0; SYSTEM.GET(ref, ch);
+		WHILE ch # 0X DO
+			WHILE (ch > 0X) & (ch < 0FCX) DO
+				INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
+				IF ad > codePos THEN RETURN pos END;
+				INC(pos, d); SYSTEM.GET(ref, ch) 
+			END;
+			IF ch = 0FCX THEN INC(ref); RefNum(ref, d); RefName(ref, name); SYSTEM.GET(ref, ch) END;
+			WHILE ch >= 0FDX DO	(* skip variables *)
+				INC(ref); RefCh(ref, ch);
+				IF ch = 10X THEN INC(ref, 4) END;
+				RefNum(ref, d); RefName(ref, name); SYSTEM.GET(ref, ch)
+			END
+		END;
+		RETURN -1
+	END SourcePos;
+	
+	(* -------------------- dynamic link libraries --------------------- *)
+	
+(*
+	PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN);
+		VAR h: KERNEL32.Handle;
+	BEGIN
+		ok := FALSE;
+		h := KERNEL32.LoadLibraryA(name);
+		IF h # 0 THEN ok := TRUE END
+	END LoadDll;
+	
+	PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER;
+		VAR ad: INTEGER; h: KERNEL32.Handle;
+	BEGIN
+		ad := 0;
+		IF mode = mProc THEN
+			h := KERNEL32.GetModuleHandleA(dll);
+			IF h # 0 THEN ad := KERNEL32.GetProcAddress(h, name) END
+		END;
+		RETURN ad
+	END ThisDllObj;
+*)
+	
+	PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN);
+		VAR h: LinDl.HANDLE;
+	BEGIN
+		ok := FALSE;
+		h := LinDl.dlopen(name, LinDl.RTLD_LAZY +  LinDl.RTLD_GLOBAL);
+		IF h # LinDl.NULL THEN ok := TRUE END
+	END LoadDll;
+	
+	PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER;
+		VAR ad: INTEGER; h: LinDl.HANDLE;
+	BEGIN
+		ad := 0;
+		IF mode IN {mVar, mProc} THEN
+			h := LinDl.dlopen(dll, LinDl.RTLD_LAZY+  LinDl.RTLD_GLOBAL);
+			IF h # LinDl.NULL THEN
+				ad := LinDl.dlsym(h, name);
+			END
+		END;
+		RETURN ad
+	END ThisDllObj;
+	
+	(* -------------------- garbage collector (portable) --------------------- *)
+	
+	PROCEDURE Mark (this: Block);
+		VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
+	BEGIN
+		IF ~ODD(SYSTEM.VAL(INTEGER, this.tag)) THEN
+			father := NIL;
+			LOOP
+				INC(SYSTEM.VAL(INTEGER, this.tag));
+				flag := SYSTEM.VAL(INTEGER, this.tag) MOD 4;
+				tag := SYSTEM.VAL(Type, SYSTEM.VAL(INTEGER, this.tag) - flag);
+				IF flag >= 2 THEN actual := this.first; this.actual := actual
+				ELSE actual := SYSTEM.ADR(this.last)
+				END;
+				LOOP
+					offset := tag.ptroffs[0];
+					IF offset < 0 THEN
+						INC(SYSTEM.VAL(INTEGER, tag), offset + 4);	(* restore tag *)
+						IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN	(* next array element *)
+							INC(actual, tag.size); this.actual := actual
+						ELSE	(* up *)
+							this.tag := SYSTEM.VAL(Type, SYSTEM.VAL(INTEGER, tag) + flag);
+							IF father = NIL THEN RETURN END;
+							son := this; this := father;
+							flag := SYSTEM.VAL(INTEGER, this.tag) MOD 4;
+							tag := SYSTEM.VAL(Type, SYSTEM.VAL(INTEGER, this.tag) - flag);
+							offset := tag.ptroffs[0];
+							IF flag >= 2 THEN actual := this.actual ELSE actual := SYSTEM.ADR(this.last) END;
+							SYSTEM.GET(actual + offset, father); SYSTEM.PUT(actual + offset, SYSTEM.ADR(son.last));
+							INC(SYSTEM.VAL(INTEGER, tag), 4)
+						END
+					ELSE
+						SYSTEM.GET(actual + offset, son);
+						IF son # NIL THEN
+							DEC(SYSTEM.VAL(INTEGER, son), 4);
+							IF ~ODD(SYSTEM.VAL(INTEGER, son.tag)) THEN	(* down *)
+								this.tag := SYSTEM.VAL(Type, SYSTEM.VAL(INTEGER, tag) + flag);
+								SYSTEM.PUT(actual + offset, father); father := this; this := son;
+								EXIT
+							END
+						END;
+						INC(SYSTEM.VAL(INTEGER, tag), 4)
+					END
+				END
+			END
+		END
+	END Mark;
+	
+	PROCEDURE MarkGlobals;
+		VAR m: Module; i, p: INTEGER;
+	BEGIN
+		m := modList;
+		WHILE m # NIL DO
+			IF m.refcnt >= 0 THEN
+				i := 0;
+				WHILE i < m.nofptrs DO
+					SYSTEM.GET(m.varBase + m.ptrs[i], p); INC(i);
+					IF p # 0 THEN
+						Mark(SYSTEM.VAL(Block, p - 4))
+					END
+				END
+			END;
+			m := m.next
+		END
+	END MarkGlobals;
+
+(*
+	PROCEDURE Next (b: Block): Block;	(* next block in same cluster *)
+		VAR size: INTEGER;
+	BEGIN
+		SYSTEM.GET(SYSTEM.VAL(INTEGER, b.tag) DIV 4 * 4, size);
+		IF ODD(SYSTEM.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - SYSTEM.ADR(b.last)) END;
+		RETURN SYSTEM.VAL(Block, SYSTEM.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
+	END Next;
+*)
+
+	PROCEDURE [code] Next (b: Block): Block	(* next block in same cluster *)
+(*
+	MOV	ECX,[EAX]	b.tag
+	AND	CL,0FCH	b.tag DIV * 4
+	MOV	ECX,[ECX]	size
+	TESTB	[EAX],02H	ODD(b.tag DIV 2)
+	JE	L1
+	ADD	ECX,[EAX,4]	size + b.last
+	SUB	ECX,EAX
+	SUB	ECX,4	size + b.last - ADR(b.last)
+	L1:
+	ADD	ECX,19	size + 19
+	AND	CL,0F0H	(size + 19) DIV 16 * 16
+	ADD	EAX,ECX	b + size
+*)
+	08BH, 008H,
+	080H, 0E1H, 0FCH,
+	08BH, 009H,
+	0F6H, 000H, 002H,
+	074H, 008H,
+	003H, 048H, 004H,
+	029H, 0C1H,
+	083H, 0E9H, 004H,
+	083H, 0C1H, 013H,
+	080H, 0E1H, 0F0H,
+	001H, 0C8H;
+	
+	PROCEDURE CheckCandidates;
+	(* pre: nofcand > 0 *)
+		VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
+	BEGIN
+		(* sort candidates (shellsort) *)
+		h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
+		REPEAT h := h DIV 3; i := h;
+			WHILE i < nofcand DO p := candidates[i]; j := i;
+				WHILE (j >= h) & (candidates[j-h] > p) DO
+					candidates[j] := candidates[j-h]; j := j-h
+				END;
+				candidates[j] := p; INC(i)
+			END
+		UNTIL h = 1;
+		(* sweep *)
+		c := root; i := 0;
+		WHILE c # NIL DO
+			blk := SYSTEM.VAL(Block, SYSTEM.VAL(INTEGER, c) + 12);
+			end := SYSTEM.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
+			WHILE candidates[i] < SYSTEM.VAL(INTEGER, blk) DO
+				INC(i);
+				IF i = nofcand THEN RETURN END
+			END;
+			WHILE SYSTEM.VAL(INTEGER, blk) < end DO
+				next := Next(blk);
+				IF candidates[i] < SYSTEM.VAL(INTEGER, next) THEN
+					IF (SYSTEM.VAL(INTEGER, blk.tag) # SYSTEM.ADR(blk.last))	(* not a free block *)
+							& (~strictStackSweep OR (candidates[i] = SYSTEM.ADR(blk.last))) THEN
+						Mark(blk)
+					END;
+					REPEAT
+						INC(i);
+						IF i = nofcand THEN RETURN END
+					UNTIL candidates[i] >= SYSTEM.VAL(INTEGER, next)
+				END;
+				IF (SYSTEM.VAL(INTEGER, blk.tag) MOD 4 = 0)
+					& (SYSTEM.VAL(INTEGER, blk.tag) # SYSTEM.ADR(blk.last))
+					& (blk.tag.base[0] = NIL) & (blk.actual > 0)
+				THEN	(* referenced interface record *)
+					Mark(blk)
+				END;
+				blk := next
+			END;
+			c := c.next
+		END
+	END CheckCandidates;
+
+	PROCEDURE MarkLocals;
+		VAR sp, p, min, max: INTEGER; c: Cluster;
+	BEGIN
+		SYSTEM.GETREG(FP, sp); nofcand := 0; c := root;
+		WHILE c.next # NIL DO c := c.next END;
+		min := SYSTEM.VAL(INTEGER, root); max := SYSTEM.VAL(INTEGER, c) + c.size;
+		WHILE sp < baseStack DO
+			SYSTEM.GET(sp, p);
+			IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
+				candidates[nofcand] := p; INC(nofcand);
+				IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
+			END;
+			INC(sp, 4)
+		END;
+		candidates[nofcand] := max; INC(nofcand);	(* ensure complete scan for interface mark*)
+		IF nofcand > 0 THEN CheckCandidates END
+	END MarkLocals;
+	
+	PROCEDURE MarkFinObj;
+		VAR f: FList;
+	BEGIN
+		wouldFinalize := FALSE;
+		f := finalizers;
+		WHILE f # NIL DO
+			IF ~ODD(SYSTEM.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
+			Mark(f.blk);
+			f := f.next
+		END;
+		f := hotFinalizers;
+		WHILE f # NIL DO IF ~ODD(SYSTEM.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
+			Mark(f.blk);
+			f := f.next
+		END
+	END MarkFinObj;
+
+	PROCEDURE CheckFinalizers;
+		VAR f, g, h, k: FList;
+	BEGIN
+		f := finalizers; g := NIL;
+		(* hotFinalizers := NIL; k := NIL; *)
+		IF hotFinalizers = NIL THEN k := NIL
+		ELSE
+			k := hotFinalizers;
+			WHILE k.next # NIL DO k := k.next END
+		END;
+		WHILE f # NIL DO
+			h := f; f := f.next;
+			IF ~ODD(SYSTEM.VAL(INTEGER, h.blk.tag)) THEN
+				IF g = NIL THEN finalizers := f ELSE g.next := f END;
+				IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
+				k := h; h.next := NIL
+			ELSE g := h
+			END
+		END;
+		h := hotFinalizers;
+		WHILE h # NIL DO Mark(h.blk); h := h.next END
+	END CheckFinalizers;
+
+	PROCEDURE ExecFinalizer (a, b, c: INTEGER);
+		VAR f: FList; fin: PROCEDURE(this: ANYPTR);
+	BEGIN
+		f := hotFinalizers; hotFinalizers := hotFinalizers.next;
+		IF f.aiptr THEN (*ArrFinalizer(SYSTEM.VAL(ANYPTR, S.ADR(f.blk.last)))*)
+		ELSE
+			SYSTEM.GET(SYSTEM.VAL(INTEGER, f.blk.tag) - 4, fin);	(* method 0 *)
+			IF fin # NIL THEN fin(SYSTEM.VAL(ANYPTR, SYSTEM.ADR(f.blk.last))) END;
+(*
+			IF f.iptr THEN RecFinalizer(SYSTEM.VAL(ANYPTR, SYSTEM.ADR(f.blk.last))) END
+*)
+		END
+	END ExecFinalizer;
+	
+	PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER);	(* COMPILER DEPENDENT *)
+
+	PROCEDURE CallFinalizers;
+		VAR f: FList;
+	BEGIN
+		WHILE hotFinalizers # NIL DO
+			f := hotFinalizers.next; hotFinalizers.next := NIL;
+			Try(ExecFinalizer, 0, 0, 0);
+			hotFinalizers := f
+		END;
+		wouldFinalize := FALSE
+	END CallFinalizers;
+	
+	PROCEDURE Insert (blk: FreeBlock; size: INTEGER);	(* insert block in free list *)
+		VAR i: INTEGER;
+	BEGIN
+		blk.size := size - 4; blk.tag := SYSTEM.VAL(Type, SYSTEM.ADR(blk.size));
+		i := MIN(N - 1, (blk.size DIV 16));
+		blk.next := free[i]; free[i] := blk
+	END Insert;
+	
+	PROCEDURE Sweep (dealloc: BOOLEAN);
+		VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
+	BEGIN
+		cluster := root; last := NIL; allocated := 0;
+		i := N;
+		REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
+		WHILE cluster # NIL DO
+			blk := SYSTEM.VAL(Block, SYSTEM.VAL(INTEGER, cluster) + 12);
+			end := SYSTEM.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
+			fblk := NIL;
+			WHILE SYSTEM.VAL(INTEGER, blk) < end DO
+				next := Next(blk);
+				IF ODD(SYSTEM.VAL(INTEGER, blk.tag)) THEN
+					IF fblk # NIL THEN
+						Insert(fblk, SYSTEM.VAL(INTEGER, blk) - SYSTEM.VAL(INTEGER, fblk));
+						fblk := NIL
+					END;
+					DEC(SYSTEM.VAL(INTEGER, blk.tag));	(* unmark *)
+					INC(allocated, SYSTEM.VAL(INTEGER, next) - SYSTEM.VAL(INTEGER, blk))
+				ELSIF fblk = NIL THEN
+					fblk := SYSTEM.VAL(FreeBlock, blk)
+				END;
+				blk := next
+			END;
+			IF dealloc & (SYSTEM.VAL(INTEGER, fblk) = SYSTEM.VAL(INTEGER, cluster) + 12) THEN
+				(* deallocate cluster *)
+				c := cluster; cluster := cluster.next;
+				IF last = NIL THEN root := cluster ELSE last.next := cluster END;
+				FreeHeapMem(c)
+			ELSE
+				IF fblk # NIL THEN Insert(fblk, end - SYSTEM.VAL(INTEGER, fblk)) END;
+				last := cluster; cluster := cluster.next
+			END
+		END;
+		(* reverse free list *)
+		i := N;
+		REPEAT
+			DEC(i);
+			b := free[i]; fblk := sentinel;
+			WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
+			free[i] := fblk
+		UNTIL i = 0
+	END Sweep;
+	
+	PROCEDURE Collect*;
+	BEGIN
+		IF root # NIL THEN
+			CallFinalizers;	(* trap cleanup *)
+			IF debug & (watcher # NIL) THEN watcher(1) END;
+			MarkGlobals;
+			MarkLocals;
+			CheckFinalizers;
+			Sweep(TRUE);
+			CallFinalizers
+		END
+	END Collect;
+	
+	PROCEDURE FastCollect*;
+	BEGIN
+		IF root # NIL THEN
+(*
+			 CallFinalizers;	(* trap cleanup  *)
+*)
+			IF debug & (watcher # NIL) THEN watcher(2) END;
+			MarkGlobals;
+			MarkLocals;
+(*			 CheckFinalizers; *)
+			MarkFinObj;
+			Sweep(FALSE);
+(*
+			CallFinalizers
+*)
+		END
+	END FastCollect;
+
+(*
+	PROCEDURE GlobalCollect*;
+	BEGIN
+		IF root # NIL THEN
+			MarkGlobals;
+			(* MarkLocals; *)
+			CheckFinalizers;
+			Sweep(FALSE);
+		END
+	END GlobalCollect;
+*)
+
+	PROCEDURE WouldFinalize* (): BOOLEAN;
+	BEGIN
+		RETURN wouldFinalize
+	END WouldFinalize;
+
+	(* --------------------- memory allocation (portable) -------------------- *)
+	
+	PROCEDURE OldBlock (size: INTEGER): FreeBlock;	(* size MOD 16 = 0 *)
+		VAR b, l: FreeBlock; s, i: INTEGER;
+	BEGIN
+		IF debug & (watcher # NIL) THEN watcher(3) END;
+		s := size - 4;
+		i := MIN(N - 1, s DIV 16);
+		WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
+		b := free[i]; l := NIL;
+		WHILE b.size < s DO l := b; b := b.next END;
+		IF b # sentinel THEN
+			IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
+		ELSE b := NIL
+		END;
+		RETURN b
+	END OldBlock;
+
+	PROCEDURE LastBlock (limit: INTEGER): FreeBlock;	(* size MOD 16 = 0 *)
+		VAR b, l: FreeBlock; s, i: INTEGER;
+	BEGIN
+		s := limit - 4;
+		i := 0;
+		REPEAT
+			b := free[i]; l := NIL;
+			WHILE (b # sentinel) & (SYSTEM.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
+			IF b # sentinel THEN
+				IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
+			ELSE b := NIL
+			END;
+			INC(i)
+		UNTIL (b # NIL) OR (i = N);
+		RETURN b
+	END LastBlock;
+
+	PROCEDURE NewBlock (size: INTEGER): Block;
+		VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
+	BEGIN
+		tsize := (size + 19) DIV 16 * 16;
+		b := OldBlock(tsize);	(* 1) search for free block *)
+		IF b = NIL THEN
+			IF dllMem THEN
+				FastCollect; b := OldBlock(tsize);	(* 2) collect *)
+				IF b = NIL THEN
+					AllocHeapMem(tsize + 12, new);	(* 3) allocate new cluster *)
+					IF new # NIL THEN
+						IF (root = NIL) OR (SYSTEM.VAL(INTEGER, new) < SYSTEM.VAL(INTEGER, root)) THEN
+							new.next := root; root := new
+						ELSE
+							c := root;
+							WHILE (c.next # NIL) & (SYSTEM.VAL(INTEGER, new) > SYSTEM.VAL(INTEGER, c.next)) DO 
+								c := c.next 
+							END;
+							new.next := c.next; c.next := new
+						END;
+						b := SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, new) + 12);
+						b.size := (new.size - 12) DIV 16 * 16 - 4
+					ELSE
+						RETURN NIL	(* 4) give up *)
+					END
+				END
+			ELSE
+				FastCollect;	(* 2) collect *)
+				IF (b = NIL) & (HeapFull(tsize)) & (reducers # NIL) THEN	(* 3) little space => reduce once *)
+					r := reducers; reducers := NIL;
+					WHILE r # NIL DO r.Reduce(FALSE); r := r.next END;
+					Collect
+				END;
+				s := 3 * (allocated + tsize) DIV 2;
+				a := 12 + (root.size - 12) DIV 16 * 16;
+				IF s <= total THEN
+					b := OldBlock(tsize);
+					IF b = NIL THEN s := a + tsize END
+				ELSIF s < a + tsize THEN
+					s := a + tsize
+				END;
+				IF total < s THEN	(* 4) enlarge heap *)
+					GrowHeapMem(s, root);
+					IF root.size >= s THEN
+						b := LastBlock(SYSTEM.VAL(INTEGER, root) + a);
+						IF b # NIL THEN
+							b.size := (root.size - a + b.size + 4) DIV 16 * 16 - 4
+						ELSE
+							b := SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, root) + a);
+							b.size := (root.size - a) DIV 16 * 16 - 4
+						END
+					ELSIF reducers # NIL THEN	(* 5) no space => fully reduce *)
+						r := reducers; reducers := NIL;
+						WHILE r # NIL DO r.Reduce(TRUE); r := r.next END;
+						Collect
+					END
+				END;
+				IF b = NIL THEN
+					b := OldBlock(tsize);
+					IF b = NIL THEN RETURN NIL END	(* 6) give up *)
+				END
+			END
+		END;
+		(* b # NIL *)
+		a := b.size + 4 - tsize;
+		IF a > 0 THEN Insert(SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, b) + tsize), a) END;
+		IF size > 0 THEN Erase(SYSTEM.ADR(b.size), (size + 3) DIV 4) END;
+		INC(allocated, tsize);
+		RETURN SYSTEM.VAL(Block, b)
+	END NewBlock;
+
+(*	
+	PROCEDURE NewBlock (size: INTEGER): Block;
+		VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
+	BEGIN
+		tsize := (size + 19) DIV 16 * 16;
+		b := OldBlock(tsize);	(* 1) search for free block *)
+		IF b = NIL THEN
+			(*FastCollect;*) b := OldBlock(tsize);	(* 2) collect *)
+			IF b = NIL THEN
+				AllocHeapMem(tsize + 12, new);	(* 3) allocate new cluster *)
+				IF new # NIL THEN
+					IF (root = NIL) OR (SYSTEM.VAL(INTEGER, new) < SYSTEM.VAL(INTEGER, root)) THEN
+						new.next := root; root := new
+					ELSE
+						c := root;
+						WHILE (c.next # NIL) & (SYSTEM.VAL(INTEGER, new) > SYSTEM.VAL(INTEGER, c.next)) DO
+							c := c.next
+						END;
+						new.next := c.next; c.next := new
+					END;
+					b := SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, new) + 12);
+					b.size := (new.size - 12) DIV 16 * 16 - 4
+				ELSE
+					RETURN NIL	(* 4) give up *)
+				END
+			END
+		END;
+		(* b # NIL *)
+		a := b.size + 4 - tsize;
+		IF a > 0 THEN Insert(SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, b) + tsize), a) END;
+		IF size > 0 THEN Erase(SYSTEM.ADR(b.size), (size + 3) DIV 4) END;
+		INC(allocated, tsize);
+		RETURN SYSTEM.VAL(Block, b)
+	END NewBlock;
+*)
+	
+	PROCEDURE Allocated* (): INTEGER;
+	BEGIN
+		RETURN allocated
+	END Allocated;
+	
+	PROCEDURE Used* (): INTEGER;
+	BEGIN
+		RETURN used
+	END Used;
+	
+	PROCEDURE Root* (): INTEGER;
+	BEGIN
+		RETURN SYSTEM.VAL(INTEGER, root)
+	END Root;
+
+	(* -------------------- Trap Handling --------------------- *)
+
+	PROCEDURE^ InitFpu;
+	
+	PROCEDURE Start* (code: Command);
+	BEGIN
+		restart := code;
+		res := LinLibc.sigsetjmp(loopContext, LinLibc.TRUE);
+		restart()
+	END Start;
+	
+	PROCEDURE Quit* (exitCode: INTEGER);
+		VAR m: Module; term: Command; t: BOOLEAN; res: INTEGER;
+	BEGIN
+		trapViewer := NIL; trapChecker := NIL; restart := NIL;
+		t := terminating; terminating := TRUE; m := modList;
+		WHILE m # NIL DO	(* call terminators *)
+			IF ~static OR ~t THEN
+				term := m.term; m.term := NIL;
+				IF term # NIL THEN term() END
+			END;
+(*
+			ReleaseIPtrs(m);
+*)
+			m := m.next
+		END;
+		CallFinalizers;
+		hotFinalizers := finalizers; finalizers := NIL;
+		CallFinalizers;
+(*
+		WinOle.OleUninitialize();
+*)
+(*
+		IF ~inDll THEN
+			KERNEL32.RemoveExcp(excpPtr^);
+			KERNEL32.ExitProcess(exitCode)	(* never returns *)
+		END
+*)
+		res := LinLibc.fflush(0);
+		LinLibc.exit(exitCode)
+	END Quit;
+	
+	PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
+		VAR res: INTEGER; title: ARRAY 16 OF SHORTCHAR; text: ARRAY 256 OF SHORTCHAR;
+	BEGIN
+		title := "Error xy";
+		title[6] := SHORT(CHR(id DIV 10 + ORD("0")));
+		title[7] := SHORT(CHR(id MOD 10 + ORD("0")));
+		text := SHORT(str$);
+		res := MessageBox(title$, text$, {mbOk});
+(*
+		WinOle.OleUninitialize();
+*)
+(*
+		IF ~inDll THEN KERNEL32.RemoveExcp(excpPtr^) END;
+		KERNEL32.ExitProcess(1)
+*)
+		LinLibc.exit(1);
+		(* never returns *)
+	END FatalError;
+
+	PROCEDURE DefaultTrapViewer;
+		VAR len, ref, end, x, a, b, c: INTEGER; mod: Module;
+			name: Name; out: ARRAY 1024 OF SHORTCHAR;
+		
+		PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
+			VAR i: INTEGER;
+		BEGIN
+			i := 0;
+			WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
+		END WriteString;
+		
+		PROCEDURE WriteHex (x, n: INTEGER);
+			VAR i, y: INTEGER;
+		BEGIN
+			IF len + n < LEN(out) THEN
+				i := len + n - 1;
+				WHILE i >= len DO
+					y := x MOD 16; x := x DIV 16;
+					IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
+					out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
+				END;
+				INC(len, n)
+			END
+		END WriteHex;
+
+		PROCEDURE WriteLn;
+		BEGIN
+			IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END
+		END WriteLn;
+		
+	BEGIN
+		len := 0;
+		IF err = 129 THEN WriteString("invalid with")
+		ELSIF err = 130 THEN WriteString("invalid case")
+		ELSIF err = 131 THEN WriteString("function without return")
+		ELSIF err = 132 THEN WriteString("type guard")
+		ELSIF err = 133 THEN WriteString("implied type guard")
+		ELSIF err = 134 THEN WriteString("value out of range")
+		ELSIF err = 135 THEN WriteString("index out of range")
+		ELSIF err = 136 THEN WriteString("string too long")
+		ELSIF err = 137 THEN WriteString("stack overflow")
+		ELSIF err = 138 THEN WriteString("integer overflow")
+		ELSIF err = 139 THEN WriteString("division by zero")
+		ELSIF err = 140 THEN WriteString("infinite real result")
+		ELSIF err = 141 THEN WriteString("real underflow")
+		ELSIF err = 142 THEN WriteString("real overflow")
+		ELSIF err = 143 THEN WriteString("undefined real result")
+		ELSIF err = 200 THEN WriteString("keyboard interrupt")
+		ELSIF err = 202 THEN WriteString("illegal instruction:  ");
+			WriteHex(val, 4)
+		ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
+			WriteHex(val, 8); WriteString("]")
+		ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
+			WriteHex(val, 8); WriteString("]")
+		ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
+			WriteHex(val, 8); WriteString("]")
+		ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
+		ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
+			WriteString("trap #"); WriteHex(err, 3)
+		END;
+		a := pc; b := fp; c := 12;
+		REPEAT
+			WriteLn; WriteString("- ");
+			mod := modList;
+			WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
+			IF mod # NIL THEN
+				DEC(a, mod.code);
+				IF mod.refcnt >= 0 THEN
+					WriteString(mod.name); ref := mod.refs;
+					REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
+					IF a < end THEN
+						WriteString("."); WriteString(name)
+					END
+				ELSE
+					WriteString("("); WriteString(mod.name); WriteString(")")
+				END;
+				WriteString("  ")
+			END;
+			WriteString("(pc="); WriteHex(a, 8);
+			WriteString(", fp="); WriteHex(b, 8); WriteString(")");
+			IF (b >= sp) & (b < stack) THEN
+				SYSTEM.GET(b+4, a);	(* stacked pc *)
+				SYSTEM.GET(b, b);	(* dynamic link *)
+				DEC(c)
+			ELSE c := 0
+			END
+		UNTIL c = 0;
+		out[len] := 0X;
+		x := MessageBox("BlackBox", out$, {mbOk})
+	END DefaultTrapViewer;
+	
+	PROCEDURE TrapCleanup;
+		VAR t: TrapCleaner;
+	BEGIN
+		WHILE trapStack # NIL DO
+			t := trapStack; trapStack := trapStack.next; t.Cleanup
+		END;
+		IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
+	END TrapCleanup;
+
+(*
+	PROCEDURE Unwind(f: KERNEL32.ExcpFrmPtr);	(* COMPILER DEPENDENT *)
+		CONST Label = 27;	(* offset of Label: from proc start *)
+	BEGIN
+		PushFP;
+		KERNEL32.RtlUnwind(f, SYSTEM.ADR(Unwind) + Label, NIL, 0);
+		(* Label: *)
+		PopFP
+	END Unwind;
+*)
+	
+(*
+	PROCEDURE TrapHandler (excpRec: KERNEL32.ExcpRecPtr; estFrame: KERNEL32.ExcpFrmPtr;
+											context: KERNEL32.ContextPtr; dispCont: INTEGER): INTEGER;
+		(* same parameter size as Try *)
+	BEGIN
+		IF excpRec^.flags * {1, 2} = {} THEN
+			IF (excpRec.code MOD 256 = 4) & ~interrupted THEN	(* wrong trace trap *)
+				context.debug[5] := 0;	(* disable all debug traps *)
+				LdSP8; PopSI; PopDI; PopFP;	(* COMPILER DEPENDENT *)
+				Return0(0)	(* return continueExecution without parameter remove *)
+			END;
+			Unwind(estFrame);
+			IF trapped & (excpRec.code MOD 256 # 1) & (excpRec.code MOD 256 # 253) THEN
+				DefaultTrapViewer;
+				IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
+			END;
+			err := -(excpRec.code MOD 256);
+			pc := context.ip; sp := context.sp; fp := context.bp; stack := baseStack;
+			IF err = -4 THEN err := 200	(* keyboard interrupt *)
+			ELSIF err = -5 THEN
+				val := excpRec.info[1];
+				IF val = pc THEN	(* call to undef adr *)
+					err := 205; SYSTEM.GET(sp, pc); INC(sp, 4); DEC(pc)
+				ELSIF excpRec.info[0] = 0 THEN	(* illegal read *)
+					err := 203
+				ELSE	(* illegal write *)
+					err := 204
+				END
+			ELSIF (err = -29) OR (err = -30) THEN	(* illegal instruction *)
+				err := 202; val := 0;
+				IF IsReadable(excpRec.adr, excpRec.adr + 4) THEN
+					SYSTEM.GET(excpRec.adr, val);
+					IF val MOD 100H = 8DH THEN	(* lea reg,reg *)
+						IF val DIV 100H MOD 100H = 0F0H THEN
+							err := val DIV 10000H MOD 100H	(* trap *)
+						ELSIF val DIV 1000H MOD 10H = 0EH THEN
+							err := 128 + val DIV 100H MOD 10H	(* run time error *)
+						END
+					END
+				END
+			ELSIF err = -142 THEN DEC(pc); err := 140	(* fpu: div by zero *)
+			ELSIF (err = -144) OR (err = -146) THEN DEC(pc); err := 143	;	(* fpu: invalid op *)
+				val := context.float[0] MOD 4096 * 65536 + context.float[1] MOD 65536
+			ELSIF err = -145 THEN DEC(pc); err := 142	(* fpu: overflow *)
+			ELSIF err = -147 THEN DEC(pc); err := 141	(* fpu: underflow *)
+			ELSIF err = -148 THEN err := 139	(* division by zero *)
+			ELSIF err = -149 THEN err := 138	(* integer overflow *)
+			ELSIF (err = -1) OR (err = -253) THEN err := 137	(* stack overflow *)
+			END;
+			INC(trapCount);
+			InitFpu;
+			IF err # 137 THEN	(* stack overflow handling is delayed *)
+				TrapCleanup;
+				IF err = 128 THEN	(* do nothing *)
+				ELSIF(trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
+					trapped := TRUE; trapViewer()
+				ELSE DefaultTrapViewer
+				END
+			END;
+			trapped := FALSE; secondTrap := FALSE;
+			IF dispCont = 0 THEN	(* InterfaceTrapHandler *)	(* COMPILER DEPENDENT *)
+				KERNEL32.RemoveExcp(estFrame^);
+				SYSTEM.PUTREG(CX, estFrame(ExcpFramePtr).par);
+				SYSTEM.PUTREG(SP, SYSTEM.VAL(INTEGER, estFrame) + 12);
+				IF err = 137 THEN	(* retrigger stack overflow *)
+					TrapCleanup; DefaultTrapViewer;
+					res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {2, 8}, old);
+					IF res = 0 THEN res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {0}, old) END
+				END;
+				PopSI; PopDI; PopBX; PopFP;
+				ReturnCX(WinApi.E_UNEXPECTED)
+			ELSIF estFrame # excpPtr THEN	(* Try failed *)	(* COMPILER DEPENDENT *)
+				KERNEL32.RemoveExcp(estFrame^);
+				res := SYSTEM.VAL(INTEGER, estFrame);
+				SYSTEM.PUTREG(FP, res + (SIZE(KERNEL32.ExcpFrm) + 8));	(* restore fp *)
+				SYSTEM.PUTREG(SP, res - 4);	(* restore stack *)
+				IF err = 137 THEN	(* retrigger stack overflow *)
+					TrapCleanup; DefaultTrapViewer;
+					res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {2, 8}, old);
+					IF res = 0 THEN res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {0}, old) END
+				END;
+				PopBX;
+				RETURN 0	(* return from Try *)
+			ELSIF restart # NIL THEN	(* Start failed *)
+				SYSTEM.PUTREG(FP, baseStack);	(* restore fp *)
+				SYSTEM.PUTREG(SP, baseStack);	(* restore stack *)
+				IF err = 137 THEN	(* retrigger stack overflow *)
+					TrapCleanup; DefaultTrapViewer;
+					res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {2, 8}, old);
+					IF res = 0 THEN res := KERNEL32.VirtualProtect(FPageWord(8), 1024, {0}, old) END
+				END;
+				restart();
+				Quit(1)
+			ELSE	(* boot process failed *)
+				Quit(1)
+			END
+			(* never returns *)
+		ELSE
+			LdSP8; PopSI; PopDI; PopFP;	(* COMPILER DEPENDENT *)
+			Return0(1)	(* return continueSearch without parameter remove *)
+		END
+	END TrapHandler;
+*)
+
+	PROCEDURE SetTrapGuard* (on: BOOLEAN);
+	BEGIN
+		guarded := on
+	END SetTrapGuard;
+
+(*
+	PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);	(* COMPILER DEPENDENT *)
+		(* same parameter size as TrapHandler *)
+		VAR excp: KERNEL32.ExcpFrm;	(* no other local variables!  *)
+	BEGIN
+		PushBX;
+		excp.handler := TrapHandler;
+		KERNEL32.InstallExcp(excp); 
+		h(a, b, c);
+		KERNEL32.RemoveExcp(excp);
+		PopBX
+	END Try;
+*)
+
+	PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);	
+		VAR res: INTEGER; context: LinLibc.sigjmp_buf; oldContext: POINTER TO LinLibc.sigjmp_buf;
+	BEGIN
+		oldContext := currentTryContext;
+		res := LinLibc.sigsetjmp(context, LinLibc.TRUE);
+		currentTryContext := SYSTEM.ADR(context);
+		IF res = 0 THEN (* first time around *)
+			h(a, b, c);
+		ELSIF res = trapReturn THEN  (* after a trap *)
+		ELSE
+			HALT(100)
+		END;
+		currentTryContext := oldContext;
+	END Try;
+	
+	PROCEDURE InterfaceTrapHandler* (excpRec, estFrame, context, dispCont: INTEGER): INTEGER;
+	(* known to compiler *)
+		VAR res: INTEGER;
+	BEGIN
+(*
+		res := TrapHandler(SYSTEM.VAL(KERNEL32.ExcpRecPtr, excpRec),
+								SYSTEM.VAL(KERNEL32.ExcpFrmPtr, estFrame),
+								SYSTEM.VAL(KERNEL32.ContextPtr, context),
+								0);
+		(* LdSP8 removes parameters of TrapHandler *)
+		LdSP8; PopSI; PopDI; PopFP;	(* COMPILER DEPENDENT *)
+		Return0(1);	(* return continueSearch without parameter remove *)
+		IF FALSE THEN RETURN 0 END
+*)
+		RETURN 0
+	END InterfaceTrapHandler;
+	
+	(* -------------------- keyboard interrupt handling --------------------- *)
+	
+(*
+	PROCEDURE KeyboardWatcher (main: INTEGER): INTEGER;	(* runs in a thread *)
+		VAR res, id, a, to: INTEGER; msg: USER32.Message; wnd: USER32.Handle;
+			context: KERNEL32.Context; mod: Module;
+	BEGIN
+		wnd := USER32.CreateWindowExA({}, "Edit", "", {}, 0, 0, 0, 0, 0, 0, KERNEL32.GetModuleHandleA(NIL), 0);
+		res := USER32.RegisterHotKey(wnd, 13, {1}, 3);	(* ctrl break *)
+		IF res = 0 THEN
+			res := USER32.RegisterHotKey(wnd, 14, {1, 2}, 3)	(* shift ctrl break *)
+		END;
+		LOOP
+			res := USER32.GetMessageA(msg, 0, 0, 0);
+			IF msg.message = USER32.WMHotKey THEN
+				wnd := USER32.GetForegroundWindow();
+				res := USER32.GetWindowThreadProcessId(wnd, id);
+				IF (msg.wParam = 14) OR (id = KERNEL32.GetCurrentProcessId()) THEN
+					to := KERNEL32.GetTickCount() + 1000;	(* 1 sec timeout *)
+					REPEAT
+						res := KERNEL32.SuspendThread(main);
+						context.flags := {0, 16};
+						res := KERNEL32.GetThreadContext(main, context);
+						mod := modList; a := context.ip;
+						WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO
+							mod := mod.next
+						END;
+						IF (mod # NIL) & (mod.name = "Kernel") THEN mod := NIL END;
+						IF mod # NIL THEN
+							interrupted := TRUE;
+							INCL(SYSTEM.VAL(SET, context.pf), 8);	(* set trap flag *)
+							res := KERNEL32.SetThreadContext(main, context)
+						END;
+						res := KERNEL32.ResumeThread(main);
+						KERNEL32.Sleep(0);
+						interrupted := FALSE
+					UNTIL (mod # NIL) OR (KERNEL32.GetTickCount() > to)
+				END
+			END
+		END;
+		RETURN 0
+	END KeyboardWatcher;
+*)
+	
+(*
+	PROCEDURE InstallKeyboardInt;
+		VAR res, id: INTEGER; t, main: KERNEL32.Handle;
+	BEGIN
+		res := KERNEL32.DuplicateHandle(KERNEL32.GetCurrentProcess(), KERNEL32.GetCurrentThread(),
+					KERNEL32.GetCurrentProcess(), main, {1, 3, 4, 16..19}, 0, {});
+		t := KERNEL32.CreateThread(NIL, 4096, KeyboardWatcher, main, {}, id)
+	END InstallKeyboardInt;
+*)
+	
+	(* -------------------- Initialization --------------------- *)
+	
+	PROCEDURE InitFpu;	(* COMPILER DEPENDENT *)
+	(* could be eliminated, delayed for backward compatibility *)
+		VAR cw: SET;
+	BEGIN
+		FINIT;
+		FSTCW;
+		(* denorm, underflow, precision, zero div, overflow masked *)
+		(* invalid trapped *)
+		(* round to nearest, temp precision *)
+		cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9};
+		FLDCW
+	END InitFpu;
+	
+	(* A. V. Shiryaev *)
+	(* show extended trap information *)
+	PROCEDURE ShowTrap (sig: INTEGER; siginfo: LinLibc.Ptrsiginfo_t; context: LinLibc.Ptrucontext_t);
+
+		PROCEDURE WriteChar (c: SHORTCHAR);
+			VAR s: ARRAY [untagged] 2 OF SHORTCHAR;
+		BEGIN
+			s[0] := c; s[1] := 0X;
+			res := LinLibc.printf(s)
+		END WriteChar;
+
+		PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
+			VAR res: INTEGER;
+		BEGIN
+			res := LinLibc.printf(s)
+		END WriteString;
+		
+		PROCEDURE WriteHex (x, n: INTEGER);
+			VAR i, y: INTEGER;
+				s: ARRAY 9 OF SHORTCHAR;
+		BEGIN
+			s[n] := 0X;
+			i := 0 + n - 1;
+			WriteChar("$");
+			WHILE i >= 0 DO
+				y := x MOD 16; x := x DIV 16;
+				IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
+				s[i] := SHORT(CHR(y + ORD("0")));
+				DEC(i)
+			END;
+			WriteString(s)
+		END WriteHex;
+
+		PROCEDURE WriteLn;
+		BEGIN
+			WriteChar(0AX)
+		END WriteLn;
+
+		PROCEDURE KV (name: ARRAY OF SHORTCHAR; x: INTEGER);
+		BEGIN
+			WriteString(name); WriteString(" = "); WriteHex(x, 8)
+		END KV;
+
+	BEGIN
+		WriteString("================================"); WriteLn;
+		WriteString("TRAP:"); WriteLn;
+		WriteString("--------------------------------"); WriteLn;
+
+		KV("sig", sig); WriteString(", ");
+		KV("baseStack", baseStack); WriteLn;		
+
+		KV("GS ", context.sc_gs); WriteString(", ");
+		KV("FS ", context.sc_fs); WriteString(", ");
+		KV("ES ", context.sc_es); WriteString(", ");
+		KV("DS ", context.sc_ds); WriteLn;
+
+		KV("EDI", context.sc_edi); WriteString(", ");
+		KV("ESI", context.sc_esi); WriteString(", ");
+		KV("EBP", context.sc_ebp); WriteString(", ");
+		KV("EBX", context.sc_ebx); WriteLn;
+
+		KV("EDX", context.sc_edx); WriteString(", ");
+		KV("ECX", context.sc_ecx); WriteString(", ");
+		KV("EAX", context.sc_eax); WriteString(", ");
+		KV("EIP", context.sc_eip); WriteLn;
+
+		KV("CS", context.sc_cs); WriteString(", ");
+		KV("EFLAGS", context.sc_eflags); WriteString(", ");
+		KV("ESP", context.sc_esp); WriteString(", ");
+		KV("SS", context.sc_ss); WriteLn;
+
+		KV("ONSTACK", context.sc_onstack); WriteString(", ");
+		KV("MASK", context.sc_mask); WriteString(", ");
+		KV("TRAPNO", context.sc_trapno); WriteString(", ");
+		KV("ERR", context.sc_err); WriteLn;
+
+		(* WriteString("--------------------------------"); WriteLn; *)
+
+		(* TODO: show siginfo *)
+
+		WriteString("================================"); WriteLn
+	END ShowTrap;
+	
+	PROCEDURE TrapHandler (sig: INTEGER; siginfo: LinLibc.Ptrsiginfo_t; context: LinLibc.Ptrucontext_t);
+	BEGIN
+	(*
+		SYSTEM.GETREG(SP, sp);
+		SYSTEM.GETREG(FP, fp);
+	*)
+		stack := baseStack;
+
+		(* A. V. Shiryaev *)
+			ShowTrap(sig, siginfo, context);
+			(*
+			sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *)
+			fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *)
+			pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *)
+			*)
+			sp := context.sc_esp; fp := context.sc_ebp; pc := context.sc_eip;
+			(* val := siginfo.si_addr; *)
+			val := siginfo.si_pid; (* XXX *)
+
+	(*
+		Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno);
+		Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int);
+	*)
+		err := sig;
+		IF trapped THEN DefaultTrapViewer END;
+		CASE sig OF
+			LinLibc.SIGINT: 
+				err := 200 (* Interrupt (ANSI). *)
+			| LinLibc.SIGILL: (* Illegal instruction (ANSI). *)
+				err := 202; val := 0;
+				IF IsReadable(pc, pc + 4) THEN
+					SYSTEM.GET(pc, val);
+					IF val MOD 100H = 8DH THEN	(* lea reg,reg *)
+						IF val DIV 100H MOD 100H = 0F0H THEN
+							err := val DIV 10000H MOD 100H	(* trap *)
+						ELSIF val DIV 1000H MOD 10H = 0EH THEN
+							err := 128 + val DIV 100H MOD 10H	(* run time error *)
+						END
+					END
+				END
+			| LinLibc.SIGFPE: 
+				CASE siginfo.si_code OF
+					0: (* TODO: ?????? *)
+						(* A. V. Shiryaev *)
+							(*
+							IF siginfo.si_int = 8 THEN
+								err := 139
+							ELSIF siginfo.si_int = 0 THEN
+								err := 143
+							END
+							*)
+							err := 143;
+					| LinLibc.FPE_INTDIV: err := 139 (* Integer divide by zero.  *)
+					| LinLibc.FPE_INTOVF: err := 138 (* Integer overflow.  *)
+					| LinLibc.FPE_FLTDIV: err := 140 (* Floating point divide by zero.  *)
+					| LinLibc.FPE_FLTOVF: err := 142 (* Floating point overflow.  *)
+					| LinLibc.FPE_FLTUND: err := 141 (* Floating point underflow.  *)
+					| LinLibc.FPE_FLTRES: err := 143 (* Floating point inexact result.  *)
+					| LinLibc.FPE_FLTINV: err := 143 (* Floating point invalid operation.  *)
+					| LinLibc.FPE_FLTSUB: err := 134 (* Subscript out of range.  *)
+				ELSE
+				END
+			| LinLibc.SIGSEGV: (* Segmentation violation (ANSI). *) 
+				err := 203
+		ELSE
+		END;
+		INC(trapCount);
+		InitFpu;
+		TrapCleanup;
+		IF err # 128 THEN
+			IF (trapViewer = NIL) OR trapped THEN
+				DefaultTrapViewer
+			ELSE
+				trapped := TRUE;
+				trapViewer();
+				trapped := FALSE
+			END
+		END;
+		IF currentTryContext # NIL THEN (* Try failed *)
+			LinLibc.siglongjmp(currentTryContext, trapReturn)
+		ELSE
+			IF restart # NIL THEN (* Start failed *)
+				LinLibc.siglongjmp(loopContext, trapReturn)
+			END;
+			Quit(1);
+		END;
+		trapped := FALSE
+	END TrapHandler;
+	
+	PROCEDURE InstallSignals*;
+		VAR sa, old: LinLibc.sigaction_t; res, i: INTEGER;
+	BEGIN
+		sa.sa_sigaction := TrapHandler;
+(*
+		res := LinLibc.sigemptyset(SYSTEM.ADR(sa.sa_mask));
+*)
+		res := LinLibc.sigfillset(SYSTEM.ADR(sa.sa_mask));
+		sa.sa_flags := LinLibc.SA_SIGINFO; (* TrapHandler takes three arguments *)
+		(*
+		IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END;
+		IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END;
+		IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END;
+		IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END;
+		IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END;
+		IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END;
+		*)
+		(* respond to all possible signals *)
+		FOR i := 1 TO LinLibc._NSIG - 1 DO 
+			IF (i # LinLibc.SIGKILL)
+				& (i # LinLibc.SIGSTOP)
+				& (i # LinLibc.SIGWINCH)
+			THEN
+				IF LinLibc.sigaction(i, sa, old) # 0 THEN Msg("failed to install signal"); Int(i) END;
+			END
+		END
+	END InstallSignals;
+	
+	PROCEDURE SetOpts;
+		VAR k: Module;
+	BEGIN
+		k := modList;
+		WHILE (k # NIL) & (k.name # "Kernel") DO k := k.next END;
+		ASSERT(k # NIL);
+		static := init IN k.opts;
+		inDll := dll IN k.opts
+	END SetOpts;
+
+	PROCEDURE SetCmdLine;
+		VAR i, l: INTEGER;
+	BEGIN
+		l := LEN(cmdLine);
+		cmdLine := bootInfo.argv[0]$;
+		FOR i := 1 TO bootInfo.argc - 1 DO cmdLine := cmdLine + " " + bootInfo.argv[i]END
+	END SetCmdLine;
+	
+	PROCEDURE Init;
+		VAR (*excp: KERNEL32.ExcpFrm; *) t: Type; (*res: COM.RESULT; *) i: INTEGER;
+			env: LinLibc.jmp_buf; res: LONGINT;
+	BEGIN
+		InstallSignals; (* init exception handling *)
+		currentTryContext := NIL;
+		t := SYSTEM.VAL(Type, SYSTEM.ADR(Command));	(* type desc of Command *)
+		comSig := t.size;	(* size = signature fprint for proc types *)
+		allocated := 0; total := 0; used := 0;
+		sentinelBlock.size := MAX(INTEGER);
+		sentinel := SYSTEM.ADR(sentinelBlock);
+(* cdg/mf, 4.2.2004, dll support
+		SYSTEM.PUTREG(ML, SYSTEM.ADR(modList));
+*)
+		IF dllMem THEN
+			i := N;
+			REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
+			root := NIL;
+(*
+			heap := KERNEL32.GetProcessHeap()
+*)
+		ELSE
+			i := N;
+			REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
+			AllocHeapMem(1, root); ASSERT(root # NIL, 100);
+			i := MIN(N - 1, (root.size - 12) DIV 16 - 1);
+			free[i] := SYSTEM.VAL(FreeBlock, SYSTEM.VAL(INTEGER, root) + 12);
+			free[i].next := sentinel;
+			free[i].size := (root.size - 12) DIV 16 * 16 - 4
+		END;
+(*
+		res := WinOle.OleInitialize(0);
+		IF inDll THEN
+			baseStack := FPageWord(4)	(* begin of stack segment *)
+		ELSE
+			InstallKeyboardInt;
+			InitFpu
+		END;
+*)
+		InitFpu;
+		IF ~static THEN
+			InitModule(modList);
+			IF ~inDll THEN Quit(1) END
+		END;
+		told := 0; shift := 0;
+	END Init;
+	
+BEGIN
+	IF modList = NIL THEN	(* only once *)
+		IF bootInfo # NIL THEN
+			modList := bootInfo.modList; (* boot loader initializes the bootInfo struct *)
+			SYSTEM.GETREG(SP, baseStack); (* TODO: Check that this is ok. *)
+			SetOpts;
+			SetCmdLine
+		ELSE
+			SYSTEM.GETREG(ML, modList);	(* linker loads module list to BX *)
+			SYSTEM.GETREG(SP, baseStack);
+			static := init IN modList.opts;
+			inDll := dll IN modList.opts;
+		END;
+(*
+		dllMem := inDll;
+*)
+		Init
+	END
+CLOSE
+	IF ~terminating THEN
+		terminating := TRUE;
+		Quit(0)
+	END
+END Kernel.
+
+(!)DevDecoder.Decode Kernel

BlackBox/Lindev/Mod/CPB.txt

@@ -0,0 +1,2248 @@
+MODULE LindevCPB;
+
+	(* THIS IS TEXT COPY OF CPB.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT DevCPT := LindevCPT, DevCPM := LindevCPM;
+
+	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;
+		min = 34; max = 35; typfn = 36; size = 37;
+		
+		(* 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; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18;
+		intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16};
+
+		(* 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;
+		lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38;
+		
+		(*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;
+		thisrecfn = 45; thisarrfn = 46;
+
+		(* COM function number *)
+		validfn = 40; iidfn = 41; queryfn = 42;
+		
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* procedure flags (conval.setval) *)
+		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
+		
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		(* case statement flags (conval.setval) *)
+		useTable = 1; useTree = 2;
+		
+		(* sysflags *)
+		nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13;
+
+		AssertTrap = 0;	(* default trap number *)
+
+		covarOut = FALSE;
+		
+		
+	VAR
+		typSize*: PROCEDURE(typ: DevCPT.Struct);
+		zero, one, two, dummy, quot: DevCPT.Const;
+
+	PROCEDURE err(n: SHORTINT);
+	BEGIN DevCPM.err(n)
+	END err;
+	
+	PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node;
+		VAR node: DevCPT.Node; typ: DevCPT.Struct;
+	BEGIN
+		typ := obj.typ;
+		CASE obj.mode OF
+		  Var:
+				node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0)
+		| VarPar:
+				node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar;
+		| Con:
+				node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst();
+				node.conval^ := obj.conval^	(* string is not copied, only its ref *)
+		| Typ:
+				node := DevCPT.NewNode(Ntype)
+		| LProc..IProc, TProc:
+				node := DevCPT.NewNode(Nproc)
+		ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp
+		END ;
+		node.obj := obj; node.typ := typ;
+		RETURN node
+	END NewLeaf;
+	
+	PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node;  y: DevCPT.Node);
+		VAR node: DevCPT.Node;
+	BEGIN
+		node := DevCPT.NewNode(class); node.typ := DevCPT.notyp;
+		node.left := x; node.right := y; x := node
+	END Construct;
+	
+	PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.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: INTEGER): BOOLEAN;
+	BEGIN
+		IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
+	END IntToBool;
+	
+	PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp;
+		x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x
+	END NewBoolConst;
+	
+	PROCEDURE OptIf*(VAR x: DevCPT.Node);	(* x.link = NIL *)
+		VAR if, pred: DevCPT.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*(): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp;
+		x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x
+	END Nil;
+
+	PROCEDURE EmptySet*(): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp;
+		x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x
+	END EmptySet;
+	
+	PROCEDURE MarkAsUsed (node: DevCPT.Node);
+		VAR c: BYTE;
+	BEGIN
+		c := node.class;
+		WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END;
+		IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END
+	END MarkAsUsed;
+	
+	
+	PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object);
+		VAR n: DevCPT.Name; o: DevCPT.Object;
+	BEGIN
+		n := "@@  "; DevCPT.Insert(n, obj); obj.name^ := name$;	(* avoid err 1 *)
+		obj.mode := Var; obj.typ := typ;
+		o := DevCPT.topScope.scope;
+		IF o = NIL THEN DevCPT.topScope.scope := obj
+		ELSE
+			WHILE o.link # NIL DO o := o.link END;
+			o.link := obj
+		END
+	END GetTempVar;
+
+
+	(* ---------- constant operations ---------- *)
+	
+	PROCEDURE Log (x: DevCPT.Node): INTEGER;
+		VAR val, exp: INTEGER;
+	BEGIN
+		exp := 0;
+		IF x.typ.form = Int64 THEN
+			RETURN -1
+		ELSE
+			val := x.conval.intval;
+			IF val > 0 THEN
+				WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END
+			END;
+			IF val # 1 THEN exp := -1 END
+		END;
+		RETURN exp
+	END Log;
+
+	PROCEDURE Floor (x: REAL): REAL;
+		VAR y: REAL;
+	BEGIN
+		IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x
+		ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN
+			y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0);
+			RETURN SHORT(ENTIER(x - y)) + y
+		ELSE RETURN SHORT(ENTIER(x))
+		END
+	END Floor;
+
+	PROCEDURE SetToInt (s: SET): INTEGER;
+		VAR x, i: INTEGER;
+	BEGIN
+		i := 31; x := 0;
+		IF 31 IN s THEN x := -1 END;
+		WHILE i > 0 DO
+			x := x * 2; DEC(i);
+			IF i IN s THEN INC(x) END
+		END;
+		RETURN x
+	END SetToInt;
+
+	PROCEDURE IntToSet (x: INTEGER): SET;
+		VAR i: INTEGER; s: SET;
+	BEGIN
+		i := 0; s := {};
+		WHILE i < 32 DO
+			IF ODD(x) THEN INCL(s, i) END;
+			x := x DIV 2; INC(i)
+		END;
+		RETURN s
+	END IntToSet;
+
+	PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct);
+		CONST MAXL = 9223372036854775808.0; (* 2^63 *)
+	BEGIN
+		IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
+				& (x.realval + x.intval <= MAX(INTEGER)) THEN
+			x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
+		END;
+		IF form IN intSet THEN
+			IF x.realval = 0 THEN typ := DevCPT.int32typ
+			ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ
+			ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ
+			END
+		ELSIF form IN realSet THEN	(* SR *)
+			typ := DevCPT.real64typ
+		ELSIF form IN charSet THEN
+			IF x.intval <= 255 THEN typ := DevCPT.char8typ
+			ELSE typ := DevCPT.char16typ
+			END
+		ELSE typ := DevCPT.undftyp
+		END
+	END GetConstType;
+	
+	PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT);
+		VAR type: DevCPT.Struct;
+	BEGIN
+		GetConstType(x, form, errno, type);
+		IF  ~DevCPT.Includes(form, type.form)
+		& ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
+		& ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) 
+		& ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN
+			err(errno); x.intval := 1; x.realval := 0
+		END
+(*
+		IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
+				& (x.realval + x.intval <= MAX(INTEGER)) THEN
+			x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
+		END;
+		IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval))
+		OR (form = Int32) & (x.realval # 0)
+		OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
+		OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
+		OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535))
+		OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255))
+		OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN
+			err(errno); x.intval := 1; x.realval := 0
+		END
+*)
+	END CheckConstType;
+	
+	PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER);
+		VAR sr: SHORTREAL;
+	BEGIN
+		IF from = Set THEN
+			x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {};
+		ELSIF from IN intSet + charSet THEN
+			IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval)
+			ELSIF to IN intSet THEN CheckConstType(x, to, 203)
+			ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc
+			ELSE (*to IN charSet*) CheckConstType(x, to, 220)
+			END
+		ELSIF from IN realSet THEN
+			IF to IN realSet THEN CheckConstType(x, to, 203);
+				IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END	(* reduce precision *)
+			ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203)
+			END
+		END
+	END ConvConst;
+	
+	PROCEDURE Prepare (x: DevCPT.Const);
+		VAR r: REAL;
+	BEGIN
+		x.realval := x.realval + x.intval DIV 32768 * 32768;
+		x.intval := x.intval MOD 32768;
+		r := Floor(x.realval / 4096) * 4096;
+		x.intval := x.intval + SHORT(ENTIER(x.realval - r));
+		x.realval := r
+		(* ABS(x.intval) < 2^15  &  ABS(x.realval) MOD 2^12 = 0 *)
+	END Prepare;
+	
+	PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x + y *)
+	BEGIN
+		IF type.form IN intSet THEN
+			Prepare(x); Prepare(y);
+			z.intval := x.intval + y.intval; z.realval := x.realval + y.realval
+		ELSIF type.form IN realSet THEN
+			IF ABS(x.realval) = DevCPM.InfReal THEN
+				IF y.realval # -x.realval THEN z.realval := x.realval ELSE err(212) END
+			ELSIF ABS(y.realval) = DevCPM.InfReal THEN z.realval := y.realval
+			ELSIF (y.realval >= 0) & (x.realval <= MAX(REAL) - y.realval)
+					OR (y.realval < 0) & (x.realval >= -MAX(REAL) - y.realval) THEN
+				z.realval := x.realval + y.realval
+			ELSE err(206)
+			END
+		ELSE HALT(100)
+		END;
+		GetConstType(z, type.form, 206, type)
+	END AddConst;
+	
+	PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x - y *)
+	BEGIN
+		IF type.form IN intSet THEN
+			Prepare(x); Prepare(y);
+			z.intval := x.intval - y.intval; z.realval := x.realval - y.realval
+		ELSIF type.form IN realSet THEN
+			IF ABS(x.realval) = DevCPM.InfReal THEN
+				IF y.realval # x.realval THEN z.realval := x.realval ELSE err(212) END
+			ELSIF ABS(y.realval) = DevCPM.InfReal THEN z.realval := -y.realval
+			ELSIF (y.realval >= 0) & (x.realval >= -MAX(REAL) + y.realval)
+					OR (y.realval < 0) & (x.realval <= MAX(REAL) + y.realval) THEN
+				z.realval := x.realval - y.realval
+			ELSE err(207)
+			END
+		ELSE HALT(100)
+		END;
+		GetConstType(z, type.form, 207, type)
+	END SubConst;
+	
+	PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x * y *)
+	BEGIN
+		IF type.form IN intSet THEN
+			Prepare(x); Prepare(y);
+			z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval;
+			z.intval := x.intval * y.intval
+		ELSIF type.form IN realSet THEN
+			IF ABS(x.realval) = DevCPM.InfReal THEN
+				IF y.realval > 0 THEN z.realval := x.realval
+				ELSIF y.realval < 0 THEN z.realval := -x.realval
+				ELSE err(212)
+				END
+			ELSIF ABS(y.realval) = DevCPM.InfReal THEN
+				IF x.realval > 0 THEN z.realval := y.realval
+				ELSIF x.realval < 0 THEN z.realval := -y.realval
+				ELSE err(212)
+				END
+			ELSIF (ABS(y.realval) <= 1) OR (ABS(x.realval) <= MAX(REAL) / ABS(y.realval)) THEN
+				z.realval := x.realval * y.realval
+			ELSE err(204)
+			END
+		ELSE HALT(100)
+		END;
+		GetConstType(z, type.form, 204, type)
+	END MulConst;
+	
+	PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x / y *)
+	BEGIN
+		IF type.form IN realSet THEN
+			IF y.realval # 0.0 THEN
+				IF ABS(x.realval) = DevCPM.InfReal THEN
+					IF ABS(y.realval) = DevCPM.InfReal THEN err(212)
+					ELSIF y.realval >= 0 THEN z.realval := x.realval
+					ELSE z.realval := -x.realval
+					END
+				ELSIF ABS(y.realval) = DevCPM.InfReal THEN z.realval := 0
+				ELSIF (ABS(y.realval) >= 1) OR (ABS(x.realval) <= MAX(REAL) * ABS(y.realval)) THEN
+					z.realval := x.realval / y.realval
+				ELSE err(204)
+				END
+			ELSE err(205)
+			END
+		ELSE HALT(100)
+		END;
+		GetConstType(z, type.form, 204, type)
+	END DivConst;
+	
+	PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct);
+	(* x := x DIV y | x MOD y *)
+	BEGIN
+		IF type.form IN intSet THEN
+			IF y.realval + y.intval # 0 THEN
+				Prepare(x); Prepare(y);
+				quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval));
+				quot.intval := 0; Prepare(quot);
+				x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval;
+				x.intval := x.intval - quot.intval * y.intval;
+				IF y.realval + y.intval > 0 THEN
+					WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
+					WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
+				ELSE
+					WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
+					WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
+				END;
+				IF div THEN x.realval := quot.realval; x.intval := quot.intval END;
+				GetConstType(x, type.form, 204, type)
+			ELSE err(205)
+			END
+		ELSE HALT(100)
+		END
+	END DivModConst;
+	
+	PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN;	(* x = y *)
+		VAR res: BOOLEAN;
+	BEGIN
+		CASE form OF
+		| Undef: res := TRUE
+		| Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval
+		| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0
+		| Real32, Real64: res := x.realval = y.realval
+		| Set: res := x.setval = y.setval
+		| String8, String16, Comp (* guid *): res := x.ext^ = y.ext^
+		| NilTyp, Pointer, ProcTyp: res := x.intval = y.intval
+		END;
+		RETURN res
+	END EqualConst;
+	
+	PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN;	(* x < y *)
+		VAR res: BOOLEAN;
+	BEGIN
+		CASE form OF
+		| Undef: res := TRUE
+		| Byte, Char8..Int32, Char16: res := x.intval < y.intval
+		| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0
+		| Real32, Real64: res := x.realval < y.realval
+		| String8, String16: res := x.ext^ < y.ext^
+		| Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108)
+		END;
+		RETURN res
+	END LessConst;
+	
+
+	PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
+		x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x
+	END NewIntConst;
+	
+	PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
+		x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x
+	END NewLargeIntConst;
+	
+	PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node;
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
+		x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc;
+		IF typ = NIL THEN typ := DevCPT.real64typ END;
+		x.typ := typ;
+		RETURN x
+	END NewRealConst;
+	
+	PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node;
+		VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt;
+	BEGIN
+		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
+		IF lstr # NIL THEN
+			x.typ := DevCPT.string16typ;
+			NEW(ext, 3 * len); i := 0; j := 0;
+			REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0;
+			x.conval.ext := ext
+		ELSE
+			x.typ := DevCPT.string8typ; x.conval.ext := str
+		END;
+		x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len;
+		RETURN x
+	END NewString;
+	
+	PROCEDURE CharToString8(n: DevCPT.Node);
+		VAR ch: SHORTCHAR;
+	BEGIN
+		n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2);
+		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 := DevCPM.ConstNotAlloc; n.obj := NIL
+	END CharToString8;
+	
+	PROCEDURE CharToString16 (n: DevCPT.Node);
+		VAR ch, ch1: SHORTCHAR; i: INTEGER;
+	BEGIN
+		n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4);
+		IF n.conval.intval = 0 THEN
+			n.conval.ext[0] := 0X; n.conval.intval2 := 1
+		ELSE
+			i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i);
+			n.conval.ext[i] := 0X; n.conval.intval2 := 2
+		END;
+		n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
+	END CharToString16;
+	
+	PROCEDURE String8ToString16 (n: DevCPT.Node);
+		VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
+	BEGIN
+		n.typ := DevCPT.string16typ; ext := n.conval.ext;
+		NEW(new, 2 * n.conval.intval2); i := 0; j := 0; 
+		REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0;
+		n.conval.ext := new; n.obj := NIL
+	END String8ToString16;
+	
+	PROCEDURE String16ToString8 (n: DevCPT.Node);
+		VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
+	BEGIN
+		n.typ := DevCPT.string8typ; ext := n.conval.ext;
+		NEW(new, n.conval.intval2); i := 0; j := 0;
+		REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0;
+		n.conval.ext := new; n.obj := NIL
+	END String16ToString8;
+	
+	PROCEDURE StringToGuid (VAR n: DevCPT.Node);
+	BEGIN
+		ASSERT((n.class = Nconst) & (n.typ.form = String8));
+		IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END;
+		n.typ := DevCPT.guidtyp
+	END StringToGuid;
+	
+	PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT);
+		VAR ntyp: DevCPT.Struct;
+	BEGIN
+		ntyp := n.typ;
+		IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n)
+		ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN
+			IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n)
+			ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *)
+			ELSE err(e)
+			END
+		ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN
+			IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n)
+			ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n)
+			ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN
+				(* ok *)
+			ELSE err(e)
+			END
+		ELSE err(e)
+		END
+	END CheckString;
+	
+	
+	PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR node: DevCPT.Node;
+	BEGIN
+		node := DevCPT.NewNode(class); node.typ := typ;
+		node.left := x; node.right := y; x := node
+	END BindNodes;
+
+	PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN;
+	BEGIN
+		RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst))
+			OR (x.typ.form IN {String8, String16})
+	END NotVar;
+
+
+	PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct);
+		VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL;
+	BEGIN f := x.typ.form; g := typ.form;
+		IF x.class = Nconst THEN
+			IF g = String8 THEN
+				IF f = String16 THEN String16ToString8(x)
+				ELSIF f IN charSet THEN CharToString8(x)
+				ELSE typ := DevCPT.undftyp
+				END
+			ELSIF g = String16 THEN
+				IF f = String8 THEN String8ToString16(x)
+				ELSIF f IN charSet THEN CharToString16(x)
+				ELSE typ := DevCPT.undftyp
+				END
+			ELSE ConvConst(x.conval, f, g)
+			END;
+			x.obj := NIL
+		ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g))
+		THEN
+			(* don't create new node *)
+			IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END
+		ELSE
+			IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN	(* propagate to leaf nodes *)
+				Convert(x.left, typ); Convert(x.right, typ)
+			ELSE
+				node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node;
+			END
+		END;
+		x.typ := typ
+	END Convert;
+
+	PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER);	(* check expression compatibility *)
+		VAR f, g: INTEGER; new: DevCPT.Struct;
+	BEGIN
+		f := left.typ.form; g := right.typ.form; new := left.typ;
+		IF f IN intSet + realSet THEN
+			IF g IN intSet + realSet THEN
+				IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst)
+					(* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32)
+							OR (ABS(right.conval.realval) = DevCPM.InfReal)) *)
+				OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst)
+					(* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32)
+							OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN
+						new := DevCPT.real32typ	(* SR *)
+				ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ
+				ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ	(* SR *)
+				ELSIF op = slash THEN new := DevCPT.real64typ
+				ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ
+				ELSE new := DevCPT.int32typ
+				END
+			ELSE err(100)
+			END
+		ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN
+			IF f = String8 THEN StringToGuid(left) END;
+			IF g = String8 THEN StringToGuid(right) END;
+			IF left.typ # right.typ THEN err(100) END;
+			f := Comp
+		ELSIF f IN charSet + {String8, String16} THEN
+			IF g IN charSet + {String8, String16} THEN
+				IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN
+					new := DevCPT.string16typ
+				ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ
+				ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ
+				ELSIF op = plus THEN
+					IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ
+					ELSE new := DevCPT.string8typ
+					END
+				END;
+				IF (new.form IN {String8, String16})
+					& ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst))
+				THEN
+					err(100)
+				END
+			ELSE err(100)
+			END
+		ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN
+			IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp)
+				& ~((f = Pointer) & (g = Pointer)
+					& (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END
+		ELSIF f # g THEN err(100)
+		END;
+		IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN
+			IF g # new.form THEN Convert(right, new) END;
+			IF f # new.form THEN Convert(left, new) END
+		END
+	END Promote;
+
+	PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *)
+		VAR ft, at: DevCPT.Struct;
+	BEGIN
+		WHILE fp # NIL DO
+			IF ap # NIL THEN
+				ft := fp.typ; at := ap.typ;
+				IF fp.ptyp # NIL THEN ft := fp.ptyp END;	(* get original formal type *)
+				IF ap.ptyp # NIL THEN at := ap.ptyp END;	(* get original formal type *)
+				IF ~DevCPT.EqualType(ft, at)
+					OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis)
+					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 CheckNewParamPair* (newPar, iidPar: DevCPT.Node);
+		VAR ityp, ntyp: DevCPT.Struct;
+	BEGIN
+		ntyp := newPar.typ.BaseTyp;
+		IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN
+			IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev)
+			THEN (* ok *)
+			ELSE err(168)
+			END
+		ELSIF ntyp.extlev = 0 THEN	(* ok *)
+		ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN
+			IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END
+		ELSE err(168)
+		END
+	END CheckNewParamPair;
+
+	
+	PROCEDURE DeRef*(VAR x: DevCPT.Node);
+		VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct;
+	BEGIN
+		typ := x.typ;
+		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
+		ELSIF typ.form = Pointer THEN
+			btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj;
+			IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN
+				btyp.pbused := TRUE
+			END ;
+			BindNodes(Nderef, btyp, x, NIL); x.subcl := 0
+		ELSE err(84)
+		END
+	END DeRef;
+
+	PROCEDURE StrDeref*(VAR x: DevCPT.Node);
+		VAR typ, btyp: DevCPT.Struct;
+	BEGIN
+		typ := x.typ;
+		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
+		ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN
+			IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ
+			ELSE btyp := DevCPT.string16typ
+			END;
+			BindNodes(Nderef, btyp, x, NIL); x.subcl := 1
+		ELSE err(90)
+		END
+	END StrDeref;
+
+	PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR f: SHORTINT; typ: DevCPT.Struct;
+	BEGIN
+		f := y.typ.form;
+		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79)
+		ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ;
+		IF f = Int64 THEN Convert(y, DevCPT.int32typ) 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 := DevCPT.undftyp
+		END ;
+		BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly
+	END Index;
+	
+	PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object);
+	BEGIN (*x.typ.comp = Record*)
+		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) 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 := DevCPT.undftyp
+		END
+	END Field;
+	
+	PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN);
+
+		PROCEDURE GTT(t0, t1: DevCPT.Struct);
+			VAR node: DevCPT.Node;
+		BEGIN
+			IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN
+				IF ~guard THEN x := NewBoolConst(TRUE) END
+			ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint)
+					OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN
+				IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly
+				ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node
+				END
+			ELSE err(85)
+			END
+		END GTT;
+
+	BEGIN
+		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112)
+		ELSIF x.typ.form = Pointer THEN
+			IF x.typ = DevCPT.sysptrtyp THEN
+				IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp)
+				ELSE err(86)
+				END
+			ELSIF x.typ.BaseTyp.comp # Record 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) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN
+			GTT(x.typ, obj.typ)
+		ELSE err(87)
+		END ;
+		IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END
+	END TypTest;
+	
+	PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR f: SHORTINT; k: INTEGER;
+	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 f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+			IF x.class = Nconst THEN
+				k := x.conval.intval;
+				IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202)
+				ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL
+				ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
+				END
+			ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
+			END
+		ELSE err(92)
+		END ;
+		x.typ := DevCPT.booltyp
+	END In;
+
+	PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node);
+		VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node;
+		
+		PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node;
+			VAR node: DevCPT.Node;
+		BEGIN
+			node := DevCPT.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)) & (op # adr) & (op # typfn) & (op # size) 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 = Set THEN z.conval.setval := -z.conval.setval
+						ELSE SubConst(zero, z.conval, z.conval, z.typ)
+						END;
+						z.obj := NIL
+					ELSE
+						IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
+						z := NewOp(op, z.typ, z)
+					END
+				ELSE err(97)
+				END
+			| abs:
+				IF f IN intSet + realSet THEN
+					IF z.class = Nconst THEN
+						IF LessConst(z.conval, zero, f) THEN SubConst(zero, z.conval, z.conval, z.typ) END;
+						z.obj := NIL
+					ELSE
+						IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
+						z := NewOp(op, z.typ, z)
+					END
+				ELSE err(111)
+				END
+			| cap:
+				IF f IN charSet THEN
+					IF z.class = Nconst THEN
+						IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END;
+						z.obj := NIL
+					ELSE z := NewOp(op, typ, z)
+					END
+				ELSE err(111); z.typ := DevCPT.char8typ
+				END
+			| odd:
+				IF f IN intSet THEN
+					IF z.class = Nconst THEN
+						DivModConst(z.conval, two, FALSE, z.typ);	(* z MOD 2 *)
+						z.obj := NIL
+					ELSE z := NewOp(op, typ, z)
+					END
+				ELSE err(111)
+				END ;
+				z.typ := DevCPT.booltyp
+			| adr: (*ADR*)
+				IF z.class = Nproc THEN
+					IF z.obj.mnolev > 0 THEN err(73)
+					ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc
+					END;
+					z := NewOp(op, typ, z)
+				ELSIF z.class = Ntype THEN
+					IF z.obj.typ.untagged THEN err(111) END;
+					z := NewOp(op, typ, z)
+				ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN
+					z := NewOp(op, typ, z)
+				ELSE err(127)
+				END ;
+				z.typ := DevCPT.int32typ
+			| typfn, size: (*TYP, SIZE*)
+				z := NewOp(op, typ, z);
+				z.typ := DevCPT.int32typ
+			| cc: (*SYSTEM.CC*)
+				IF (f IN intSet) & (z.class = Nconst) THEN
+					IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN
+						z := NewOp(op, typ, z)
+					ELSE err(219)
+					END
+				ELSE err(69)
+				END;
+				z.typ := DevCPT.booltyp
+			END
+		END;
+		x := z
+	END MOp;
+	
+	PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node);
+		VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct;
+	BEGIN
+		f := x.typ.form;
+		IF f = y.typ.form THEN
+			xval := x.conval; yval := y.conval;
+			CASE op OF
+			| times:
+				IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ)
+				ELSIF f = Set THEN xval.setval := xval.setval * yval.setval
+				ELSIF f # Undef THEN err(101)
+				END
+			| slash:
+				IF f IN realSet THEN DivConst(xval, yval, xval, x.typ)
+				ELSIF f = Set THEN xval.setval := xval.setval / yval.setval
+				ELSIF f # Undef THEN err(102)
+				END
+			| div:
+				IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ)
+				ELSIF f # Undef THEN err(103)
+				END
+			| mod:
+				IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ)
+				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 + realSet THEN AddConst(xval, yval, xval, x.typ)
+				ELSIF f = Set THEN xval.setval := xval.setval + yval.setval
+				ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN
+					NEW(ext, LEN(xval.ext^) + LEN(yval.ext^));
+					i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END;
+					j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END;
+					ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1)
+				ELSIF f # Undef THEN err(105)
+				END
+			| minus:
+				IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ)
+				ELSIF f = Set THEN xval.setval := xval.setval - yval.setval
+				ELSIF f # Undef THEN err(106)
+				END
+			| min:
+				IF f IN intSet + realSet THEN
+					IF LessConst(yval, xval, f) THEN xval^ := yval^ END
+				ELSIF f # Undef THEN err(111)
+				END
+			| max:
+				IF f IN intSet + realSet THEN
+					IF LessConst(xval, yval, f) THEN xval^ := yval^ END
+				ELSIF f # Undef THEN err(111)
+				END
+			| or:
+				IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval))
+				ELSE err(95)
+				END
+			| eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
+			| neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
+			| lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
+			| leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
+			| gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
+			| geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
+			END
+		ELSE err(100)
+		END;
+		x.obj := NIL
+	END ConstOp;
+	
+	PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER;
+
+		PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
+			VAR node: DevCPT.Node;
+		BEGIN
+			node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ;
+			node.left := x; node.right := y; x := node
+		END NewOp;
+
+	BEGIN z := x;
+		IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
+		ELSE
+			Promote(z, y, op);
+			IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y)
+			ELSE
+				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
+							IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y
+							ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE
+							ELSE val := Log(z);
+								IF val >= 0 THEN
+									t := y; y := z; z := t;
+									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
+								END
+							END
+						ELSIF y.class = Nconst THEN
+							IF EqualConst(y.conval, one, f) THEN do := FALSE
+							ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y
+							ELSE val := Log(y);
+								IF val >= 0 THEN
+									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
+								END
+							END
+						END
+					ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp
+					END ;
+					IF do THEN NewOp(op, typ, z, y) END;
+				| slash:
+					IF f IN realSet THEN
+						IF (y.class = Nconst) & (y.conval.realval = 0) THEN err(205) END
+					ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp
+					END ;
+					NewOp(op, typ, z, y)
+				| div:
+					do := TRUE;
+					IF f IN intSet THEN
+						IF y.class = Nconst THEN
+							IF EqualConst(y.conval, zero, f) THEN err(205)
+							ELSIF EqualConst(y.conval, one, f) THEN do := FALSE
+							ELSE val := Log(y);
+								IF val >= 0 THEN
+									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL
+								END
+							END
+						END
+					ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp
+					END ;
+					IF do THEN NewOp(op, typ, z, y) END;
+				| mod:
+					IF f IN intSet THEN
+						IF y.class = Nconst THEN
+							IF EqualConst(y.conval, zero, f) THEN err(205)
+							ELSE val := Log(y);
+								IF val >= 0 THEN
+									op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL
+								END
+							END
+						END
+					ELSIF f # Undef THEN err(104); typ := DevCPT.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 *)
+						ELSE NewOp(op, typ, z, y)
+						END
+					ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp
+					END
+				| plus:
+					IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END;
+					do := TRUE;
+					IF f IN intSet THEN
+						IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ;
+						IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END
+					ELSIF f IN {String8, String16} THEN
+						IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ;
+						IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END;
+						IF do THEN
+							IF z.class = Ndop THEN
+								t := z; WHILE t.right.class = Ndop DO t := t.right END;
+								IF (t.right.class = Nconst) & (y.class = Nconst) THEN
+									ConstOp(op, t.right, y); do := FALSE
+								ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
+									ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE
+								ELSE
+									NewOp(op, typ, t.right, y); do := FALSE
+								END
+							ELSE
+								IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
+									ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE
+								END
+							END
+						END
+					END ;
+					IF do THEN NewOp(op, typ, z, y) END;
+				| minus:
+					IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END;
+					IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y)
+					END;
+				| min, max:
+					IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END;
+					NewOp(op, typ, z, y);
+				| 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 *)
+						ELSE NewOp(op, typ, z, y)
+						END
+					ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp
+					END
+				| eql, neq, lss, leq, gtr, geq:
+					IF f IN {String8, String16} THEN
+						IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN
+							z := z.left; y := y.left	(* remove LONG on both sides *)
+						ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *)
+							y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0
+						ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *)
+							z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0
+						END;
+						typ := DevCPT.booltyp
+					ELSIF (f IN {Undef, Char8..Real64, Char16, Int64})
+							OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN
+						typ := DevCPT.booltyp
+					ELSE err(107); typ := DevCPT.undftyp
+					END;
+					NewOp(op, typ, z, y)
+				END
+			END
+		END;
+		x := z
+	END Op;
+
+	PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR k, l: INTEGER;
+	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.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
+			IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END;
+			IF x.class = Nconst THEN
+				k := x.conval.intval;
+				IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END
+			END ;
+			IF y.class = Nconst THEN
+				l := y.conval.intval;
+				IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) 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, DevCPT.settyp, x, y)
+			END
+		ELSE err(93)
+		END ;
+		x.typ := DevCPT.settyp
+	END SetRange;
+
+	PROCEDURE SetElem*(VAR x: DevCPT.Node);
+		VAR k: INTEGER;
+	BEGIN
+		IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END;
+		IF x.typ.form IN intSet THEN
+			IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
+			IF x.class = Nconst THEN
+				k := x.conval.intval;
+				IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k}
+				ELSE err(202)
+				END ;
+				x.obj := NIL
+			ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit
+			END ;
+		ELSE err(93)
+		END;
+		x.typ := DevCPT.settyp
+	END SetElem;
+	
+	PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node);
+	(* x := y, checks assignment compatibility *)
+		VAR f, g: SHORTINT; y, b: DevCPT.Struct;
+	BEGIN
+		y := ynode.typ; f := x.form; g := y.form;
+		IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
+		CASE f OF
+		| Undef, String8, String16, Byte:
+		| Bool, Set:
+			IF g # f THEN err(113) END
+		| Int8, Int16, Int32, Int64, Real32, Real64:	(* SR *)
+			IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN
+				IF ynode.class = Nconst THEN Convert(ynode, x)
+				ELSIF ~DevCPT.Includes(f, g) THEN err(113)
+				END
+			ELSE err(113)
+			END
+(*			
+			IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN
+				err(113)
+			ELSIF ynode.class = Nconst THEN Convert(ynode, x)
+			END
+*)
+		| Char8, Char16:
+			IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113)
+			ELSIF ynode.class = Nconst THEN Convert(ynode, x)
+			END
+		| Pointer:
+			b := x.BaseTyp;
+			IF DevCPT.Extends(y, x)
+				OR (g = NilTyp)
+				OR (g = Pointer)
+					& ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp))
+			THEN (* ok *)
+			ELSIF (b.comp = DynArr) & b.untagged THEN	(* pointer to untagged open array *)
+				IF ynode.class = Nconst THEN CheckString(ynode, b, 113)
+				ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113)
+				END
+			ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN	(* p := ADR(r) *)
+				IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113)
+				ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113)
+				END
+			ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8}))
+			THEN
+				IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END
+			ELSE err(113)
+			END
+		| ProcTyp:
+			IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *)
+			ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN
+				IF ynode.obj.mode = LProc THEN
+					IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END
+				END;
+				IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN
+					IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE)
+					ELSE err(117)
+					END
+				ELSE err(113)
+				END
+			ELSE err(113)
+			END
+		| NoTyp, NilTyp: err(113)
+		| Comp:
+			x.pvused := TRUE;	(* idfp of y guarantees assignment compatibility with x *)
+			IF x.comp = Record THEN
+				IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END
+			ELSIF g IN {Char8, Char16, String8, String16} THEN
+				IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ)
+				ELSE CheckString(ynode, x, 113);
+				END;
+				IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN
+					err(114)
+				END
+			ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *)
+			ELSE err(113)
+			END
+		END
+	END CheckAssign;
+	
+	PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node);	(* x := str or x[0] := 0X *)
+	BEGIN
+		ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16}));
+		IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN	(* x := "" -> x[0] := 0X *)
+			Index(x, NewIntConst(0));
+			str.typ := x.typ; str.conval.intval := 0;
+		END;
+		BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign
+	END AssignString;
+	
+	PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN);
+	BEGIN
+		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 CheckOldType (x: DevCPT.Node);
+	BEGIN
+		IF ~(DevCPM.oberon IN DevCPM.options)
+			& ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN
+			err(198)
+		END
+	END CheckOldType;
+	
+	PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT);	(* par0: first param of standard proc *)
+		VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node;
+	BEGIN x := par0; f := x.typ.form;
+		CASE fctno OF
+		  haltfn: (*HALT*)
+				IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
+					IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
+						BindNodes(Ntrap, DevCPT.notyp, x, x)
+					ELSE err(218)
+					END
+				ELSIF (DevCPM.java IN DevCPM.options)
+					& ((x.class = Ntype) OR (x.class = Nvar))
+					& (x.typ.form = Pointer)
+				THEN
+					BindNodes(Ntrap, DevCPT.notyp, x, x)
+				ELSE err(69)
+				END ;
+				x.typ := DevCPT.notyp
+		| newfn: (*NEW*)
+				typ := DevCPT.notyp;
+				IF NotVar(x) THEN err(112)
+				ELSIF f = Pointer THEN
+					IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
+					IF x.readonly THEN err(76)
+					ELSIF (x.typ.BaseTyp.attribute = absAttr)
+						OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193)
+					ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
+					END ;
+					MarkAsUsed(x);
+					f := x.typ.BaseTyp.comp;
+					IF f IN {Record, DynArr, Array} THEN
+						IF f = DynArr THEN typ := x.typ.BaseTyp END ;
+						BindNodes(Nassign, DevCPT.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 = Char8 THEN Convert(x, DevCPT.int16typ)
+				ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ)
+				ELSIF f = Set THEN Convert(x, DevCPT.int32typ)
+				ELSE err(111)
+				END
+		| bitsfn: (*BITS*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp)
+				ELSE err(111)
+				END
+		| entierfn: (*ENTIER*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
+				ELSE err(111)
+				END ;
+				x.typ := DevCPT.int64typ
+		| lentierfcn: (* LENTIER *)
+				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
+				ELSE err(111)
+				END ;
+				x.typ := DevCPT.int64typ
+		| oddfn: (*ODD*)
+				MOp(odd, x)
+		| minfn: (*MIN*)
+				IF x.class = Ntype THEN
+					CheckOldType(x);
+					CASE f OF
+					  Bool:  x := NewBoolConst(FALSE)
+					| Char8:  x := NewIntConst(0); x.typ := DevCPT.char8typ
+					| Char16:  x := NewIntConst(0); x.typ := DevCPT.char8typ
+					| Int8:  x := NewIntConst(-128)
+					| Int16:   x := NewIntConst(-32768)
+					| Int32:  x := NewIntConst(-2147483648)
+					| Int64:  x := NewLargeIntConst(0, -9223372036854775808.0E0)	(* -2^63 *)
+					| Set:   x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *)
+					| Real32:  x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ)
+					| Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ)
+					ELSE err(111)
+					END;
+					x.hint := 1
+				ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
+				END
+		| maxfn: (*MAX*)
+				IF x.class = Ntype THEN
+					CheckOldType(x);
+					CASE f OF
+					  Bool:  x := NewBoolConst(TRUE)
+					| Char8:  x := NewIntConst(0FFH); x.typ := DevCPT.char8typ
+					| Char16:  x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ
+					| Int8:  x := NewIntConst(127)
+					| Int16:   x := NewIntConst(32767)
+					| Int32:  x := NewIntConst(2147483647)
+					| Int64:  x := NewLargeIntConst(-1, 9223372036854775808.0E0)	(* 2^63 - 1 *)
+					| Set:   x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *)
+					| Real32:  x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ)
+					| Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ)
+					ELSE err(111)
+					END;
+					x.hint := 1
+				ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
+				END
+		| chrfn: (*CHR*) 
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
+				ELSE err(111); x.typ := DevCPT.char16typ
+				END
+		| lchrfn: (* LCHR *)
+				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
+				ELSE err(111); x.typ := DevCPT.char16typ
+				END
+		| shortfn: (*SHORT*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSE
+					IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
+					END;
+					IF f = Int16 THEN Convert(x, DevCPT.int8typ)
+					ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ)
+					ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ)
+					ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ)
+					ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ)
+					ELSIF f = String16 THEN Convert(x, DevCPT.string8typ)
+					ELSE err(111)
+					END
+				END
+		| longfn: (*LONG*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSE
+					IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
+					END;
+					IF f = Int8 THEN Convert(x, DevCPT.int16typ)
+					ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ)
+					ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ)
+					ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ)
+					ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ)
+					ELSIF f = String8 THEN Convert(x, DevCPT.string16typ)
+					ELSE err(111)
+					END
+				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;
+				MarkAsUsed(x)
+		| inclfn, exclfn: (*INCL, EXCL*)
+				IF NotVar(x) THEN err(112)
+				ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp
+				ELSIF x.readonly THEN err(76)
+				END;
+				MarkAsUsed(x)
+		| lenfn: (*LEN*)
+				IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126)	(* !!! *)
+				(* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *)
+				ELSE
+					IF x.typ.form = Pointer THEN DeRef(x) END;
+					IF x.class = Nconst THEN
+						IF x.typ.form = Char8 THEN CharToString8(x)
+						ELSIF x.typ.form = Char16 THEN CharToString16(x)
+						END
+					END;
+					IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END
+				END
+		| copyfn: (*COPY*)
+				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END
+		| ashfn: (*ASH*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN intSet THEN
+					IF f < Int32 THEN Convert(x, DevCPT.int32typ) END
+				ELSE err(111); x.typ := DevCPT.int32typ
+				END
+		| adrfn: (*ADR*)
+				IF x.class = Ntype THEN CheckOldType(x) END;
+				CheckLeaf(x, FALSE); MOp(adr, x)
+		| typfn: (*TYP*)
+				CheckLeaf(x, FALSE);
+				IF x.class = Ntype THEN
+					CheckOldType(x);
+					IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END;
+					IF x.typ.comp # Record THEN err(111) END;
+					MOp(adr, x)
+				ELSE
+					IF x.typ.form = Pointer THEN DeRef(x) END;
+					IF x.typ.comp # Record THEN err(111) END;
+					MOp(typfn, x)
+				END
+		| sizefn: (*SIZE*)
+				IF x.class # Ntype THEN err(110); x := NewIntConst(1)
+				ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN
+					CheckOldType(x); x.typ.pvused := TRUE;
+					IF typSize # NIL THEN
+						typSize(x.typ); x := NewIntConst(x.typ.size)
+					ELSE
+						MOp(size, x)
+					END
+				ELSE err(111); x := NewIntConst(1)
+				END
+		| thisrecfn, (*THISRECORD*)
+		  thisarrfn: (*THISARRAY*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ)
+				ELSIF f # Int32 THEN err(111)
+				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 + charSet + {Byte, Set}) 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 {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
+				ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
+				END
+		| getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
+				IF (f IN intSet) & (x.class = Nconst) THEN
+					IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220)
+					END
+				ELSE err(69)
+				END
+		| valfn: (*SYSTEM.VAL*)
+				IF x.class # Ntype THEN err(110)
+				ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111)
+				ELSE CheckOldType(x)
+				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
+		| validfn: (* VALID *)
+				IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN
+					MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil())
+				ELSE err(111)
+				END;
+				x.typ := DevCPT.booltyp
+		| iidfn: (* COM.IID *)
+				IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x)
+				ELSE
+					typ := x.typ;
+					IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+					IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN
+						IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END
+					ELSE err(111)
+					END;
+					x.class := Nconst; x.typ := DevCPT.guidtyp
+				END
+		| queryfn: (* COM.QUERY *)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f # Pointer THEN err(111)
+				END
+		END ;
+		par0 := x
+	END StPar0;
+
+	PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE);
+	(* x: second parameter of standard proc *)
+		VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node;
+		
+		PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node;
+			VAR node: DevCPT.Node;
+		BEGIN
+			node := DevCPT.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 := DevCPT.notyp
+				ELSE
+					IF f # p.typ.form THEN
+						IF f IN intSet THEN Convert(x, p.typ)
+						ELSE err(111)
+						END
+					END ;
+					p := NewOp(Nassign, fctno, p, x);
+					p.typ := DevCPT.notyp
+				END
+		| inclfn, exclfn: (*INCL, EXCL*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN intSet THEN
+					IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+					IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202)
+					END ;
+					p := NewOp(Nassign, fctno, p, x)
+				ELSE err(111)
+				END ;
+				p.typ := DevCPT.notyp
+		| lenfn: (*LEN*)
+				IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69)
+				ELSE
+					IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+					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) (* possible side effect ignored *)
+							END;
+							p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ
+						ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ
+						END
+					END
+				END
+		| copyfn: (*COPY*)
+				IF NotVar(x) THEN err(112)
+				ELSIF x.readonly THEN err(76)
+				ELSE
+					CheckString(p, x.typ, 111); t := x; x := p; p := t;
+					IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x)
+					ELSE p := NewOp(Nassign, copyfn, p, x)
+					END
+				END ;
+				p.typ := DevCPT.notyp; MarkAsUsed(x)
+		| ashfn: (*ASH*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN intSet THEN
+					IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208)
+					ELSIF (p.class = Nconst) & (x.class = Nconst) THEN
+						n := x.conval.intval;
+						IF n > 0 THEN
+							WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END
+						ELSE
+							WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END
+						END;
+						p.obj := NIL
+					ELSE
+						IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+						typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ
+					END
+				ELSE err(111)
+				END
+		| minfn: (*MIN*)
+				IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END
+		| maxfn: (*MAX*)
+				IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) 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 f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+						IF (x.class = Nconst) & (x.conval.intval <= 0)
+							& (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END
+					ELSE err(111)
+					END ;
+					p.right := x; p.typ := p.typ.BaseTyp
+				ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN
+					typ := p.left.typ;
+					WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
+					IF typ.sysflag = interface THEN
+						typ := x.typ;
+						WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
+						IF (f = Pointer) & (typ.sysflag = interface) THEN
+							p.right := x
+						ELSE err(169)
+						END
+					ELSE err(64)
+					END
+				ELSE err(111)
+				END
+		| thisrecfn, (*THISRECORD*)
+		  thisarrfn: (*THISARRAY*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF f IN {Int8, Int16, Int32} THEN
+					IF f < Int32 THEN Convert(x, DevCPT.int32typ) END;
+					p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp
+				ELSE err(111)
+				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, NilTyp, Pointer, ProcTyp, Char16, Int64} 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 := DevCPT.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 := DevCPT.booltyp
+		| valfn: (*SYSTEM.VAL*)	(* type is changed without considering the byte ordering on the target machine *)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF x.typ.comp = DynArr THEN
+					IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN	(* ok *)
+					ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN
+						typ := x.typ;
+						WHILE typ.comp = DynArr DO typ := typ.BaseTyp END;
+						tp1 := p.typ;
+						WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END;
+						IF typ.size # tp1.size THEN err(115) END
+					ELSE err(115)
+					END
+				ELSIF p.typ.comp = DynArr THEN err(115)
+				ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN
+					i := 0; n := 0;
+					WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END;
+					x := NewIntConst(n)
+				ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111)
+				END ;
+				IF (x.class = Nconst) & (x.typ = p.typ) THEN	(* ok *)
+				ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet))
+						OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN
+					t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t
+				ELSE x.readonly := FALSE
+				END ;
+				x.typ := p.typ; p := x
+		| movefn: (*SYSTEM.MOVE*)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
+				ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
+				END ;
+				p.link := x
+		| assertfn: (*ASSERT*)
+				IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
+					IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
+						BindNodes(Ntrap, DevCPT.notyp, x, x);
+						Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
+					ELSE err(218)
+					END
+				ELSIF
+					(DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer)
+				THEN
+					BindNodes(Ntrap, DevCPT.notyp, x, x);
+					Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
+				ELSE err(69)
+				END;
+				IF p = NIL THEN	(* ASSERT(TRUE) *)
+				ELSIF p.class = Ntrap THEN err(99)
+				ELSE p.subcl := assertfn
+				END
+		| queryfn: (* COM.QUERY *)
+				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+				ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp
+				END;
+				p.link := x
+		ELSE err(64)
+		END ;
+		par0 := p
+	END StPar1;
+
+	PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT);
+	(* x: n+1-th param of standard proc *)
+		VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct;
+	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 f = Int64 THEN Convert(x, DevCPT.int32typ) END;
+				IF (x.class = Nconst) & (x.conval.intval <= 0) 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 := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p;
+				node.left := p.link; p.link := x; p := node
+			ELSE err(111)
+			END ;
+			p.typ := DevCPT.notyp
+		ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *)
+			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+			ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN
+				IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END;
+				IF x.readonly THEN err(76) END;
+				CheckNewParamPair(x, p.link);
+				MarkAsUsed(x);
+				node := DevCPT.NewNode(Ndop); node.subcl := queryfn;
+				node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node
+			ELSE err(111)
+			END;
+			p.typ := DevCPT.booltyp
+		ELSE err(64)
+		END ;
+		par0 := p
+	END StParN;
+
+	PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT);
+		VAR dim: SHORTINT; x, p: DevCPT.Node;
+	BEGIN p := par0;
+		IF fctno <= ashfn THEN
+			IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN
+				IF p.typ.comp = DynArr THEN err(65) END ;
+				p.typ := DevCPT.notyp
+			ELSIF (fctno = minfn) OR (fctno = maxfn) THEN
+				IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END;
+				p.hint := 0
+			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, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ
+				ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
+					IF p.typ.form IN {String8, String16} THEN
+						IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1)
+						ELSIF (p.class = Ndop) & (p.subcl = plus) THEN	(* propagate to leaf nodes *)
+							StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ
+						ELSE
+							WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END;
+							IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END;
+							BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len
+						END
+					ELSIF p.typ.comp = DynArr THEN dim := 0;
+						WHILE p.class = Nindex DO p := p.left; INC(dim) END ;	(* possible side effect ignored *)
+						BindNodes(Ndop, DevCPT.int32typ, 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, DevCPT.notyp, x, NewIntConst(AssertTrap));
+				Construct(Nif, p, x); 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
+		ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN
+			IF parno < 1 THEN err(65) END
+		ELSIF fctno < validfn THEN (*SYSTEM*)
+			IF (parno < 1) OR
+				(fctno > ccfn) & (parno < 2) OR
+				(fctno = movefn) & (parno < 3) THEN err(65)
+			END
+		ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN
+			IF parno < 2 THEN err(65) END
+		ELSE (* COM *)
+			IF fctno = queryfn THEN
+				IF parno < 3 THEN err(65) END
+			ELSE
+				IF parno < 1 THEN err(65) END
+			END
+		END ;
+		par0 := p
+	END StFct;
+	
+	PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN);
+	(* check array compatibility *)
+		VAR atyp: DevCPT.Struct;
+	BEGIN (* ftyp.comp = DynArr *)
+		atyp := ap.typ;
+		IF atyp.form IN {Char8, Char16, String8, String16} THEN
+			IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ)
+			ELSE CheckString(ap, ftyp, 67)
+			END
+		ELSE		
+			WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO
+				ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
+			END;
+			IF ftyp.comp = DynArr THEN err(67)
+			ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *)
+			ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66)
+			END
+		END
+	END DynArrParCheck;
+
+	PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.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
+				IF fpar.typ.form = Pointer THEN
+					IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END
+				END;
+				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 := DevCPT.undftyp
+		END
+	END PrepCall;
+
+	PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object);	(* checks parameter compatibilty *)
+		VAR at, ft: DevCPT.Struct;
+	BEGIN
+		at := ap.typ; ft := fp.typ;
+		IF fp.ptyp # NIL THEN ft := fp.ptyp END;	(* get original formal type *)
+		IF ft.form # Undef THEN
+			IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END;
+			IF fp.mode = VarPar THEN
+				IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *)
+				ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *)
+				ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN
+					(* ok *)
+				ELSE
+					IF fp.vis = inPar THEN
+						IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN
+							StringToGuid(ap); at := ap.typ
+(*
+						ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp))
+								& ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *)
+						ELSIF NotVar(ap) THEN err(122)
+*)
+						END;
+						IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END
+					ELSE
+						IF NotVar(ap) THEN err(122)
+						ELSIF ap.readonly THEN err(76)
+						ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN		
+							err(167)
+						ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE)
+						END
+					END;
+					IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar)
+					ELSIF ODD(fp.sysflag DIV newBit) THEN
+						IF ~DevCPT.Extends(at, ft) THEN err(123) END
+					ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *)
+					ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *)
+					ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *)
+					ELSIF fp.vis = inPar THEN CheckAssign(ft, ap)
+					ELSIF ~DevCPT.EqualType(ft, at) THEN err(123)
+					END
+				END
+			ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE)
+			ELSE CheckAssign(ft, ap)
+			END
+		END
+	END Param;
+	
+	PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN);
+		VAR scope: DevCPT.Object;
+	BEGIN
+		scope := DevCPT.topScope;
+		WHILE dlev > 0 DO DEC(dlev);
+			INCL(scope.link.conval.setval, slNeeded);
+			scope := scope.left
+		END;
+		IF var THEN INCL(scope.link.conval.setval, imVar) END	(* !!! *)
+	END StaticLink;
+
+	PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object);
+		VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE;
+	BEGIN
+		IF x.class = Nproc THEN typ := x.typ;
+			lev := x.obj.mnolev;
+			IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) 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: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object);
+		VAR x: DevCPT.Node;
+	BEGIN
+		x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc;
+		x.left := procdec; x.right := stat; procdec := x
+	END Enter;
+	
+	PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object);
+		VAR node: DevCPT.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 # DevCPT.notyp THEN err(124)
+			END
+		END ;
+		node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node
+	END Return;
+
+	PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node);
+		VAR z: DevCPT.Node;
+	BEGIN
+		IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ;
+		CheckAssign(x.typ, y);
+		IF x.readonly THEN err(76)
+		ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
+		END ;
+		MarkAsUsed(x);
+		IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y)
+		ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign
+		END
+	END Assign;
+	
+	PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct);
+		VAR node: DevCPT.Node;
+	BEGIN
+		node := DevCPT.NewNode(Ninittd); node.typ := typ;
+		node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos;
+		IF inittd = NIL THEN inittd := node ELSE last.link := node END ;
+		last := node
+	END Inittd;
+	
+	(* handling of temporary variables for string operations *)
+	
+	PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN;
+	BEGIN
+		IF right.class = Nconst THEN
+			RETURN FALSE
+		ELSIF (right.class = Ndop) & (right.subcl = plus) THEN
+			RETURN Overlap(left, right.left) OR Overlap(left, right.right)
+		ELSE
+			WHILE right.class = Nmop DO right := right.left END;
+			IF right.class = Nderef THEN right := right.left END;
+			IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END;
+			LOOP
+				IF left.class = Nvarpar THEN
+					WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO
+						right := right.left
+					END;
+					RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev)
+				ELSIF right.class = Nvarpar THEN
+					WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END;
+					RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev)
+				ELSIF (left.class = Nvar) & (right.class = Nvar) THEN
+					RETURN left.obj = right.obj
+				ELSIF (left.class = Nderef) & (right.class = Nderef) THEN
+					RETURN TRUE
+				ELSIF (left.class = Nindex) & (right.class = Nindex) THEN
+					IF (left.right.class = Nconst) & (right.right.class = Nconst)
+						& (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END;
+					left := left.left; right := right.left
+				ELSIF (left.class = Nfield) & (right.class = Nfield) THEN
+					IF left.obj # right.obj THEN RETURN FALSE END;
+					left := left.left; right := right.left;
+					WHILE left.class = Nguard DO left := left.left END;
+					WHILE right.class = Nguard DO right := right.left END
+				ELSE
+					RETURN FALSE
+				END
+			END
+		END
+	END Overlap;
+
+	PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER);
+		VAR x: INTEGER;
+	BEGIN
+		IF n.class = Nconst THEN
+			length := n.conval.intval2 - 1
+		ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
+			GetStaticLength(n.left, length); GetStaticLength(n.right, x);
+			IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END
+		ELSE
+			WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
+			IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
+			IF n.typ.comp = Array THEN
+				length := n.typ.n - 1
+			ELSIF n.typ.comp = DynArr THEN
+				length := -1
+			ELSE	(* error case *)
+				length := 4
+			END
+		END
+	END GetStaticLength;
+
+	PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node);
+		VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object;
+	BEGIN
+		IF n.class = Nconst THEN
+			length := NewIntConst(n.conval.intval2 - 1)
+		ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
+			GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x);
+			IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x)
+			ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus
+			END
+		ELSE
+			WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
+			IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
+			IF n.typ.comp = Array THEN
+				length := NewIntConst(n.typ.n - 1)
+			ELSIF n.typ.comp = DynArr THEN
+				d := 0;
+				WHILE n.class = Nindex DO n := n.left; INC(d) END;
+				ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar));
+				IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN
+					GetTempVar("@tmp", n.left.typ, obj);
+					x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x);
+					n.left := NewLeaf(obj);	(* tree is manipulated here *)
+					n := NewLeaf(obj); DeRef(n)
+				END;
+				IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN
+					StrDeref(n);
+					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
+					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus
+				ELSE
+					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
+				END;
+				length := n
+			ELSE	(* error case *)
+				length := NewIntConst(4)
+			END
+		END
+	END GetMaxLength;
+
+	PROCEDURE CheckBuffering* (
+		VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node
+	);
+		VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER;
+	BEGIN
+		IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options)
+			& ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right))
+				OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL)
+				OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN
+			IF (par # NIL) & (par.typ.comp = Array) THEN
+				len := par.typ.n - 1
+			ELSE
+				IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END;
+				GetStaticLength(n, xlen);
+				IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END
+			END;
+			IF len # -1 THEN
+				typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp;
+				GetTempVar("@str", typ, obj);
+				x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
+				n := NewLeaf(obj)
+			ELSE
+				IF left # NIL THEN GetMaxLength(left, stat, last, length)
+				ELSE GetMaxLength(n, stat, last, length)
+				END;
+				typ := DevCPT.NewStr(Pointer, Basic);
+				typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp;
+				GetTempVar("@ptr", typ, obj);
+				x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x);
+				x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x);
+				n := NewLeaf(obj); DeRef(n)
+			END;
+			StrDeref(n)
+		ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL)
+				& ((par # NIL) OR (n.class = Ncall))
+				& ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN
+			GetTempVar("@cip", DevCPT.punktyp, obj);
+			x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
+			n := NewLeaf(obj)
+		END
+	END CheckBuffering;
+	
+	PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node);
+		VAR x: DevCPT.Node; obj: DevCPT.Object;
+	BEGIN
+		IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN
+			GetTempVar("@ptr", n.typ, obj);
+			x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
+			n := NewLeaf(obj)
+		END
+	END CheckVarParBuffering;
+
+	
+	(* case optimization *)
+
+	PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node);
+		VAR a: INTEGER;
+	BEGIN
+		IF n.left # NIL THEN
+			a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head);
+			IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END
+		ELSIF n.conval.intval < min THEN
+			min := n.conval.intval
+		END;
+		IF n.right # NIL THEN
+			a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head);
+			IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END
+		ELSIF n.conval.intval2 > max THEN
+			max := n.conval.intval2
+		END;
+		INC(num);
+		IF n.conval.intval < n.conval.intval2 THEN
+			INC(num);
+			IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END
+		END
+	END Evaluate;
+	
+	PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node);
+		VAR n: DevCPT.Node;
+	BEGIN
+		IF root # head THEN
+			IF head.conval.intval2 < root.conval.intval THEN
+				Rebuild(root.left, head);
+				root.left := head.right; head.right := root; root := head
+			ELSE
+				Rebuild(root.right, head);
+				root.right := head.left; head.left := root; root := head
+			END
+		END
+	END Rebuild;
+	
+	PROCEDURE OptimizeCase* (VAR n: DevCPT.Node);
+		VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node;
+	BEGIN
+		IF n # NIL THEN
+			min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n;
+			Evaluate(n, min, max, num, dist, head);
+			limit := 6 * num;
+			IF limit < 100 THEN limit := 100 END;
+			IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN
+				INCL(n.conval.setval, useTable)
+			ELSE
+				IF num > 4 THEN Rebuild(n, head) END;
+				INCL(n.conval.setval, useTree);
+				OptimizeCase(n.left);
+				OptimizeCase(n.right)
+			END
+		END
+	END OptimizeCase;
+(*	
+	PROCEDURE ShowTree (n: DevCPT.Node; opts: SET);
+	BEGIN
+		IF n # NIL THEN
+			IF opts = {} THEN opts := n.conval.setval END;
+			IF useTable IN opts THEN
+				IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END;
+				DevCPM.LogWNum(n.conval.intval, 1);
+				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
+				END;
+				IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END
+			ELSIF useTree IN opts THEN
+				DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1);
+				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
+				END;
+				DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")")
+			ELSE
+				ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1);
+				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
+				END;
+				DevCPM.LogW(" "); ShowTree(n.right, opts)
+			END
+		END
+	END ShowTree;
+*)
+BEGIN
+	zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0;
+	one := DevCPT.NewConst(); one.intval := 1; one.realval := 0;
+	two := DevCPT.NewConst(); two.intval := 2; two.realval := 0;
+	dummy := DevCPT.NewConst();
+	quot := DevCPT.NewConst()
+END LindevCPB.

BlackBox/Lindev/Mod/CPC486.txt

@@ -0,0 +1,2334 @@
+MODULE LindevCPC486;
+
+	(* THIS IS TEXT COPY OF CPC486.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, DevCPM := LindevCPM, DevCPT := LindevCPT, DevCPE := LindevCPE, 
+		DevCPL486 := LindevCPL486;
+
+	CONST
+		initializeAll = FALSE;	(* initialize all local variable to zero *)
+		initializeOut = FALSE;	(* initialize all OUT parameters to zero *)
+		initializeDyn = FALSE;	(* initialize all open array OUT parameters to zero *)
+		initializeStr = FALSE;	(* initialize rest of string value parameters to zero *)
+		
+		FpuControlRegister = 33EH;	(* value for fpu control register initialization *)
+		
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
+		VString16to8 = 29; VString8 = 30; VString16 = 31;
+		intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64};
+
+		(* composite structure forms *)
+		Basic = 1; Array = 2; DynArr = 3; Record = 4;
+
+		(* item base modes (=object modes) *)
+		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
+
+		(* item modes for i386 *)
+		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
+		
+		(* symbol values and 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;
+		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
+		getrfn = 26; putrfn = 27;
+		min = 34; max = 35; typ = 36;
+
+		(* procedure flags (conval.setval) *)
+		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31;
+
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		false = 0; true = 1; nil = 0;
+
+		(* registers *)
+		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
+		stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI};
+	
+		(* GenShiftOp *)
+		ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H;
+
+		(* GenBitOp *)
+		BT = 20H; BTS = 28H; BTR = 30H;
+		
+		(* GenFDOp *)
+		FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H; 
+		
+		(* GenFMOp *)
+		FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H;
+
+		(* GenCode *)
+		SAHF = 9EH; WAIT = 9BH;
+
+		(* condition codes *)
+		ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
+		ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
+		ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
+		ccAlways = -1; ccNever = -2; ccCall = -3;
+
+		(* sysflag *)
+		untagged = 1; callback = 2; noAlign = 3; union = 7;
+		interface = 10; ccall = -10; guarded = 10; noframe = 16;
+		nilBit = 1; enumBits = 8; new = 1; iid = 2;
+		stackArray = 120;
+		
+		(* system trap numbers *)
+		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
+		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
+		
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* pointer init limits *)
+		MaxPtrs = 10; MaxPush = 4;
+		
+		Tag0Offset = 12;
+		Mth0Offset = -4;
+		ArrDOffs = 8;
+		numPreIntProc = 2;
+		
+		stackAllocLimit = 2048;
+
+		
+	VAR
+		imLevel*: ARRAY 64 OF BYTE;
+		intHandler*: DevCPT.Object;
+		inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN;
+		WReg, BReg, AllReg: SET; FReg: INTEGER;
+		ptrTab: ARRAY MaxPtrs OF INTEGER;
+		stkAllocLbl: DevCPL486.Label;
+		procedureUsesFpu: BOOLEAN;
+
+	
+	PROCEDURE Init* (opt: SET);
+		CONST chk = 0; achk = 1; hint = 29;
+	BEGIN
+		inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt;
+		hints := hint IN opt;
+		stkAllocLbl := DevCPL486.NewLbl
+	END Init;
+
+	PROCEDURE Reversed (cond: BYTE): BYTE;	(* reversed condition *)
+	BEGIN
+		IF cond = lss THEN RETURN gtr
+		ELSIF cond = gtr THEN RETURN lss
+		ELSIF cond = leq THEN RETURN geq
+		ELSIF cond = geq THEN RETURN leq
+		ELSE RETURN cond
+		END
+	END Reversed;
+	
+	PROCEDURE Inverted (cc: INTEGER): INTEGER;	(* inverted sense of condition code *)
+	BEGIN
+		IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END
+	END Inverted;
+
+	PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN);
+	BEGIN
+		IF reversed THEN rel := Reversed(rel) END;
+		CASE rel OF
+		   false: x.offset := ccNever
+		| true: x.offset := ccAlways
+		| eql: x.offset := ccE
+		| neq: x.offset := ccNE
+		| lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END
+		| leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END
+		| gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END
+		| geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END
+		END;
+		x.mode := Cond; x.form := Bool; x.reg := 0;
+		IF reversed THEN x.reg := 1 END;
+		IF signed THEN INC(x.reg, 2) END
+	END setCC;
+
+	PROCEDURE StackAlloc*;	(* pre: len = CX bytes; post: len = CX words *)
+	BEGIN
+		DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE)
+	END StackAlloc;
+	
+	PROCEDURE^ CheckAv* (reg: INTEGER);
+
+	PROCEDURE AdjustStack (val: INTEGER);
+		VAR c, sp: DevCPL486.Item;
+	BEGIN
+		IF val < -stackAllocLimit THEN
+			CheckAv(CX);
+			DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp);
+			StackAlloc
+		ELSIF val # 0 THEN
+			DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE)
+		END
+	END AdjustStack;
+	
+	PROCEDURE DecStack (form: INTEGER);
+	BEGIN
+		IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END
+	END DecStack;
+	
+	PROCEDURE IncStack (form: INTEGER);
+	BEGIN
+		IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END
+	END IncStack;
+	
+	(*-----------------register handling------------------*)
+	
+	PROCEDURE SetReg* (reg: SET);
+	BEGIN
+		AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8
+	END SetReg;
+	
+	PROCEDURE CheckReg*;
+		VAR reg: SET;
+	BEGIN
+		reg := AllReg - WReg;
+		IF reg # {} THEN
+			DevCPM.err(-777); (* register not released *)
+			IF AX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " AX" END;
+			IF BX IN reg THEN DevCPM.errorMes := DevCPM.errorMes  +" BX" END;
+			IF CX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " CX" END;
+			IF DX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" DX" END;
+			IF SI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " SI" END;
+			IF DI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " DI" END;
+			WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4)
+		END;
+		IF FReg < 8 THEN DevCPM.err(-778); FReg := 8	 (* float register not released *)
+		ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8
+		END
+	END CheckReg;
+	
+	PROCEDURE CheckAv* (reg: INTEGER);
+	BEGIN
+		ASSERT(reg IN WReg)
+	END CheckAv; 
+	
+	PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET);
+		VAR n: INTEGER; s, s1: SET;
+	BEGIN
+		CASE f OF
+		| Byte, Bool, Char8, Int8:
+			s := BReg * {0..3} - stop;
+			IF (high IN stop) OR (high IN hint) & (s - hint  # {}) THEN n := 0;
+				IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
+				IF s - hint # {} THEN s := s - hint END;
+				WHILE ~(n IN s) DO INC(n) END
+			ELSE
+				s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0;
+				IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
+				s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4);
+				IF s1 # {} THEN s := s1 END;
+				WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END;
+				IF ~(n IN s) THEN n := n + 4 END
+			END;
+			EXCL(BReg, n); EXCL(WReg, n MOD 4)
+		| Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: 
+			s := WReg - stop;
+			IF high IN stop THEN s := s * {0..3} END;
+			IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END;
+			s1 := s - hint;
+			IF high IN hint THEN s1 := s1 * {0..3} END;
+			IF s1 # {} THEN s := s1 END;
+			IF 0 IN s THEN n := 0
+			ELSIF 2 IN s THEN n := 2
+			ELSIF 6 IN s THEN n := 6
+			ELSIF 7 IN s THEN n := 7
+			ELSIF 1 IN s THEN n := 1
+			ELSE n := 3
+			END;
+			EXCL(WReg, n);
+			IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END
+		| Real32, Real64:
+			IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END;
+			DEC(FReg); n := 0
+		END;
+		DevCPL486.MakeReg(x, n, f);
+	END GetReg;
+	
+	PROCEDURE FreeReg (n, f: INTEGER);
+	BEGIN
+		IF f <= Int8 THEN
+			INCL(BReg, n);
+			IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END
+		ELSIF f IN realSet THEN
+			INC(FReg)
+		ELSIF n IN AllReg THEN
+			INCL(WReg, n);
+			IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
+		END
+	END FreeReg;
+	
+	PROCEDURE FreeWReg (n: INTEGER);
+	BEGIN
+		IF n IN AllReg THEN
+			INCL(WReg, n);
+			IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
+		END
+	END FreeWReg;
+	
+	PROCEDURE Free* (VAR x: DevCPL486.Item);
+	BEGIN
+		CASE x.mode OF
+		| Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END
+		| Ind: FreeWReg(x.reg);
+			IF x.scale # 0 THEN FreeWReg(x.index) END
+		| Reg: FreeReg(x.reg, x.form);
+			IF x.form = Int64 THEN FreeWReg(x.index) END
+		ELSE
+		END
+	END Free;
+	
+	PROCEDURE FreeHi (VAR x: DevCPL486.Item);	(* free hi byte of word reg *)
+	BEGIN
+		IF x.mode = Reg THEN
+			IF x.form = Int64 THEN FreeWReg(x.index)
+			ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4)
+			END
+		END
+	END FreeHi;
+
+	PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN;	(* x.mode = Reg *)
+	BEGIN
+		IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END;
+		IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop))
+		ELSIF x.form IN realSet THEN RETURN ~(float IN stop)
+		ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop)
+		ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop))
+		END
+	END Fits;
+	
+	PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET);
+		VAR rh: DevCPL486.Item;
+	BEGIN
+		IF f = Int64 THEN
+			GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r);
+			GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh);
+			r.form := Int64; r.index := rh.reg
+		ELSE
+			IF f < Int16 THEN INCL(stop, high) END;
+			GetReg(r, f, hint, stop); DevCPL486.GenPop(r)
+		END
+	END Pop;
+	
+	PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
+	
+	PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET);	(* = Assert(x, hint, stop + {mem, stk}) *)
+		VAR r: DevCPL486.Item; f: BYTE;
+	BEGIN
+		f := x.typ.form;
+		IF x.mode = Con THEN
+			IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END;
+			IF con IN stop THEN
+				IF f = Int64 THEN LoadLong(x, hint, stop)
+				ELSE
+					GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r);
+					x.mode := Reg; x.reg := r.reg; x.form := f
+				END
+			END
+		ELSIF x.mode = Stk THEN
+			IF f IN realSet THEN
+				GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form)
+			ELSE
+				Pop(r, f, hint, stop)
+			END;
+			x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f
+		ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN
+			Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r);
+			x.mode := Reg; x.reg := r.reg; x.form := Int32
+		ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN
+			IF f = Int64 THEN LoadLong(x, hint, stop)
+			ELSE
+				Free(x); GetReg(r, f, hint, stop);
+				IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END;
+				x.mode := Reg; x.reg := r.reg; x.form := f
+			END
+		END
+	END Load;
+	
+	PROCEDURE Push* (VAR x: DevCPL486.Item);
+		VAR y: DevCPL486.Item;
+	BEGIN
+		IF x.form IN realSet THEN
+			Load(x, {}, {}); DecStack(x.form);
+			Free(x); x.mode := Stk;
+			IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END;
+			DevCPL486.GenFStore(x, TRUE)
+		ELSIF x.form = Int64 THEN
+			Free(x); x.form := Int32; y := x;
+			IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END;
+			DevCPL486.GenPush(y); DevCPL486.GenPush(x);
+			x.mode := Stk; x.form := Int64
+		ELSE
+			IF x.form < Int16 THEN Load(x, {}, {high})
+			ELSIF x.form = Int16 THEN Load(x, {}, {})
+			END;
+			Free(x); DevCPL486.GenPush(x); x.mode := Stk
+		END
+	END Push;
+	
+	PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR r: DevCPL486.Item;
+	BEGIN
+		IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN
+			IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x)
+			ELSE Load(x, hint, stop);
+			END
+		ELSE
+			CASE x.mode OF
+			| Var, VarPar: IF ~(mem IN stop) THEN RETURN END
+			| Con: IF ~(con IN stop) THEN RETURN END
+			| Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
+			| Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
+			| Stk: IF ~(stk IN stop) THEN RETURN END
+			| Reg: IF Fits(x, stop) THEN RETURN END
+			ELSE RETURN
+			END;
+			IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x)
+			ELSE Load(x, hint, stop)
+			END
+		END
+	END Assert;
+	
+	(*------------------------------------------------*)
+
+	PROCEDURE LoadR (VAR x: DevCPL486.Item);
+	BEGIN
+		IF x.mode # Reg THEN
+			Free(x); DevCPL486.GenFLoad(x);
+			IF x.mode = Stk THEN IncStack(x.form) END;
+			GetReg(x, Real32, {}, {})
+		END
+	END LoadR;
+
+	PROCEDURE PushR (VAR x: DevCPL486.Item);
+	BEGIN
+		IF x.mode # Reg THEN LoadR(x) END;
+		DecStack(x.form);
+		Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE)
+	END PushR;
+	
+	PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR r: DevCPL486.Item;
+	BEGIN
+		IF x.mode = Stk THEN
+			Pop(x, x.form, hint, stop)
+		ELSE
+			Free(x); GetReg(r, x.form, hint, stop);
+			DevCPL486.GenMove(x, r);
+			x.mode := Reg; x.reg := r.reg
+		END
+	END LoadW;
+
+	PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR r: DevCPL486.Item;
+	BEGIN
+		IF x.mode = Stk THEN
+			Pop(x, x.form, hint, stop);
+			IF (x.form < Int32) OR (x.form = Char16) THEN
+				r := x; x.form := Int32; DevCPL486.GenExtMove(r, x)
+			END
+		ELSE
+			Free(x);
+			IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END;
+			IF x.mode = Con THEN x.form := r.form END;
+			IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END;
+			x.mode := Reg; x.reg := r.reg; x.form := r.form
+		END
+	END LoadL;
+	
+	PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR r, rh, c: DevCPL486.Item; offs: INTEGER;
+	BEGIN
+		IF x.form = Int64 THEN
+			IF  x.mode = Stk THEN
+				Pop(x, x.form, hint, stop)
+			ELSIF x.mode = Reg THEN
+				FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop);
+				FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop);
+				x.form := Int32; DevCPL486.GenMove(x, r);
+				x.reg := x.index; DevCPL486.GenMove(x, rh);
+				x.reg := r.reg; x.index := rh.reg
+			ELSE
+				GetReg(rh, Int32, hint, stop + {AX});
+				Free(x);
+				GetReg(r, Int32, hint, stop); 
+				x.form := Int32; offs := x.offset;
+				IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END;
+				DevCPL486.GenMove(x, rh);
+				x.offset := offs;
+				DevCPL486.GenMove(x, r);
+				x.mode := Reg; x.reg := r.reg; x.index := rh.reg
+			END
+		ELSE
+			LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh);
+			x.index := rh.reg
+		END;
+		x.form := Int64
+	END LoadLong;
+	
+	(*------------------------------------------------*)
+	
+	PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET);
+	BEGIN
+		ASSERT(x.mode = Reg);
+		GetReg(y, x.form, hint, stop);
+		DevCPL486.GenMove(x, y)
+	END CopyReg;
+
+	PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR r: DevCPL486.Item;
+	BEGIN
+		IF x.mode = DInd THEN
+			x.mode := Ind
+		ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN
+			x.mode := Reg
+		ELSE
+			Free(x); GetReg(r, Pointer, hint, stop);
+			IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END;
+			x.mode := Reg; x.reg := r.reg; x.form := Pointer
+		END;
+		x.form := Pointer; x.typ := DevCPT.anyptrtyp;
+		Assert(x, hint, stop)
+	END GetAdr;
+	
+	PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN);
+		VAR r, v: DevCPL486.Item;
+	BEGIN
+		IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer
+		ELSIF niltest THEN
+			GetAdr(x, {}, {mem, stk});
+			DevCPL486.MakeReg(r, AX, Int32);
+			v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg;
+			DevCPL486.GenTest(r, v)
+		ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer
+		ELSE GetAdr(x, {}, {})
+		END;
+		Free(x); DevCPL486.GenPush(x)
+	END PushAdr;
+
+	PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET);
+		VAR n: BYTE;
+	BEGIN
+		a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ;
+		IF lev = DevCPL486.level THEN a.reg := BP
+		ELSE
+			a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev]));
+			WHILE n > 0 DO
+				a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n)
+			END
+		END
+	END LevelBase;
+	
+	PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *)
+	BEGIN
+		IF x.tmode = VarPar THEN
+			LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr;
+		ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind));
+			len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32
+		END;
+		INC(len.offset, typ.n * 4 + 4);
+		IF typ.sysflag = stackArray THEN len.offset := -4 END
+	END LenDesc;
+	
+	PROCEDURE Tag* (VAR x, tag: DevCPL486.Item);
+		VAR typ: DevCPT.Struct;
+	BEGIN
+		typ := x.typ;
+		IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+		IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN	(* final type *)
+			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ)
+		ELSIF x.typ.form = Pointer THEN
+			ASSERT(x.mode = Reg);
+			tag.mode := Ind; tag.reg := x.reg; tag.offset := -4;
+			IF x.typ.sysflag = interface THEN tag.offset := 0 END
+		ELSIF x.tmode = VarPar THEN
+			LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4;
+			Free(tag)	(* ??? *)
+		ELSIF x.tmode = Ind THEN
+			ASSERT(x.mode = Ind);
+			tag := x; tag.offset := -4
+		ELSE
+			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ)
+		END;
+		tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp
+	END Tag;
+	
+	PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
+	BEGIN
+		WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
+		IF typ # NIL THEN RETURN typ.n
+		ELSE RETURN 0
+		END
+	END NumOfIntProc;
+	
+	PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN;
+		VAR fld: DevCPT.Object;
+	BEGIN
+		WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END;
+		IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE
+		ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
+			REPEAT
+				fld := typ.link;
+				WHILE (fld # NIL) & (fld.mode = Fld) DO
+					IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) 
+						OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END;
+					fld := fld.link
+				END;
+				typ := typ.BaseTyp
+			UNTIL typ = NIL
+		END;
+		RETURN FALSE
+	END ContainsIPtrs;
+	
+	PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item);
+		VAR cv: DevCPT.Const;
+	BEGIN
+		IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END;
+		cv := DevCPT.NewConst();
+		cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str;
+		DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp
+	END GuidFromString;
+	
+	PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN);
+		VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
+	BEGIN
+		ASSERT(x.mode IN {Reg, Ind, Abs});
+		ASSERT({AX, CX, DX} - WReg = {});
+		IF hints THEN
+			IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END
+		END;
+		IF x.mode # Reg THEN 
+			GetReg(r, Pointer, {}, {});
+			p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
+		ELSE r := x
+		END;
+		IF nilTest THEN
+			DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r);
+			lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
+		END;
+		DevCPL486.GenPush(r); p := r;
+		IF x.mode # Reg THEN Free(r) END;
+		GetReg(r, Pointer, {}, {});
+		p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r);
+		p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p);
+		IF nilTest THEN DevCPL486.SetLabel(lbl) END;
+	END IPAddRef;
+	
+	PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN);
+		VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
+	BEGIN
+		ASSERT(x.mode IN {Ind, Abs});
+		ASSERT({AX, CX, DX} - WReg = {});
+		IF hints THEN
+			IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END
+		END;
+		GetReg(r, Pointer, {}, {});
+		p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
+		DevCPL486.MakeConst(c, 0, Pointer);
+		IF nilTest THEN
+			DevCPL486.GenComp(c, r);
+			lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
+		END;
+		IF nilSet THEN DevCPL486.GenMove(c, p) END;
+		DevCPL486.GenPush(r);
+		p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r);
+		p.offset := 8; Free(r); DevCPL486.GenCall(p);
+		IF nilTest THEN DevCPL486.SetLabel(lbl) END;
+	END IPRelease;
+	
+	PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct;
+	BEGIN
+		IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN
+			DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ;
+			WHILE typ.comp = DynArr DO (* complete dynamic array iterations *)
+				LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp;
+				IF x.tmode = VarPar THEN Free(len) END;	(* ??? *)
+			END;
+			n := x.scale; i := 0;
+			WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END;
+			IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *)
+				DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n 
+			END
+		END;
+		CASE x.mode OF
+		   Var, VarPar:
+				lev := x.obj.mnolev;
+				IF lev <= 0 THEN
+					x.mode := Abs
+				ELSE
+					LevelBase(y, lev, hint, stop);
+					IF x.mode # VarPar THEN
+						x.mode := Ind
+					ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN
+						x.mode := DInd; x.offset := x.obj.adr
+					ELSE
+						y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind
+					END;
+					x.reg := y.reg
+				END;
+				x.form := x.typ.form
+		| LProc, XProc, IProc:
+				x.mode := Con; x.offset := 0; x.form := ProcTyp
+		| TProc, CProc:
+				x.form := ProcTyp
+		| Ind, Abs, Stk, Reg:
+				IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END
+		END
+	END Prepare;
+	
+	PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object);
+	BEGIN
+		INC(x.offset, field.adr); x.tmode := Con
+	END Field;
+	
+	PROCEDURE DeRef* (VAR x: DevCPL486.Item);
+		VAR btyp: DevCPT.Struct;
+	BEGIN
+		x.mode := Ind; x.tmode := Ind; x.scale := 0;
+		btyp := x.typ.BaseTyp;
+		IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0
+		ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size
+		ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 
+		ELSE x.offset := 0
+		END
+	END DeRef;
+	
+	PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET);	(* x[y] *)
+		VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER;
+	BEGIN
+		btyp := x.typ.BaseTyp; elsize := btyp.size;
+		IF elsize = 0 THEN Free(y)
+		ELSIF x.typ.comp = Array THEN
+			len.mode := Con; len.obj := NIL;
+			IF y.mode = Con THEN
+				INC(x.offset, y.offset * elsize)
+			ELSE
+				Load(y, hint, stop + {mem, stk, short});
+				IF inxchk THEN
+					DevCPL486.MakeConst(len, x.typ.n, Int32);
+					DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap)
+				END;
+				IF x.scale = 0 THEN x.index := y.reg
+				ELSE
+					IF x.scale MOD elsize # 0 THEN
+						IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4
+						ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2
+						ELSE elsize := 1
+						END;
+						DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32);
+						DevCPL486.GenMul(len, y, FALSE)
+					END;
+					DevCPL486.MakeConst(len, x.scale DIV elsize, Int32);
+					DevCPL486.MakeReg(idx, x.index, Int32);
+					DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y)
+				END;
+				x.scale := elsize
+			END;
+			x.tmode := Con
+		ELSE (* x.typ.comp = DynArr *)
+			IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END;
+			LenDesc(x, len, x.typ);
+			IF x.scale # 0 THEN
+				DevCPL486.MakeReg(idx, x.index, Int32); 
+				DevCPL486.GenMul(len, idx, FALSE)
+			END;
+			IF (y.mode # Con) OR (y.offset # 0) THEN
+				IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN
+					Load(y, hint, stop + {mem, stk, con, short})
+				ELSE y.form := Int32
+				END;
+				IF inxchk & ~x.typ.untagged THEN
+					DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap)
+				END;
+				IF (y.mode = Con) & (btyp.comp # DynArr) THEN
+					INC(x.offset, y.offset * elsize)
+				ELSIF x.scale = 0 THEN
+					WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END;
+					x.index := y.reg; x.scale := btyp.size
+				ELSE
+					DevCPL486.GenAdd(y, idx, FALSE); Free(y)
+				END
+			END;
+			IF x.tmode = VarPar THEN Free(len) END;	(* ??? *)
+			IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END
+		END
+	END Index;
+	
+	PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN);
+		VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct;
+	BEGIN
+		typ := x.typ;
+		IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END;
+		IF ~guard & typ.untagged THEN DevCPM.err(139)
+		ELSIF ~guard OR typchk & ~typ.untagged THEN
+			IF testtyp.untagged THEN DevCPM.err(139)
+			ELSE
+				IF (x.typ.form = Pointer) & (x.mode # Reg) THEN
+					GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag)
+				ELSE Tag(x, tag)
+				END;
+				IF ~guard THEN Free(x) END;
+				IF ~equal THEN
+					GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r);
+					tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev
+				END;
+				DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
+				DevCPL486.GenComp(tdes, tag);
+				IF guard THEN
+					IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END
+				ELSE setCC(x, eql, FALSE, FALSE)
+				END
+			END
+		END
+	END TypTest;
+	
+	PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct);
+		VAR tag, tdes: DevCPL486.Item;
+	BEGIN
+		(* tag must be in AX ! *)
+		IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END;
+		IF testtyp.untagged THEN DevCPM.err(139)
+		ELSE
+			tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer;
+			DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
+			DevCPL486.GenComp(tdes, tag);
+			setCC(x, eql, FALSE, FALSE)
+		END
+	END ShortTypTest;
+
+	PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4));
+		IF ranchk & (x.mode # Con) THEN
+			DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x);
+			IF min # 0 THEN
+				DevCPL486.GenAssert(ccLE, ranTrap);
+				c.offset := min; DevCPL486.GenComp(c, x);
+				DevCPL486.GenAssert(ccGE, ranTrap)
+			ELSIF max # 0 THEN
+				DevCPL486.GenAssert(ccBE, ranTrap)
+			ELSE
+				DevCPL486.GenAssert(ccNS, ranTrap)
+			END
+		END
+	END Check;
+
+	PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN);
+		VAR c: DevCPL486.Item; local: DevCPL486.Label;
+	BEGIN
+		IF useSt1 THEN DevCPL486.GenFMOp(5D1H);	(* FST ST1 *)
+		ELSE DevCPL486.GenFMOp(1C0H);	(* FLD ST0 *)
+		END;
+		DevCPL486.GenFMOp(1FCH);	(* FRNDINT *)
+		DevCPL486.GenFMOp(0D1H);	(* FCOM *)
+		CheckAv(AX);
+		DevCPL486.GenFMOp(FSTSW);
+		DevCPL486.GenFMOp(5D9H);	(* FSTP ST1 *)
+		(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
+		local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
+		DevCPL486.AllocConst(c, DevCPL486.one, Real32);
+		DevCPL486.GenFDOp(FSUB, c);
+		DevCPL486.SetLabel(local);
+	END Floor;
+	
+	PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
+	BEGIN
+		IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END;
+		DevCPL486.GenFStore(x, TRUE);
+		IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END
+	END Entier;
+
+	PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET);	(* x := y *)
+		(* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *)
+		VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item;
+	BEGIN
+		f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk});
+		IF y.form IN {Real32, Real64} THEN
+			IF f IN {Real32, Real64} THEN
+				IF m = Undef THEN
+					IF (y.form = Real64) & (f = Real32) THEN
+						IF y.mode # Reg THEN LoadR(y) END;
+						Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE)
+					END
+				ELSE
+					IF y.mode # Reg THEN LoadR(y) END;
+					IF m = Stk THEN DecStack(f) END;
+					IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END;
+				END
+			ELSE (* x not real *)
+				IF sysval THEN
+					IF y.mode = Reg THEN Free(y);
+						IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN
+							x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f
+						ELSE
+							ASSERT(y.form # Real64);
+							DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32;
+							IF m # Stk THEN
+								Pop(y, y.form, hint, stop);
+								IF f < Int16 THEN ASSERT(y.reg < 4) END;
+								y.form := f;
+								IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END
+							END
+						END
+					ELSE (* y.mode # Reg *)
+						y.form := f;
+						IF m # Undef THEN LoadW(y, hint, stop); Free(y);
+							IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END
+						END
+					END
+				ELSE (* not sysval *)
+					IF y.mode # Reg THEN LoadR(y) END;
+					Free(y);
+					IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN
+						Entier(x, y.typ, hint, stop);
+					ELSE
+						DecStack(f); y.mode := Stk;
+						IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END;
+						IF m = Stk THEN Entier(y, y.typ, {}, {})
+						ELSIF m = Undef THEN Entier(y, y.typ, hint, stop)
+						ELSE Entier(y, y.typ, hint, stop + {stk})
+						END;
+						IF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
+						ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
+						ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y)
+						END;
+						y.form := f;
+						IF (m # Undef) & (m # Stk) THEN
+							IF f = Int64 THEN
+								Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
+								IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END;
+								y.reg := y.index; DevCPL486.GenMove(y, z);
+							ELSE
+								Free(y); DevCPL486.GenMove(y, x);
+							END
+						END
+					END
+				END
+			END
+		ELSE (* y not real *)
+			IF sysval THEN
+				IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END;
+				IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END
+			ELSE
+				CASE y.form OF
+				| Byte, Bool:
+						IF f = Int64 THEN LoadLong(y, hint, stop)
+						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
+						END
+				| Char8:
+						IF f = Int8 THEN Check(y, 0, 0)
+						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
+						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
+						END
+				| Char16:
+						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
+						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
+						ELSIF f = Int16 THEN Check(y, 0, 0)
+						ELSIF f = Char16 THEN (* ok *)
+						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
+						ELSIF f >= Int32 THEN LoadL(y, hint, stop)
+						END
+				| Int8:
+						IF f = Char8 THEN Check(y, 0, 0)
+						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
+						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
+						END
+				| Int16:
+						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
+						ELSIF f = Char16 THEN Check(y, 0, 0)
+						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
+						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
+						ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop)
+						END
+				| Int32, Set, Pointer, ProcTyp:
+						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
+						ELSIF f = Char16 THEN Check(y, 0, 65536)
+						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
+						ELSIF f = Int16 THEN Check(y, -32768, 32767)
+						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
+						END
+				| Int64:
+						IF f IN {Bool..Int32, Char16} THEN
+							(* make range checks !!! *)
+							FreeHi(y)
+						END
+				END
+			END;
+			IF f IN {Real32, Real64} THEN
+				IF sysval THEN
+					IF (m # Undef) & (m # Reg) THEN
+						IF y.mode # Reg THEN LoadW(y, hint, stop) END;
+						Free(y);
+						IF m = Stk THEN DevCPL486.GenPush(y)
+						ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f
+						END
+					ELSE
+						IF y.mode = Reg THEN Push(y) END;
+						y.form := f;
+						IF m = Reg THEN LoadR(y) END
+					END
+				ELSE (* not sysval *) (* int -> float *)
+					IF y.mode = Reg THEN Push(y) END;
+					IF m = Stk THEN
+						Free(y); DevCPL486.GenFLoad(y); s := -4;
+						IF f = Real64 THEN DEC(s, 4) END;
+						IF y.mode = Stk THEN
+							IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END
+						END;
+						IF s # 0 THEN AdjustStack(s) END;
+						GetReg(y, Real32, {}, {});
+						Free(y); DevCPL486.GenFStore(x, TRUE)
+					ELSIF m = Reg THEN
+						LoadR(y)
+					ELSIF m # Undef THEN
+						LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) 
+					END
+				END
+			ELSE
+				y.form := f;
+				IF m = Stk THEN
+					IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END;
+					Push(y)
+				ELSIF m # Undef THEN
+					IF f = Int64 THEN
+						IF y.mode # Reg THEN LoadLong(y, hint, stop) END;
+						Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
+						IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END;
+						y.reg := y.index; DevCPL486.GenMove(y, z);
+					ELSE
+						IF y.mode # Reg THEN LoadW(y, hint, stop) END;
+						Free(y); DevCPL486.GenMove(y, x)
+					END
+				END
+			END
+		END	
+	END ConvMove;
+
+	PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET);	(* size >= 0: sysval *)
+		VAR y: DevCPL486.Item;
+	BEGIN
+		ASSERT(x.mode # Con);
+		IF (size >= 0)
+			& ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4))
+				OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END;
+(*
+		IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form  IN {Comp, Int64})) THEN DevCPM.err(220) END;
+*)
+		y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop)
+	END Convert;
+
+	PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET);
+		VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item;
+	BEGIN
+		IF mem IN stop THEN GetReg(x, Bool, hint, stop) END;
+		IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *)
+			DevCPL486.GenSetCC(y.offset, x)
+		ELSE
+			end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl;
+			DevCPL486.GenJump(y.offset, T1, TRUE);	(* T1 to enable short jump *)
+			DevCPL486.SetLabel(F);
+			DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x);
+			DevCPL486.GenJump(ccAlways, end, TRUE);
+			DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); 
+			DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x);
+			DevCPL486.SetLabel(end)
+		END;
+		IF x.mode # Reg THEN Free(x) END
+	END LoadCond;
+	
+	PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
+		VAR local: DevCPL486.Label;
+	BEGIN
+		ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con));
+		CASE subcl OF
+		| eql..geq:
+				DevCPL486.GenComp(y, x); Free(x);
+				setCC(x, subcl, rev, x.typ.form IN {Int8..Int32})
+		| times: 
+				IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END
+		| slash:
+				DevCPL486.GenXor(y, x)
+		| plus:
+				IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END
+		| minus, msk:
+				IF (x.form = Set) OR (subcl = msk) THEN (* and not *)
+					IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x)								(* y and not x *)
+					ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x)	(* x and y' *)
+					ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x)			(* x and not y *)
+					ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x)					(* not (not x or y) *)
+					END
+				ELSE	(* minus *)
+					IF rev THEN	(* y - x *)
+						IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x)
+						ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk)	(* ??? *)
+						END
+					ELSE	(* x - y *)
+						DevCPL486.GenSub(y, x, ovflchk)
+					END
+				END
+		| min, max:
+				local := DevCPL486.NewLbl;
+				DevCPL486.GenComp(y, x);
+				IF subcl = min THEN 
+					IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE)
+					ELSE DevCPL486.GenJump(ccLE, local, TRUE)
+					END
+				ELSE
+					IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE)
+					ELSE DevCPL486.GenJump(ccGE, local, TRUE)
+					END
+				END;
+				DevCPL486.GenMove(y, x);
+				DevCPL486.SetLabel(local)
+		END;
+		Free(y);
+		IF x.mode # Reg THEN Free(x) END
+	END IntDOp;
+	
+	PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN);	(* INC(x, y) or DEC(x, y) *)
+	BEGIN
+		ASSERT(x.form = Int64);
+		IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END;
+		Free(x); Free(y); x.form := Int32; y.form := Int32;
+		IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END;
+		INC(x.offset, 4);
+		IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END;
+		IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END;
+	END LargeInc;
+	
+	PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
+		VAR local: DevCPL486.Label; a, b: DevCPL486.Item;
+	BEGIN
+		ASSERT(x.mode = Reg);
+		IF y.form = Int64 THEN LoadR(y) END;
+		IF y.mode = Reg THEN rev := ~rev END;
+		CASE subcl OF
+		| eql..geq: DevCPL486.GenFDOp(FCOMP, y)
+		| times: DevCPL486.GenFDOp(FMUL, y)
+		| slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END
+		| plus: DevCPL486.GenFDOp(FADD, y)
+		| minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END
+		| min, max:
+			IF y.mode = Reg THEN
+				DevCPL486.GenFMOp(0D1H);	(* FCOM ST1 *)
+				CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
+				local := DevCPL486.NewLbl;
+				IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END;
+				DevCPL486.GenFMOp(5D1H);	(* FST ST1 *)
+				DevCPL486.SetLabel(local);
+				DevCPL486.GenFMOp(5D8H)	(* FSTP ST0 *)
+			ELSE
+				DevCPL486.GenFDOp(FCOM, y);
+				CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
+				local := DevCPL486.NewLbl;
+				IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END;
+				DevCPL486.GenFMOp(5D8H);	(* FSTP ST0 *)
+				DevCPL486.GenFLoad(y);
+				DevCPL486.SetLabel(local)
+			END
+		(* largeint support *)
+		| div:
+			IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END;
+			Floor(y, FALSE)
+		| mod:
+			IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
+			IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
+			DevCPL486.GenFMOp(1F8H);	(* FPREM *)
+			DevCPL486.GenFMOp(1E4H);	(* FTST *)
+			CheckAv(AX);
+			DevCPL486.GenFMOp(FSTSW);
+			DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX});
+			DevCPL486.GenMove(a, b);
+			DevCPL486.GenFMOp(0D1H);	(* FCOM *)
+			DevCPL486.GenFMOp(FSTSW);
+			DevCPL486.GenXor(b, a); Free(b);
+			(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
+			local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
+			DevCPL486.GenFMOp(0C1H);	(* FADD ST1 *)
+			DevCPL486.SetLabel(local);
+			DevCPL486.GenFMOp(5D9H);	(* FSTP ST1 *)
+		| ash:
+			IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
+			IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
+			DevCPL486.GenFMOp(1FDH);	(* FSCALE *)
+			Floor(y, TRUE)
+		END;
+		IF y.mode = Stk THEN IncStack(y.form) END;
+		Free(y);
+		IF (subcl >= eql) & (subcl <= geq) THEN
+			Free(x); CheckAv(AX);
+			DevCPL486.GenFMOp(FSTSW);
+			(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
+			setCC(x, subcl, rev, FALSE)
+		END
+	END FloatDOp;
+	
+	PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
+		VAR L: DevCPL486.Label; c: DevCPL486.Item;
+	BEGIN
+		CASE subcl OF
+		| minus:
+				IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END
+		| abs:
+				L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form);
+				DevCPL486.GenComp(c, x);
+				DevCPL486.GenJump(ccNS, L, TRUE);
+				DevCPL486.GenNeg(x, ovflchk);
+				DevCPL486.SetLabel(L)
+		| cap:
+				DevCPL486.MakeConst(c, -1 - 20H, x.form);
+				DevCPL486.GenAnd(c, x)
+		| not:
+				DevCPL486.MakeConst(c, 1, x.form);
+				DevCPL486.GenXor(c, x)
+		END;
+		IF x.mode # Reg THEN Free(x) END
+	END IntMOp;
+	
+	PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
+	BEGIN
+		ASSERT(x.mode = Reg);
+		IF subcl = minus THEN DevCPL486.GenFMOp(FCHS)
+		ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS)
+		END
+	END FloatMOp;
+
+	PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET);
+		(* range neg	result
+				F	F		{x}
+				F	T		-{x}
+				T	F		{x..31}
+				T	T		-{0..x}	*)
+		VAR c, r: DevCPL486.Item; val: INTEGER;
+	BEGIN
+		IF x.mode = Con THEN
+			IF range THEN
+				IF neg THEN val := -2 ELSE val := -1 END;
+				x.offset := SYSTEM.LSH(val, x.offset)
+			ELSE
+				val := 1; x.offset := SYSTEM.LSH(val, x.offset);
+				IF neg THEN x.offset := -1 - x.offset END
+			END
+		ELSE
+			Check(x, 0, 31);
+			IF neg THEN val := -2
+			ELSIF range THEN val := -1
+			ELSE val := 1
+			END;
+			DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r);
+			IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END;
+			Free(x); x.reg := r.reg
+		END;
+		x.typ := DevCPT.settyp; x.form := Set
+	END MakeSet;
+	
+	PROCEDURE MakeCond* (VAR x: DevCPL486.Item);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		IF x.mode = Con THEN
+			setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE)
+		ELSE
+			DevCPL486.MakeConst(c, 0, x.form);
+			DevCPL486.GenComp(c, x); Free(x);
+			setCC(x, neq, FALSE, FALSE)
+		END
+	END MakeCond;
+	
+	PROCEDURE Not* (VAR x: DevCPL486.Item);
+		VAR a: INTEGER;
+	BEGIN
+		x.offset := Inverted(x.offset); (* invert cc *)
+	END Not;
+	
+	PROCEDURE Odd* (VAR x: DevCPL486.Item);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END;
+		Free(x); DevCPL486.MakeConst(c, 1, x.form);
+		IF x.mode = Reg THEN
+			IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END;
+			DevCPL486.GenAnd(c, x)
+		ELSE
+			c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x)
+		END;
+		setCC(x, neq, FALSE, FALSE)
+	END Odd;
+	
+	PROCEDURE In* (VAR x, y: DevCPL486.Item);
+	BEGIN
+		IF y.form = Set THEN Check(x, 0, 31) END;
+		DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y);
+		setCC(x, lss, FALSE, FALSE); (* carry set *)
+	END In;
+	
+	PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE);	(* ASH, LSH, ROT *)
+		VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER;
+	BEGIN
+		IF subcl = ash THEN opl := SHL; opr := SAR
+		ELSIF subcl = lsh THEN opl := SHL; opr := SHR
+		ELSE opl := ROL; opr := ROR
+		END;
+		IF y.mode = Con THEN
+			IF y.offset > 0 THEN
+				DevCPL486.GenShiftOp(opl, y, x)
+			ELSIF y.offset < 0 THEN
+				y.offset := -y.offset;
+				DevCPL486.GenShiftOp(opr, y, x)
+			END
+		ELSE
+			ASSERT(y.mode = Reg);
+			Check(y, -31, 31);
+			L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; 
+			DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y);
+			DevCPL486.GenJump(ccNS, L1, TRUE);
+			DevCPL486.GenNeg(y, FALSE);
+			DevCPL486.GenShiftOp(opr, y, x);
+			DevCPL486.GenJump(ccAlways, L2, TRUE);
+			DevCPL486.SetLabel(L1);
+			DevCPL486.GenShiftOp(opl, y, x);
+			DevCPL486.SetLabel(L2);
+			Free(y)
+		END;
+		IF x.mode # Reg THEN Free(x) END
+	END Shift;
+
+	PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN);
+		VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN;
+	BEGIN
+		ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE;
+		IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END;
+		DevCPL486.GenDiv(y, mod, pos); Free(y);
+		IF mod THEN
+			r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *)	(* ??? *)
+		END
+	END DivMod;
+
+	PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct);	(* x := Mem[x+offset] *)
+	BEGIN
+		IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset)
+		ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset
+		END;
+		x.scale := 0; x.typ := typ; x.form := typ.form
+	END Mem;
+	
+	PROCEDURE SysMove* (VAR len: DevCPL486.Item);	(* implementation of SYSTEM.MOVE *)
+	BEGIN
+		IF len.mode = Con THEN
+			IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END
+		ELSE
+			Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len)
+		END;
+		FreeWReg(SI); FreeWReg(DI)
+	END SysMove;
+	
+	PROCEDURE Len* (VAR x, y: DevCPL486.Item);
+		VAR typ: DevCPT.Struct; dim: INTEGER;
+	BEGIN
+		dim := y.offset; typ := x.typ;
+		IF typ.untagged THEN DevCPM.err(136) END;
+		WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END;
+		LenDesc(x, x, typ);
+	END Len;
+	
+	PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER;
+	BEGIN
+		CASE x.form OF
+		| String8, VString8: RETURN 1
+		| String16, VString16: RETURN 2
+		| VString16to8: RETURN 0
+		| Comp: RETURN x.typ.BaseTyp.size
+		END
+	END StringWSize;
+
+	PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN);
+		VAR sw, dw: INTEGER;
+	BEGIN
+		CheckAv(CX);
+		IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN
+			DevCPL486.GenBlockComp(4, 4)
+		ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index)
+		ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index)
+		ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index)
+		ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index)
+		ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x))
+		END;
+		FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE);
+	END CmpString;
+
+	PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item);
+		VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct;
+	BEGIN
+		atyp := y.typ;
+		WHILE ftyp.comp = DynArr DO
+			IF ftyp.BaseTyp = DevCPT.bytetyp THEN
+				IF atyp.comp = DynArr THEN
+					IF atyp.untagged THEN DevCPM.err(137) END;
+					LenDesc(y, len, atyp);
+					IF y.tmode = VarPar THEN Free(len) END;	(* ??? *)
+					GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z);
+					len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp;
+					WHILE atyp.comp = DynArr DO
+						LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE);
+						IF y.tmode = VarPar THEN Free(z) END;	(* ??? *)
+						atyp := atyp.BaseTyp
+					END;
+					DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE);
+					Free(len)
+				ELSE
+					DevCPL486.MakeConst(len, atyp.size, Int32)
+				END
+			ELSE
+				IF atyp.comp = DynArr THEN LenDesc(y, len, atyp);
+					IF atyp.untagged THEN DevCPM.err(137) END;
+					IF y.tmode = VarPar THEN Free(len) END;	(* ??? *)
+				ELSE DevCPL486.MakeConst(len, atyp.n, Int32)
+				END
+			END;
+			DevCPL486.GenPush(len);
+			ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
+		END
+	END VarParDynArr;
+
+	PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *)
+	BEGIN
+		IF y.mode = Con THEN
+			IF y.form IN {Real32, Real64} THEN
+				DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {});
+				IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END	(* ??? move const *)
+			ELSIF x.form = Int64 THEN
+				ASSERT(x.mode IN {Ind, Abs});
+				y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x);
+				y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x);
+				DEC(x.offset, 4); x.form := Int64
+			ELSE
+				DevCPL486.GenMove(y, x)
+			END
+		ELSE
+			IF y.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
+				ASSERT(x.form = Pointer);
+				GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer
+			END;
+			IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END;
+			ConvMove(x, y, FALSE, {}, {})
+		END;
+		Free(x)
+	END Assign;
+	
+	PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
+		ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
+		ELSE len.mode := Con
+		END;
+		len.typ := DevCPT.int32typ
+	END ArrayLen;
+
+(*
+(!)		src		dest	zero
+sx	= sy	x b		y b
+SHORT(lx)	= sy	x b+	x w	y b
+SHORT(lx)	= SHORT(ly)	x b+	x w	y b+
+
+lx	= ly	x w		y w
+LONG(sx)	= ly	x b		y w	*
+LONG(SHORT(lx))	= ly	x b+	x w*	y w	*
+
+sx	:= sy	y b		x b
+sx	:= SHORT(ly)	y b+	y w	x b
+
+lx	:= ly	y w		x w
+lx	:= LONG(sy)	y b		x w	*
+lx	:= LONG(SHORT(ly))	y b+	y w*	x w	*
+(!)*)
+	
+	PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *)
+	BEGIN
+		IF (x.typ.comp = DynArr) & x.typ.untagged THEN
+			DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1)
+		ELSE
+			DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0)
+		END;
+		FreeWReg(SI); FreeWReg(DI)
+	END AddCopy;
+	
+	PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *)
+		VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item;
+	BEGIN
+		sx := x.typ.size; CheckAv(CX);
+		IF y.form IN {String8, String16} THEN
+			sy := y.index * y.typ.BaseTyp.size;
+			IF x.typ.comp = Array THEN	(* adjust size for optimal performance *)
+				sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4;
+				IF sy4 <= sx THEN sy := sy4
+				ELSIF sy2 <= sx THEN sy := sy2
+				ELSIF sy > sx THEN DevCPM.err(114); sy := 1
+				END
+			ELSIF inxchk & ~x.typ.untagged THEN	(* check array length *)
+				Free(x); LenDesc(x, c, x.typ);
+				DevCPL486.MakeConst(y, y.index, Int32);
+				DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap);
+				Free(c)
+			END;
+			DevCPL486.GenBlockMove(1, sy)
+		ELSIF x.typ.comp = DynArr THEN
+			IF x.typ.untagged THEN
+				DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1)
+			ELSE
+				Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c);
+				DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0)
+			END
+		ELSIF y.form IN {VString16to8, VString8, VString16} THEN
+			DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
+			ASSERT(y.mode # Stk)
+		ELSIF short THEN	(* COPY *)
+			sy := y.typ.size;
+			IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END;
+			DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
+			IF y.mode = Stk THEN AdjustStack(sy) END
+		ELSE	(* := *)
+			IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END;
+			IF y.mode = Stk THEN AdjustStack(sy) END
+		END;
+		FreeWReg(SI); FreeWReg(DI)
+	END Copy;
+	
+	PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		CheckAv(AX); CheckAv(CX);
+		DevCPL486.GenStringLength(typ.BaseTyp.size, -1);
+		Free(x); GetReg(x, Int32, {}, wreg - {CX});
+		DevCPL486.GenNot(x);
+		IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END;
+		FreeWReg(DI)
+	END StrLen;
+
+	PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct);	(* z := z * y *)
+		VAR c: DevCPL486.Item;
+	BEGIN
+		IF y.mode = Con THEN fact := fact * y.offset
+		ELSE
+			IF ranchk OR inxchk THEN
+				DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap)
+			END;
+			DevCPL486.GenPush(y);
+			IF z.mode = Con THEN z := y
+			ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y)
+			END
+		END
+	END MulDim;
+	
+	PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *)
+		(* y const or on stack *) 
+		VAR z: DevCPL486.Item; end: DevCPL486.Label;
+	BEGIN
+		ASSERT((x.mode = Reg) & (x.form = Pointer));
+		z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32;
+		IF y.mode = Con THEN y.form := Int32
+		ELSE Pop(y, Int32, {}, {})
+		END;
+		end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE);	(* flags set in New *)
+		DevCPL486.GenMove(y, z);
+		DevCPL486.SetLabel(end);
+		IF y.mode = Reg THEN Free(y) END
+	END SetDim;
+
+	PROCEDURE SysNew* (VAR x: DevCPL486.Item);
+	BEGIN
+		DevCPM.err(141)
+	END SysNew;
+
+	PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER);
+		(* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *)
+		VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label;
+	BEGIN
+		typ := x.typ.BaseTyp;
+		IF typ.untagged THEN DevCPM.err(138) END;
+		IF typ.comp = Record THEN	(* call to Kernel.NewRec(tag: Tag): ADDRESS *)
+			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ);
+			IF ContainsIPtrs(typ) THEN INC(tag.offset) END;
+			DevCPL486.GenPush(tag);
+			p.mode := XProc; p.obj := DevCPE.KNewRec;
+		ELSE eltyp := typ.BaseTyp;
+			IF typ.comp = Array THEN
+				nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n
+			ELSE (* DynArr *)
+				nofdim := typ.n+1;
+				WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END
+			END ;
+			WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END;
+			IF eltyp.comp = Record THEN
+				IF eltyp.untagged THEN DevCPM.err(138) END;
+				DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp);
+				IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END;
+			ELSIF eltyp.form = Pointer THEN
+				IF ~eltyp.untagged THEN
+					DevCPL486.MakeConst(tag, 0, Pointer)	(* special TDesc in Kernel for ARRAY OF pointer *)
+				ELSIF eltyp.sysflag = interface THEN
+					DevCPL486.MakeConst(tag, -1, Pointer)	(* special TDesc in Kernel for ARRAY OF interface pointer *)
+				ELSE
+					DevCPL486.MakeConst(tag, 12, Pointer)
+				END
+			ELSE	(* eltyp is pointerless basic type *)
+				CASE eltyp.form OF
+				| Undef, Byte, Char8: n := 1;
+				| Int16: n := 2;
+				| Int8: n := 3;
+				| Int32: n := 4;
+				| Bool: n := 5;
+				| Set: n := 6;
+				| Real32: n := 7;
+				| Real64: n := 8;
+				| Char16: n := 9;
+				| Int64: n := 10;
+				| ProcTyp: n := 11;
+				END;
+				DevCPL486.MakeConst(tag, n, Pointer)
+(*
+				DevCPL486.MakeConst(tag, eltyp.size, Pointer)
+*)
+			END;
+			IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL
+			ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk)
+			END;
+			DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p);
+			DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag);
+			p.mode := XProc; p.obj := DevCPE.KNewArr;
+		END;
+		DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX});
+		IF typ.comp = DynArr THEN	(* set flags for nil test *)
+			DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x)
+		ELSIF typ.comp = Record THEN
+			n := NumOfIntProc(typ);
+			IF n > 0 THEN	(* interface method table pointer setup *)
+				DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x);
+				lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE);
+				tag.offset := - 4 * (n + numPreIntProc);
+				p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer;
+				DevCPL486.GenMove(tag, p);
+				IF nofel.mode # Con THEN	(* unk pointer setup *)
+					p.offset := 8;
+					DevCPL486.GenMove(nofel, p);
+					Free(nofel)
+				END;
+				DevCPL486.SetLabel(lbl);
+			END
+		END
+	END New;
+
+	PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item);	(* returns tag if rec *)
+		VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct;
+	BEGIN
+		par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form;
+		IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END;
+		IF ap.typ = DevCPT.niltyp THEN
+			IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN
+				DevCPM.err(142)
+			END;
+			DevCPL486.GenPush(ap)
+		ELSIF par.typ.comp = DynArr THEN
+			IF ap.form IN {String8, String16} THEN
+				IF ~par.typ.untagged THEN
+					DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c)
+				END;
+				ap.mode := Con; DevCPL486.GenPush(ap);
+			ELSIF ap.form IN {VString8, VString16} THEN
+				DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a);
+				IF ~par.typ.untagged THEN
+					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c);
+					Free(ap); StrLen(c, ap.typ, TRUE);
+					DevCPL486.GenPush(c); Free(c)
+				END;
+				DevCPL486.GenPush(a)
+			ELSE
+				IF ~par.typ.untagged THEN
+					IF ap.typ.comp = DynArr THEN niltest := FALSE END;	(* ap dereferenced for length descriptor *)
+					VarParDynArr(par.typ, ap)
+				END;
+				PushAdr(ap, niltest)
+			END
+		ELSIF fp.mode = VarPar THEN
+			recTyp := ap.typ;
+			IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END;
+			IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN
+				Tag(ap, tag);
+				IF rec & (tag.mode # Con) THEN
+					GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c
+				END;
+				DevCPL486.GenPush(tag);
+				IF tag.mode # Con THEN niltest := FALSE END;
+				PushAdr(ap, niltest);
+				IF rec THEN Free(tag) END
+			ELSE PushAdr(ap, niltest)
+			END;
+			tag.typ := recTyp
+		ELSIF par.form = Comp THEN
+			s := par.typ.size;
+			IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN
+				s := (s + 3) DIV 4 * 4; AdjustStack(-s);
+				IF ap.form IN {String8, String16} THEN
+					IF ap.index > 1 THEN	(* nonempty string *)
+						ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4;
+						DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
+						DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
+						DevCPL486.GenBlockMove(1, ss);
+					ELSE
+						ss := 0;
+						DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c)
+					END;
+					IF s > ss THEN
+						DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
+						DevCPL486.GenBlockStore(1, s - ss)
+					END;
+				ELSE
+					DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
+					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
+					DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n);
+					DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
+					DevCPL486.GenBlockStore(StringWSize(par), 0)
+				END
+			ELSE
+				IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN	(* empty string *)
+					AdjustStack((4 - s) DIV 4 * 4);
+					DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c)
+				ELSE
+					AdjustStack((-s) DIV 4 * 4);
+					DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
+					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
+					IF ap.form IN {String8, String16} THEN
+						DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4)
+					ELSIF ap.form IN {VString8, VString16, VString16to8} THEN
+						DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n)
+					ELSE
+						DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4)
+					END
+				END
+			END
+		ELSIF ap.mode = Con THEN
+			IF ap.form IN {Real32, Real64} THEN	(* ??? push const *)
+				DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE)
+			ELSE
+				ap.form := Int32;
+				IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END;
+				DevCPL486.GenPush(ap)
+			END
+		ELSIF ap.typ.form = Pointer THEN
+			recTyp := ap.typ.BaseTyp;
+			IF rec THEN
+				Load(ap, {}, {}); Tag(ap, tag);
+				IF tag.mode = Con THEN	(* explicit nil test needed *)
+					DevCPL486.MakeReg(a, AX, Int32);
+					c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg;
+					DevCPL486.GenTest(a, c)
+				END
+			END;
+			DevCPL486.GenPush(ap); Free(ap);
+			tag.typ := recTyp
+		ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
+			ASSERT(par.form = Pointer);
+			PushAdr(ap, FALSE)
+		ELSE
+			ConvMove(par, ap, FALSE, {}, {high});
+		END
+	END Param;
+	
+	PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item);
+		VAR r: DevCPL486.Item;
+	BEGIN
+		DevCPL486.MakeReg(r, AX, proc.typ.form);	(* don't allocate AX ! *)
+		IF res.mode = Con THEN
+			IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res);
+			ELSIF r.form = Int64 THEN
+				r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r);
+				r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r)
+			ELSE DevCPL486.GenMove(res, r);
+			END
+		ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
+			ASSERT(r.form = Pointer);
+			GetAdr(res, {}, wreg - {AX})
+		ELSE
+			r.index := DX;	(* for int64 *)
+			ConvMove(r, res, FALSE, wreg - {AX} + {high}, {});
+		END;
+		Free(res)
+	END Result;
+	
+	PROCEDURE InitFpu;
+		VAR x: DevCPL486.Item;
+	BEGIN
+		DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x);
+		DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H);	(* FLDCW 0(SP) *)
+		DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x);	(* reset stack *)
+	END InitFpu;
+	
+	PROCEDURE PrepCall* (proc: DevCPT.Object);
+		VAR lev: BYTE; r: DevCPL486.Item;
+	BEGIN
+		lev := proc.mnolev;
+		IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN
+			DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r)
+		END
+	END PrepCall;
+	
+	PROCEDURE Call* (VAR x, tag: DevCPL486.Item);	(* TProc: tag.typ = actual receiver type *)
+		VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object;
+	BEGIN
+		IF x.mode IN {LProc, XProc, IProc} THEN
+			lev := x.obj.mnolev; saved := FALSE;
+			IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN	(* pass static link *)
+				n := imLevel[DevCPL486.level] - imLevel[lev];
+				IF n > 0 THEN
+					saved := TRUE;
+					y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4;
+					DevCPL486.MakeReg(r, BX, Pointer);
+					WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END
+				END
+			END;
+			DevCPL486.GenCall(x);
+			IF x.obj.sysflag = ccall THEN	(* remove parameters *)
+				p := x.obj.link; n := 0;
+				WHILE p # NIL DO
+					IF p.mode = VarPar THEN INC(n, 4)
+					ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
+					END;
+					p := p.link
+				END;
+				AdjustStack(n)
+			END;
+			IF saved THEN DevCPL486.GenPop(r) END;
+		ELSIF x.mode = TProc THEN
+			IF x.scale = 1 THEN (* super *)
+				DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp)
+			ELSIF x.scale = 2 THEN (* static call *)
+				DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ;
+				IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+				tag.obj := DevCPE.TypeObj(typ)
+			ELSIF x.scale = 3 THEN (* interface method call *)
+				DevCPM.err(200)
+			END;
+			IF tag.mode = Con THEN
+				y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0
+			ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN	(* final method *)
+				y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0;
+				IF tag.mode = Ind THEN	(* nil test *)
+					DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag)
+				END
+			ELSE
+				IF tag.mode = Reg THEN y.reg := tag.reg
+				ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y)
+				END;
+				y.mode := Ind; y.offset := 0; y.scale := 0
+			END;
+			IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset
+			ELSIF tag.typ.untagged THEN DevCPM.err(140)
+			ELSE
+				IF x.obj.link.typ.sysflag = interface THEN	(* correct method number *)
+					x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset
+				END;
+				INC(y.offset, Mth0Offset - 4 * x.offset)
+			END;
+			DevCPL486.GenCall(y); Free(y)
+		ELSIF x.mode = CProc THEN
+			IF x.obj.link # NIL THEN	(* tag = first param *)
+				IF x.obj.link.mode = VarPar THEN
+					GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag)
+				ELSE 
+					(* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *)
+					Result(x.obj.link, tag)	(* use result load for first parameter *)
+				END
+			END;
+			i := 1; n := ORD(x.obj.conval.ext^[0]);
+			WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END
+		ELSE	(* proc var *)
+			DevCPL486.GenCall(x); Free(x);
+			IF x.typ.sysflag = ccall THEN	(* remove parameters *)
+				p := x.typ.link; n := 0;
+				WHILE p # NIL DO
+					IF p.mode = VarPar THEN INC(n, 4)
+					ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
+					END;
+					p := p.link
+				END;
+				AdjustStack(n)
+			END;
+			x.typ := x.typ.BaseTyp
+		END;
+		IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128)
+				& ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN	(* restore fpu *)
+			InitFpu
+		END;
+		CheckReg;
+		IF x.typ.form = Int64 THEN
+			GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX});
+			x.index := y.reg; x.form := Int64
+		ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high})
+		END
+	END Call;
+	
+	PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct);	(* needs CX, SI, DI *)
+		VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct;
+	BEGIN
+		IF typ.untagged THEN DevCPM.err(-137) END;
+		ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer;
+		DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32);
+		DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32);
+		DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp;
+		WHILE bt.comp = DynArr DO
+			INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp
+		END;
+		ptr.offset := adr; DevCPL486.GenMove(ptr, src);
+		DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE);
+		(* CX = length in bytes *)
+		StackAlloc; 
+		(* CX = length in 32bit words *)
+		DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr);
+		DevCPL486.GenBlockMove(4, 0)  (* 32bit moves *)
+	END CopyDynArray;
+	
+	PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER);
+		VAR i, j, x: INTEGER;
+	BEGIN
+		(* align *)
+		i := 1;
+		WHILE i < n DO
+			x := tab[i]; j := i-1;
+			WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END;
+			tab[j+1] := x; INC(i)
+		END;
+		(* eliminate equals *)
+		i := 1; j := 1;
+		WHILE i < n DO
+			IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END;
+			INC(i)
+		END;
+		n := j
+	END Sort;
+	
+	PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER);
+		VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
+	BEGIN
+		IF typ.form IN {Pointer, ProcTyp} THEN
+			IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END;
+			INC(num);
+			IF adr MOD 4 # 0 THEN
+				IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END;
+				INC(num)
+			END
+		ELSIF typ.comp = Record THEN
+			btyp := typ.BaseTyp;
+			IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ;
+			fld := typ.link;
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				IF (fld.name^ = DevCPM.HdPtrName) OR
+					(fld.name^ = DevCPM.HdUtPtrName) OR
+					(fld.name^ = DevCPM.HdProcName) THEN
+					FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num)
+				ELSE FindPtrs(fld.typ, fld.adr + adr, num)
+				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 (btyp.form = Pointer) OR (btyp.comp = Record) THEN
+				i := num; FindPtrs(btyp, adr, num);
+				IF num # i THEN i := 1;
+					WHILE (i < n) & (num <= MaxPtrs) DO
+						INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i)
+					END
+				END
+			END
+		END
+	END FindPtrs;
+
+	PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item);
+		VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct;
+	BEGIN
+		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr;
+		DevCPL486.MakeReg(y, DI, Int32);
+		IF par.typ.comp # DynArr THEN
+			DevCPL486.GenMove(x, y);
+			lbl := DevCPL486.NewLbl;
+			IF ODD(par.sysflag DIV nilBit) THEN
+				DevCPL486.GenComp(zreg, y);
+				DevCPL486.GenJump(ccE, lbl, TRUE)
+			END;
+			size := par.typ.size;
+			IF size <= 16 THEN
+				x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0;
+				WHILE size > 0 DO
+					IF size = 1 THEN x.form := Int8; s := 1
+					ELSIF size = 2 THEN x.form := Int16; s := 2
+					ELSE x.form := Int32; s := 4
+					END;
+					zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s)
+				END;
+				zreg.form := Int32
+			ELSE
+				DevCPL486.GenBlockStore(1, size)
+			END;
+			DevCPL486.SetLabel(lbl)
+		ELSIF initializeDyn & ~par.typ.untagged THEN	(* untagged open arrays not initialized !!! *)
+			DevCPL486.GenMove(x, y);
+			DevCPL486.MakeReg(len, CX, Int32);
+			INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *)
+			bt := par.typ.BaseTyp;
+			WHILE bt.comp = DynArr DO
+				INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp
+			END;
+			size := bt.size;
+			IF size MOD 4 = 0 THEN size := size DIV 4; s := 4
+			ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2
+			ELSE s := 1
+			END;
+			DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE);
+			DevCPL486.GenBlockStore(s, 0)
+		END
+	END InitOutPar;
+
+	PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);
+		VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER;
+	BEGIN
+		op := 0; par := proc.link;
+		WHILE par # NIL DO	(* count out parameters [with COM pointers] *)
+			IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END;
+			par := par.link
+		END;
+		DevCPL486.MakeConst(zero, 0, Int32);
+		IF (op = 0) & (size <= 8) THEN	(* use PUSH 0 *)
+			WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END
+		ELSE
+			DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z);
+			IF size <= 32 THEN	(* use PUSH reg *)
+				WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END
+			ELSE	(* use string store *)
+				AdjustStack(-size);
+				DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
+				DevCPL486.GenBlockStore(1, size)
+			END;
+			IF op > 0 THEN
+				par := proc.link;
+				WHILE par # NIL DO	(* init out parameters [with COM pointers] *)
+					IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END;
+					par := par.link
+				END
+			END
+		END
+	END AllocAndInitAll;
+	
+	PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);	(* needs AX *)
+		VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object;
+	BEGIN
+		IF ptrinit & (proc.scope # NIL) THEN
+			nofptrs := 0; obj := proc.scope.scope;	(* local variables *)
+			WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO
+				FindPtrs(obj.typ, obj.adr, nofptrs);
+				obj := obj.link
+			END;
+			IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN
+				base := proc.conval.intval2;
+				Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0;
+				WHILE i < nofptrs DO
+					DEC(a, 4);
+					IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END;
+					INC(i)
+				END;
+				IF a # base THEN INC(gaps) END;
+				IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN
+					DevCPL486.MakeConst(z, 0, Pointer);
+					IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END;
+					i := 0; a := size + base;
+					WHILE i < nofptrs DO
+						DEC(a, 4);
+						IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END;
+						DevCPL486.GenPush(z); INC(i)
+					END;
+					IF a # base THEN AdjustStack(base - a) END
+				ELSE
+					AdjustStack(-size);
+					DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z);
+					x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; 
+					WHILE i < nofptrs DO
+						x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
+					END
+				END
+			ELSE
+				AdjustStack(-size)
+			END
+		ELSE
+			nofptrs := 0;
+			AdjustStack(-size)
+		END
+	END AllocAndInitPtrs1;
+
+	PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER);	(* needs AX, CX, DI *)
+		VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label;
+	BEGIN
+		IF ptrinit THEN
+			zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer);
+			IF nofptrs > MaxPtrs THEN
+				DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE;
+				x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr;
+				DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y);
+				DevCPL486.GenStrStore(size)
+			END;
+			obj := proc.link;	(* parameters *)
+			WHILE obj # NIL DO
+				IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
+					nofptrs := 0;
+					IF obj.typ.comp = DynArr THEN	(* currently not initialized *)
+					ELSE FindPtrs(obj.typ, 0, nofptrs)
+					END;
+					IF nofptrs > 0 THEN
+						IF ~zeroed THEN
+							DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE
+						END;
+						x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr;
+						DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
+						IF ODD(obj.sysflag DIV nilBit) THEN
+							DevCPL486.GenComp(zero, y);
+							lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
+						END;
+						IF nofptrs > MaxPtrs THEN
+							DevCPL486.GenStrStore(obj.typ.size)
+						ELSE
+							Sort(ptrTab, nofptrs);
+							x.reg := DI; i := 0;
+							WHILE i < nofptrs DO
+								x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
+							END
+						END;
+						IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END
+					END
+				END;
+				obj := obj.link
+			END
+		END
+	END InitPtrs2;
+	
+	PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN;
+		VAR obj: DevCPT.Object; nofptrs: INTEGER;
+	BEGIN
+		IF ptrinit THEN
+			obj := proc.link;
+			WHILE obj # NIL DO
+				IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
+					nofptrs := 0;
+					IF obj.typ.comp = DynArr THEN	(* currently not initialized *)
+					ELSE FindPtrs(obj.typ, 0, nofptrs)
+					END;
+					IF nofptrs > 0 THEN RETURN TRUE END
+				END;
+				obj := obj.link
+			END
+		END;
+		RETURN FALSE
+	END NeedOutPtrInit;
+	
+	PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN);
+		VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER;
+	BEGIN
+		procedureUsesFpu := useFpu;
+		SetReg({AX, CX, DX, SI, DI});
+		DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer);
+		IF proc # NIL THEN (* enter proc *)
+			DevCPL486.SetLabel(proc.adr);
+			IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN
+				DevCPL486.GenPush(fp);
+				DevCPL486.GenMove(sp, fp);
+				adr := proc.conval.intval2; size := -adr;
+				IF isGuarded IN proc.conval.setval THEN
+					DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r);
+					DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
+					DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r);
+					r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL;
+					DevCPL486.GenPush(r1);
+					intHandler.used := TRUE;
+					r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler;
+					DevCPL486.GenPush(r1);
+					r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL;
+					DevCPL486.GenCode(64H); DevCPL486.GenPush(r1);
+					DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1);
+					DEC(size, 24)
+				ELSE
+					IF imVar IN proc.conval.setval THEN	(* set down pointer *)
+						DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4)
+					END;
+					IF isCallback IN proc.conval.setval THEN
+						DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
+						DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8)
+					END
+				END;
+				ASSERT(size >= 0);
+				IF initializeAll THEN
+					AllocAndInitAll(proc, adr, size, np)
+				ELSE
+					AllocAndInitPtrs1(proc, adr, size, np);	(* needs AX *)
+					InitPtrs2(proc, adr, size, np);	(* needs AX, CX, DI *)
+				END;
+				par := proc.link;	(* parameters *)
+				WHILE par # NIL DO
+					IF (par.mode = Var) & (par.typ.comp = DynArr) THEN 
+						CopyDynArray(par.adr, par.typ)
+					END;
+					par := par.link
+				END;
+				IF imVar IN proc.conval.setval THEN
+					DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r)
+				END
+			END
+		ELSIF ~empty THEN (* enter module *)
+			DevCPL486.GenPush(fp);
+			DevCPL486.GenMove(sp, fp);
+			DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r);
+			DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r)
+		END;
+		IF useFpu THEN InitFpu END
+	END Enter;
+	
+	PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN);
+		VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER;
+	BEGIN
+		DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer);
+		IF proc # NIL THEN (* exit proc *)
+			IF proc.sysflag # noframe THEN
+				IF ~empty OR NeedOutPtrInit(proc) THEN
+					IF isGuarded IN proc.conval.setval THEN	(* remove exception frame *)
+						x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32;
+						DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r);
+						x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL;
+						DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x);
+						size := 12
+					ELSE
+						size := 0;
+						IF imVar IN proc.conval.setval THEN INC(size, 4) END;
+						IF isCallback IN proc.conval.setval THEN INC(size, 8) END
+					END;
+					IF size > 0 THEN
+						x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32;
+						DevCPL486.GenLoadAdr(x, sp);
+						IF size > 4 THEN
+							DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
+							DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r)
+						END;
+						IF size # 8 THEN
+							DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r)
+						END
+					ELSE
+						DevCPL486.GenMove(fp, sp)
+					END;
+					DevCPL486.GenPop(fp)
+				END;
+				IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0)
+				ELSE DevCPL486.GenReturn(proc.conval.intval - 8)
+				END
+			END
+		ELSE (* exit module *)
+			IF ~empty THEN
+				DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
+				DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r);
+				DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp)
+			END;
+			DevCPL486.GenReturn(0)
+		END
+	END Exit;
+	
+	PROCEDURE InstallStackAlloc*;
+		VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label;
+	BEGIN
+		IF stkAllocLbl # DevCPL486.NewLbl THEN
+			DevCPL486.SetLabel(stkAllocLbl);
+			DevCPL486.MakeReg(ax, AX, Int32);
+			DevCPL486.MakeReg(cx, CX, Int32);
+			DevCPL486.MakeReg(sp, SP, Int32);
+			DevCPL486.GenPush(ax);
+			DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE);
+			l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE);
+			DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx);
+			DevCPL486.SetLabel(l1);
+			DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx);
+			DevCPL486.GenMove(cx, ax);
+			DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax);
+			DevCPL486.GenSub(ax, sp, FALSE);
+			DevCPL486.GenMove(cx, ax);
+			DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax);
+			l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE);
+			l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1);
+			DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c);
+			DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE);
+			DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE);
+			DevCPL486.GenJump(ccNE, l1, TRUE);
+			DevCPL486.SetLabel(l2);
+			DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE);
+			x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1;
+			DevCPL486.GenMove(x, ax);
+			DevCPL486.GenPush(ax);
+			DevCPL486.GenMove(x, ax);
+			DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx);
+			DevCPL486.GenReturn(0);
+			name := "$StackAlloc"; DevCPE.OutRefName(name);
+		END
+	END InstallStackAlloc;
+
+	PROCEDURE Trap* (n: INTEGER);
+	BEGIN
+		DevCPL486.GenAssert(ccNever, n)
+	END Trap;
+	
+	PROCEDURE Jump* (VAR L: DevCPL486.Label);
+	BEGIN
+		DevCPL486.GenJump(ccAlways, L, FALSE)
+	END Jump;
+
+	PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
+	BEGIN
+		DevCPL486.GenJump(x.offset, L, FALSE);
+	END JumpT; 
+	
+	PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
+	BEGIN
+		DevCPL486.GenJump(Inverted(x.offset), L, FALSE);
+	END JumpF;
+	
+	PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label);
+		VAR c: DevCPL486.Item; n: INTEGER;
+	BEGIN
+		n := high - low + 1;
+		DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE);
+		DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x);
+		DevCPL486.GenJump(ccAE, else, FALSE);
+		DevCPL486.GenCaseJump(x)
+	END CaseTableJump;
+	
+	PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN);
+		VAR c: DevCPL486.Item;
+	BEGIN
+		IF high = low THEN
+			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
+			IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END;
+			DevCPL486.GenJump(ccE, this, FALSE)
+		ELSIF first THEN
+			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
+			DevCPL486.GenJump(ccL, else, FALSE);
+			DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
+			DevCPL486.GenJump(ccLE, this, FALSE);
+		ELSE
+			DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
+			DevCPL486.GenJump(ccG, else, FALSE);
+			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
+			DevCPL486.GenJump(ccGE, this, FALSE);
+		END
+	END CaseJump;
+
+BEGIN
+	imLevel[0] := 0
+END LindevCPC486.

BlackBox/Lindev/Mod/CPE.txt

@@ -0,0 +1,1102 @@
+MODULE LindevCPE;
+
+	(* THIS IS TEXT COPY OF CPE.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, (*Dates,*) DevCPM := LindevCPM, DevCPT := LindevCPT;
+
+
+	CONST
+		(* item base modes (=object modes) *)
+		Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
+	
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
+		
+		(* composite structure forms *)
+		Basic = 1; Array = 2; DynArr = 3; Record = 4;
+		
+		(* object modes *)
+		Fld = 4; Typ = 5; Head = 12;
+		
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* history of imported objects *)
+		inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
+		
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		(* meta interface consts *)
+		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+		mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
+		mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
+		mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
+		mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
+		mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
+		mInterface = 32; mGuid = 33; mResult = 34;
+
+		(* sysflag *)
+		untagged = 1; noAlign = 3; union = 7; interface = 10;
+		
+		(* fixup types *)
+		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105;
+		
+		(* kernel flags *)
+		iptrs = 30;
+		
+		expAllFields = TRUE;
+		
+		(* implementation restrictions *)
+		CodeBlocks = 512;
+		CodeLength = 16384;
+		MaxNameTab = 800000H;
+		
+		useAllRef = FALSE;
+		outSignatures = TRUE;
+	
+	TYPE
+		CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR;
+	
+	VAR
+		pc*: INTEGER;
+		dsize*: INTEGER;	(* global data size *)
+		KNewRec*, KNewArr*: DevCPT.Object;
+		closeLbl*: INTEGER;
+		CaseLinks*: DevCPT.LinkList;
+		
+		processor: INTEGER;
+		bigEndian: BOOLEAN;
+		procVarIndirect: BOOLEAN;
+		idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER;
+		Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object;
+		outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN;
+		codePos, srcPos: INTEGER;
+		options: SET;
+		code: ARRAY CodeBlocks OF CodeBlock;
+		actual: CodeBlock;
+		actIdx, blkIdx: INTEGER;
+		CodeOvF: BOOLEAN;
+		zero: ARRAY 16 OF SHORTCHAR;	(* all 0X *)
+		imports: INTEGER;
+		dllList, dllLast: DevCPT.Object;
+		
+		
+	PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
+		CONST N = 4294967296.0; (* 2^32 *)
+		VAR rh, rl: REAL;
+	BEGIN
+		rl := con.intval; rh := con.realval / N;
+		IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N
+		ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N
+		END;
+		hi := SHORT(ENTIER(rh));
+		rl := rl + (rh - hi) * N;
+		IF rl < 0 THEN hi := hi - 1; rl := rl + N
+		ELSIF rl >= N THEN hi := hi + 1; rl := rl - N
+		END;
+		IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END;
+		low := SHORT(ENTIER(rl))
+(*
+		hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0));
+		r := con.realval + con.intval - hi * 4294967296.0;
+		IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
+		low := SHORT(ENTIER(r))
+*)
+	END GetLongWords;
+	
+	PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER);
+		VAR r: SHORTREAL;
+	BEGIN
+		r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r)
+	END GetRealWord;
+		
+	PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
+		TYPE A = ARRAY 2 OF INTEGER;
+		VAR a: A;
+	BEGIN
+		a := SYSTEM.VAL(A, con.realval);
+		IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END
+	END GetRealWords;
+		
+	PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER);
+		VAR c: DevCPT.Const;
+	BEGIN
+		INCL(con.setval, form);
+		CASE form OF
+		| String8:
+			obj := Const8; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
+			IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END
+		| String16:
+			obj := Const16; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
+			IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END
+		| Int64:
+			obj := Const64; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO
+				c := c.link
+			END;
+			IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END
+		| Real32:
+			obj := Const32; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.realval # c.realval)) DO c := c.link END;
+			IF c = NIL THEN adr := idx32; INC(idx32, 4) END
+		| Real64:
+			obj := Const64; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.realval # c.realval)) DO c := c.link END;
+			IF c = NIL THEN adr := idx64; INC(idx64, 8) END
+		| Guid:
+			obj := Const32; c := obj.conval;
+			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
+			IF c = NIL THEN adr := idx32; INC(idx32, 16) END
+		END;
+		IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END;
+		con.intval := adr
+	END AllocConst;
+
+
+	PROCEDURE AllocTypDesc* (typ: DevCPT.Struct);	 (* typ.comp = Record *)
+		VAR obj: DevCPT.Object; name: DevCPT.Name;
+	BEGIN
+		IF typ.strobj = NIL THEN
+			name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null;	(* avoid err 1 *)
+			obj.mode := Typ; obj.typ := typ; typ.strobj := obj
+		END
+	END AllocTypDesc; 
+
+
+	PROCEDURE PutByte* (a, x: INTEGER);
+	BEGIN
+		code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256))
+	END PutByte;
+	
+	PROCEDURE PutShort* (a, x: INTEGER);
+	BEGIN
+		IF bigEndian THEN
+			PutByte(a, x DIV 256); PutByte(a + 1, x)
+		ELSE
+			PutByte(a, x); PutByte(a + 1, x DIV 256)
+		END
+	END PutShort;
+	
+	PROCEDURE PutWord* (a, x: INTEGER);
+	BEGIN
+		IF bigEndian THEN
+			PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H);
+			PutByte(a + 2, x DIV 256); PutByte(a + 3, x)
+		ELSE
+			PutByte(a, x); PutByte(a + 1, x DIV 256);
+			PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H)
+		END
+	END PutWord;
+	
+	PROCEDURE ThisByte* (a: INTEGER): INTEGER;
+	BEGIN
+		RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength])
+	END ThisByte;
+	
+	PROCEDURE ThisShort* (a: INTEGER): INTEGER;
+	BEGIN
+		IF bigEndian THEN
+			RETURN ThisByte(a) * 256 + ThisByte(a+1)
+		ELSE
+			RETURN ThisByte(a+1) * 256 + ThisByte(a)
+		END
+	END ThisShort;
+	
+	PROCEDURE ThisWord* (a: INTEGER): INTEGER;
+	BEGIN
+		IF bigEndian THEN
+			RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3)
+		ELSE
+			RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a)
+		END
+	END ThisWord;
+	
+	PROCEDURE GenByte* (x: INTEGER);
+	BEGIN
+		IF actIdx >= CodeLength THEN
+			IF blkIdx < CodeBlocks THEN
+				NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0
+			ELSE
+				IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END;
+				actIdx := 0; pc := 0
+			END
+		END;
+		actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc)
+	END GenByte;
+	
+	PROCEDURE GenShort* (x: INTEGER);
+	BEGIN
+		IF bigEndian THEN
+			GenByte(x DIV 256); GenByte(x)
+		ELSE
+			GenByte(x); GenByte(x DIV 256)
+		END
+	END GenShort;
+	
+	PROCEDURE GenWord* (x: INTEGER);
+	BEGIN
+		IF bigEndian THEN
+			GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x)
+		ELSE
+			GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H)
+		END
+	END GenWord;
+	
+	PROCEDURE WriteCode;
+		VAR i, j, k, n: INTEGER; b: CodeBlock;
+	BEGIN
+		j := 0; k := 0;
+		WHILE j < pc DO
+			n := pc - j; i := 0; b := code[k];
+			IF n > CodeLength THEN n := CodeLength END;
+			WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END;
+			INC(j, n); INC(k)
+		END
+	END WriteCode;
+
+
+	PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList;
+		VAR link: DevCPT.LinkList; m: DevCPT.Object;
+	BEGIN
+		ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ));
+		ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp));
+		IF obj.mnolev >= 0 THEN	(* not imported *)
+			CASE obj.mode OF
+			| Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END
+			| TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END
+			| Var: offs := offs + dsize; obj := Data
+			| Con, IProc, XProc, LProc:
+			END
+		ELSIF obj.mode = Typ THEN
+			IF obj.typ.untagged THEN	(* add desc for imported untagged types *)
+				IF obj.links = NIL THEN obj.link := descList; descList := obj END
+			ELSE
+				m := DevCPT.GlbMod[-obj.mnolev];
+				IF m.library # NIL THEN RETURN NIL END	(* type import from dll *)
+			END
+		END;
+		link := obj.links;
+		WHILE (link # NIL) & (link.offset # offs) DO link := link.next END;
+		IF link = NIL THEN
+			NEW(link); link.offset := offs; link.linkadr := 0;
+			link.next := obj.links; obj.links := link
+		END;
+		RETURN link
+	END OffsetLink;
+
+
+	PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object;
+		VAR obj: DevCPT.Object;
+	BEGIN
+		obj := typ.strobj;
+		IF obj = NIL THEN
+			obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0;
+			obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj
+		END;
+		RETURN obj
+	END TypeObj;
+
+
+	PROCEDURE Align (n: INTEGER);
+		VAR p: INTEGER;
+	BEGIN
+		p := DevCPM.ObjLen();
+		DevCPM.ObjWBytes(zero, (-p) MOD n)
+	END Align;
+	
+	PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR);
+		VAR ch: SHORTCHAR; i: SHORTINT;
+	BEGIN i := 0;
+		REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X
+	END OutName;
+	
+	PROCEDURE Out2 (x: INTEGER);	(* byte ordering must correspond to target machine *)
+	BEGIN
+		IF bigEndian THEN
+			DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
+		ELSE
+			DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256)))
+		END
+	END Out2;
+	
+	PROCEDURE Out4 (x: INTEGER);	(* byte ordering must correspond to target machine *)
+	BEGIN
+		IF bigEndian THEN
+			DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H)));
+			DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
+		ELSE
+			DevCPM.ObjWLInt(x)
+		END
+	END Out4;
+
+	PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER);
+		VAR link: DevCPT.LinkList;
+	BEGIN
+		link := OffsetLink(obj, offs);
+		IF link # NIL THEN
+			Out4(typ * 1000000H + link.linkadr MOD 1000000H);
+			link.linkadr := -(DevCPM.ObjLen() - headSize - 4)
+		ELSE Out4(0)
+		END
+	END OutReference;
+	
+	PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER);
+		VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
+	BEGIN
+		IF typ.form = Pointer THEN
+			IF ip & (typ.sysflag = interface)
+				OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END
+		ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
+			btyp := typ.BaseTyp;
+			IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ;
+			fld := typ.link;
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface)
+					OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num)
+				ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num)
+				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 (btyp.form = Pointer) OR (btyp.comp = Record) THEN
+				i := num; FindPtrs(btyp, adr, ip, num);
+				IF num # i THEN i := 1;
+					WHILE i < n DO
+						INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i)
+					END
+				END
+			END
+		END
+	END FindPtrs;
+	
+
+	PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR);
+	BEGIN
+		DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name)
+	END OutRefName;
+
+	PROCEDURE OutRefs* (obj: DevCPT.Object);
+		VAR f: BYTE;
+	BEGIN
+		IF outRef & (obj # NIL) THEN
+			OutRefs(obj.left);
+			IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN
+				f := obj.typ.form;
+				IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) 
+						OR outURef & (obj.typ.comp # DynArr)
+						OR outAllRef & ~obj.typ.untagged
+						OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN
+					IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END;
+					IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr)))
+					ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec)))
+					ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
+					ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16)))
+					ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64)))
+					ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid)))
+					ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult)))
+					ELSIF f = Pointer THEN
+						IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface)))
+						ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
+						ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
+						END
+					ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN
+						DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
+					ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1)))
+					ELSE DevCPM.ObjW(SHORT(CHR(f)))
+					END;
+					IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END;
+					OutName(obj.name^)
+				END
+			END ;
+			OutRefs(obj.right)
+		END
+	END OutRefs;
+	
+	PROCEDURE OutSourceRef* (pos: INTEGER);
+	BEGIN
+		IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN
+			WHILE pc > codePos + 250 DO
+				DevCPM.ObjW(SHORT(CHR(250)));
+				INC(codePos, 250);
+				DevCPM.ObjWNum(0)
+			END;
+			DevCPM.ObjW(SHORT(CHR(pc - codePos)));
+			codePos := pc;
+			DevCPM.ObjWNum(pos - srcPos);
+			srcPos := pos
+		END
+	END OutSourceRef;
+
+	
+	PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER);
+	BEGIN
+		WHILE link # NIL DO
+			ASSERT(link.linkadr # 0);
+			DevCPM.ObjWNum(link.linkadr);
+			DevCPM.ObjWNum(adr + link.offset);
+			link := link.next
+		END
+	END OutPLink;
+
+	PROCEDURE OutLink (link: DevCPT.LinkList);
+	BEGIN
+		OutPLink(link, 0); DevCPM.ObjW(0X)
+	END OutLink;
+	
+	PROCEDURE OutNames;
+		VAR a, b, c: DevCPT.Object;
+	BEGIN
+		a := nameList; b := NIL;
+		WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END;
+		DevCPM.ObjW(0X);	(* names[0] = 0X *)
+		WHILE b # NIL DO
+			OutName(b.name^);
+			b := b.nlink
+		END;
+	END OutNames;
+	
+	PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR);
+		
+		PROCEDURE Copy (n: INTEGER);
+			VAR x, y: INTEGER;
+		BEGIN
+			x := ORD(str[n]); y := ORD(str[n + 1]);
+			IF x >= ORD("a") THEN DEC(x, ORD("a") - 10)
+			ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10)
+			ELSE DEC(x, ORD("0"))
+			END;
+			IF y >= ORD("a") THEN DEC(y, ORD("a") - 10)
+			ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10)
+			ELSE DEC(y, ORD("0"))
+			END;
+			DevCPM.ObjW(SHORT(CHR(x * 16 + y)))
+		END Copy;
+		
+	BEGIN
+		IF bigEndian THEN
+			Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17)
+		ELSE
+			Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15)
+		END;
+		Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35)
+	END OutGuid;
+
+	PROCEDURE OutConst (obj: DevCPT.Object);
+		TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR;
+		VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER;
+	BEGIN
+		a := obj.conval; b := NIL;
+		WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END;
+		WHILE b # NIL DO
+			IF String8 IN b.setval THEN
+				DevCPM.ObjWBytes(b.ext^, b.intval2);
+				Align(4)
+			ELSIF String16 IN b.setval THEN
+				i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0;
+				Align(4)
+			ELSIF Real32 IN b.setval THEN
+				r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r);
+				IF DevCPM.LEHost = bigEndian THEN
+					ch := a4[0]; a4[0] := a4[3]; a4[3] := ch;
+					ch := a4[1]; a4[1] := a4[2]; a4[2] := ch
+				END;
+				DevCPM.ObjWBytes(a4, 4)
+			ELSIF Real64 IN b.setval THEN
+				a8 := SYSTEM.VAL(A8, b.realval);
+				IF DevCPM.LEHost = bigEndian THEN
+					ch := a8[0]; a8[0] := a8[7]; a8[7] := ch;
+					ch := a8[1]; a8[1] := a8[6]; a8[6] := ch;
+					ch := a8[2]; a8[2] := a8[5]; a8[5] := ch;
+					ch := a8[3]; a8[3] := a8[4]; a8[4] := ch
+				END;
+				DevCPM.ObjWBytes(a8, 8)
+			ELSIF Int64 IN b.setval THEN
+				(* intval moved to intval2 by AllocConst *)
+				x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x;
+				IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END
+			ELSIF Guid IN b.setval THEN
+				OutGuid(b.ext^)
+			END;
+			b := b.link
+		END
+	END OutConst;
+	
+	PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN);
+	BEGIN
+		IF typ = NIL THEN Out4(0)
+		ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr)
+		ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec)
+		ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr)
+		ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid)
+		ELSIF typ = DevCPT.restyp THEN Out4(mResult)
+		ELSE
+			CASE typ.form OF
+			| Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0)
+			| Bool, Char8: Out4(typ.form - 1)
+			| Int8..Set: Out4(typ.form)
+			| Char16: Out4(mChar16)
+			| Int64: Out4(mInt64)
+			| ProcTyp: OutReference(TypeObj(typ), 0, absolute)
+			| Pointer:
+				IF typ.sysflag = interface THEN Out4(mInterface)
+				ELSIF typ.untagged THEN Out4(mSysPtr)
+				ELSE OutReference(TypeObj(typ), 0, absolute)
+				END
+			| Comp:
+				IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute)
+				ELSE Out4(0)
+				END
+			END
+		END
+	END OutStruct;
+	
+	PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER;
+		VAR n: INTEGER;
+	BEGIN
+		n := 0;
+		IF obj.name # DevCPT.null THEN
+			IF obj.num = 0 THEN
+				obj.num := namex;
+				WHILE obj.name[n] # 0X DO INC(n) END;
+				INC(namex, n + 1);
+				obj.nlink := nameList; nameList := obj
+			END;
+			n := obj.num;
+		END;
+		RETURN n
+	END NameIdx;
+	
+	PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER);
+		VAR p: DevCPT.Object; n, m: INTEGER;
+	BEGIN
+		pos := DevCPM.ObjLen() - headSize;
+		OutStruct(retTyp, TRUE);
+		p := par; n := 0;
+		WHILE p # NIL DO INC(n); p := p.link END;
+		Out4(n); p := par;
+		WHILE p # NIL DO
+			IF p.mode # VarPar THEN m := mValue
+			ELSIF p.vis = inPar THEN m := mInPar
+			ELSIF p.vis = outPar THEN m := mOutPar
+			ELSE m := mVarPar
+			END;
+			Out4(NameIdx(p) * 256 + m);
+			OutStruct(p.typ, TRUE);
+			p := p.link
+		END
+	END OutSignature;
+	
+	PROCEDURE PrepObject (obj: DevCPT.Object);
+	BEGIN
+		IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN	(* write param list *)
+			OutSignature(obj.link, obj.typ, obj.conval.intval)
+		END
+	END PrepObject;
+	
+	PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object);
+		VAR vis: INTEGER;
+	BEGIN
+		Out4(fprint);
+		Out4(offs);
+		IF obj.vis = internal THEN vis := mInternal
+		ELSIF obj.vis = externalR THEN vis := mReadonly
+		ELSIF obj.vis = external THEN vis := mExported
+		END;
+		Out4(mode + vis * 16 + NameIdx(obj) * 256);
+		IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute)	(* ref to par list *)
+		ELSE OutStruct(typ, mode = mField)
+		END
+	END OutObject;
+	
+	PROCEDURE PrepDesc (desc: DevCPT.Struct);
+		VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct;
+	BEGIN
+		IF desc.comp = Record THEN	(* write field list *)
+			desc.strobj.adr := DevCPM.ObjLen() - headSize;
+			n := 0; fld := desc.link;
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				IF expAllFields OR (fld.vis # internal) THEN INC(n) END;
+				fld := fld.link
+			END;
+			Out4(n); fld := desc.link;
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				IF expAllFields OR (fld.vis # internal) THEN
+					OutObject(mField, 0, fld.adr, fld.typ, fld)
+				END;
+				fld := fld.link
+			END
+		ELSIF (desc.form = ProcTyp) & outSignatures THEN	(* write param list *)
+			OutSignature(desc.link, desc.BaseTyp, desc.n)
+		END;
+		(* assert name and base type are included *)
+		IF desc.untagged THEN n := NameIdx(untgd)
+		ELSE n := NameIdx(desc.strobj)
+		END;
+		IF desc.form # ProcTyp THEN b := desc.BaseTyp;
+			IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp})
+					& (b.sysflag # interface) & (b # DevCPT.guidtyp)
+					& (~b.untagged OR outURef & (b.form = Comp)) THEN
+				l := OffsetLink(TypeObj(b), 0)
+			END
+		END
+	END PrepDesc;
+	
+	PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object;
+		VAR obj: DevCPT.Object;
+	BEGIN
+		IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END;
+		obj := NumMeth(root.left, num);
+		IF obj = NIL THEN obj := NumMeth(root.right, num) END;
+		RETURN obj
+	END NumMeth;
+	
+	PROCEDURE OutDesc (desc: DevCPT.Struct);
+		VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE;
+			name: DevCPT.Name;
+	BEGIN
+		ASSERT(~desc.untagged);
+		IF desc.comp = Record THEN
+			xb := desc; flddir := desc.strobj.adr;
+			REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged;
+			Out4(-1); i := desc.n;
+			WHILE i > 0 DO DEC(i); t := desc;
+				REPEAT
+					m := NumMeth(t.link, i); t := t.BaseTyp
+				UNTIL (m # NIL) OR (t = xb);
+				IF m # NIL THEN 
+					IF absAttr IN m.conval.setval THEN Out4(0)
+					ELSE OutReference(m, 0, absolute)
+					END
+				ELSIF (xb = NIL) OR xb.untagged THEN Out4(0)	(* unimplemented ANYREC method *)
+				ELSE OutReference(xb.strobj, -4 - 4 * i, copy)
+				END
+			END;
+			desc.strobj.adr := DevCPM.ObjLen() - headSize;	(* desc adr *)
+			Out4(desc.size);
+			OutReference(Mod, 0, absolute);
+			IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
+			IF desc.attribute = extAttr THEN attr := 1
+			ELSIF desc.attribute = limAttr THEN attr := 2
+			ELSIF desc.attribute = absAttr THEN attr := 3
+			ELSE attr := 0
+			END;
+			Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0;
+			WHILE i <= desc.extlev DO
+				t := desc;
+				WHILE t.extlev > i DO t := t.BaseTyp END;
+				IF t.sysflag = interface THEN Out4(0)
+				ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute)
+				ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute)
+				ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute)
+				ELSE OutReference(xb.strobj, 12 + 4 * i, copy)
+				END;
+				INC(i)
+			END;
+			WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END;
+			OutReference(Meta, flddir, absolute);	(* ref to field list *)
+			nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr);
+			Out4(-(4 * nofptr + 4));
+			nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr);
+			Out4(-1)
+		ELSE
+			desc.strobj.adr := DevCPM.ObjLen() - headSize;
+			lev := 0; size := 0;
+			IF desc.comp = Array THEN
+				size := desc.n; form := mArray
+			ELSIF desc.comp = DynArr THEN
+				form := mArray; lev := SHORT(SHORT(desc.n + 1))
+			ELSIF desc.form = Pointer THEN
+				form := mPointer
+			ELSE ASSERT(desc.form = ProcTyp);
+				DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp;
+			END;
+			Out4(size);
+			OutReference(Mod, 0, absolute);
+			IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
+			Out4(form + lev * 16 + NameIdx(m) * 256);
+			IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE)
+			ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute)	(* ref to par list *)
+			END
+		END
+	END OutDesc;
+
+	PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER);
+		VAR i: INTEGER; (*t: Dates.Time; d: Dates.Date;*)
+	BEGIN
+		Out4(0);	(* link *)
+		Out4(ORD(options));	(* opts *)
+		Out4(0);	(* refcnt *)
+		(*Dates.GetDate(d); Dates.GetTime(t); 	(* compile time *)
+		Out2(d.year); Out2(d.month); Out2(d.day);
+		Out2(t.hour); Out2(t.minute); Out2(t.second);*)
+		Out2(2007); Out2(5); Out2(25);
+		Out2(0); Out2(0); Out2(0);
+		Out4(0); Out4(0); Out4(0); 	(* load time *)
+		Out4(0);	(* ext *)
+		IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute);	(* terminator *)
+		ELSE Out4(0)
+		END;
+		Out4(imports);	(* nofimps *)
+		Out4(nofptr);	(* nofptrs *)
+		Out4(pc);	(* csize *)
+		Out4(dsize);	(* dsize *)
+		Out4(refSize);	(* rsize *)
+		OutReference(Code, 0, absolute);	(* code *)
+		OutReference(Data, 0, absolute);	(* data *)
+		OutReference(Meta, 0, absolute);	(* refs *)
+		IF procVarIndirect THEN
+			OutReference(Proc, 0, absolute);	(* procBase *)
+		ELSE
+			OutReference(Code, 0, absolute);	(* procBase *)
+		END;
+		OutReference(Data, 0, absolute);	(* varBase *)
+		OutReference(Meta, namePos, absolute);	(* names *)
+		OutReference(Meta, ptrPos, absolute);	(* ptrs *)
+		OutReference(Meta, impPos, absolute);	(* imports *)
+		OutReference(Meta, expPos, absolute);	(* export *)
+		i := 0;	(* name *)
+		WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END;
+		DevCPM.ObjW(0X);
+		Align(4)
+	END OutModDesc;
+
+	PROCEDURE OutProcTable (obj: DevCPT.Object);	(* 68000 *)
+	BEGIN
+		IF obj # NIL THEN
+			OutProcTable(obj.left);
+			IF obj.mode IN {XProc, IProc} THEN
+				Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0);
+			END;
+			OutProcTable(obj.right);
+		END;
+	END OutProcTable;
+
+	PROCEDURE PrepExport (obj: DevCPT.Object);
+	BEGIN
+		IF obj # NIL THEN
+			PrepExport(obj.left);
+			IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN
+				PrepObject(obj)
+			END;
+			PrepExport(obj.right)
+		END
+	END PrepExport;
+	
+	PROCEDURE OutExport (obj: DevCPT.Object);
+		VAR num: INTEGER;
+	BEGIN
+		IF obj # NIL THEN
+			OutExport(obj.left);
+			IF (obj.history # removed) & ((obj.vis # internal) OR
+						(obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN
+				DevCPT.FPrintObj(obj);
+				IF obj.mode IN {LProc, XProc, IProc} THEN
+					IF procVarIndirect THEN
+						ASSERT(obj.nlink = NIL);
+						num := obj.num; obj.num := 0;
+						OutObject(mProc, obj.fprint, num, NIL, obj);
+						obj.num := num
+					ELSE
+						OutObject(mProc, obj.fprint, obj.adr, NIL, obj)
+					END
+				ELSIF obj.mode = Var THEN
+					OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj)
+				ELSIF obj.mode = Typ THEN
+					OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj)
+				ELSE ASSERT(obj.mode IN {Con, CProc});
+					OutObject(mConst, obj.fprint, 0, NIL, obj)
+				END
+			END;
+			OutExport(obj.right)
+		END
+	END OutExport;
+	
+	PROCEDURE OutCLinks (obj: DevCPT.Object);
+	BEGIN
+		IF obj # NIL THEN
+			OutCLinks(obj.left);
+			IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END;
+			OutCLinks(obj.right)
+		END
+	END OutCLinks;
+
+	PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER);
+	BEGIN
+		IF obj # NIL THEN
+			OutCPLinks(obj.left, base);
+			IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END;
+			OutCPLinks(obj.right, base)
+		END
+	END OutCPLinks;
+
+	PROCEDURE OutImport (obj: DevCPT.Object);
+		VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER;
+	BEGIN
+		IF obj # NIL THEN
+			OutImport(obj.left);
+			IF obj.mode = Typ THEN typ := obj.typ;
+				IF obj.used OR
+					(typ.form IN {Pointer, Comp}) & (typ.strobj = obj) &
+						((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN
+					DevCPT.FPrintStr(typ);
+					DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^);
+					IF obj.used THEN opt := 2 ELSE opt := 0 END;
+					IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN
+						DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1)));
+						IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END
+					ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt)))
+					END;
+					OutLink(obj.links)
+				END
+			ELSIF obj.used THEN
+				DevCPT.FPrintObj(obj);
+				IF obj.mode = Var THEN
+					DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^);
+					DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
+				ELSIF obj.mode IN {XProc, IProc} THEN
+					DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^);
+					DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
+				ELSE ASSERT(obj.mode IN {Con, CProc});
+					DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint)
+				END
+			END;
+			OutImport(obj.right)
+		END
+	END OutImport;
+	
+	PROCEDURE OutUseBlock;
+		VAR m, obj: DevCPT.Object; i: INTEGER;
+	BEGIN
+		m := dllList;
+		WHILE m # NIL DO
+			obj := m.nlink;
+			WHILE obj # NIL DO
+				IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar)))
+				ELSE DevCPM.ObjW(SHORT(CHR(mProc)))
+				END;
+				IF obj.entry # NIL THEN OutName(obj.entry^)
+				ELSE OutName(obj.name^);
+				END;
+				DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links);
+				obj := obj.nlink
+			END;
+			DevCPM.ObjW(0X); m := m.link
+		END;
+		i := 1;
+		WHILE i < DevCPT.nofGmod DO
+			obj := DevCPT.GlbMod[i];
+			IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END;
+			INC(i)
+		END;
+	END OutUseBlock;
+
+	PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String);
+		VAR name: DevCPT.String; dll: DevCPT.Object;
+	BEGIN
+		IF obj # NIL THEN
+			CollectDll(obj.left, mod);
+			IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN
+				IF obj.library # NIL THEN name := obj.library
+				ELSE name := mod
+				END;
+				dll := dllList;
+				WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END;
+				IF dll = NIL THEN
+					NEW(dll); dll.library := name; INC(imports);
+					IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END;
+					dllLast := dll; dll.left := dll;
+				END;
+				dll.left.nlink := obj; dll.left := obj
+			END;
+			CollectDll(obj.right, mod)
+		END
+	END CollectDll;
+	
+	PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER);
+	BEGIN
+		IF obj # NIL THEN
+			EnumXProc(obj.left, num);
+			IF obj.mode IN {XProc, IProc} THEN
+				obj.num := num; INC(num, 8);
+			END;
+			EnumXProc(obj.right, num)
+		END;
+	END EnumXProc;
+	
+	PROCEDURE OutHeader*;
+		VAR i: INTEGER; m: DevCPT.Object;
+	BEGIN
+		DevCPM.ObjWLInt(processor);	(* processor type *)
+		DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0);
+		DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0);	(* sizes *)
+		imports := 0; i := 1;
+		WHILE i < DevCPT.nofGmod DO
+			m := DevCPT.GlbMod[i];
+			IF m.library # NIL THEN	(* dll import *)
+				CollectDll(m.right, m.library);
+			ELSE INC(imports)	(* module import *)
+			END;
+			INC(i)
+		END;
+		DevCPM.ObjWNum(imports);	(* num of import *)
+		OutName(DevCPT.SelfName); 
+		m := dllList;
+		WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END;
+		i := 1;
+		WHILE i < DevCPT.nofGmod DO
+			m := DevCPT.GlbMod[i];
+			IF m.library = NIL THEN OutName(m.name^) END;
+			INC(i)
+		END;
+		Align(16); headSize := DevCPM.ObjLen();
+		IF procVarIndirect THEN
+			i := 0; EnumXProc(DevCPT.topScope.right, i)
+		END
+	END OutHeader;
+
+	PROCEDURE OutCode*;
+		VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos,
+			con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER;
+			m, obj, dlist: DevCPT.Object;
+	BEGIN
+	(* Ref *)
+		DevCPM.ObjW(0X); (* end mark *)
+		refSize := DevCPM.ObjLen() - headSize;
+	(* Export *)
+		Align(4);
+		IF outSignatures THEN PrepExport(DevCPT.topScope.right) END;	(* procedure signatures *)
+		Align(8); expPos := DevCPM.ObjLen(); 
+		Out4(0);
+		OutExport(DevCPT.topScope.right);	(* export objects *)
+		i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i);
+	(* Pointers *)
+		ptrPos := DevCPM.ObjLen();
+		obj := DevCPT.topScope.scope; nofptrs := 0;
+		WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END;
+		obj := DevCPT.topScope.scope; i := 0;
+		WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END;
+		IF i > 0 THEN Out4(-1); INCL(options, iptrs) END;
+	(* Prepare Type Descriptors *)
+		dlist := NIL;
+		WHILE descList # NIL DO
+			obj := descList; descList := descList.link;
+			PrepDesc(obj.typ);
+			obj.link := dlist; dlist := obj
+		END;
+	(* Import List *)
+		impPos := DevCPM.ObjLen(); i := 0;
+		WHILE i < imports DO Out4(0); INC(i) END;
+	(* Names *)
+		namePos := DevCPM.ObjLen(); OutNames;
+	(* Const *)
+		Align(4); con8Pos := DevCPM.ObjLen();
+		OutConst(Const8); con16Pos := DevCPM.ObjLen();
+		ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8);
+		OutConst(Const16); con32Pos := DevCPM.ObjLen();
+		ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16);
+		OutConst(Const32); con64Pos := DevCPM.ObjLen();
+		ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32);
+		IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END;
+		OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64);
+	(* Module Descriptor *)
+		Align(16); modPos := DevCPM.ObjLen();
+		OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize);
+	(* Procedure Table *)
+		procPos := DevCPM.ObjLen();
+		OutProcTable(DevCPT.topScope.right);
+		Out4(0); Out4(0); (* at least one entry in ProcTable *)
+		Out4(0); (* sentinel *)
+	(* Type Descriptors *)
+		obj := dlist;
+		WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END;
+	(* Code *)
+		codePos := DevCPM.ObjLen(); WriteCode;
+		WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END;
+	(* Fixups *)
+		OutLink(KNewRec.links); OutLink(KNewArr.links);
+		(* metalink *)
+		OutPLink(Const8.links, con8Pos - headSize);
+		OutPLink(Const16.links, con16Pos - headSize);
+		OutPLink(Const32.links, con32Pos - headSize);
+		OutPLink(Const64.links, con64Pos - headSize);
+		OutLink(Meta.links);
+		(* desclink *)
+		obj := dlist; i := modPos - headSize;
+		WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END;
+		IF procVarIndirect THEN
+			OutPLink(Proc.links, procPos - modPos);
+			OutCPLinks(DevCPT.topScope.right, procPos - modPos)
+		END;
+		OutLink(Mod.links);
+		(* codelink *)
+		IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END;
+		OutPLink(CaseLinks, 0); OutLink(Code.links);
+		(* datalink *)
+		OutLink(Data.links);
+	(* Use *)
+		OutUseBlock;
+	(* Header Fixups *)
+		DevCPM.ObjSet(8);
+		DevCPM.ObjWLInt(headSize);
+		DevCPM.ObjWLInt(modPos - headSize);
+		DevCPM.ObjWLInt(codePos - modPos);
+		DevCPM.ObjWLInt(pc);
+		DevCPM.ObjWLInt(dsize);
+		IF namex > MaxNameTab THEN DevCPM.err(242) END;
+		IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END
+	END OutCode;
+
+	PROCEDURE Init* (proc: INTEGER; opt: SET);
+		CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14;
+	BEGIN
+		processor := proc;
+		bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt;
+		outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt;
+		outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options);
+		outSrc := srcpos IN opt;
+		pc := 0; actIdx := CodeLength; blkIdx := 0; 
+		idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1;
+		options := opt * {0..15}; CodeOvF := FALSE;
+		KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
+		Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
+		Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
+		Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
+		nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
+		codePos := 0; srcPos := 0;
+		NEW(untgd); untgd.name := DevCPT.NewName("!");
+		closeLbl := 0
+	END Init;
+
+	PROCEDURE Close*;
+	BEGIN
+		KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
+		Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
+		Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
+		Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
+		nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
+		WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END;
+		actual := NIL; untgd := NIL;
+	END Close;
+
+BEGIN
+	NEW(KNewRec); KNewRec.mnolev := -128;
+	NEW(KNewArr); KNewArr.mnolev := -128;
+	NEW(Const8); Const8.mode := Con; Const8.mnolev := 0;
+	NEW(Const16); Const16.mode := Con; Const16.mnolev := 0;
+	NEW(Const32); Const32.mode := Con; Const32.mnolev := 0;
+	NEW(Const64); Const64.mode := Con; Const64.mnolev := 0;
+	NEW(Code); Code.mode := Con; Code.mnolev := 0;
+	NEW(Data); Data.mode := Con; Data.mnolev := 0;
+	NEW(Mod); Mod.mode := Con; Mod.mnolev := 0;
+	NEW(Proc); Proc.mode := Con; Proc.mnolev := 0;
+	NEW(Meta); Meta.mode := Con; Mod.mnolev := 0;
+END LindevCPE.

BlackBox/Lindev/Mod/CPH.txt

@@ -0,0 +1,291 @@
+MODULE LindevCPH;
+
+	(* THIS IS TEXT COPY OF CPH.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT DevCPT := LindevCPT;
+	
+	CONST
+		(* UseCalls options *)
+		longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3;
+		realMop* = 8; realDop* = 9; realConv* = 10;
+		intMulDiv* = 11;
+		force = 16; hide = 17;
+	
+		(* 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; Ncomp = 30;
+		Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
+		
+		(*function number*)
+		assign = 0; newfn = 1; incfn = 13; decfn = 14;
+		inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32;
+		getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31;
+		
+		(* symbol values and 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;
+		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
+		min = 34; max = 35; typfn = 36;
+		thisrecfn = 45; thisarrfn = 46;
+		shl = 50; shr = 51; lshr = 52; xor = 53;
+
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18;
+		VString16to8 = 29; VString8 = 30; VString16 = 31;
+		realSet = {Real32, Real64};
+		Basic = 1; Array = 2; DynArr = 3; Record = 4;
+
+		
+
+	PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR);
+		VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN;
+	BEGIN
+		IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real"
+		ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal"
+		ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long"
+		ELSE mod := "Int"
+		END;
+		moda := mod + "%";
+		DevCPT.Find(moda, mobj);
+		IF mobj = NIL THEN
+			DevCPT.Import(moda, mod, done);
+			IF done THEN DevCPT.Find(moda, mobj) END
+		END;
+		nm := name$; DevCPT.FindImport(nm, mobj, obj);
+		n.class := Ncall; n.subcl := 0; n.obj := obj.link;
+		n.left.link := n.right; n.right := n.left;
+		n.left := DevCPT.NewNode(Nproc);
+		n.left.obj := obj; n.left.typ := obj.typ;
+		ASSERT(n.typ.form = obj.typ.form)
+	END UseThisCall;
+	
+	PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct);
+		VAR new: DevCPT.Node; r: REAL;
+	BEGIN
+		IF n.class = Nconst THEN
+			ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp));
+			r := n.conval.realval + n.conval.intval;
+			IF r = n.conval.realval + n.conval.intval THEN
+				n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL
+			END
+		END;
+		IF (n.typ # typ)
+			& ((n.class # Nmop) OR (n.subcl # conv)
+				OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN
+			new := DevCPT.NewNode(0); new^ := n^;
+			n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL
+		END;
+		n.typ := typ
+	END Convert;
+	
+	PROCEDURE UseCallForComp (n: DevCPT.Node);
+		VAR new: DevCPT.Node;
+	BEGIN
+		new := DevCPT.NewNode(0);
+		new.left := n.left; new.right := n.right;
+		new.typ := DevCPT.int32typ;
+		UseThisCall(new, "Comp");
+		n.left := new;
+		n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst();
+		n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ;
+	END UseCallForComp;
+	
+	PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET);
+		VAR f, g: INTEGER; typ: DevCPT.Struct;
+	BEGIN
+		typ := n.typ; f := typ.form; g := n.left.typ.form;
+		IF realConv IN opts THEN
+			IF f IN realSet THEN
+				IF g = Real32 THEN UseThisCall(n, "Long")
+				ELSIF g = Real64 THEN UseThisCall(n, "Short")
+				ELSIF g = Int64 THEN UseThisCall(n, "LFloat")
+				ELSIF g = Int32 THEN UseThisCall(n, "Float")
+				ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float")
+				END
+			ELSIF g IN realSet THEN
+				IF f = Int64 THEN UseThisCall(n, "LFloor")
+				ELSIF f = Int32 THEN UseThisCall(n, "Floor")
+				ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ)
+				END
+			END
+		END;
+		IF longConv IN opts THEN
+			IF f = Int64 THEN
+				IF g = Int32 THEN UseThisCall(n, "Long")
+				ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong")
+				END
+			ELSIF g = Int64 THEN
+				IF f = Int32 THEN UseThisCall(n, "Short")
+				ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ)
+				END
+			END
+		END
+	END UseCallForConv;
+		
+	PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET);
+	BEGIN
+		CASE n.subcl OF
+		| minus:
+			IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
+				UseThisCall(n, "Neg")
+			END
+		| abs:
+			IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
+				UseThisCall(n, "Abs")
+			END
+		| odd:
+			IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END
+		| conv:
+			UseCallForConv(n, opts)
+		ELSE
+		END
+	END UseCallForMop;
+		
+	PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET);
+	BEGIN
+		IF (realDop IN opts) & (n.left.typ.form IN realSet)
+				OR (longDop IN opts) & (n.left.typ.form = Int64)
+				OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN
+			CASE n.subcl OF
+			| times: UseThisCall(n, "Mul")
+			| slash: UseThisCall(n, "Div")
+			| div: UseThisCall(n, "Div")
+			| mod: UseThisCall(n, "Mod")
+			| plus: UseThisCall(n, "Add")
+			| minus: UseThisCall(n, "Sub")
+			| ash: UseThisCall(n, "Ash")
+			| min: UseThisCall(n, "Min")
+			| max: UseThisCall(n, "Max")
+			| eql..geq: UseCallForComp(n)
+			ELSE
+			END
+		END
+	END UseCallForDop;
+	
+	PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET);
+		VAR f, g: INTEGER;
+	BEGIN
+		f := n.typ.form; g := typ.form;
+		IF f # g THEN
+			IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet))
+					OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN
+				Convert(n, typ);
+				UseCallForConv(n, opts)
+			END
+		END
+	END UseCallForMove;
+		
+	PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET);
+	BEGIN
+		IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END
+	END UseCallForAssign;
+	
+	PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET);
+	BEGIN
+		IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END
+	END UseCallForReturn;
+	
+	PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET);
+	BEGIN
+		WHILE n # NIL DO
+			UseCallForMove(n, fp.typ, opts);
+			n := n.link; fp := fp.link
+		END
+	END UseCallForParam;
+	
+	PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET);
+	BEGIN
+		WHILE n # NIL DO
+			CASE n.class OF
+			| Nmop:
+				UseCalls(n.left, opts); UseCallForMop(n, opts)
+			| Ndop:
+				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts)
+			| Ncase:
+				UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts)
+			| Nassign:
+				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts)
+			| Ncall:
+				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts)
+			| Nreturn:
+				UseCalls(n.left, opts); UseCallForReturn(n, opts)
+			| Ncasedo:
+				UseCalls(n.right, opts)
+			| Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard:
+				UseCalls(n.left, opts)
+			| Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
+				UseCalls(n.left, opts); UseCalls(n.right, opts)
+			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
+			END;
+			n := n.link
+		END
+	END UseCalls;
+	
+		
+	PROCEDURE UseReals* (n: DevCPT.Node; opts: SET);
+	BEGIN
+		WHILE n # NIL DO
+			CASE n.class OF
+			| Nmop:
+				IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN
+					UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp
+				ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide})
+				ELSE UseReals(n.left, opts - {force, hide})
+				END
+			| Ndop:
+				IF (longDop IN opts) & (n.left.typ.form = Int64) THEN
+					UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force});
+					IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END
+				ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
+				END
+			| Ncase:
+				UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide});
+				UseReals(n.right.right, opts - {force, hide})
+			| Ncasedo:
+				UseReals(n.right, opts - {force, hide})
+			| Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard:
+				UseReals(n.left, opts - {force, hide})
+			| Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
+				UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
+			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
+			END;
+			IF force IN opts THEN Convert(n, DevCPT.intrealtyp)
+			ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ)
+			END;
+			n := n.link
+		END
+	END UseReals;
+		
+END LindevCPH.
+
+
+
+
+	PROCEDURE Traverse (n: DevCPT.Node; opts: SET);
+	BEGIN
+		WHILE n # NIL DO
+			CASE n.class OF
+			| Ncase:
+				Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts)
+			| Ncasedo:
+				Traverse(n.right, opts)
+			| Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
+				Traverse(n.left, opts)
+			| Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
+				Traverse(n.left, opts); Traverse(n.right, opts)
+			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
+			END;
+			n := n.link
+		END
+	END Traverse;
+		

BlackBox/Lindev/Mod/CPL486.txt

@@ -0,0 +1,1057 @@
+MODULE LindevCPL486;
+
+	(* THIS IS TEXT COPY OF CPL486.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT DevCPM := LindevCPM, DevCPT := LindevCPT, DevCPE := LindevCPE;
+	
+	TYPE
+		Item* = RECORD
+			mode*,  tmode*, form*: BYTE;
+			offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *)
+			typ*: DevCPT.Struct;
+			obj*: DevCPT.Object
+		END ;
+		
+(* Items:
+
+	 mode	| offset	index		scale		reg     obj
+------------------------------------------------
+ 1 Var	 | adr		 xreg		 scale					  obj  (ea = FP + adr + xreg * scale)
+ 2 VarPar| off     xreg     scale            obj  (ea = [FP + obj.adr] + off + xreg * scale)
+ 3 Con	 | val              (val2)           NIL
+   Con   | off                               obj  (val = adr(obj) + off)
+	 Con	 | id														    NIL  (for predefined reals)
+ 6 LProc |                                   obj
+ 7 XProc |                                   obj
+ 9 CProc |                                   obj						
+10 IProc |                                   obj
+13 TProc | mthno						0/1		          obj	(0 = normal / 1 = super call)
+14 Ind	 | off		 xreg		 scale		Reg	      	(ea = Reg + off + xreg * scale)
+15 Abs	 | adr		 xreg		 scale				    NIL  (ea = adr + xreg * scale) 
+   Abs	 | off		 xreg		 scale				    obj  (ea = adr(obj) + off + xreg * scale)
+   Abs   | off     len      0                obj  (for constant strings and reals)
+16 Stk	 |																      	(ea = ESP)
+17 Cond	| CC
+18 Reg	 |				(Reg2)						 Reg
+19 DInd	| off		 xreg		 scale		Reg	      	(ea = [Reg + off + xreg * scale])
+
+	tmode	| record tag     array desc
+-------------------------------------
+  VarPar | [FP + obj.adr + 4]  [FP + obj.adr]
+  Ind    | [Reg - 4]         [Reg + 8]
+  Con    | Adr(typ.strobj)
+
+*)
+
+	CONST
+		processor* = 10; (* for i386 *)
+		NewLbl* = 0;
+
+	TYPE
+		Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *)
+		
+	VAR
+		level*: BYTE;
+		one*: DevCPT.Const;
+
+	CONST
+		(* item base modes (=object modes) *)
+		Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
+	
+		(* item modes for i386 (must not overlap item basemodes,	> 13) *)
+		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
+	
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
+		
+		(* composite structure forms *)
+		Basic = 1; Array = 2; DynArr = 3; Record = 4;
+		
+		(* condition codes *)
+		ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
+		ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
+		ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
+		ccAlways = -1; ccNever = -2; ccCall = -3;
+		
+		(* registers *)
+		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
+		
+		(* fixup types *)
+		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105;
+		
+		(* system trap numbers *)
+		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
+		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
+		
+
+	VAR
+		Size: ARRAY 32 OF INTEGER;	(* Size[typ.form] == +/- typ.size *)
+		a1, a2: Item;
+
+
+	PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE);
+	BEGIN
+		ASSERT((reg >= 0) & (reg < 8));
+		x.mode := Reg; x.reg := reg; x.form := form
+	END MakeReg;
+	
+	PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE);
+	BEGIN
+		x.mode := Con; x.offset := val; x.form := form; x.obj := NIL;
+	END MakeConst;
+
+	PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE);
+		VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER;
+	BEGIN
+		IF form IN {Real32, Real64} THEN
+			r := con.realval;
+			IF ABS(r) <= MAX(SHORTREAL) THEN
+				short := SHORT(r);
+				IF short = r THEN form := Real32	(* a shortreal can represent the exact value *)
+				ELSE form := Real64	(* use a real *)
+				END
+			ELSE form := Real64	(* use a real *)
+			END
+		ELSIF form IN {String8, String16, Guid} THEN
+			x.index := con.intval2	(* string length *)
+		END;
+		DevCPE.AllocConst(con, form, x.obj, x.offset);
+		x.form := form; x.mode := Abs; x.scale := 0
+	END AllocConst;
+
+	(*******************************************************)
+	
+	PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *)
+	BEGIN
+	END BegStat;
+
+	PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *)
+	BEGIN
+	END EndStat;
+
+	(*******************************************************)
+	
+	PROCEDURE SetLabel* (VAR L: Label);
+		VAR link, typ, disp, x: INTEGER; c: SHORTCHAR;
+	BEGIN
+		ASSERT(L <= 0); link := -L;
+		WHILE link # 0 DO
+			typ := link DIV 1000000H; link := link MOD 1000000H;
+			IF typ = short THEN
+				disp := DevCPE.pc - link - 1; ASSERT(disp < 128);
+				DevCPE.PutByte(link, disp); link := 0
+			ELSIF typ = relative THEN
+				x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x
+			ELSE
+				x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x
+			END
+		END;		
+		L := DevCPE.pc;
+		a1.mode := 0; a2.mode := 0
+	END SetLabel;
+	
+
+	(*******************************************************)
+	
+	PROCEDURE GenWord (x: INTEGER);
+	BEGIN
+		DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256)
+	END GenWord;
+
+	PROCEDURE GenDbl (x: INTEGER);
+	BEGIN
+		DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H)
+	END GenDbl;
+	
+	PROCEDURE CaseEntry* (tab, from, to: INTEGER);
+		VAR a, e: INTEGER;
+	BEGIN
+		a := tab + 4 * from; e := tab + 4 * to;
+		WHILE a <= e DO
+			DevCPE.PutByte(a, DevCPE.pc);
+			DevCPE.PutByte(a + 1, DevCPE.pc DIV 256);
+			DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536);
+			INC(a, 4)
+		END;
+		a1.mode := 0; a2.mode := 0
+	END CaseEntry;
+
+	PROCEDURE GenLinked (VAR x: Item; type: BYTE);
+		VAR link: DevCPT.LinkList;
+	BEGIN
+		IF x.obj = NIL THEN GenDbl(x.offset)
+		ELSE
+			link := DevCPE.OffsetLink(x.obj, x.offset);
+			IF link # NIL THEN
+				GenDbl(type * 1000000H + link.linkadr MOD 1000000H);
+				link.linkadr := DevCPE.pc - 4
+			ELSE GenDbl(0)
+			END
+		END
+	END GenLinked;
+	
+	PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER);
+	BEGIN
+		IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1
+		ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1
+		ELSE w := 0
+		END
+	END CheckSize;
+	
+	PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER);
+	BEGIN
+		IF form = Real32 THEN mf := 0
+		ELSIF form = Real64 THEN mf := 4
+		ELSIF form = Int32 THEN mf := 2
+		ELSE ASSERT(form = Int16); mf := 6
+		END
+	END CheckForm;
+	
+	PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER);
+	BEGIN
+		IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2
+		ELSE s := 0
+		END 
+	END CheckConst;
+	
+	PROCEDURE GenConst (VAR x: Item; short: BOOLEAN);
+	BEGIN
+		IF x.obj # NIL THEN GenLinked(x, absolute)
+		ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset)
+		ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset)
+		ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset)
+		ELSE GenDbl(x.offset)
+		END
+	END GenConst;
+	
+	PROCEDURE GenCExt (code: INTEGER; VAR x: Item);
+		VAR disp, mod, base, scale: INTEGER;
+	BEGIN
+		ASSERT(x.mode IN {Reg, Ind, Abs, Stk});
+		ASSERT((code MOD 8 = 0) & (code < 64));
+		disp := x.offset; base := x.reg; scale := x.scale;
+		IF x.mode = Reg THEN mod := 0C0H; scale := 0
+		ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0
+		ELSIF x.mode = Abs THEN
+			IF scale = 1 THEN base := x.index; mod := 80H; scale := 0
+			ELSE base := BP; mod := 0
+			END
+		ELSIF (disp = 0) & (base # BP) THEN mod := 0
+		ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H
+		ELSE mod := 80H
+		END;
+		IF scale # 0 THEN
+			DevCPE.GenByte(mod + code + 4); base := base + x.index * 8;
+			IF scale = 8 THEN DevCPE.GenByte(0C0H + base);
+			ELSIF scale = 4 THEN DevCPE.GenByte(80H + base);
+			ELSIF scale = 2 THEN DevCPE.GenByte(40H + base);
+			ELSE ASSERT(scale = 1); DevCPE.GenByte(base);
+			END;
+		ELSE
+			DevCPE.GenByte(mod + code + base);
+			IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END
+		END;
+		IF x.mode = Abs THEN GenLinked(x, absolute)
+		ELSIF mod = 80H THEN GenDbl(disp)
+		ELSIF mod = 40H THEN DevCPE.GenByte(disp)
+		END
+	END GenCExt;
+	
+	PROCEDURE GenDExt (VAR r, x: Item);
+	BEGIN
+		ASSERT(r.mode = Reg);
+		GenCExt(r.reg * 8, x)
+	END GenDExt;
+	
+	(*******************************************************)
+	
+	PROCEDURE GenMove* (VAR from, to: Item);
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(Size[from.form] = Size[to.form]);
+		IF to.mode = Reg THEN
+			IF from.mode = Con THEN
+				IF to.reg = AX THEN
+
+					IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN
+						RETURN
+					END;
+
+					a1 := from; a2.mode := 0
+				END;
+				CheckSize(from.form, w);
+				IF (from.offset = 0) & (from.obj = NIL) THEN
+					DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *)
+				ELSE
+					DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE)
+				END;
+			ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN
+
+				IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form)
+					OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN
+					RETURN
+				END;
+
+				a1 := from; a2.mode := 0;
+				CheckSize(from.form, w);
+				DevCPE.GenByte(0A0H + w); GenLinked(from, absolute);
+			ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN
+				IF to.reg = AX THEN
+					IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN
+
+						IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form)
+							OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN
+							RETURN
+						END;
+
+						a1 := from
+					ELSE a1.mode := 0
+					END;
+					a2.mode := 0
+				END;
+				CheckSize(from.form, w);
+				DevCPE.GenByte(8AH + w); GenDExt(to, from)
+			END 
+		ELSE
+			CheckSize(from.form, w);
+			IF from.mode = Con THEN
+				DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE);
+				a1.mode := 0; a2.mode := 0
+			ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN
+				DevCPE.GenByte(0A2H + w); GenLinked(to, absolute);
+				a2 := to
+			ELSE
+				DevCPE.GenByte(88H + w); GenDExt(from, to);
+				IF from.reg = AX THEN
+					IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END
+				ELSE a1.mode := 0; a2.mode := 0
+				END
+			END
+		END
+	END GenMove;
+	
+	PROCEDURE GenExtMove* (VAR from, to: Item);
+		VAR w, op: INTEGER;
+	BEGIN
+		ASSERT(from.mode # Con);
+		IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *)
+		ELSE op := 0BEH (* MOVSX *)
+		END;
+		IF from.form IN {Int16, Char16} THEN INC(op) END;
+		DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from);
+		IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END
+	END GenExtMove;
+	
+	PROCEDURE GenSignExt* (VAR from, to: Item);
+	BEGIN
+		ASSERT(to.mode = Reg);
+		IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN
+			DevCPE.GenByte(99H)	(* cdq *)
+		ELSE
+			GenMove(from, to);	(* mov to, from *)
+			DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31)	(* sar to, 31 *)
+		END
+	END GenSignExt;
+	
+	PROCEDURE GenLoadAdr* (VAR from, to: Item);
+	BEGIN
+		ASSERT(to.form IN {Int32, Pointer, ProcTyp});
+		IF (from.mode = Abs) & (from.scale = 0) THEN
+			DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute)
+		ELSIF from.mode = Stk THEN
+			DevCPE.GenByte(89H); GenCExt(SP * 8, to)
+		ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN
+			DevCPE.GenByte(8DH); GenDExt(to, from)
+		ELSIF from.reg # to.reg THEN
+			DevCPE.GenByte(89H); GenCExt(from.reg * 8, to)
+		ELSE RETURN
+		END;
+		IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END
+	END GenLoadAdr;
+
+	PROCEDURE GenPush* (VAR src: Item);
+		VAR s: INTEGER;
+	BEGIN
+		IF src.mode = Con THEN
+			ASSERT(src.form >= Int32);
+			CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE)
+		ELSIF src.mode = Reg THEN
+			ASSERT((src.form >= Int16) OR (src.reg < 4));
+			DevCPE.GenByte(50H + src.reg)
+		ELSE
+			ASSERT(src.form >= Int32);
+			DevCPE.GenByte(0FFH); GenCExt(30H, src)
+		END
+	END GenPush;
+	
+	PROCEDURE GenPop* (VAR dst: Item);
+	BEGIN
+		IF dst.mode = Reg THEN
+			ASSERT((dst.form >= Int16) OR (dst.reg < 4));
+			DevCPE.GenByte(58H + dst.reg);
+			IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END
+		ELSE
+			DevCPE.GenByte(08FH); GenCExt(0, dst) 
+		END
+	END GenPop;
+	
+	PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item);
+		VAR w, s: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		CheckSize(src.form, w);
+		CheckConst(src, s);
+		IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN
+			DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE)
+		ELSE
+			DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE)
+		END
+	END GenConOp;
+	
+	PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item);
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		CheckSize(src.form, w);
+		IF dst.mode = Reg THEN
+			DevCPE.GenByte(op + 2 + w); GenDExt(dst, src)
+		ELSE
+			DevCPE.GenByte(op + w); GenDExt(src, dst)
+		END
+	END GenDirOp;
+
+	PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN);
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		IF src.mode = Con THEN
+			IF src.obj = NIL THEN
+				IF src.offset = 1 THEN
+					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *)
+					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst)
+					END
+				ELSIF src.offset = -1 THEN
+					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *)
+					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst)
+					END
+				ELSIF src.offset # 0 THEN
+					GenConOp(0, src, dst)
+				ELSE RETURN
+				END
+			ELSE
+				GenConOp(0, src, dst)
+			END
+		ELSE
+			GenDirOp(0, src, dst)
+		END;
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenAdd;
+	
+	PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN);
+		VAR op: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		IF first THEN op := 0 ELSE op := 10H END;
+		IF src.mode = Con THEN GenConOp(op, src, dst)
+		ELSE GenDirOp(op, src, dst)
+		END;
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenAddC;
+	
+	PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN);
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		IF src.mode = Con THEN
+			IF src.obj = NIL THEN
+				IF src.offset = 1 THEN
+					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *)
+					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst)
+					END
+				ELSIF src.offset = -1 THEN
+					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *)
+					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst)
+					END
+				ELSIF src.offset # 0 THEN
+					GenConOp(28H, src, dst)
+				ELSE RETURN
+				END
+			ELSE
+				GenConOp(28H, src, dst)
+			END
+		ELSE
+			GenDirOp(28H, src, dst)
+		END;
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenSub;
+
+	PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN);
+		VAR op: INTEGER;
+	BEGIN
+		ASSERT(Size[src.form] = Size[dst.form]);
+		IF first THEN op := 28H ELSE op := 18H END;
+		IF src.mode = Con THEN GenConOp(op, src, dst)
+		ELSE GenDirOp(op, src, dst)
+		END;
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenSubC;
+
+	PROCEDURE GenComp* (VAR src, dst: Item);
+		VAR w: INTEGER;
+	BEGIN
+		IF src.mode = Con THEN
+			IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN 
+				CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *)
+			ELSE GenConOp(38H, src, dst)
+			END
+		ELSE
+			GenDirOp(38H, src, dst)
+		END
+	END GenComp;
+	
+	PROCEDURE GenAnd* (VAR src, dst: Item);
+	BEGIN
+		IF src.mode = Con THEN
+			IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END
+		ELSE GenDirOp(20H, src, dst)
+		END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenAnd;
+	
+	PROCEDURE GenOr* (VAR src, dst: Item);
+	BEGIN
+		IF src.mode = Con THEN
+			IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END
+		ELSE GenDirOp(8H, src, dst)
+		END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenOr;
+	
+	PROCEDURE GenXor* (VAR src, dst: Item);
+	BEGIN
+		IF src.mode = Con THEN
+			IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END
+		ELSE GenDirOp(30H, src, dst)
+		END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenXor;
+	
+	PROCEDURE GenTest* (VAR x, y: Item);
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(Size[x.form] = Size[y.form]);
+		CheckSize(x.form, w);
+		IF x.mode = Con THEN
+			IF (x.mode = Reg) & (x.reg = AX) THEN
+				DevCPE.GenByte(0A8H + w); GenConst(x, FALSE)
+			ELSE
+				DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE)
+			END
+		ELSE
+			DevCPE.GenByte(84H + w);
+			IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END
+		END
+	END GenTest;
+	
+	PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN);
+		VAR w: INTEGER;
+	BEGIN
+		CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst);
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenNeg;
+	
+	PROCEDURE GenNot* (VAR dst: Item);
+		VAR w: INTEGER;
+	BEGIN
+		CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst);
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenNot;
+	
+	PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN);
+		VAR w, s, val, f2, f5, f9: INTEGER;
+	BEGIN
+		ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form]));
+		IF (src.mode = Con) & (src.offset = 1) THEN RETURN END;
+		IF src.form <= Int8 THEN
+			ASSERT(dst.reg = 0);
+			DevCPE.GenByte(0F6H); GenCExt(28H, src)
+		ELSIF src.mode = Con THEN
+			val := src.offset;
+			IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN
+				f2 := 0; f5 := 0; f9 := 0;
+				WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END;
+				WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END;
+				WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END;
+				IF ABS(val) <= 3 THEN
+					WHILE f9 > 0 DO
+						DevCPE.GenByte(8DH);
+						DevCPE.GenByte(dst.reg * 8 + 4);
+						DevCPE.GenByte(0C0H + dst.reg * 9);
+						DEC(f9)
+					END;
+					WHILE f5 > 0 DO
+						DevCPE.GenByte(8DH);
+						DevCPE.GenByte(dst.reg * 8 + 4);
+						DevCPE.GenByte(80H + dst.reg * 9);
+						DEC(f5)
+					END;
+					IF ABS(val) = 3 THEN
+						DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9)
+					END;
+					IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2)
+					ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9)
+					END;
+					IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END;
+					IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END;
+					RETURN
+				END
+			END;
+			CheckSize(src.form, w); CheckConst(src, s);
+			DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE)
+		ELSE
+			CheckSize(src.form, w);
+			DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src)
+		END;
+		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
+		IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END
+	END GenMul;
+	
+	PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN);
+		VAR w, rem: INTEGER;
+	BEGIN
+		ASSERT(src.mode = Reg);
+		IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *)
+		ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *)
+		ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *)
+		END;
+		CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *)
+		IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END;
+		IF pos THEN (* src > 0 *)
+			CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
+			IF mod THEN
+				DevCPE.GenByte(79H); DevCPE.GenByte(2);	(* jns end *)
+				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
+			ELSE
+				DevCPE.GenByte(79H); DevCPE.GenByte(1);	(* jns end *)
+				DevCPE.GenByte(48H);					(* dec eax *)
+			END
+		ELSE
+			CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *)
+			IF mod THEN
+				DevCPE.GenByte(79H);	(* jns end *)
+				IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END;
+				DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
+				DevCPE.GenByte(74H); DevCPE.GenByte(4);	(* je end *)
+				DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *)
+				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
+			ELSE
+				DevCPE.GenByte(79H);	(* jns end *)
+				IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END;
+				DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
+				DevCPE.GenByte(74H); DevCPE.GenByte(1);	(* je end *)
+				DevCPE.GenByte(48H);					(* dec eax *)
+			END
+(*
+			CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *)
+			IF mod THEN
+				DevCPE.GenByte(72H); DevCPE.GenByte(4);	(* jb end *)
+				DevCPE.GenByte(7FH); DevCPE.GenByte(2);	(* jg end *)
+				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
+			ELSE
+				DevCPE.GenByte(72H); DevCPE.GenByte(3);	(* jb end *)
+				DevCPE.GenByte(7FH); DevCPE.GenByte(1);	(* jg end *)
+				DevCPE.GenByte(48H);					(* dec eax *)
+			END
+*)
+		END;
+		a1.mode := 0; a2.mode := 0
+	END GenDiv;
+
+	PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item);
+		VAR w: INTEGER;
+	BEGIN
+		CheckSize(dst.form, w);
+		IF cnt.mode = Con THEN
+			ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL);
+			IF cnt.offset = 1 THEN
+				IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *)
+					DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *)
+				ELSE
+					DevCPE.GenByte(0D0H + w); GenCExt(op, dst)
+				END
+			ELSIF cnt.offset > 1 THEN
+				DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset)
+			END
+		ELSE
+			ASSERT((cnt.mode = Reg) & (cnt.reg = CX));
+			DevCPE.GenByte(0D2H + w); GenCExt(op, dst)
+		END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenShiftOp;
+	
+	PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item);
+	BEGIN
+		DevCPE.GenByte(0FH);
+		IF num.mode = Con THEN
+			ASSERT(num.obj = NIL);
+			DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset)
+		ELSE
+			ASSERT((num.mode = Reg) & (num.form = Int32));
+			DevCPE.GenByte(83H + op); GenDExt(num, dst)
+		END;
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenBitOp;
+	
+	PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item);
+	BEGIN
+		ASSERT((dst.form = Bool) & (cc >= 0));
+		DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst);
+		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
+	END GenSetCC;
+	
+	PROCEDURE GenFLoad* (VAR src: Item);
+		VAR mf: INTEGER;
+	BEGIN
+		IF src.mode = Con THEN (* predefined constants *)
+			DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset)
+		ELSIF src.form = Int64 THEN
+			DevCPE.GenByte(0DFH); GenCExt(28H, src)
+		ELSE
+			CheckForm(src.form, mf);
+			DevCPE.GenByte(0D9H + mf); GenCExt(0, src)
+		END
+	END GenFLoad;
+	
+	PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN);
+		VAR mf: INTEGER;
+	BEGIN
+		IF dst.form = Int64 THEN ASSERT(pop);
+			DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH)	(* wait *)
+		ELSE
+			CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf);
+			IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH)	(* wait *)
+			ELSE GenCExt(10H, dst)
+			END
+		END;
+		a1.mode := 0; a2.mode := 0
+	END GenFStore;
+	
+	PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item);
+		VAR mf: INTEGER;
+	BEGIN
+		IF src.mode = Reg THEN
+			DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op)
+		ELSE
+			CheckForm(src.form, mf);
+			DevCPE.GenByte(0D8H + mf); GenCExt(op, src)
+		END
+	END GenFDOp;
+	
+	PROCEDURE GenFMOp* (op: INTEGER);
+	BEGIN
+		DevCPE.GenByte(0D8H + op DIV 256);
+		DevCPE.GenByte(op MOD 256);
+		IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END	(* FSTSW AX *)
+	END GenFMOp;
+	
+	PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN);
+	BEGIN
+		IF cc # ccNever THEN
+			IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN
+				IF cc = ccAlways THEN DevCPE.GenByte(0EBH)
+				ELSE DevCPE.GenByte(70H + cc)
+				END;
+				IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1)
+				ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0)
+				END
+			ELSE
+				IF cc = ccAlways THEN DevCPE.GenByte(0E9H)
+				ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H)
+				ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc)
+				END;
+				IF L > 0 THEN GenDbl(L - DevCPE.pc - 4)
+				ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H)
+				END
+			END
+		END
+	END GenJump;
+	
+	PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item);
+	BEGIN
+		IF cc = ccAlways THEN DevCPE.GenByte(0E9H)
+		ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc)
+		END;
+		dst.offset := 0; GenLinked(dst, relative)
+	END GenExtJump;
+	
+	PROCEDURE GenIndJump* (VAR dst: Item);
+	BEGIN
+		DevCPE.GenByte(0FFH); GenCExt(20H, dst)
+	END GenIndJump;
+	
+	PROCEDURE GenCaseJump* (VAR src: Item);
+		VAR link: DevCPT.LinkList; tab: INTEGER;
+	BEGIN
+		ASSERT((src.form = Int32) & (src.mode = Reg));
+		DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg);
+		tab := (DevCPE.pc + 7) DIV 4 * 4;
+		NEW(link); link.offset := tab; link.linkadr := DevCPE.pc;
+		link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link;
+		GenDbl(absolute * 1000000H + tab);
+		WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END;
+	END GenCaseJump;
+(*	
+	PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT);
+		VAR link: DevCPT.LinkList; else, last: LONGINT;
+	BEGIN
+		ASSERT((src.form = Int32) & (src.mode = Reg));
+		DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg);
+		tab := (DevCPE.pc + 7) DIV 4 * 4;
+		else := tab + num * 4; last := else - 4;
+		NEW(link); link.offset := tab; link.linkadr := DevCPE.pc;
+		link.next := CaseLinks; CaseLinks := link;
+		GenDbl(absolute * 1000000H + tab);
+		WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END;
+		WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END;
+		GenDbl(tableend * 1000000H + else)
+	END GenCaseJump;
+*)	
+	PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN);
+		VAR typ: INTEGER;
+	BEGIN
+		IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END;
+		IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END
+	END GenCaseEntry;
+	
+	PROCEDURE GenCall* (VAR dst: Item);
+	BEGIN
+		IF dst.mode IN {LProc, XProc, IProc} THEN
+			DevCPE.GenByte(0E8H);
+			IF dst.obj.mnolev >= 0 THEN (* local *)
+				IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4)
+				ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H)
+				END
+			ELSE (* imported *)
+				dst.offset := 0; GenLinked(dst, relative)
+			END
+		ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst)
+		END;
+		a1.mode := 0; a2.mode := 0
+	END GenCall;
+	
+	PROCEDURE GenAssert* (cc, no: INTEGER);
+	BEGIN
+		IF cc # ccAlways THEN
+			IF cc >= 0 THEN
+				DevCPE.GenByte(70H + cc); (* jcc end *)
+				IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END
+			END;
+			IF no < 0 THEN
+				DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no)
+			ELSE
+				DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no)
+			END
+		END
+	END GenAssert;
+	
+	PROCEDURE GenReturn* (val: INTEGER);
+	BEGIN
+		IF val = 0 THEN DevCPE.GenByte(0C3H)
+		ELSE DevCPE.GenByte(0C2H); GenWord(val)
+		END;
+		a1.mode := 0; a2.mode := 0
+	END GenReturn;
+	
+	PROCEDURE LoadStr (size: INTEGER);
+	BEGIN
+		IF size = 2 THEN DevCPE.GenByte(66H) END;
+		IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *)
+	END LoadStr;
+	
+	PROCEDURE StoreStr (size: INTEGER);
+	BEGIN
+		IF size = 2 THEN DevCPE.GenByte(66H) END;
+		IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *)
+	END StoreStr;
+	
+	PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN);
+	BEGIN
+		IF size = 2 THEN DevCPE.GenByte(66H) END;
+		IF rep THEN DevCPE.GenByte(0F2H) END;
+		IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *)
+	END ScanStr;
+	
+	PROCEDURE TestNull (size: INTEGER);
+	BEGIN
+		IF size = 2 THEN DevCPE.GenByte(66H) END;
+		IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *)
+		ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *)
+		END
+	END TestNull;
+	
+	PROCEDURE GenBlockMove* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
+		VAR w: INTEGER;
+	BEGIN
+		IF len = 0 THEN (* variable size move *)
+			IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
+			DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *)
+		ELSE (* fixed size move *)
+			len := len * wsize;
+			IF len >= 16 THEN
+				DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *)
+				DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*)
+				len := len MOD 4
+			END;
+			WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *);
+			IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *);
+			IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *)
+		END
+	END GenBlockMove;
+	
+	PROCEDURE GenBlockStore* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
+		VAR w: INTEGER;
+	BEGIN
+		IF len = 0 THEN (* variable size move *)
+			IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
+			DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *)
+		ELSE (* fixed size move *)
+			len := len * wsize;
+			IF len >= 16 THEN
+				DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *)
+				DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*)
+				len := len MOD 4
+			END;
+			WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *);
+			IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *);
+			IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *)
+		END
+	END GenBlockStore;
+	
+	PROCEDURE GenBlockComp* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
+		VAR w: INTEGER;
+	BEGIN
+		ASSERT(len >= 0);
+		IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
+		IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
+		DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *)
+	END GenBlockComp;
+	
+	PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER);
+	(*
+	len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X
+	*)
+		VAR loop, end: Label;
+	BEGIN
+		IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
+		(* len >= 0: len IN ECX *)
+		IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *)
+		loop := NewLbl; end := NewLbl;
+		SetLabel(loop); LoadStr(wsize);
+		IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *)
+		IF len < 0 THEN (* no limit *)
+			StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE);
+			IF excl THEN (* dec edi *)
+				DevCPE.GenByte(4FH);
+				IF dsize # 1 THEN DevCPE.GenByte(4FH) END
+			END;
+		ELSE	(* cx limit *)
+			IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize)
+			ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE)
+			END;
+			DevCPE.GenByte(49H); (* dec ecx *)
+			GenJump(ccNE, loop, TRUE);
+			GenAssert(ccNever, copyTrap); (* trap *)
+			SetLabel(end)
+		END;
+		a1.mode := 0; a2.mode := 0
+	END GenStringMove;
+	
+	PROCEDURE GenStringComp* (wsize, dsize: INTEGER);
+	(* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *)
+		VAR loop, end: Label;
+	BEGIN
+		IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END;
+		loop := NewLbl; end := NewLbl;
+		SetLabel(loop); LoadStr(wsize);
+		IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *)
+		ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE);
+		IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *)
+		TestNull(wsize); GenJump(ccNE, loop, TRUE);
+		SetLabel(end);
+		a1.mode := 0; a2.mode := 0
+	END GenStringComp;
+
+	PROCEDURE GenStringLength* (wsize, len: INTEGER);	(* len = 0: len in ECX, len = -1: len undefined *)
+	BEGIN
+		DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *)
+		IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
+		ScanStr(wsize, TRUE);
+		a1.mode := 0; a2.mode := 0
+	END GenStringLength;
+	
+	PROCEDURE GenStrStore* (size: INTEGER);
+		VAR w: INTEGER;
+	BEGIN
+		IF size # 0 THEN
+			IF size MOD 4 = 0 THEN w := 1; size := size DIV 4
+			ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2
+			ELSE w := 0
+			END;
+			DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *)
+			IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END
+		ELSE w := 0
+		END;
+		DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *)
+		a1.mode := 0; a2.mode := 0
+	END GenStrStore;
+
+	PROCEDURE GenCode* (op: INTEGER);
+	BEGIN
+		DevCPE.GenByte(op);
+		a1.mode := 0; a2.mode := 0
+	END GenCode;
+
+
+	PROCEDURE Init*(opt: SET);
+	BEGIN
+		DevCPE.Init(processor, opt);
+		level := 0;
+		NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc;
+	END Init;
+
+	PROCEDURE Close*;
+	BEGIN
+		a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL;
+		DevCPE.Close
+	END Close;
+
+BEGIN
+	Size[Undef] := 0;
+	Size[Byte] := 1;
+	Size[Bool] := 1;
+	Size[Char8] := 1;
+	Size[Int8] := 1;
+	Size[Int16] := 2;
+	Size[Int32] := 4;
+	Size[Real32] := -4;
+	Size[Real64] := -8;
+	Size[Set] := 4;
+	Size[String8] := 0;
+	Size[NilTyp] := 4;
+	Size[NoTyp] := 0;
+	Size[Pointer] := 4;
+	Size[ProcTyp] := 4;
+	Size[Comp] := 0;
+	Size[Char16] := 2;
+	Size[Int64] := 8;
+	Size[String16] := 0
+END LindevCPL486.

BlackBox/Lindev/Mod/CPM.txt

@@ -0,0 +1,763 @@
+MODULE LindevCPM;
+
+	(* THIS IS TEXT COPY PF CPM.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, Kernel, Files(*, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers*);
+
+	CONST
+		ProcSize* = 4;	(* PROCEDURE type *)
+		PointerSize* = 4;	(* POINTER type *)
+		DArrSizeA* = 8;	(* dyn array descriptor *)
+		DArrSizeB* = 4;	(* size = A + B * typ.n *)
+
+		MaxSet* = 31;
+		MaxIndex* = 7FFFFFFFH;	(* maximal index value for array declaration *)
+
+		MinReal32Pat = 0FF7FFFFFH;	(* most positive, 32-bit pattern *)
+		MinReal64PatL = 0FFFFFFFFH;	(* most  negative, lower 32-bit pattern *)
+		MinReal64PatH = 0FFEFFFFFH;	(* most  negative, higher 32-bit pattern *)
+		MaxReal32Pat = 07F7FFFFFH;	(* most positive, 32-bit pattern *)
+		MaxReal64PatL = 0FFFFFFFFH;	(* most positive, lower 32-bit pattern *)
+		MaxReal64PatH = 07FEFFFFFH;	(* most positive, higher 32-bit pattern *)
+		InfRealPat = 07F800000H;	(* real infinity pattern *)
+
+
+		(* inclusive range of parameter of standard procedure HALT *)
+		MinHaltNr* = 0;
+		MaxHaltNr* = 128;
+
+		(* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *)
+		MinRegNr* = 0;
+		MaxRegNr* = 31;
+
+		(* maximal value of flag used to mark interface structures *)
+		MaxSysFlag* = 127;	(* shortint *)
+		CProcFlag* = 1;	(* code procedures *)
+
+		(* maximal condition value of parameter of SYSTEM.CC *)
+		MaxCC* = 15;
+
+		(* initialization of constant address, must be different from any valid constant address *)
+		ConstNotAlloc* = -1;
+
+		(* whether hidden pointer fields have to be nevertheless exported *)
+		ExpHdPtrFld* = TRUE;
+		HdPtrName* = "@ptr";
+
+		(* whether hidden untagged pointer fields have to be nevertheless exported *)
+		ExpHdUtPtrFld* = TRUE;
+		HdUtPtrName* = "@utptr";
+
+		(* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *)
+		ExpHdProcFld* = TRUE;
+		HdProcName* = "@proc";
+
+		(* whether hidden bound procedures have to be nevertheless exported *)
+		ExpHdTProc* = FALSE;
+		HdTProcName* = "@tproc";
+
+		(* maximal number of exported stuctures: *)
+		MaxStruct* = 16000;	(* must be < MAX(INTEGER) DIV 2 in object model *)
+		
+		(* maximal number of record extensions: *)
+		MaxExts* = 15;	(* defined by type descriptor layout *)
+		
+		(* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *)
+		NEWusingAdr* = FALSE;
+
+		(* special character (< " ") returned by procedure Get, if end of text reached *)
+		Eot* = 0X;
+		
+		(* warnings *)
+		longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7;
+		
+		(* language options *)
+		interface* = 1;
+		com* = 2; comAware* = 3;
+		som* = 4; somAware* = 5;
+		oberon* = 6;
+		java* = 7; javaAware* = 8;
+		noCode* = 9;
+		allSysVal* = 14;
+		sysImp* = 15;
+		trap* = 31;
+		sys386 = 10; sys68k = 20;	(* processor type in options if system imported *)
+		
+	CONST
+		SFdir = "Sym";
+		OFdir = "Code";
+		SYSdir = "System";
+		SFtag = 6F4F5346H;	(* symbol file tag *)
+		OFtag = 6F4F4346H;	(* object file tag *)
+		maxErrors = 64;
+		
+TYPE
+	File = POINTER TO RECORD next: File; f: Files.File END;
+
+	VAR
+		LEHost*: BOOLEAN;	(* little or big endian host *)
+		MinReal32*, MaxReal32*, InfReal*,
+		MinReal64*, MaxReal64*: REAL;
+		noerr*: BOOLEAN;	(* no error found until now *)
+		curpos*, startpos*, errpos*: INTEGER;	(* character, start, and error position in source file *)
+		searchpos*: INTEGER;	(* search position in source file *)
+		errors*: INTEGER;
+		breakpc*: INTEGER;	(* set by OPV.Init *)
+		options*: SET;	(* language options *)
+		file*: Files.File;	(* used for sym file import *)
+		codeDir*: ARRAY 16 OF CHAR;
+		symDir*: ARRAY 16 OF CHAR;
+		
+		errorMes*: ARRAY 4096 OF CHAR;
+		
+		lastpos: INTEGER;
+		realpat: INTEGER;
+		lrealpat: RECORD H, L: INTEGER END;
+		fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR;
+		ObjFName: Files.Name;
+
+		in: Files.Reader;
+		oldSymFile, symFile, objFile: Files.File;
+		inSym: Files.Reader;
+		outSym, outObj: Files.Writer;
+		
+		errNo-, errPos-: ARRAY maxErrors OF INTEGER;
+		
+		lineReader: Files.Reader;
+		lineNum: INTEGER;
+		
+		crc32tab: ARRAY 256 OF INTEGER;
+
+
+	PROCEDURE^ err* (n: INTEGER);
+
+	PROCEDURE Init* (source: Files.Reader);
+	BEGIN
+		in := source;
+		noerr := TRUE; options := {};
+		curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0;
+		codeDir := OFdir; symDir := SFdir;
+		errorMes := ""
+	END Init;
+	
+	PROCEDURE Close*;
+	BEGIN
+		oldSymFile := NIL; inSym := NIL;
+		symFile := NIL; outSym := NIL;
+		objFile := NIL; outObj := NIL;
+		in := NIL; lineReader := NIL
+	END Close;
+
+	PROCEDURE Get* (VAR ch: SHORTCHAR);
+		VAR
+			ch1: BYTE;
+	BEGIN
+		REPEAT
+			in.ReadByte(ch1);
+			ch := SYSTEM.VAL(SHORTCHAR, ch1);
+			INC(curpos)
+		UNTIL (ch < 100X)
+	END Get;
+	
+	PROCEDURE GetL* (VAR ch: CHAR);
+		VAR
+			sCh: SHORTCHAR;
+	BEGIN
+		Get(sCh);
+		ch := sCh
+	END GetL;
+
+	PROCEDURE LoWord (r: REAL): INTEGER;
+		VAR x: INTEGER;
+	BEGIN
+		x := SYSTEM.ADR(r);
+		IF ~LEHost THEN INC(x, 4) END;
+		SYSTEM.GET(x, x);
+		RETURN x
+	END LoWord;
+
+	PROCEDURE HiWord (r: REAL): INTEGER;
+		VAR x: INTEGER;
+	BEGIN
+		x := SYSTEM.ADR(r);
+		IF LEHost THEN INC(x, 4) END;
+		SYSTEM.GET(x, x);
+		RETURN x
+	END HiWord;
+	
+	PROCEDURE Compound (lo, hi: INTEGER): REAL;
+		VAR r: REAL;
+	BEGIN
+		IF LEHost THEN
+			SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi)
+		ELSE
+			SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi)
+		END;
+		RETURN r
+	END Compound;
+
+
+	(* sysflag control *)
+	
+	PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN;
+		VAR i: SHORTINT; ch: SHORTCHAR;
+	BEGIN
+		IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END;
+		i := 1;
+		WHILE i < 37 DO
+			ch := str[i];
+			IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN
+				IF ch # "-" THEN RETURN FALSE END
+			ELSE
+				IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END
+			END;
+			INC(i)
+		END;
+		RETURN TRUE
+	END ValidGuid;
+	
+	PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+	BEGIN
+		IF id # "" THEN
+			IF id = "code" THEN num := 1
+			ELSIF id = "callback" THEN num := 2
+			ELSIF id = "nostkchk" THEN num := 4
+			ELSIF id = "ccall" THEN num := -10
+			ELSIF id = "guarded" THEN num := 8
+			ELSIF id = "noframe" THEN num := 16
+			ELSIF id = "native" THEN num := -33
+			ELSIF id = "bytecode" THEN num := -35
+			END
+		END;
+		IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num)
+		ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num)
+		ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10
+		ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8
+		ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16
+		ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num
+		ELSE err(225); flag := 0
+		END
+	END GetProcSysFlag;
+	
+	PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+		VAR old: SHORTINT;
+	BEGIN
+		old := flag; flag := 0;
+		IF (options * {sys386, sys68k, interface, com} # {}) THEN
+			IF (num = 1) OR (id = "nil") THEN
+				IF ~ODD(old) THEN flag := SHORT(old + 1) END
+			ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN
+				IF old <= 1 THEN flag := SHORT(old + 2) END
+			ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN
+				IF old <= 1 THEN flag := SHORT(old + 4) END
+			ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN
+				IF old <= 1 THEN flag := SHORT(old + 8) END
+			ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN
+				IF old <= 1 THEN flag := SHORT(old + 16) END
+			END
+		END;
+		IF flag = 0 THEN err(225) END
+	END GetVarParSysFlag;
+	
+	PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+		VAR old: SHORTINT;
+	BEGIN
+		old := flag; flag := 0;
+		IF (num = 1) OR (id = "untagged") THEN
+			IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
+		ELSIF (num = 3) OR (id = "noalign") THEN
+			IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END
+		ELSIF (num = 4) OR (id = "align2") THEN
+			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END
+		ELSIF (num = 5) OR (id = "align4") THEN
+			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END
+		ELSIF (num = 6) OR (id = "align8") THEN
+			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END
+		ELSIF (num = 7) OR (id = "union") THEN
+			IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END
+		ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN
+			IF (com IN options) & (old = 0) THEN flag := 10 END
+		ELSIF (num = -11) OR (id = "jint") THEN
+			IF (java IN options) & (old = 0) THEN flag := -11 END
+		ELSIF (num = -13) OR (id = "jstr") THEN
+			IF (java IN options) & (old = 0) THEN flag := -13 END
+		ELSIF (num = 20) OR (id = "som") THEN
+			IF (som IN options) & (old = 0) THEN flag := 20 END
+		END;
+		IF flag = 0 THEN err(225) END
+	END GetRecordSysFlag;
+	
+	PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+		VAR old: SHORTINT;
+	BEGIN
+		old := flag; flag := 0;
+		IF (num = 1) OR (id = "untagged") THEN
+			IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
+		ELSIF (num = -12) OR (id = "jarr") THEN
+			IF (java IN options) & (old = 0) THEN flag := -12 END
+		ELSIF (num = -13) OR (id = "jstr") THEN
+			IF (java IN options) & (old = 0) THEN flag := -13 END
+		END;
+		IF flag = 0 THEN err(225) END
+	END GetArraySysFlag;
+	
+	PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+		VAR old: SHORTINT;
+	BEGIN
+		old := flag; flag := 0;
+		IF (num = 1) OR (id = "untagged") THEN
+			IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
+		ELSIF (num = 2) OR (id = "handle") THEN
+			IF (sys68k IN options) & (old = 0) THEN flag := 2 END
+		ELSIF (num = 10) OR (id = "interface") THEN
+			IF (com IN options) & (old = 0) THEN flag := 10 END
+		ELSIF (num = 20) OR (id = "som") THEN
+			IF (som IN options) & (old = 0) THEN flag := 20 END
+		END;
+		IF flag = 0 THEN err(225) END
+	END GetPointerSysFlag;
+	
+	PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
+	BEGIN
+		IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10
+		ELSE err(225); flag := 0
+		END
+	END GetProcTypSysFlag;
+	
+	PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
+	BEGIN
+		IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN	(* propagate untagged .. union *)
+			IF flag = 0 THEN flag := baseFlag
+			ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *)	(* special case for 8 byte aligned records *)
+			ELSIF flag # baseFlag THEN err(225); flag := 0
+			END
+		ELSIF (baseFlag # 10) & (flag = 10) THEN err(225)
+		END
+	END PropagateRecordSysFlag;
+	
+	PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
+	BEGIN
+		IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN	(* pointer to untagged .. union is untagged *)
+			IF flag = 0 THEN flag := 1
+			ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
+			END
+		ELSIF baseFlag = 10 THEN	(* pointer to interface is interface *)
+			IF flag = 0 THEN flag := 10
+			ELSIF flag # 10 THEN err(225); flag := 0
+			END
+		ELSIF baseFlag = -11 THEN	(* pointer to java interface is java interface *)
+			IF flag # 0 THEN err(225) END;
+			flag := -11
+		ELSIF baseFlag = -13 THEN	(* pointer to java string is java string *)
+			IF flag # 0 THEN err(225) END;
+			flag := -13
+		END
+	END PropagateRecPtrSysFlag;
+	
+	PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
+	BEGIN
+		IF baseFlag = 1 THEN	(* pointer to untagged or guid is untagged *)
+			IF flag = 0 THEN flag := 1
+			ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
+			END
+		ELSIF baseFlag = -12 THEN	(* pointer to java array is java array *)
+			IF flag # 0 THEN err(225) END;
+			flag := -12
+		ELSIF baseFlag = -13 THEN	(* pointer to java string is java string *)
+			IF flag # 0 THEN err(225) END;
+			flag := -13
+		END
+	END PropagateArrPtrSysFlag;
+	
+	
+	(* utf8 strings *)
+	
+	PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER);
+	BEGIN
+		ASSERT((val >= 0) & (val < 65536));
+		IF val < 128 THEN
+			str[idx] := SHORT(CHR(val)); INC(idx)
+		ELSIF val < 2048 THEN
+			str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx);
+			str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
+		ELSE
+			str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); 
+			str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx);
+			str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
+		END
+	END PutUtf8;
+	
+	PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER);
+		VAR ch: SHORTCHAR;
+	BEGIN
+		ch := str[idx]; INC(idx);
+		IF ch < 80X THEN
+			val := ORD(ch)
+		ELSIF ch < 0E0X THEN
+			val := ORD(ch) - 192;
+			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
+		ELSE
+			val := ORD(ch) - 224;
+			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128;
+			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
+		END
+	END GetUtf8;
+	
+	PROCEDURE Mark* (n, pos: INTEGER);
+	BEGIN
+		IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN
+			noerr := FALSE;
+			IF pos < 0 THEN pos := 0 END;
+			IF (pos < lastpos) OR (lastpos + 9 < pos) THEN
+				lastpos := pos;
+				IF errors < maxErrors THEN
+					errNo[errors] := n; errPos[errors] := pos
+				END;
+				INC(errors)
+			END;
+			IF trap IN options THEN HALT(100) END;
+		ELSIF (n <= -700) & (errors < maxErrors) THEN
+			errNo[errors] := -n; errPos[errors] := pos; INC(errors)
+		END
+	END Mark;
+	
+	PROCEDURE err* (n: INTEGER);
+	BEGIN
+		Mark(n, errpos)
+	END err;
+
+	(* fingerprinting *)
+
+	PROCEDURE InitCrcTab;
+		(* CRC32, high bit first, pre & post inverted *)
+		CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26};	(* CRC32 polynom *)
+		VAR x, c, i: INTEGER;
+	BEGIN
+		x := 0;
+		WHILE x < 256 DO
+			c := x * 1000000H; i := 0;
+			WHILE i < 8 DO
+				IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
+				ELSE c := c * 2
+				END;
+				INC(i)
+			END;
+			crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
+			INC(x)
+		END
+	END InitCrcTab;
+	
+	PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
+		VAR c, i: INTEGER;
+	BEGIN
+(*
+		fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1)	(* bad collision detection *)
+*)
+		(* CRC32, high bit first, pre & post inverted *)
+		c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
+		c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
+		c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
+		fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
+	END FPrint;
+
+	PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
+	BEGIN FPrint(fp, ORD(set))
+	END FPrintSet;
+
+	PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
+	BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
+	END FPrintReal;
+
+	PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
+		VAR l, h: INTEGER;
+	BEGIN
+		FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
+	END FPrintLReal;
+
+
+
+	(* compact format *)
+	
+	PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
+	BEGIN
+		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
+		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
+		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
+		w.WriteByte(SHORT(SHORT(i MOD 256)))
+	END WriteLInt;
+
+	PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
+		VAR b: BYTE; x: INTEGER;
+	BEGIN
+		r.ReadByte(b); x := b MOD 256;
+		r.ReadByte(b); x := x + 100H * (b MOD 256);
+		r.ReadByte(b); x := x + 10000H * (b MOD 256);
+		r.ReadByte(b); i := x + 1000000H * b
+	END ReadLInt;
+
+	PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
+	BEGIN	(* old format of Oberon *)
+		WHILE (i < -64) OR (i > 63) DO w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END;
+		w.WriteByte(SHORT(SHORT(i MOD 128)))
+	END WriteNum;
+
+	PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
+		VAR b: BYTE; s, y: INTEGER;
+	BEGIN
+		s := 0; y := 0; r.ReadByte(b);
+		WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b) END;
+		i := ASH((b + 64) MOD 128 - 64, s) + y
+	END ReadNum;
+	
+	PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
+	BEGIN
+		WriteNum(w, ORD(x))
+	END WriteNumSet;
+
+	PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
+		VAR i: INTEGER;
+	BEGIN
+		ReadNum(r, i); x := BITS(i)
+	END ReadNumSet;
+
+	PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
+	BEGIN
+		WriteLInt(w, SYSTEM.VAL(INTEGER, x))
+	END WriteReal;
+
+	PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
+		VAR i: INTEGER;
+	BEGIN
+		ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
+	END ReadReal;
+
+	PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
+	BEGIN
+		WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
+	END WriteLReal;
+
+	PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
+		VAR h, l: INTEGER;
+	BEGIN
+		ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
+	END ReadLReal;
+
+
+	(* read symbol file *)
+
+	PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
+		VAR b: BYTE;
+	BEGIN
+		inSym.ReadByte(b); ch := SHORT(CHR(b))
+	END SymRCh;
+	
+	PROCEDURE SymRInt* (): INTEGER;
+		VAR k: INTEGER;
+	BEGIN
+		ReadNum(inSym, k); RETURN k
+	END SymRInt;
+		
+	PROCEDURE SymRSet* (VAR s: SET);
+	BEGIN
+		ReadNumSet(inSym, s)
+	END SymRSet;
+
+	PROCEDURE SymRReal* (VAR r: SHORTREAL);
+	BEGIN
+		ReadReal(inSym, r)
+	END SymRReal;
+	
+	PROCEDURE SymRLReal* (VAR lr: REAL);
+	BEGIN
+		ReadLReal(inSym, lr)
+	END SymRLReal;
+	
+	PROCEDURE eofSF* (): BOOLEAN;
+	BEGIN
+		RETURN inSym.eof
+	END eofSF;
+	
+	PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
+		VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name;
+	BEGIN
+		done := FALSE;
+		IF modName = "@file" THEN
+			oldSymFile := file
+		ELSE
+			name := modName$; Kernel.SplitName(name, dir, name);
+			Kernel.MakeFileName(name, Kernel.symType); 
+			loc := Files.dir.This(dir); loc := loc.This(symDir);
+			oldSymFile := Files.dir.Old(loc, name, Files.shared);
+			IF (oldSymFile = NIL) & (dir = "") THEN
+				loc := Files.dir.This(SYSdir); loc := loc.This(symDir);
+				oldSymFile := Files.dir.Old(loc, name, Files.shared)
+			END
+		END;
+		IF oldSymFile # NIL THEN
+			inSym := oldSymFile.NewReader(inSym);
+			IF inSym # NIL THEN
+				ReadLInt(inSym, tag);
+				IF tag = SFtag THEN done := TRUE ELSE err(151) END
+			END
+		END
+	END OldSym;
+
+	PROCEDURE CloseOldSym*;
+	BEGIN
+		IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
+	END CloseOldSym;
+
+
+	(* write symbol file *)
+
+	PROCEDURE SymWCh* (ch: SHORTCHAR);
+	BEGIN
+		outSym.WriteByte(SHORT(ORD(ch)))
+	END SymWCh;
+
+	PROCEDURE SymWInt* (i: INTEGER);
+	BEGIN
+		WriteNum(outSym, i)
+	END SymWInt;
+
+	PROCEDURE SymWSet* (s: SET);
+	BEGIN
+		WriteNumSet(outSym, s)
+	END SymWSet;
+
+	PROCEDURE SymWReal* (VAR r: SHORTREAL);
+	BEGIN
+		WriteReal(outSym, r)
+	END SymWReal;
+
+	PROCEDURE SymWLReal* (VAR r: REAL);
+	BEGIN
+		WriteLReal(outSym, r)
+	END SymWLReal;
+
+	PROCEDURE SymReset*;
+	BEGIN
+		outSym.SetPos(4)
+	END SymReset;
+
+	PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR);
+		VAR loc: Files.Locator; dir: Files.Name;
+	BEGIN
+		ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
+		loc := Files.dir.This(dir); loc := loc.This(symDir);
+		symFile := Files.dir.New(loc, Files.dontAsk);
+		IF symFile # NIL THEN
+			outSym := symFile.NewWriter(NIL);
+			WriteLInt(outSym, SFtag)
+		ELSE
+			err(153)
+		END
+	END NewSym;
+	
+	PROCEDURE RegisterNewSym*;
+		VAR res: INTEGER; name: Files.Name;
+	BEGIN
+		IF symFile # NIL THEN
+			name := ObjFName$;
+			Kernel.MakeFileName(name, Kernel.symType);
+			symFile.Register(name, Kernel.symType, Files.dontAsk, res);
+			symFile := NIL
+		END
+	END RegisterNewSym;
+	
+	PROCEDURE DeleteNewSym*;
+	BEGIN
+		IF symFile # NIL THEN symFile.Close; symFile := NIL END
+	END DeleteNewSym;
+
+
+	(* write object file *)
+
+	PROCEDURE ObjW* (ch: SHORTCHAR);
+	BEGIN
+		outObj.WriteByte(SHORT(ORD(ch)))
+	END ObjW;
+
+	PROCEDURE ObjWNum* (i: INTEGER);
+	BEGIN
+		WriteNum(outObj, i)
+	END ObjWNum;
+
+	PROCEDURE ObjWInt (i: SHORTINT);
+	BEGIN
+		outObj.WriteByte(SHORT(SHORT(i MOD 256)));
+		outObj.WriteByte(SHORT(SHORT(i DIV 256)))
+	END ObjWInt;
+
+	PROCEDURE ObjWLInt* (i: INTEGER);
+	BEGIN
+		ObjWInt(SHORT(i MOD 65536));
+		ObjWInt(SHORT(i DIV 65536))
+	END ObjWLInt;
+
+	PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER);
+		TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
+		VAR p: P;
+	BEGIN
+		p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
+		outObj.WriteBytes(p^, 0, n)
+	END ObjWBytes;
+	
+	PROCEDURE ObjLen* (): INTEGER;
+	BEGIN
+		RETURN outObj.Pos()
+	END ObjLen;
+	
+	PROCEDURE ObjSet* (pos: INTEGER);
+	BEGIN
+		outObj.SetPos(pos)
+	END ObjSet;
+
+	PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR);
+		VAR loc: Files.Locator; dir: Files.Name;
+	BEGIN
+		errpos := 0;
+		ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
+		loc := Files.dir.This(dir); loc := loc.This(codeDir);
+		objFile := Files.dir.New(loc, Files.dontAsk);
+		IF objFile # NIL THEN
+			outObj := objFile.NewWriter(NIL);
+			WriteLInt(outObj, OFtag)
+		ELSE
+			err(153)
+		END
+	END NewObj;
+
+	PROCEDURE RegisterObj*;
+		VAR res: INTEGER; name: Files.Name;
+	BEGIN
+		IF objFile # NIL THEN
+			name := ObjFName$;
+			Kernel.MakeFileName(name, Kernel.objType);
+			objFile.Register(name, Kernel.objType, Files.dontAsk, res);
+			objFile := NIL; outObj := NIL
+		END
+	END RegisterObj;
+
+	PROCEDURE DeleteObj*;
+	BEGIN
+		IF objFile # NIL THEN objFile.Close; objFile := NIL END
+	END DeleteObj;
+
+
+	PROCEDURE InitHost;
+		VAR test: SHORTINT; lo: SHORTCHAR;
+	BEGIN
+		test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
+		InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
+		MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
+		MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
+		MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
+		MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
+	END InitHost;
+
+BEGIN
+	InitCrcTab;
+	InitHost
+END LindevCPM.

BlackBox/Lindev/Mod/CPP.txt

@@ -0,0 +1,1649 @@
+MODULE LindevCPP;
+
+	(* THIS IS TEXT COPY OF CPP.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT
+		DevCPM := LindevCPM, DevCPT := LindevCPT, DevCPB := LindevCPB, DevCPS := LindevCPS;
+		
+	CONST
+		anchorVarPar = TRUE;
+	
+		(* numtyp values *)
+		char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
+
+		(*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; dollar = 18; period = 19;
+		comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
+		rbrace = 25; of = 26; then = 27; do = 28; to = 29;
+		by = 30; not = 33;
+		lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
+		number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
+		bar = 50; end = 51; else = 52; elsif = 53; until = 54;
+		if = 55; case = 56; while = 57; repeat = 58; for = 59;
+		loop = 60; with = 61; exit = 62; return = 63; array = 64;
+		record = 65; pointer = 66; begin = 67; const = 68; type = 69;
+		var = 70; out = 71; procedure = 72; close = 73; import = 74;
+		module = 75; eof = 76;
+
+		(* 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; Attr = 20;
+
+		(* Structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18;
+		intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16};
+		
+		(* 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; Ncomp = 30;
+
+		(* node subclasses *)
+		super = 1;
+		
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* procedure flags (conval.setval) *)
+		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
+		
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		(* case statement flags (conval.setval) *)
+		useTable = 1; useTree = 2;
+		
+		(* sysflags *)
+		nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13;
+		
+		
+	TYPE
+		Elem = POINTER TO RECORD
+			next: Elem;
+			struct: DevCPT.Struct;
+			obj, base: DevCPT.Object;
+			pos: INTEGER;
+			name: DevCPT.String
+		END;
+		
+		
+	VAR
+		sym, level: BYTE;
+		LoopLevel: SHORTINT;
+		TDinit, lastTDinit: DevCPT.Node;
+		userList: Elem;
+		recList: Elem;
+		hasReturn: BOOLEAN;
+		numUsafeVarPar, numFuncVarPar: INTEGER;
+		
+
+	PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String);
+	PROCEDURE^ Expression(VAR x: DevCPT.Node);
+	PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node);
+	
+	(* forward type handling *)
+	
+	PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN;
+	BEGIN
+		IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+		RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp)
+	END IncompleteType;
+	
+	PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String);
+		VAR u: Elem;
+	BEGIN
+		IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END;
+		IF name # NIL THEN
+			NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name;
+			u.next := userList; userList := u
+		END
+	END SetType;
+
+	PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER);
+	BEGIN
+		typ.pvused := TRUE;
+		IF typ.comp = DynArr THEN
+			IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END
+		ELSIF typ.comp = Record THEN
+			IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN
+				DevCPM.Mark(193, pos); typ := DevCPT.undftyp
+			END
+		END
+	END CheckAlloc;
+
+	PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER);
+		VAR fld: DevCPT.Object;
+	BEGIN
+		IF outer = inner THEN DevCPM.Mark(58, pos)
+		ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos)
+		ELSIF inner.comp = Record THEN
+			fld := inner.link;
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				CheckRecursiveType(outer, fld.typ, pos);
+				fld := fld.link
+			END;
+			IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END
+		END
+	END CheckRecursiveType;
+	
+	PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
+	(* fix forward reference *)
+		VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT;
+	BEGIN
+		IF obj # NIL THEN
+			IF obj.mode = Var THEN	(* variable type *)
+				IF struct # NIL THEN	(* receiver type *)
+					IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END;
+				ELSE CheckAlloc(typ, obj.mnolev > level, pos)	(* TRUE for parameters *)
+				END
+			ELSIF obj.mode = VarPar THEN	(* varpar type *)
+				IF struct # NIL THEN	(* varpar receiver type *)
+					IF typ # struct THEN DevCPM.Mark(180, pos) END
+				END
+			ELSIF obj.mode = Fld THEN	(* field type *)
+				CheckAlloc(typ, FALSE, pos);
+				CheckRecursiveType(struct, typ, pos)
+			ELSIF obj.mode = TProc THEN	(* proc return type *)
+				IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END
+			ELSIF obj.mode = Typ THEN	(* alias type *)
+				IF typ.form IN {Byte..Set, Char16, Int64} THEN	(* make alias structure *)
+					t := DevCPT.NewStr(typ.form, Basic); i := t.ref;
+					t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0;
+					t.BaseTyp := typ; typ := t
+				END;
+				IF obj.vis # internal THEN
+					IF typ.comp = Record THEN typ.exp := TRUE
+					ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE
+					END
+				END
+			ELSE HALT(100)
+			END;
+			obj.typ := typ
+		ELSE
+			IF struct.form = Pointer THEN	(* pointer base type *)
+				IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag)
+				ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag)
+				ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos)
+				END;
+				struct.untagged := struct.sysflag > 0;
+				IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END;
+			ELSIF struct.comp = Array THEN	(* array base type *)
+				CheckAlloc(typ, FALSE, pos);
+				CheckRecursiveType(struct, typ, pos)
+			ELSIF struct.comp = DynArr THEN	(* array base type *)
+				CheckAlloc(typ, TRUE, pos);
+				CheckRecursiveType(struct, typ, pos)
+			ELSIF struct.comp = Record THEN	(* record base type *)
+				IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+				typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1));
+				DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag);
+				IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos)
+				ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos)
+				ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos)
+				END;
+				f := struct.link;
+				WHILE f # NIL DO	(* check for field name conflicts *)
+					DevCPT.FindField(f.name, typ, bf);
+					IF bf # NIL THEN DevCPM.Mark(1, pos) END;
+					f := f.link
+				END;
+				CheckRecursiveType(struct, typ, pos);
+				struct.untagged := struct.sysflag > 0;
+			ELSIF struct.form = ProcTyp THEN	(* proc type return type *)
+				IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END;
+			ELSE HALT(100)
+			END;
+			struct.BaseTyp := typ
+		END
+	END FixType;
+
+	PROCEDURE CheckForwardTypes;
+		VAR u, next: Elem; progress: BOOLEAN;
+	BEGIN
+		u := userList; userList := NIL;
+		WHILE u # NIL DO
+			next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base);
+			IF u.base = NIL THEN DevCPM.Mark(0, u.pos)
+			ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos)
+			ELSE u.next := userList; userList := u	(* reinsert *)
+			END;
+			u := next
+		END;
+		REPEAT	(* iteration for multy level alias *)
+			u := userList; userList := NIL; progress := FALSE;
+			WHILE u # NIL DO
+				next := u.next;
+				IF IncompleteType(u.base.typ) THEN
+					u.next := userList; userList := u	(* reinsert *)
+				ELSE
+					progress := TRUE;
+					FixType(u.struct, u.obj, u.base.typ, u.pos)
+				END;
+				u := next
+			END
+		UNTIL (userList = NIL) OR ~progress;
+		u := userList;	(* remaining type relations are cyclic *)
+		WHILE u # NIL DO
+			IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END;
+			u := u.next
+		END;
+	END CheckForwardTypes;
+	
+	PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
+		VAR obj: DevCPT.Object;
+	BEGIN
+		IF m # NIL THEN
+			IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN
+				DevCPT.FindField(m.name^, typ, obj);
+				IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN
+					DevCPM.Mark(192, pos);
+					DevCPM.errorMes := DevCPM.errorMes + "  " + m.name^ + " not implemented";
+					IF typ.strobj # NIL THEN
+						DevCPM.errorMes :=  DevCPM.errorMes+ " in " + typ.strobj.name^
+					END
+				END
+			END;
+			CheckUnimpl(m.left, typ, pos);
+			CheckUnimpl(m.right, typ, pos)
+		END
+	END CheckUnimpl;
+	
+	PROCEDURE CheckRecords (rec: Elem);
+		VAR b: DevCPT.Struct;
+	BEGIN
+		WHILE rec # NIL DO	(* check for unimplemented methods in base type *)
+			b := rec.struct.BaseTyp;
+			WHILE (b # NIL) & (b # DevCPT.undftyp) DO
+				CheckUnimpl(b.link, rec.struct, rec.pos);
+				b := b.BaseTyp
+			END;
+			rec := rec.next
+		END
+	END CheckRecords;
+
+
+	PROCEDURE err(n: SHORTINT);
+	BEGIN DevCPM.err(n)
+	END err;
+
+	PROCEDURE CheckSym(s: SHORTINT);
+	BEGIN
+		IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END
+	END CheckSym;
+
+	PROCEDURE qualident(VAR id: DevCPT.Object);
+		VAR obj: DevCPT.Object; lev: BYTE;
+	BEGIN (*sym = ident*)
+		DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym);
+		IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
+			DevCPS.Get(sym);
+			IF sym = ident THEN
+				DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym)
+			ELSE err(ident); obj := NIL
+			END
+		END ;
+		IF obj = NIL THEN err(0);
+			obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0
+		ELSE lev := obj.mnolev;
+			IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN
+				obj.leaf := FALSE;
+				IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END	(* !!! *)
+			END
+		END ;
+		id := obj
+	END qualident;
+
+	PROCEDURE ConstExpression(VAR x: DevCPT.Node);
+	BEGIN Expression(x);
+		IF x.class # Nconst THEN
+			err(50); x := DevCPB.NewIntConst(1) 
+		END
+	END ConstExpression;
+
+	PROCEDURE CheckMark(obj: DevCPT.Object);	(* !!! *)
+		VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String;
+	BEGIN DevCPS.Get(sym);
+		IF (sym = times) OR (sym = minus) THEN
+			IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ;
+			IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ;
+			DevCPS.Get(sym)
+		ELSE obj.vis := internal
+		END;
+		IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN
+			DevCPS.Get(sym);
+			IF (sym = number) & (DevCPS.numtyp = char) THEN
+				NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
+			END;
+			IF sym = string THEN
+				IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
+				DevCPS.Get(sym); n := 0;
+				IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN
+					DevCPS.Get(sym);
+					IF (sym = number) & (DevCPS.numtyp = char) THEN
+						NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
+					END;
+					IF sym = string THEN
+						obj.library := obj.entry; obj.entry := NIL;
+						IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
+						DevCPS.Get(sym);
+					ELSE err(string)
+					END
+				END;
+				WHILE sym = comma DO
+					DevCPS.Get(sym);
+					IF (sym = number) & (DevCPS.numtyp = char) THEN
+						NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
+					END;
+					IF sym = string THEN
+						IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n)
+						ELSE err(235)
+						END;
+						DevCPS.Get(sym)
+					ELSE err(string)
+					END
+				END;
+				IF n > 0 THEN
+					NEW(obj.modifiers, n);
+					WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END
+				END
+			ELSE err(string)
+			END;
+			CheckSym(rbrak);
+			IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END
+		END
+	END CheckMark;
+
+	PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT;
+										GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT));
+		VAR x: DevCPT.Object; i: SHORTINT;
+	BEGIN
+		sysflag := 0;
+		IF sym = lbrak THEN
+			DevCPS.Get(sym);
+			WHILE (sym = number) OR (sym = ident) OR (sym = string) DO
+				IF sym = number THEN
+					IF DevCPS.numtyp = integer THEN
+						i := SHORT(DevCPS.intval); GetSF("", i, sysflag)
+					ELSE err(225)
+					END
+				ELSIF sym = ident THEN
+					DevCPT.Find(DevCPS.name, x);
+					IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN 
+						i := SHORT(x.conval.intval); GetSF("", i, sysflag)
+					ELSE
+						GetSF(DevCPS.name, 0, sysflag)
+					END
+				ELSE
+					GetSF(DevCPS.str^, 0, sysflag)
+				END;
+				DevCPS.Get(sym);
+				IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END
+			END;
+			CheckSym(rbrak)
+		END
+	END CheckSysFlag;
+	
+	PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct);
+		VAR obj: DevCPT.Object; tname: DevCPT.String;
+	BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0;
+		IF sym = var THEN DevCPS.Get(sym); mode := VarPar;
+		ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar	(* ??? *)
+		ELSE mode := Var
+		END ;
+		name := DevCPS.name; CheckSym(ident); CheckSym(colon);
+		IF sym # ident THEN err(ident) END;
+		Type(typ, tname);
+		IF tname = NIL THEN
+			IF typ.form = Pointer THEN  rec := typ.BaseTyp ELSE rec := typ END;
+			IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR
+				(mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END;
+			IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END
+		ELSE err(0)
+		END;
+		CheckSym(rparen);
+		IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END
+	END Receiver;
+	
+	PROCEDURE FormalParameters(
+		VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String
+	);
+		VAR mode, vis: BYTE; sys: SHORTINT;
+				par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct;
+	BEGIN
+		first := NIL; last := firstPar;
+		newPar := NIL; iidPar := NIL;
+		IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN
+			LOOP
+				sys := 0; vis := 0;
+				IF sym = var THEN DevCPS.Get(sym); mode := VarPar
+				ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar
+				ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar
+				ELSE mode := Var
+				END ;
+				IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END;
+				IF ODD(sys DIV inBit) THEN vis := inPar
+				ELSIF ODD(sys DIV outBit) THEN vis := outPar
+				END;
+				IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225)
+				ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225)
+				END;
+				LOOP
+					IF sym = ident THEN
+						DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym);
+						par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys);
+						IF first = NIL THEN first := par END ;
+						IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ;
+						last := par
+					ELSE err(ident)
+					END;
+					IF sym = comma THEN DevCPS.Get(sym)
+					ELSIF sym = ident THEN err(comma)
+					ELSIF sym = var THEN err(comma); DevCPS.Get(sym)
+					ELSE EXIT
+					END
+				END ;
+				CheckSym(colon); Type(typ, name);
+				IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END;
+				IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177)
+				END;
+				(* typ.pbused is set when parameter type name is parsed *)
+				WHILE first # NIL DO
+					SetType (NIL, first, typ, name);
+					IF DevCPM.com IN DevCPM.options THEN
+						IF ODD(sys DIV newBit) THEN
+							IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END;
+							newPar := first
+						ELSIF ODD(sys DIV iidBit) THEN
+							IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END;
+							iidPar := first
+						END
+					END;
+					first := first.link
+				END;
+				IF sym = semicolon THEN DevCPS.Get(sym)
+				ELSIF sym = ident THEN err(semicolon)
+				ELSE EXIT
+				END
+			END
+		END;
+		CheckSym(rparen);
+		IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END;
+		name := NIL;
+		IF sym = colon THEN
+			DevCPS.Get(sym);
+			Type(resTyp, name);
+			IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END
+		ELSE resTyp := DevCPT.notyp
+		END
+	END FormalParameters;
+	
+	PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct);
+		VAR o, bo: DevCPT.Object;
+	BEGIN
+		IF base # NIL THEN
+			IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END;
+			IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis)
+				OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END;
+			o := proc.link; bo := base.link;
+			WHILE (o # NIL) & (bo # NIL) DO
+				IF (bo.sysflag # 0) & (o.sysflag = 0) THEN	(* propagate sysflags *)
+					o.sysflag := bo.sysflag
+				END;
+				o := o.link; bo := bo.link
+			END;
+			DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE);
+			IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END;
+			IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END;
+			INCL(proc.conval.setval, isRedef)
+		END;
+	END CheckOverwrite;
+
+	PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct);	(* read method attributes *)
+		VAR attr, battr: SET; o: DevCPT.Object;
+	BEGIN
+		attr := {};
+		IF sym = comma THEN	(* read attributes *)
+			DevCPS.Get(sym);
+			IF sym = ident THEN
+				DevCPT.Find(DevCPS.name, o);
+				IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN
+					IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END;
+					DevCPS.Get(sym);
+					IF sym = comma THEN
+						DevCPS.Get(sym);
+						IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END
+					ELSE o := NIL
+					END
+				END;
+				IF o # NIL THEN
+					IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178)
+					ELSE INCL(attr, o.adr)
+					END;
+					DevCPS.Get(sym)
+				END
+			ELSE err(ident)
+			END
+		END;
+		IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr)
+		ELSIF (base # NIL) & (newAttr IN attr) THEN err(186)
+		END;
+		IF absAttr IN attr THEN
+			IF owner.attribute # absAttr THEN err(190) END;
+			IF (proc.vis = internal) & owner.exp THEN err(179) END
+		END;
+		IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN
+			IF (empAttr IN attr) & (newAttr IN attr) THEN err(187)
+(*
+			ELSIF extAttr IN attr THEN err(188)
+*)
+			END
+		END;
+		IF base # NIL THEN
+			battr := base.conval.setval;
+			IF empAttr IN battr THEN
+				IF absAttr IN attr THEN err(189) END
+			ELSIF ~(absAttr IN battr) THEN
+				IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END
+			END
+		END;
+		IF empAttr IN attr THEN
+			IF proc.typ # DevCPT.notyp THEN err(195)
+			ELSE
+				o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END;
+				IF o # NIL THEN err(195) END
+			END
+		END;
+		IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END;
+		proc.conval.setval := attr
+	END GetAttributes;
+	
+	PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object);
+		VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String;
+	BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL;
+		CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag);
+		IF attr # NIL THEN
+			IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr))
+			ELSE err(178)
+			END
+		END;
+		IF typ.sysflag = interface THEN
+			IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END;
+			IF typ.attribute # absAttr THEN err(163) END;
+			IF sym # lparen THEN err(160) END
+		END;
+		IF sym = lparen THEN
+			DevCPS.Get(sym); (*record extension*)
+			IF sym = ident THEN
+				Type(ftyp, name);
+				IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END;
+				SetType(typ, NIL, ftyp, name);
+				IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN
+					ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1));
+					DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag);
+					IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181)
+					ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191)
+					ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197)
+					END
+				ELSIF ftyp # DevCPT.undftyp THEN err(53)
+				END
+			ELSE err(ident)
+			END ;
+			IF typ.attribute # absAttr THEN	(* save typ for unimplemented method check *)
+				NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r
+			END;
+			CheckSym(rparen)
+		END;
+(*
+		DevCPT.OpenScope(0, NIL);
+*)
+		first := NIL; last := NIL;
+		LOOP
+			IF sym = ident THEN
+				LOOP
+					IF sym = ident THEN
+						IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN
+							DevCPT.FindBaseField(DevCPS.name, typ, fld);
+							IF fld # NIL THEN err(1) END
+						END ;
+						DevCPT.InsertField(DevCPS.name, typ, fld);
+						fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp;
+						CheckMark(fld);
+						IF first = NIL THEN first := fld END ;
+						IF last = NIL THEN typ.link := fld ELSE last.link := fld END ;
+						last := fld
+					ELSE err(ident)
+					END ;
+					IF sym = comma THEN DevCPS.Get(sym)
+					ELSIF sym = ident THEN err(comma)
+					ELSE EXIT
+					END
+				END ;
+				CheckSym(colon); Type(ftyp, name);
+				CheckAlloc(ftyp, FALSE, DevCPM.errpos);
+				WHILE first # NIL DO
+					SetType(typ, first, ftyp, name); first := first.link
+				END;
+				IF typ.sysflag = interface THEN err(161) END
+			END;
+			IF sym = semicolon THEN DevCPS.Get(sym)
+			ELSIF sym = ident THEN err(semicolon)
+			ELSE EXIT
+			END
+		END;
+(*
+		IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END;
+		typ.link := DevCPT.topScope.right; DevCPT.CloseScope;
+*)
+		typ.untagged := typ.sysflag > 0;
+		DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end)
+	END RecordType;
+
+	PROCEDURE ArrayType(VAR typ: DevCPT.Struct);
+		VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String;
+	BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag);
+		IF sym = of THEN	(*dynamic array*)
+			typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag;
+			DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
+			CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos);
+			IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END
+		ELSE
+			typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x);
+			IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval;
+				IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END
+			ELSE err(42); n := 1
+			END ;
+			typ.n := n;
+			IF sym = of THEN
+				DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
+				CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos)
+			ELSIF sym = comma THEN
+				DevCPS.Get(sym);
+				IF sym # of THEN ArrayType(typ.BaseTyp) END
+			ELSE err(35)
+			END
+		END;
+		typ.untagged := typ.sysflag > 0
+	END ArrayType;
+
+	PROCEDURE PointerType(VAR typ: DevCPT.Struct);
+		VAR id: DevCPT.Object; name: DevCPT.String;
+	BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag);
+		CheckSym(to);
+		Type(typ.BaseTyp, name);
+		SetType(typ, NIL, typ.BaseTyp, name);
+		IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN
+			typ.BaseTyp := DevCPT.undftyp; err(57)
+		END;
+		IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
+		ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
+		END;
+		typ.untagged := typ.sysflag > 0
+	END PointerType;
+	
+	PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String);	(* name # NIL => forward reference *)
+		VAR id: DevCPT.Object; tname: DevCPT.String;
+	BEGIN
+		typ := DevCPT.undftyp; name := NIL;
+		IF sym < lparen THEN err(12);
+			REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
+		END ;
+		IF sym = ident THEN
+			DevCPT.Find(DevCPS.name, id);
+			IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN	(* forward type definition *)
+				name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym);
+				IF (id = NIL) & (sym = period) THEN	(* missing module *)
+					err(0); DevCPS.Get(sym); name := NIL;
+					IF sym = ident THEN DevCPS.Get(sym) END
+				ELSIF sym = record THEN	(* wrong attribute *)
+					err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL)
+				END
+			ELSE
+				qualident(id);
+				IF id.mode = Typ THEN
+					IF ~(DevCPM.oberon IN DevCPM.options)
+						& ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN
+						err(198)
+					END;
+					typ := id.typ
+				ELSIF id.mode = Attr THEN
+					IF sym = record THEN
+						DevCPS.Get(sym); RecordType(typ, id)
+					ELSE err(12)
+					END
+				ELSE err(52)
+				END
+			END
+		ELSIF sym = array THEN
+			DevCPS.Get(sym); ArrayType(typ)
+		ELSIF sym = record THEN
+			DevCPS.Get(sym); RecordType(typ, NIL)
+		ELSIF sym = pointer THEN
+			DevCPS.Get(sym); PointerType(typ)
+		ELSIF sym = procedure THEN
+			DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic);
+			CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag);
+			typ.untagged := typ.sysflag > 0;
+			IF sym = lparen THEN
+				DevCPS.Get(sym); DevCPT.OpenScope(level, NIL);
+				FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope
+			ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL
+			END
+		ELSE err(12)
+		END ;
+		LOOP
+			IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof)
+				OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END;
+			err(15); IF sym = ident THEN EXIT END;
+			DevCPS.Get(sym)
+		END
+	END Type;
+	
+	PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node);
+		VAR apar, last, newPar, iidPar, n: DevCPT.Node;
+	BEGIN
+		aparlist := NIL; last := NIL;
+		IF sym # rparen THEN
+			newPar := NIL; iidPar := NIL;
+			LOOP Expression(apar);
+				IF fpar # NIL THEN
+					IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END;
+					DevCPB.Param(apar, fpar);
+					IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END;
+					DevCPB.Link(aparlist, last, apar);
+					IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar
+					ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar
+					END;
+					IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END;
+					IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options)
+						OR (DevCPM.allSysVal IN DevCPM.options)	(* source output: avoid double evaluation *)
+							 & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged
+								OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN
+						n := apar;
+						WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END;
+						IF (n.class = Nderef) & (n.subcl = 0) THEN
+							IF n.left.class = Nguard THEN n := n.left END;
+							DevCPB.CheckVarParBuffering(n.left, pre, lastp)
+						END
+					END;
+					fpar := fpar.link
+				ELSE err(64)
+				END;
+				IF sym = comma THEN DevCPS.Get(sym)
+				ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
+				ELSE EXIT
+				END
+			END
+		END;
+		IF fpar # NIL THEN err(65) END
+	END ActualParameters;
+
+	PROCEDURE selector(VAR x: DevCPT.Node);
+		VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name;
+	BEGIN
+		LOOP
+			IF sym = lbrak THEN DevCPS.Get(sym);
+				LOOP
+					IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ;
+					Expression(y); DevCPB.Index(x, y);
+					IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END
+				END ;
+				CheckSym(rbrak)
+			ELSIF sym = period THEN DevCPS.Get(sym);
+				IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym);
+					IF x.typ # NIL THEN
+						IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ;
+						IF x.typ.comp = Record THEN
+							typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj);
+							IF (obj # NIL) & (obj.mode = TProc) THEN
+								IF sym = arrow THEN  (* super call *) DevCPS.Get(sym);
+									y := x.left;
+									IF y.class = Nderef THEN y := y.left END ;	(* y = record variable *)
+									IF y.obj # NIL THEN
+										proc := DevCPT.topScope;	(* find innermost scope which owner is a TProc *)
+										WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ;
+										IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75)
+										END ;
+										typ := y.obj.typ;
+										IF typ.form = Pointer THEN typ := typ.BaseTyp END ;
+										DevCPT.FindBaseField(x.obj.name^, typ, p);
+										IF p # NIL THEN
+											x.subcl := super; x.typ := p.typ;	(* correct result type *)
+											IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END;
+											IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END;
+										ELSE err(74)
+										END
+									ELSE err(75)
+									END
+								ELSE
+									proc := obj;
+									WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO
+										(* find base method *)
+										typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc);
+									END;
+									IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END;
+								END ;
+								IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END
+							END
+						ELSE err(53)
+						END
+					ELSE err(52)
+					END
+				ELSE err(ident)
+				END
+			ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x)
+			ELSIF sym = dollar THEN
+				IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
+				DevCPS.Get(sym); DevCPB.StrDeref(x)
+			ELSIF sym = lparen THEN
+				IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ
+				ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp
+				ELSIF x.class = Nproc THEN EXIT	(* standard procedure *)
+				ELSE typ := NIL
+				END;
+				IF typ # DevCPT.notyp THEN
+					DevCPS.Get(sym);
+					IF typ = NIL THEN	(* type guard *)
+						IF sym = ident THEN
+							qualident(obj);
+							IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
+							ELSE err(52)
+							END
+						ELSE err(ident)
+						END
+					ELSE	(* function call *)
+						pre := NIL; lastp := NIL;
+						DevCPB.PrepCall(x, fpar);
+						IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp)
+						END;
+						ActualParameters(apar, fpar, pre, lastp);
+						DevCPB.Call(x, apar, fpar);
+						IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END;
+						IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
+					END;
+					CheckSym(rparen)
+				ELSE EXIT
+				END
+(*
+			ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) &
+					((x.obj = NIL) OR (x.obj.mode # TProc)) THEN
+				DevCPS.Get(sym);
+				IF sym = ident THEN
+					qualident(obj);
+					IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
+					ELSE err(52)
+					END
+				ELSE err(ident)
+				END ;
+				CheckSym(rparen)
+*)
+			ELSE EXIT
+			END
+		END
+	END selector;
+
+	PROCEDURE StandProcCall(VAR x: DevCPT.Node);
+		VAR y: DevCPT.Node; m: BYTE; n: SHORTINT;
+	BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0;
+		IF sym = lparen THEN DevCPS.Get(sym);
+			IF sym # rparen THEN
+				LOOP
+					IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1
+					ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2
+					ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n)
+					END ;
+					IF sym = comma THEN DevCPS.Get(sym)
+					ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
+					ELSE EXIT
+					END
+				END ;
+				CheckSym(rparen)
+			ELSE DevCPS.Get(sym)
+			END ;
+			DevCPB.StFct(x, m, n)
+		ELSE err(lparen)
+		END ;
+		IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END
+	END StandProcCall;
+	
+	PROCEDURE Element(VAR x: DevCPT.Node);
+		VAR y: DevCPT.Node;
+	BEGIN Expression(x);
+		IF sym = upto THEN
+			DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y)
+		ELSE DevCPB.SetElem(x)
+		END
+	END Element;
+
+	PROCEDURE Sets(VAR x: DevCPT.Node);
+		VAR y: DevCPT.Node;
+	BEGIN
+		IF sym # rbrace THEN
+			Element(x);
+			LOOP
+				IF sym = comma THEN DevCPS.Get(sym)
+				ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
+				ELSE EXIT
+				END ;
+				Element(y); DevCPB.Op(plus, x, y)
+			END
+		ELSE x := DevCPB.EmptySet()
+		END ;
+		CheckSym(rbrace)
+	END Sets;
+	
+	PROCEDURE Factor(VAR x: DevCPT.Node);
+		VAR fpar, id: DevCPT.Object; apar: DevCPT.Node;
+	BEGIN
+		IF sym < not THEN err(13);
+			REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
+		END ;
+		IF sym = ident THEN
+			qualident(id); x := DevCPB.NewLeaf(id); selector(x);
+			IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x)	(* x may be NIL *)
+(*
+			ELSIF sym = lparen THEN
+				DevCPS.Get(sym); DevCPB.PrepCall(x, fpar);
+				ActualParameters(apar, fpar);
+				DevCPB.Call(x, apar, fpar);
+				CheckSym(rparen);
+				IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
+*)
+			END
+		ELSIF sym = number THEN
+			CASE DevCPS.numtyp OF
+			   char:
+				x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ;
+				IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END
+			| integer: x := DevCPB.NewIntConst(DevCPS.intval)
+			| int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval)
+			| real: x := DevCPB.NewRealConst(DevCPS.realval, NIL)
+			| real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ)
+			| real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ)
+			END ;
+			DevCPS.Get(sym)
+		ELSIF sym = string THEN
+			x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval);
+			DevCPS.Get(sym)
+		ELSIF sym = nil THEN
+			x := DevCPB.Nil(); DevCPS.Get(sym)
+		ELSIF sym = lparen THEN
+			DevCPS.Get(sym); Expression(x); CheckSym(rparen)
+		ELSIF sym = lbrak THEN
+			DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen)
+		ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x)
+		ELSIF sym = not THEN
+			DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x)
+		ELSE err(13); DevCPS.Get(sym); x := NIL
+		END ;
+		IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END
+	END Factor;
+
+	PROCEDURE Term(VAR x: DevCPT.Node);
+		VAR y: DevCPT.Node; mulop: BYTE;
+	BEGIN Factor(x);
+		WHILE (times <= sym) & (sym <= and) DO
+			mulop := sym; DevCPS.Get(sym);
+			Factor(y); DevCPB.Op(mulop, x, y)
+		END
+	END Term;
+
+	PROCEDURE SimpleExpression(VAR x: DevCPT.Node);
+		VAR y: DevCPT.Node; addop: BYTE;
+	BEGIN
+		IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x)
+		ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x)
+		ELSE Term(x)
+		END ;
+		WHILE (plus <= sym) & (sym <= or) DO
+			addop := sym; DevCPS.Get(sym); Term(y); 
+			IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
+			IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN
+				DevCPB.StrDeref(x)
+			END;
+			IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END;
+			IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN
+				DevCPB.StrDeref(y)
+			END;
+			DevCPB.Op(addop, x, y)
+		END
+	END SimpleExpression;
+
+	PROCEDURE Expression(VAR x: DevCPT.Node);
+		VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE;
+	BEGIN SimpleExpression(x);
+		IF (eql <= sym) & (sym <= geq) THEN
+			relation := sym; DevCPS.Get(sym); SimpleExpression(y);
+			pre := NIL; last := NIL;
+			IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN
+				DevCPB.StrDeref(x)
+			END;
+			IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN
+				DevCPB.StrDeref(y)
+			END;
+			DevCPB.CheckBuffering(x, NIL, NIL, pre, last);
+			DevCPB.CheckBuffering(y, NIL, NIL, pre, last);
+			DevCPB.Op(relation, x, y);
+			IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END
+		ELSIF sym = in THEN
+			DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y)
+		ELSIF sym = is THEN
+			DevCPS.Get(sym);
+			IF sym = ident THEN
+				qualident(obj);
+				IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE)
+				ELSE err(52)
+				END
+			ELSE err(ident)
+			END
+		END
+	END Expression;
+
+	PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node);
+		VAR proc, fwd: DevCPT.Object;
+			name: DevCPT.Name;
+			mode: BYTE;
+			forward: BOOLEAN;
+			sys: SHORTINT;
+
+		PROCEDURE GetCode;
+			VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR;
+		BEGIN
+			n := 0;
+			IF sym = string THEN
+				NEW(ext, DevCPS.intval);
+				WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ;
+				ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym);
+			ELSE
+				LOOP
+					IF sym = number THEN c := DevCPS.intval; INC(n);
+						IF (c < 0) OR (c > 255) OR (n = 255) THEN
+							err(64); c := 1; n := 1
+						END ;
+						DevCPS.Get(sym); s[n] := SHORT(CHR(c))
+					END ;
+					IF sym = comma THEN DevCPS.Get(sym)
+					ELSIF sym = number THEN err(comma)
+					ELSE s[0] := SHORT(CHR(n)); EXIT
+					END
+				END;
+				NEW(ext, n + 1); i := 0;
+				WHILE i <= n DO ext[i] := s[i]; INC(i) END;
+			END;
+			proc.conval.ext := ext;
+			INCL(proc.conval.setval, hasBody)
+		END GetCode;
+
+		PROCEDURE GetParams;
+			VAR name: DevCPT.String;
+		BEGIN
+			proc.mode := mode; proc.typ := DevCPT.notyp;
+			proc.sysflag := SHORT(sys);
+			proc.conval.setval := {};
+			IF sym = lparen THEN
+				DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name);
+				IF name # NIL THEN err(0) END
+			END;
+			CheckForwardTypes; userList := NIL;
+			IF fwd # NIL THEN
+				DevCPB.CheckParameters(proc.link, fwd.link, TRUE);
+				IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ;
+				proc := fwd; DevCPT.topScope := proc.scope;
+				IF mode = IProc THEN proc.mode := IProc END
+			END
+		END GetParams;
+
+		PROCEDURE Body;
+			VAR procdec, statseq: DevCPT.Node; c: INTEGER;
+		BEGIN
+			c := DevCPM.errpos;
+			INCL(proc.conval.setval, hasBody);
+			CheckSym(semicolon); Block(procdec, statseq);
+			DevCPB.Enter(procdec, statseq, proc); x := procdec;
+			x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos;
+			CheckSym(end);
+			IF sym = ident THEN
+				IF DevCPS.name # proc.name^ THEN err(4) END ;
+				DevCPS.Get(sym)
+			ELSE err(ident)
+			END
+		END Body;
+
+		PROCEDURE TProcDecl;
+			VAR baseProc, o, bo: DevCPT.Object;
+				objTyp, recTyp: DevCPT.Struct;
+				objMode, objVis: BYTE;
+				objName: DevCPT.Name;
+				pnode: DevCPT.Node;
+				fwdAttr: SET;
+		BEGIN
+			DevCPS.Get(sym); mode := TProc;
+			IF level > 0 THEN err(73) END;
+			Receiver(objMode, objVis, objName, objTyp, recTyp);
+			IF sym = ident THEN
+				name := DevCPS.name;
+				DevCPT.FindField(name, recTyp, fwd);
+				DevCPT.FindBaseField(name, recTyp, baseProc);
+				IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ;
+				IF fwd = baseProc THEN fwd := NIL END ;
+				IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ;
+				IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN
+					(* there exists a corresponding forward declaration *)
+					proc := DevCPT.NewObj(); proc.leaf := TRUE;
+					proc.mode := TProc; proc.conval := DevCPT.NewConst();
+					CheckMark(proc);
+					IF fwd.vis # proc.vis THEN err(118) END;
+					fwdAttr := fwd.conval.setval
+				ELSE
+					IF fwd # NIL THEN err(1); fwd := NIL END ;
+					DevCPT.InsertField(name, recTyp, proc);
+					proc.mode := TProc; proc.conval := DevCPT.NewConst();
+					CheckMark(proc);
+					IF recTyp.strobj # NIL THEN	(* preserve declaration order *)
+						o := recTyp.strobj.link;
+						IF o = NIL THEN recTyp.strobj.link := proc
+						ELSE
+							WHILE o.nlink # NIL DO o := o.nlink END;
+							o.nlink := proc
+						END
+					END
+				END;
+				INC(level); DevCPT.OpenScope(level, proc);
+				DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp;
+				ASSERT(DevCPT.topScope # NIL);
+				GetParams;	(* may change proc := fwd !!! *)
+				ASSERT(DevCPT.topScope # NIL);
+				GetAttributes(proc, baseProc, recTyp);
+				IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END;
+				CheckOverwrite(proc, baseProc, recTyp);
+				IF ~forward THEN
+					IF empAttr IN proc.conval.setval THEN	(* insert empty procedure *)
+						pnode := NIL; DevCPB.Enter(pnode, NIL, proc);
+						pnode.conval := DevCPT.NewConst();
+						pnode.conval.intval := DevCPM.errpos;
+						pnode.conval.intval2 := DevCPM.errpos;
+						x := pnode;
+					ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
+					ELSIF ~(absAttr IN proc.conval.setval) THEN Body
+					END;
+					proc.adr := 0
+				ELSE
+					proc.adr := DevCPM.errpos;
+					IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END
+				END;
+				DEC(level); DevCPT.CloseScope;
+			ELSE err(ident)
+			END;
+		END TProcDecl;
+	
+	BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0;
+		IF (sym # ident) & (sym # lparen) THEN
+			CheckSysFlag(sys, DevCPM.GetProcSysFlag);
+			IF sys # 0 THEN
+				IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END
+			ELSE
+				IF sym = times THEN	(* mode set later in DevCPB.CheckAssign *)
+				ELSIF sym = arrow THEN forward := TRUE
+				ELSE err(ident)
+				END;
+				DevCPS.Get(sym)
+			END
+		END ;
+		IF sym = lparen THEN TProcDecl
+		ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd);
+			name := DevCPS.name;
+			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
+				(* there exists a corresponding forward declaration *)
+				proc := DevCPT.NewObj(); proc.leaf := TRUE;
+				proc.mode := mode; proc.conval := DevCPT.NewConst();
+				CheckMark(proc);
+				IF fwd.vis # proc.vis THEN err(118) END
+			ELSE
+				IF fwd # NIL THEN err(1); fwd := NIL END ;
+				DevCPT.Insert(name, proc);
+				proc.mode := mode; proc.conval := DevCPT.NewConst();
+				CheckMark(proc);
+			END ;
+			IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ;
+			IF (mode # LProc) & (level > 0) THEN err(73) END ;
+			INC(level); DevCPT.OpenScope(level, proc);
+			proc.link := NIL; GetParams;	(* may change proc := fwd !!! *)
+			IF mode = CProc THEN GetCode
+			ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
+			ELSIF ~forward THEN Body; proc.adr := 0
+			ELSE proc.adr := DevCPM.errpos
+			END ;
+			DEC(level); DevCPT.CloseScope
+		ELSE err(ident)
+		END
+	END ProcedureDeclaration;
+
+	PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER);
+		VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER;
+		
+		PROCEDURE Insert(VAR n: DevCPT.Node);	(* build binary tree of label ranges *)	(* !!! *)
+		BEGIN
+			IF n = NIL THEN
+				IF x.hint # 1 THEN n := x END
+			ELSIF yval < n.conval.intval THEN Insert(n.left)
+			ELSIF xval > n.conval.intval2 THEN Insert(n.right)
+			ELSE err(63)
+			END
+		END Insert;
+		
+	BEGIN lab := NIL; lastlab := NIL;
+		LOOP ConstExpression(x); f := x.typ.form;
+			IF f IN {Int8..Int32} + charSet THEN  xval := x.conval.intval
+			ELSE err(61); xval := 1
+			END ;
+			IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
+			IF sym = upto THEN
+				DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval;
+				IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
+				IF yval < xval THEN err(63); yval := xval END
+			ELSE yval := xval
+			END ;
+			x.conval.intval2 := yval;
+			IF xval < min THEN min := xval END;
+			IF yval > max THEN max := yval END;
+			IF lab = NIL THEN lab := x; Insert(root)
+			ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root)
+			ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval
+			ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval
+			ELSE
+				y := lab;
+				WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END;
+				IF y.link = NIL THEN y.link := x; Insert(root)
+				ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root)
+				ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval
+				ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval
+				END
+			END;
+			IF sym = comma THEN DevCPS.Get(sym)
+			ELSIF (sym = number) OR (sym = ident) THEN err(comma)
+			ELSE EXIT
+			END
+		END
+	END CaseLabelList;
+	
+	PROCEDURE StatSeq(VAR stat: DevCPT.Node);
+		VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN;
+				s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name;
+
+		PROCEDURE CasePart(VAR x: DevCPT.Node);
+			VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node; 
+		BEGIN
+			Expression(x);
+			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
+			ELSIF x.typ.form = Int64 THEN err(260)
+			ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125)
+			END ;
+			CheckSym(of); cases := NIL; lastcase := NIL; root := NIL;
+			low := MAX(INTEGER); high := MIN(INTEGER);
+			LOOP
+				IF sym < bar THEN
+					CaseLabelList(lab, root, x.typ.form, low, high);
+					CheckSym(colon); StatSeq(y);
+					DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab)
+				END ;
+				IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
+			END;
+			e := sym = else;
+			IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
+			DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases);
+			cases.conval := DevCPT.NewConst();
+			cases.conval.intval := low; cases.conval.intval2 := high;
+			IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END;
+			DevCPB.OptimizeCase(root); cases.link := root	(* !!! *)
+		END CasePart;
+		
+		PROCEDURE SetPos(x: DevCPT.Node);
+		BEGIN
+			x.conval := DevCPT.NewConst(); x.conval.intval := pos
+		END SetPos;
+
+		PROCEDURE CheckBool(VAR x: DevCPT.Node);
+		BEGIN
+			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE)
+			ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE)
+			END
+		END CheckBool;
+
+	BEGIN stat := NIL; last := NIL;
+		LOOP x := NIL;
+			IF sym < ident THEN err(14);
+				REPEAT DevCPS.Get(sym) UNTIL sym >= ident
+			END ;
+			pos := DevCPM.startpos;
+			IF sym = ident THEN
+				qualident(id); x := DevCPB.NewLeaf(id); selector(x);
+				IF sym = becomes THEN
+					DevCPS.Get(sym); Expression(y);
+					IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END;
+					pre := NIL; lastp := NIL;
+					DevCPB.CheckBuffering(y, x, NIL, pre, lastp);
+					DevCPB.Assign(x, y);
+					IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
+				ELSIF sym = eql THEN
+					err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y)
+				ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN
+					StandProcCall(x);
+					IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END;
+					IF (x # NIL) & (x.class = Nifelse) THEN	(* error pos for ASSERT *)
+						SetPos(x.left); SetPos(x.left.right)
+					END
+				ELSIF x.class = Ncall THEN err(55)
+				ELSE
+					pre := NIL; lastp := NIL;
+					DevCPB.PrepCall(x, fpar);
+					IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END;
+					IF sym = lparen THEN
+						DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen)
+					ELSE apar := NIL;
+						IF fpar # NIL THEN err(65) END
+					END ;
+					DevCPB.Call(x, apar, fpar);
+					IF x.typ # DevCPT.notyp THEN err(55) END;
+					IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
+					IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
+				END
+			ELSIF sym = if THEN
+				DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y);
+				DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x;
+				WHILE sym = elsif DO
+					DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z);
+					DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y)
+				END ;
+				pos := DevCPM.startpos;
+				IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
+				DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x);
+			ELSIF sym = case THEN
+				DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end)
+			ELSIF sym = while THEN
+				DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y);
+				DevCPB.Construct(Nwhile, x, y); CheckSym(end)
+			ELSIF sym = repeat THEN
+				DevCPS.Get(sym); StatSeq(x);
+				IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y)
+				ELSE err(43)
+				END ;
+				DevCPB.Construct(Nrepeat, x, y)
+			ELSIF sym = for THEN
+				DevCPS.Get(sym); pos := DevCPM.startpos;
+				IF sym = ident THEN qualident(id);
+					IF ~(id.typ.form IN intSet) THEN err(68) END ;
+					CheckSym(becomes); Expression(y);
+					x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x);
+					CheckSym(to); pos := DevCPM.startpos; Expression(y);
+					IF y.class # Nconst THEN
+						DevCPB.GetTempVar("@for", x.left.typ, t);
+						z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z);
+						y := DevCPB.NewLeaf(t)
+					ELSE
+						DevCPB.CheckAssign(x.left.typ, y)
+					END ;
+					DevCPB.Link(stat, last, x);
+					p := DevCPM.startpos;
+					IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ;
+					x := DevCPB.NewLeaf(id);
+					IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y)
+					ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y)
+					ELSE err(63); DevCPB.Op(geq, x, y)
+					END ;
+					CheckSym(do); StatSeq(s);
+					y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; 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); DevCPB.Construct(Nwhile, x, s); pos := p
+				ELSE err(ident)
+				END
+			ELSIF sym = loop THEN
+				DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel);
+				DevCPB.Construct(Nloop, x, NIL); CheckSym(end)
+			ELSIF sym = with THEN
+				DevCPS.Get(sym); idtyp := NIL; x := NIL;
+				LOOP
+					IF sym < bar THEN
+						pos := DevCPM.startpos;
+						IF sym = ident THEN
+							qualident(id); y := DevCPB.NewLeaf(id);
+							IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN
+								err(-302)	(* warning 302 *)
+							END ;
+							CheckSym(colon);
+							IF sym = ident THEN qualident(t);
+								IF t.mode = Typ THEN
+									IF id # NIL THEN
+										idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ;
+										IF id.ptyp = NIL THEN id.ptyp := idtyp END
+									ELSE err(130)
+									END
+								ELSE err(52)
+								END
+							ELSE err(ident)
+							END
+						ELSE err(ident)
+						END ;
+						CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y);
+						IF idtyp # NIL THEN
+							IF id.ptyp = idtyp THEN id.ptyp := NIL END;
+							id.typ := idtyp; idtyp := NIL
+						END ;
+						IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END
+					END;
+					IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
+				END;
+				e := sym = else; pos := DevCPM.startpos;
+				IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ;
+				DevCPB.Construct(Nwith, x, s); CheckSym(end);
+				IF e THEN x.subcl := 1 END
+			ELSIF sym = exit THEN
+				DevCPS.Get(sym);
+				IF LoopLevel = 0 THEN err(46) END ;
+				DevCPB.Construct(Nexit, x, NIL)
+			ELSIF sym = return THEN DevCPS.Get(sym);
+				IF sym < semicolon THEN Expression(x) END ;
+				IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link)
+				ELSE (* not standard Oberon *) DevCPB.Return(x, NIL)
+				END;
+				hasReturn := TRUE
+			END ;
+			IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ;
+			IF sym = semicolon THEN DevCPS.Get(sym)
+			ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon)
+			ELSE EXIT
+			END
+		END
+	END StatSeq;
+
+	PROCEDURE Block(VAR procdec, statseq: DevCPT.Node);
+		VAR typ: DevCPT.Struct;
+			obj, first, last, o: DevCPT.Object;
+			x, lastdec: DevCPT.Node;
+			i: SHORTINT;
+			rname: DevCPT.Name;
+			name: DevCPT.String;
+			rec: Elem;
+
+	BEGIN
+		IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END;
+		first := NIL; last := NIL; userList := NIL; recList := NIL;
+		LOOP
+			IF sym = const THEN
+				DevCPS.Get(sym);
+				WHILE sym = ident DO
+					DevCPT.Insert(DevCPS.name, obj);
+					obj.mode := Con; CheckMark(obj);
+					obj.typ := DevCPT.int8typ; obj.mode := Var;	(* Var to avoid recursive definition *)
+					IF sym = eql THEN
+						DevCPS.Get(sym); ConstExpression(x)
+					ELSIF sym = becomes THEN
+						err(eql); DevCPS.Get(sym); ConstExpression(x)
+					ELSE err(eql); x := DevCPB.NewIntConst(1)
+					END ;
+					obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *)
+					CheckSym(semicolon)
+				END
+			END ;
+			IF sym = type THEN
+				DevCPS.Get(sym);
+				WHILE sym = ident DO
+					DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp;
+					CheckMark(obj); obj.mode := -1;
+					IF sym # eql THEN err(eql) END;
+					IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN
+						DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name);
+					END;
+					obj.mode := Typ;
+					IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN	(* make alias structure *)
+						typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref;
+						typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos;
+						typ.BaseTyp := obj.typ; obj.typ := typ;
+					END;
+					IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ;
+					IF obj.typ.form = Pointer THEN	(* !!! *)
+						typ := obj.typ.BaseTyp;
+						IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN
+							(* pointer to unnamed record: name record as "pointerName^" *)
+							rname := obj.name^$; i := 0;
+							WHILE rname[i] # 0X DO INC(i) END;
+							rname[i] := "^"; rname[i+1] := 0X;
+							DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o
+						END
+					END;
+					IF obj.vis # internal THEN
+						typ := obj.typ;
+						IF typ.form = Pointer THEN typ := typ.BaseTyp END;
+						IF typ.comp = Record THEN typ.exp := TRUE END
+					END;
+					CheckSym(semicolon)
+				END
+			END ;
+			IF sym = var THEN
+				DevCPS.Get(sym);
+				WHILE sym = ident DO
+					LOOP
+						IF sym = ident THEN
+							DevCPT.Insert(DevCPS.name, obj);
+							obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp;
+							CheckMark(obj);
+							IF first = NIL THEN first := obj END ;
+							IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ;
+							last := obj
+						ELSE err(ident)
+						END ;
+						IF sym = comma THEN DevCPS.Get(sym)
+						ELSIF sym = ident THEN err(comma)
+						ELSE EXIT
+						END
+					END ;
+					CheckSym(colon); Type(typ, name);
+					CheckAlloc(typ, FALSE, DevCPM.errpos);
+					WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ;
+					CheckSym(semicolon)
+				END
+			END ;
+			IF (sym < const) OR (sym > var) THEN EXIT END ;
+		END ;
+		CheckForwardTypes;
+		userList := NIL; rec := recList; recList := NIL;
+		DevCPT.topScope.adr := DevCPM.errpos;
+		procdec := NIL; lastdec := NIL;
+		IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END;
+		WHILE sym = procedure DO
+			DevCPS.Get(sym); ProcedureDeclaration(x);
+			IF x # NIL THEN
+				IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ;
+				lastdec := x
+			END ;
+			CheckSym(semicolon)
+		END ;
+		IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END;
+		hasReturn := FALSE;
+		IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END;
+		IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq)
+		ELSE statseq := NIL
+		END ;
+		IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp)
+			& ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END;
+		IF (level = 0) & (TDinit # NIL) THEN
+			lastTDinit.link := statseq; statseq := TDinit
+		END
+	END Block;
+
+	PROCEDURE Module*(VAR prog: DevCPT.Node);
+		VAR impName, aliasName: DevCPT.Name;
+				procdec, statseq: DevCPT.Node;
+				c, sf: INTEGER; done: BOOLEAN;
+	BEGIN
+		DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym);
+		IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ;
+		IF sym = ident THEN
+			DevCPT.Open(DevCPS.name); DevCPS.Get(sym);
+			DevCPT.libName := "";
+			IF sym = lbrak THEN
+				INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym);
+				IF sym = eql THEN DevCPS.Get(sym)
+				ELSE INCL(DevCPM.options, DevCPM.noCode)
+				END;
+				IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym)
+				ELSE err(string)
+				END;
+				CheckSym(rbrak)
+			END;
+			CheckSym(semicolon);
+			IF sym = import THEN DevCPS.Get(sym);
+				LOOP
+					IF sym = ident THEN
+						aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym);
+						IF sym = becomes THEN DevCPS.Get(sym);
+							IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END
+						END ;
+						DevCPT.Import(aliasName, impName, done)
+					ELSE err(ident)
+					END ;
+					IF sym = comma THEN DevCPS.Get(sym)
+					ELSIF sym = ident THEN err(comma)
+					ELSE EXIT
+					END
+				END ;
+				CheckSym(semicolon)
+			END ;
+			IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos;
+				Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec;
+				prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos;
+				IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END;
+				prog.conval.realval := DevCPM.startpos;
+				CheckSym(end);
+				IF sym = ident THEN
+					IF DevCPS.name # DevCPT.SelfName THEN err(4) END ;
+					DevCPS.Get(sym)
+				ELSE err(ident)
+				END;
+				IF sym # period THEN err(period) END
+			END
+		ELSE err(ident)
+		END ;
+		TDinit := NIL; lastTDinit := NIL;
+		DevCPS.str := NIL
+	END Module;
+
+END LindevCPP.

BlackBox/Lindev/Mod/CPS.txt

@@ -0,0 +1,367 @@
+MODULE LindevCPS;
+
+	(* THIS IS TEXT COPY OF CPS.odc *)
+	(* DO NOT EDIT *)
+	(* SEE XXX BELOW *)
+
+	IMPORT SYSTEM, Math, DevCPM := LindevCPM, DevCPT := LindevCPT;
+	
+	CONST
+		MaxIdLen = 256;
+	
+	TYPE
+(*
+		Name* = ARRAY MaxIdLen OF SHORTCHAR;
+		String* = POINTER TO ARRAY OF SHORTCHAR;
+*)
+
+	(* name, str, numtyp, intval, realval, realval are implicit results of Get *)
+
+	VAR
+		name*: DevCPT.Name;
+		str*: DevCPT.String;
+		lstr*: POINTER TO ARRAY OF CHAR;
+		numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *)
+		intval*: INTEGER;	(* integer value or string length (incl. 0X) *)
+		realval*: REAL;
+
+
+	CONST
+		(* numtyp values *)
+		char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
+
+		(*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; dollar = 18; period = 19;
+		comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
+		rbrace = 25; of = 26; then = 27; do = 28; to = 29;
+		by = 30; not = 33;
+		lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
+		number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
+		bar = 50; end = 51; else = 52; elsif = 53; until = 54;
+		if = 55; case = 56; while = 57; repeat = 58; for = 59;
+		loop = 60; with = 61; exit = 62; return = 63; array = 64;
+		record = 65; pointer = 66; begin = 67; const = 68; type = 69;
+		var = 70; out = 71; procedure = 72; close = 73; import = 74;
+		module = 75; eof = 76;
+
+	VAR
+		ch: SHORTCHAR;     (*current character*)
+
+	PROCEDURE err(n: SHORTINT);
+	BEGIN DevCPM.err(n)
+	END err;
+	
+	PROCEDURE Str(VAR sym: BYTE);
+		VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN;
+			s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR;
+	BEGIN i := 0; och := ch; long := FALSE;
+		LOOP DevCPM.GetL(lch);
+			IF lch = och THEN EXIT END ;
+			IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END;
+			IF lch > 0FFX THEN long := TRUE END;
+			IF i < LEN(s) - 1 THEN s[i] := lch
+			ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch
+			ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch
+			ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch
+			END;
+			INC(i)
+		END ;
+		IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0])
+		ELSE
+			sym := string; numtyp := 0; intval := i + 1; NEW(str, intval);
+			IF long THEN
+				IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$
+				ELSE lstr[i] := 0X
+				END;
+				str^ := SHORT(lstr$)
+			ELSE
+				IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$);
+				ELSE lstr[i] := 0X; str^ := SHORT(lstr$)
+				END;
+				lstr := NIL
+			END
+		END;
+		DevCPM.Get(ch)
+	END Str;
+
+	PROCEDURE Identifier(VAR sym: BYTE);
+		VAR i: SHORTINT;
+	BEGIN i := 0;
+		REPEAT
+			name[i] := ch; INC(i); DevCPM.Get(ch)
+		UNTIL (ch < "0")
+			OR ("9" < ch) & (CAP(ch) < "A")
+			OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À")
+			OR (ch = "×")
+			OR (ch = "÷")
+			OR (i = MaxIdLen);
+		IF i = MaxIdLen THEN err(240); DEC(i) END ;
+		name[i] := 0X; sym := ident
+	END Identifier;
+
+	PROCEDURE Number;
+		VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL;
+			dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER;
+
+		PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT;
+		BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *)
+			IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0"))
+			ELSIF hex THEN RETURN SHORT(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;
+				DevCPM.Get(ch); INC(i)
+			ELSIF ch = "." THEN DevCPM.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 *) realval := 0; numtyp := integer;
+			IF n = m THEN intval := 0; i := 0;
+				IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char;
+					IF n <= 4 THEN
+						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
+					ELSE err(203)
+					END
+				ELSIF (ch = "H") OR (ch = "S") THEN	(* hex 32bit *)
+					tch := ch; DevCPM.Get(ch);
+					IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN	(* old syntax: hex 64bit *)
+						DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch);
+						IF n <= 16 THEN
+							IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
+							WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
+							WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
+							numtyp := int64
+						ELSE err(203)
+						END
+					ELSIF n <= 8 THEN
+						IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END;
+						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END;
+						IF tch = "S" THEN	(* 32 bit hex float *)
+							r := SYSTEM.VAL(SHORTREAL, intval);
+							realval := r; intval := 0; numtyp := real32
+						END
+					ELSE err(203)
+					END
+				ELSIF ch = "L" THEN	(* hex 64bit *)
+					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
+					IF n <= 16 THEN
+						IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
+						WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
+						WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
+						numtyp := int64
+					ELSE err(203)
+					END
+				ELSIF ch = "R" THEN	(* hex float 64bit *)
+					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
+					IF n <= 16 THEN
+						a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END;
+						WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
+						IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END;
+						a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END;
+						WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
+						IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END;
+						realval := SYSTEM.VAL(REAL, arr);
+						intval := 0; numtyp := real64
+					ELSE err(203)
+					END
+				ELSE	(* decimal *) 
+					WHILE i < n DO d := Ord(dig[i], FALSE); INC(i);
+						a := (MAX(INTEGER) - d) DIV 10;
+						IF intval > a THEN
+							a := (intval - a + 65535) DIV 65536 * 65536;
+							realval := realval + a; intval := intval - a
+						END;
+						realval := realval * 10; intval := intval * 10 + d
+					END;
+					IF realval = 0 THEN numtyp := integer
+					ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64	(* 2^63 *)
+					ELSE intval := 0; err(203)
+					END
+				END
+			ELSE err(203)
+			END
+		ELSE (* fraction *)
+			f := 0; g := 0; e := 0; j := 0; expCh := "E";
+			WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END;	(* !!! *)
+			WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END;
+			IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN
+				expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE;
+				IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch)
+				ELSIF ch = "+" THEN DevCPM.Get(ch)
+				END;
+				IF ("0" <= ch) & (ch <= "9") THEN
+					REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch);
+						IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(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 e < -308 - 16 THEN
+				realval := 0.0
+			ELSIF e < -308 + 14 THEN
+				realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15
+			ELSIF e < j THEN
+				realval := (f + g) / Math.IntPower(10, j-e)	(* Ten(j-e) *)
+			ELSIF e <= 308 THEN
+				realval := (f + g) * Math.IntPower(10, e-j)	(* Ten(e-j) *)
+			ELSIF e = 308 + 1 THEN
+				realval := (f + g) * (Math.IntPower(10, e-j) / 16);
+				IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16
+				ELSE err(203)
+				END
+			ELSE err(203)
+			END;
+			numtyp := real
+		END
+	END Number;
+
+	PROCEDURE Get*(VAR sym: BYTE);
+		VAR s: BYTE; old: INTEGER;
+
+		PROCEDURE Comment;	(* do not read after end of file *)
+		BEGIN DevCPM.Get(ch);
+			LOOP
+				LOOP
+					WHILE ch = "(" DO DevCPM.Get(ch);
+						IF ch = "*" THEN Comment END
+					END ;
+					IF ch = "*" THEN DevCPM.Get(ch); EXIT END ;
+					IF ch = DevCPM.Eot THEN EXIT END ;
+					DevCPM.Get(ch)
+				END ;
+				IF ch = ")" THEN DevCPM.Get(ch); EXIT END ;
+				IF ch = DevCPM.Eot THEN err(5); EXIT END
+			END
+		END Comment;
+
+	BEGIN
+		DevCPM.errpos := DevCPM.curpos-1;
+		WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*)
+			IF ch = DevCPM.Eot THEN sym := eof; RETURN
+			ELSE DevCPM.Get(ch)
+			END
+		END ;
+		DevCPM.startpos := DevCPM.curpos - 1;
+		CASE ch OF   (* ch > " " *)
+			| 22X, 27X  : Str(s)
+			| "#"  : s := neq; DevCPM.Get(ch)
+			| "&"  : s :=  and; DevCPM.Get(ch)
+			| "("  : DevCPM.Get(ch);
+					 IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; 
+					 ELSE s := lparen
+					 END
+			| ")"  : s := rparen; DevCPM.Get(ch)
+			| "*"  : s :=  times; DevCPM.Get(ch)
+			| "+"  : s :=  plus; DevCPM.Get(ch)
+			| ","  : s := comma; DevCPM.Get(ch)
+			| "-"  : s :=  minus; DevCPM.Get(ch)
+			| "."  : DevCPM.Get(ch);
+							 IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END
+			| "/"  : s := slash;  DevCPM.Get(ch)
+			| "0".."9": Number; s := number
+			| ":"  : DevCPM.Get(ch);
+							 IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END
+			| ";"  : s := semicolon; DevCPM.Get(ch)
+			| "<"  : DevCPM.Get(ch);
+							 IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END
+			| "="  : s :=  eql; DevCPM.Get(ch)
+			| ">"  : DevCPM.Get(ch);
+							 IF ch = "=" THEN DevCPM.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
+						ELSIF name = "CLOSE" THEN s := close
+						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
+						ELSIF name = "OUT" THEN s := out
+						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", "a".."z", "_" (* XXX *): Identifier(s)
+			| "["  : s := lbrak; DevCPM.Get(ch)
+			| "]"  : s := rbrak; DevCPM.Get(ch)
+			| "^"  : s := arrow; DevCPM.Get(ch)
+			| "$"  : s := dollar; DevCPM.Get(ch)
+			| "{"  : s := lbrace; DevCPM.Get(ch);
+			| "|"  : s := bar; DevCPM.Get(ch)
+			| "}"  : s := rbrace; DevCPM.Get(ch)
+			| "~"  : s := not; DevCPM.Get(ch)
+			| 7FX  : s := upto; DevCPM.Get(ch)
+		ELSE s :=  null; DevCPM.Get(ch)
+		END ;
+		sym := s
+	END Get;
+
+	PROCEDURE Init*;
+	BEGIN ch := " "
+	END Init;
+
+END LindevCPS.

BlackBox/Lindev/Mod/CPT.txt

@@ -0,0 +1,1886 @@
+MODULE LindevCPT;
+
+	(* THIS IS TEXT COPY OF CPT.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT DevCPM := LindevCPM;
+
+	CONST
+		MaxIdLen = 256;
+	
+	TYPE
+		Name* = ARRAY MaxIdLen OF SHORTCHAR;
+		String* = POINTER TO ARRAY OF SHORTCHAR;
+		Const* = POINTER TO ConstDesc;
+		Object* = POINTER TO ObjDesc;
+		Struct* = POINTER TO StrDesc;
+		Node* = POINTER TO NodeDesc;
+		ConstExt* = String;
+		LinkList* = POINTER TO LinkDesc;
+
+		ConstDesc* = RECORD
+			ext*: ConstExt;	(* string or code for code proc (longstring in utf8) *)
+			intval*: INTEGER;	(* constant value or adr, proc par size, text position or least case label *)
+			intval2*: INTEGER;	(* string length (#char, incl 0X), proc var size or larger case label *)
+			setval*: SET;	(* constant value, procedure body present or "ELSE" present in case *)
+			realval*: REAL;	(* real or longreal constant value *)
+			link*: Const	(* chain of constants present in obj file *)
+		END ;
+
+		LinkDesc* = RECORD
+			offset*, linkadr*: INTEGER;
+			next*: LinkList;
+		END;
+
+		ObjDesc* = RECORD
+			left*, right*, link*, scope*: Object;
+			name*: String;	(* name = null OR name^ # "" *)
+			leaf*: BOOLEAN;
+			sysflag*: BYTE;
+			mode*, mnolev*: BYTE;	(* mnolev < 0 -> mno = -mnolev *)
+			vis*: BYTE;	(* internal, external, externalR, inPar, outPar *)
+			history*: BYTE;	(* relevant if name # "" *)
+			used*, fpdone*: BOOLEAN;
+			fprint*: INTEGER;
+			typ*: Struct;	(* actual type, changed in with statements *)
+			ptyp*: Struct;	(* original type if typ is changed *)
+			conval*: Const;
+			adr*, num*: INTEGER;	(* mthno *)
+			links*: LinkList;
+			nlink*: Object;	(* link for name list, declaration order for methods, library link for imp obj *)
+			library*, entry*: String;	(* library name, entry name *)
+			modifiers*: POINTER TO ARRAY OF String;	(* additional interface strings *)
+			linkadr*: INTEGER;	(* used in ofront *)
+			red: BOOLEAN;
+		END ;
+
+		StrDesc* = RECORD
+			form*, comp*, mno*, extlev*: BYTE;
+			ref*, sysflag*: SHORTINT;
+			n*, size*, align*, txtpos*: INTEGER;	(* align is alignment for records and len offset for dynarrs *)
+			untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN;
+			attribute*: BYTE;
+			idfp, pbfp*, pvfp*:INTEGER;
+			BaseTyp*: Struct;
+			link*, strobj*: Object;
+			ext*: ConstExt	(* id string for interface records *)
+		END ;
+		
+		NodeDesc* = RECORD
+			left*, right*, link*: Node;
+			class*, subcl*, hint*: BYTE;
+			readonly*: BOOLEAN;
+			typ*: Struct;
+			obj*: Object;
+			conval*: Const
+		END ;
+	
+	CONST
+		maxImps = 127;	(* must be <= MAX(SHORTINT) *)
+		maxStruct = DevCPM.MaxStruct;	(* must be < MAX(INTEGER) DIV 2 *)
+		FirstRef = 32;
+		FirstRef0 = 16;	(* correction for version 0 *)
+		actVersion = 1;
+
+	VAR
+		topScope*: Object;
+		undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*,
+		real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*,
+		anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*,
+		restyp*, iunktyp*, punktyp*, guidtyp*,
+		intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct;
+		nofGmod*: BYTE;	(*nof imports*)
+		GlbMod*: ARRAY maxImps OF Object;	(* .right = first object, .name = module import name (not alias) *)
+		SelfName*: Name;	(* name of module being compiled *)
+		SYSimported*: BOOLEAN;
+		processor*, impProc*: SHORTINT;
+		libName*: Name;	(* library alias of module being compiled *)
+		null*: String;	(* "" *)
+		
+	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; Attr = 20;
+
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		AnyPtr = 14; AnyRec = 15;	(* sym file only *)
+		Char16 = 16; String16 = 17; Int64 = 18;
+		Res = 20; IUnk = 21; PUnk = 22; Guid = 23;
+		
+		(* 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;
+		lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38;
+		
+		(*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;
+		thisrecfn = 45; thisarrfn = 46;
+		
+		(* COM function number *)
+		validfn = 40; iidfn = 41; queryfn = 42;
+		
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		(* procedure flags (conval.setval) *)
+		isHidden = 29;
+
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* history of imported objects *)
+		inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
+
+		(* sysflags *)
+		inBit = 2; outBit = 4; interface = 10; 
+
+		(* 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;
+		Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26;
+		Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22;
+		
+	TYPE
+		ImpCtxt = RECORD
+			nextTag, reffp: INTEGER;
+			nofr, minr, nofm: SHORTINT;
+			self: BOOLEAN;
+			ref: ARRAY maxStruct OF Struct;
+			old: ARRAY maxStruct OF Object;
+			pvfp: ARRAY maxStruct OF INTEGER;	(* set only if old # NIL *)
+			glbmno: ARRAY maxImps OF BYTE	(* index is local mno *)
+		END ;
+
+		ExpCtxt = RECORD
+			reffp: INTEGER;
+			ref: SHORTINT;
+			nofm: BYTE;
+			locmno: ARRAY maxImps OF BYTE	(* index is global mno *)
+		END ;
+
+	VAR
+		universe, syslink, comlink, infinity: Object;
+		impCtxt: ImpCtxt;
+		expCtxt: ExpCtxt;
+		nofhdfld: INTEGER;
+		sfpresent, symExtended, symNew: BOOLEAN;
+		version: INTEGER;
+		symChanges: INTEGER;
+		portable: BOOLEAN;
+		depth: INTEGER;
+		
+
+	PROCEDURE err(n: SHORTINT);
+	BEGIN DevCPM.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); obj.name := null; RETURN obj
+	END NewObj;
+	
+	PROCEDURE NewStr*(form, comp: BYTE): Struct;
+		VAR typ: Struct;
+	BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *)
+		typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ
+	END NewStr;
+	
+	PROCEDURE NewNode*(class: BYTE): 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 NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String;
+		VAR i: INTEGER; p: String;
+	BEGIN
+		i := 0; WHILE name[i] # 0X DO INC(i) END;
+		IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p
+		ELSE RETURN null
+		END
+	END NewName;
+
+	PROCEDURE OpenScope*(level: BYTE; 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*(opt: SET);
+	BEGIN
+		topScope := universe; OpenScope(0, NIL); SYSimported := FALSE;
+		GlbMod[0] := topScope; nofGmod := 1;
+		sfpresent := TRUE;	(* !!! *)
+		symChanges := 0;
+		infinity.conval.intval := DevCPM.ConstNotAlloc;
+		depth := 0
+	END Init;
+	
+	PROCEDURE Open* (name: Name);
+	BEGIN
+		SelfName := name$; topScope.name := NewName(name);
+	END Open;
+
+	PROCEDURE Close*;
+		VAR i: SHORTINT;
+	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 SameType* (x, y: Struct): BOOLEAN;
+	BEGIN
+		RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp)
+	END SameType;
+	
+	PROCEDURE EqualType* (x, y: Struct): BOOLEAN;
+		VAR xp, yp: Object; n: INTEGER;
+	BEGIN
+		n := 0;
+		WHILE (n < 100) & (x # y)
+			& (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag))
+				OR ((x.form = Pointer) & (y.form = Pointer))
+				OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO
+			IF x.form = ProcTyp THEN
+				IF x.sysflag # y.sysflag THEN RETURN FALSE END;
+				xp := x.link; yp := y.link;
+				INC(depth);
+				WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag)
+						& (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO
+					xp := xp.link; yp := yp.link
+				END;
+				DEC(depth);
+				IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END
+			END;
+			x := x.BaseTyp; y := y.BaseTyp; INC(n)
+		END;
+		RETURN SameType(x, y)
+	END EqualType;
+	
+	PROCEDURE Extends* (x, y: Struct): BOOLEAN;
+	BEGIN
+		IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END;
+		IF (x.comp = Record) & (y.comp = Record) THEN
+			IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END;
+			WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END
+		END;
+		RETURN (x # NIL) & EqualType(x, y)
+	END Extends;
+	
+	PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN;
+	BEGIN
+		CASE xform OF
+		| Char16: RETURN yform IN {Char8, Char16, Int8}
+		| Int16: RETURN yform IN {Char8, Int8, Int16}
+		| Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32}
+		| Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64}
+		| Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32}
+		| Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64}
+		| String16: RETURN yform IN {String8, String16}
+		ELSE RETURN xform = yform
+		END
+	END Includes;
+	
+	PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object);
+		VAR obj: Object; (* i: INTEGER; n: Name; *)
+	BEGIN obj := mod.scope.right;
+		LOOP
+			IF obj = NIL THEN EXIT END ;
+			IF name < obj.name^ THEN obj := obj.left
+			ELSIF 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;
+(*	bh: checks usage of non Unicode WinApi functions and types
+		IF (res # NIL) & (mod.scope.library # NIL)
+				& ~(DevCPM.interface IN DevCPM.options)
+				& (SelfName # "Kernel") & (SelfName # "HostPorts") THEN
+			n := name + "W";
+			FindImport(n, mod, obj);
+			IF obj # NIL THEN
+				DevCPM.err(733)
+			ELSE
+				i := LEN(name$);
+				IF name[i - 1] = "A" THEN
+					n[i - 1] := "W"; n[i] := 0X;
+					FindImport(n, mod, obj);
+					IF obj # NIL THEN
+						DevCPM.err(734)
+					END
+				END
+			END
+		END;
+*)
+	END FindImport;
+
+	PROCEDURE Find*(VAR name: Name; VAR res: Object);
+		VAR obj, head: Object;
+	BEGIN head := topScope;
+		LOOP obj := head.right;
+			LOOP
+				IF obj = NIL THEN EXIT END ;
+				IF name < obj.name^ THEN obj := obj.left
+				ELSIF 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 FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
+		VAR obj: Object;
+	BEGIN 
+		WHILE (typ # NIL) & (typ # undftyp) 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 FindFld;
+	
+	PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
+	BEGIN
+		FindFld(name, typ, res);
+		IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
+	END FindField;
+	
+	PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
+	BEGIN
+		FindFld(name, typ.BaseTyp, res);
+		IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
+	END FindBaseField;
+	
+(*
+	PROCEDURE Rotated (y: Object; name: String): Object;
+		VAR c, gc: Object;
+	BEGIN
+		IF name^ < y.name^ THEN
+			c := y.left;
+			IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
+			ELSE gc := c.right; c.right := gc.left; gc.left := c
+			END;
+			y.left := gc
+		ELSE
+			c := y.right;
+			IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
+			ELSE gc := c.right; c.right := gc.left; gc.left := c
+			END;
+			y.right := gc
+		END;
+		RETURN gc
+	END Rotated;
+	
+	PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
+		VAR gg, g, p, x: Object; name, sname: String;
+	BEGIN
+		sname := scope.name; scope.name := null;
+		gg := scope; g := gg; p := g; x := p.right; name := obj.name;
+		WHILE x # NIL DO
+			IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN
+				x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE;
+				IF p.red THEN
+					g.red := TRUE;
+					IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
+					x := Rotated(gg, name); x.red := FALSE
+				END
+			END;
+			gg := g; g := p; p := x;
+			IF name^ < x.name^ THEN x := x.left
+			ELSIF name^ > x.name^ THEN x := x.right
+			ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN
+			END
+		END;
+		x := obj; old := NIL;
+		IF name^ < p.name^ THEN p.left := x ELSE p.right := x END;
+		x.red := TRUE;
+		IF p.red THEN
+			g.red := TRUE;
+			IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
+			x := Rotated(gg, name);
+			x.red := FALSE
+		END;
+		scope.right.red := FALSE; scope.name := sname
+	END InsertIn;
+*)	
+	PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
+		VAR ob0, ob1: Object; left: BOOLEAN; name: String;
+	BEGIN
+		ASSERT((scope # NIL) & (scope.mode = Head), 100);
+		ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name;
+		WHILE ob1 # NIL DO
+			IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
+			ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
+			ELSE old := ob1; RETURN
+			END
+		END;
+		IF left THEN ob0.left := obj ELSE ob0.right := obj END ;
+		obj.left := NIL; obj.right := NIL; old := NIL
+	END InsertIn;
+
+	PROCEDURE Insert* (VAR name: Name; VAR obj: Object);
+		VAR old: Object;
+	BEGIN
+		obj := NewObj(); obj.leaf := TRUE;
+		obj.name := NewName(name);
+		obj.mnolev := topScope.mnolev;
+		InsertIn(obj, topScope, old);
+		IF old # NIL THEN err(1) END	(*double def*)
+	END Insert;
+	
+	PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object);
+		VAR ob0, ob1: Object; left: BOOLEAN; name: String;
+	BEGIN
+		IF typ.link = NIL THEN typ.link := obj
+		ELSE
+			ob1 := typ.link; name := obj.name;
+			REPEAT
+				IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
+				ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
+				ELSE old := ob1; RETURN
+				END
+			UNTIL ob1 = NIL;
+			IF left THEN ob0.left := obj ELSE ob0.right := obj END
+		END
+	END InsertThisField;
+
+	PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object);
+		VAR old: Object;
+	BEGIN
+		obj := NewObj(); obj.leaf := TRUE;
+		obj.name := NewName(name);
+		InsertThisField(obj, typ, old);
+		IF old # NIL THEN err(1) END	(*double def*)
+	END InsertField;
+
+
+(*-------------------------- Fingerprinting --------------------------*)
+
+	PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR);
+		VAR i: SHORTINT; ch: SHORTCHAR;
+	BEGIN i := 0;
+		REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X
+	END FPrintName;
+
+	PROCEDURE ^IdFPrint*(typ: Struct);
+
+	PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object);
+	(* depends on assignment compatibility of params only *)
+	BEGIN
+		IdFPrint(result); DevCPM.FPrint(fp, result.idfp);
+		WHILE par # NIL DO
+			DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp);
+			IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END;	(* IN / OUT *)
+			IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END;
+			(* 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: INTEGER; f, c: SHORTINT;
+	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; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c);
+			btyp := typ.BaseTyp; strobj := typ.strobj;
+			IF (strobj # NIL) & (strobj.name # null) 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); DevCPM.FPrint(idfp, btyp.idfp)
+			ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.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: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER;
+
+		PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
+
+		PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER);	(* modifies pvfp only *)
+			VAR i, j, n: INTEGER; 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 <= DevCPM.MaxHdFld) *) DO	(* !!! *)
+							INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i)
+						END
+					END
+				END
+			ELSIF DevCPM.ExpHdPtrFld &
+				((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN	(* !!! *)
+				DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
+			ELSIF DevCPM.ExpHdUtPtrFld &
+				((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN	(* !!! *)
+				DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld);
+				IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END
+			ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
+				DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
+			END
+		END FPrintHdFld;
+
+		PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);	(* modifies pbfp and pvfp *)
+		BEGIN
+			WHILE (fld # NIL) & (fld.mode = Fld) DO
+				IF (fld.vis # internal) & visible THEN
+					DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr);
+					FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.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
+						IF obj.vis = externalR THEN DevCPM.FPrint(pbfp, externalR) END;
+						IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(pbfp, limAttr)
+						ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(pbfp, absAttr)
+						ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(pbfp, empAttr)
+						ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(pbfp, extAttr)
+						END;
+						DevCPM.FPrint(pbfp, TProc); DevCPM.FPrint(pbfp, obj.num);
+						FPrintSign(pbfp, obj.typ, obj.link); FPrintName(pbfp, obj.name^);
+						IF obj.entry # NIL THEN FPrintName(pbfp, obj.entry^) END
+					ELSIF DevCPM.ExpHdTProc THEN
+						DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num)
+					END
+				END;
+				FPrintTProcs(obj.right)
+			END
+		END FPrintTProcs;
+
+	BEGIN
+		IF ~typ.fpdone THEN
+			IdFPrint(typ); pbfp := typ.idfp;
+			IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END;
+			IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END;
+			IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) 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 = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN
+					FPrintStr(btyp); DevCPM.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); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp
+			ELSE (* c = Record *)
+				IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ;
+				DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n);
+				nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE);
+(*
+				IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(225, typ.txtpos) END ;
+*)
+				FPrintTProcs(typ.link); DevCPM.FPrint(pvfp, pbfp); strobj := typ.strobj;
+				IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END
+			END ;
+			typ.pbfp := pbfp; typ.pvfp := pvfp
+		END
+	END FPrintStr;
+
+	PROCEDURE FPrintObj*(obj: Object);
+		VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER;
+	BEGIN
+		IF ~obj.fpdone THEN
+			fprint := 0; obj.fpdone := TRUE;
+			DevCPM.FPrint(fprint, obj.mode);
+			IF obj.mode = Con THEN
+				f := obj.typ.form; DevCPM.FPrint(fprint, f);
+				CASE f OF
+				| Bool, Char8, Char16, Int8, Int16, Int32:
+					DevCPM.FPrint(fprint, obj.conval.intval)
+				| Int64:
+					x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0));
+					r := obj.conval.realval + obj.conval.intval - x * 4294967296.0;
+					IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
+					DevCPM.FPrint(fprint, SHORT(ENTIER(r)));
+					DevCPM.FPrint(fprint, x)
+				| Set:
+					DevCPM.FPrintSet(fprint, obj.conval.setval)
+				| Real32:
+					rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval)
+				| Real64:
+					DevCPM.FPrintLReal(fprint, obj.conval.realval)
+				| String8, String16:
+					FPrintName(fprint, obj.conval.ext^)
+				| NilTyp:
+				ELSE err(127)
+				END
+			ELSIF obj.mode = Var THEN
+				DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.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; DevCPM.FPrint(fprint, m);
+				WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END
+			ELSIF obj.mode = Typ THEN
+				FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp)
+			END ;
+			IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END;
+			IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN
+				IF obj.library # NIL THEN
+					FPrintName(fprint, obj.library^)
+				ELSIF obj.mnolev < 0 THEN
+					mod := GlbMod[-obj.mnolev];
+					IF (mod.library # NIL) THEN
+						FPrintName(fprint, mod.library^)
+					END
+				ELSIF obj.mnolev = 0 THEN
+					IF libName # "" THEN FPrintName(fprint, libName) END
+				END;
+				IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END
+			END;
+			obj.fprint := fprint
+		END
+	END FPrintObj;
+
+	PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT);	(* !!! *)
+		CONST
+			nl = 0DX;
+	BEGIN
+		IF errno = 249 THEN
+			DevCPM.errorMes := DevCPM.errorMes + nl + " ";
+			DevCPM.errorMes := DevCPM.errorMes + GlbMod[-obj.mnolev].name^;
+			DevCPM.errorMes := DevCPM.errorMes + "." + obj.name^;
+			DevCPM.errorMes := DevCPM.errorMes +" is not consistently imported";
+			err(249)
+		ELSIF obj = NIL THEN	(* changed module sys flags *)
+			IF ~symNew & sfpresent THEN
+				DevCPM.errorMes := DevCPM.errorMes + nl + "  changed library flag"
+			END
+		ELSIF obj.mnolev = 0 THEN	(* don't report changes in imported modules *)
+			IF sfpresent THEN
+				IF symChanges < 20 THEN
+					DevCPM.errorMes := DevCPM.errorMes + nl + " " + obj.name^;
+					IF errno = 250 THEN DevCPM.errorMes := DevCPM.errorMes + " is no longer in symbol file"
+					ELSIF errno = 251 THEN DevCPM.errorMes := DevCPM.errorMes + " is redefined internally "
+					ELSIF errno = 252 THEN DevCPM.errorMes := DevCPM.errorMes + " is redefined"
+					ELSIF errno = 253 THEN DevCPM.errorMes := DevCPM.errorMes + " is new in symbol file"
+					END
+				ELSIF symChanges = 20 THEN
+					DevCPM.errorMes := DevCPM.errorMes + nl + "  ..."
+				END;
+				INC(symChanges)
+			ELSIF (errno = 253) & ~symExtended THEN
+				DevCPM.errorMes := DevCPM.errorMes + nl + "  new symbol file"
+			END
+		END;
+		IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END
+	END FPrintErr;
+
+(*-------------------------- Import --------------------------*)
+
+	PROCEDURE InName(VAR name: String);
+		VAR i: SHORTINT; ch: SHORTCHAR; n: Name;
+	BEGIN i := 0;
+		REPEAT
+			DevCPM.SymRCh(ch); n[i] := ch; INC(i)
+		UNTIL ch = 0X;
+		IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END
+	END InName;
+	
+	PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE);	(* mno is global *)
+		VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String;
+	BEGIN
+		IF tag = 0 THEN mno := impCtxt.glbmno[0]
+		ELSIF tag > 0 THEN
+			lib := NIL;
+			IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
+			ASSERT(tag = Smname);
+			InName(name);
+			IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) 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; head.name := name;
+				mno := nofGmod; head.mnolev := SHORT(SHORT(-mno));
+				head.library := lib;
+				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[-tag]
+		END
+	END InMod;
+
+	PROCEDURE InConstant(f: INTEGER; conval: Const);
+		VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name;
+	BEGIN
+		CASE f OF
+		| Byte, Char8, Bool:
+			DevCPM.SymRCh(ch); conval.intval := ORD(ch)
+		| Char16:
+			DevCPM.SymRCh(ch); conval.intval := ORD(ch);
+			DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256
+		| Int8, Int16, Int32:
+			conval.intval := DevCPM.SymRInt()
+		| Int64:
+			DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*);
+			WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO
+				x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch)
+			END;
+			WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END;
+			conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s;
+			conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval))
+		| Set:
+			DevCPM.SymRSet(conval.setval)
+		| Real32:
+			DevCPM.SymRReal(rval); conval.realval := rval;
+			conval.intval := DevCPM.ConstNotAlloc
+		| Real64:
+			DevCPM.SymRLReal(conval.realval);
+			conval.intval := DevCPM.ConstNotAlloc
+		| String8, String16:
+			i := 0;
+			REPEAT
+				DevCPM.SymRCh(ch);
+				IF i < LEN(str) - 1 THEN str[i] := ch
+				ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch
+				ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch
+				ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch
+				END;
+				INC(i)
+			UNTIL ch = 0X;
+			IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END;
+			conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc;
+			IF f = String8 THEN conval.intval2 := i
+			ELSE
+				i := 0; y := 0;
+				REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0;
+				conval.intval2 := y
+			END
+(*		
+			ext := NewExt(); conval.ext := ext; i := 0;
+			REPEAT
+				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
+			UNTIL ch = 0X;
+			conval.intval2 := i;
+			conval.intval := DevCPM.ConstNotAlloc
+		| String16:
+			ext := NewExt(); conval.ext := ext; i := 0;
+			REPEAT
+				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i);
+				DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i)
+			UNTIL (ch = 0X) & (ch1 = 0X);
+			conval.intval2 := i;
+			conval.intval := DevCPM.ConstNotAlloc
+*)
+		| NilTyp:
+			conval.intval := 0
+(*
+		| Guid:
+			ext := NewExt(); conval.ext := ext; i := 0;
+			WHILE i < 16 DO
+				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
+			END;
+			ext[16] := 0X;
+			conval.intval2 := 16;
+			conval.intval := DevCPM.ConstNotAlloc;
+*)
+		END
+	END InConstant;
+
+	PROCEDURE ^InStruct(VAR typ: Struct);
+
+	PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object);
+		VAR last, new: Object; tag: INTEGER;
+	BEGIN
+		InStruct(res);
+		tag := DevCPM.SymRInt(); last := NIL;
+		WHILE tag # Send DO
+			new := NewObj(); new.mnolev := SHORT(SHORT(-mno));
+			IF last = NIL THEN par := new ELSE last.link := new END ;
+			IF tag = Ssys THEN
+				new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt();
+				IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar
+				ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar
+				END
+			END;
+			IF tag = Svalpar THEN new.mode := Var
+			ELSE new.mode := VarPar;
+				IF tag = Sinpar THEN new.vis := inPar
+				ELSIF tag = Soutpar THEN new.vis := outPar
+				END
+			END ;
+			InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name);
+			last := new; tag := DevCPM.SymRInt()
+		END
+	END InSign;
+
+	PROCEDURE InFld(): Object;	(* first number in impCtxt.nextTag, mno set outside *)
+		VAR tag: INTEGER; 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 := DevCPM.SymRInt()
+		ELSE
+			obj.mode := Fld;
+			IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName)
+			ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName);	(* !!! *)
+				obj.sysflag := 1
+			ELSIF tag = Ssys THEN
+				obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt()))
+			ELSE obj.name := NewName(DevCPM.HdProcName)
+			END;
+			obj.typ := undftyp; obj.vis := internal;
+			obj.adr := DevCPM.SymRInt()
+		END;
+		RETURN obj
+	END InFld;
+
+	PROCEDURE InTProc(mno: BYTE): Object;	(* first number in impCtxt.nextTag *)
+		VAR tag: INTEGER; obj: Object;
+	BEGIN
+		tag := impCtxt.nextTag;
+		obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno));
+		IF tag = Shdtpro THEN
+			obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName);
+			obj.link := NewObj();	(* dummy, easier in Browser *)
+			obj.typ := undftyp; obj.vis := internal;
+			obj.num := DevCPM.SymRInt()
+		ELSE
+			obj.vis := external;
+			IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END;
+			obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1;
+			IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END;
+			InSign(mno, obj.typ, obj.link); InName(obj.name);
+			obj.num := DevCPM.SymRInt();
+			IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr)
+			ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr)
+			ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr)
+			ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr)
+			END
+		END ;
+		RETURN obj
+	END InTProc;
+
+	PROCEDURE InStruct(VAR typ: Struct);
+		VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String;
+			t: Struct; obj, last, fld, old, dummy: Object;
+	BEGIN
+		tag := DevCPM.SymRInt();
+		IF tag # Sstruct THEN
+			tag := -tag;
+			IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END;	(* correction for new FirstRef *)
+			typ := impCtxt.ref[tag]
+		ELSE
+			ref := impCtxt.nofr; INC(impCtxt.nofr);
+			IF ref < impCtxt.minr THEN impCtxt.minr := ref END ;
+			tag := DevCPM.SymRInt();
+			InMod(tag, mno); InName(name); obj := NewObj();
+			IF name = null THEN
+				IF impCtxt.self THEN old := NIL	(* do not insert type desc anchor here, but in OPL *)
+				ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null
+				END ;
+				typ := NewStr(Undef, Basic)
+			ELSE obj.name := name; InsertIn(obj, GlbMod[mno], 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.ext := NIL;
+						typ.fpdone := FALSE; typ.idfpdone := FALSE
+					END
+				ELSE typ := NewStr(Undef, Basic)
+				END
+			END ;
+			impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(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 := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *)
+			tag := DevCPM.SymRInt();
+			IF tag = Ssys THEN
+				typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt()
+			END;
+			typ.untagged := typ.sysflag > 0;
+			IF tag = Slib THEN
+				InName(obj.library); tag := DevCPM.SymRInt()
+			END;
+			IF tag = Sentry THEN
+				InName(obj.entry); tag := DevCPM.SymRInt()
+			END;
+			IF tag = String8 THEN
+				InName(typ.ext); tag := DevCPM.SymRInt()
+			END;
+			CASE tag OF
+			| Sptr:
+				typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp)
+			| Sarr:
+				typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt();
+				typ.size := typ.n * typ.BaseTyp.size	(* !!! *)
+			| 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 ;
+				typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n;	(* !!! *)
+				IF typ.untagged THEN typ.size := DevCPM.PointerSize END
+			| Srec, Sabsrec, Slimrec, Sextrec:
+				typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp);
+				(* correction by ETH 18.1.96 *)
+				IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END;
+				typ.extlev := 0; t := typ.BaseTyp;
+				WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END;
+				typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt();
+				typ.n := DevCPM.SymRInt();
+				IF tag = Sabsrec THEN typ.attribute := absAttr
+				ELSIF tag = Slimrec THEN typ.attribute := limAttr
+				ELSIF tag = Sextrec THEN typ.attribute := extAttr
+				END;
+				impCtxt.nextTag := DevCPM.SymRInt(); last := NIL;
+				WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro)
+						OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO
+					fld := InFld(); fld.mnolev := SHORT(SHORT(-mno));
+					IF last # NIL THEN last.link := fld END ;
+					last := fld;
+					InsertThisField(fld, typ, dummy);
+					impCtxt.nextTag := DevCPM.SymRInt()
+				END ;
+				WHILE impCtxt.nextTag # Send DO fld := InTProc(mno);
+					InsertThisField(fld, typ, dummy);
+					impCtxt.nextTag := DevCPM.SymRInt()
+				END
+			| Spro:
+				typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link)
+			| Salias:
+				InStruct(t);
+				typ.form := t.form; typ.comp := Basic; typ.size := t.size;
+				typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE;
+				typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t
+			END ;
+			IF ref = impCtxt.minr THEN
+				WHILE ref < impCtxt.nofr DO
+					t := impCtxt.ref[ref]; FPrintStr(t);
+					obj := t.strobj;	(* obj.typ.strobj = obj, else obj.fprint differs (alias) *)
+					IF obj.name # null 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: BYTE): Object;	(* first number in impCtxt.nextTag *)
+		VAR ch: SHORTCHAR; obj, old: Object; typ: Struct;
+			tag, i, s: INTEGER; 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 := SHORT(SHORT(-mno)); obj.vis := external;
+			IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END;
+			IF tag = Slib THEN
+				InName(obj.library); tag := DevCPM.SymRInt()
+			END;
+			IF tag = Sentry THEN
+				InName(obj.entry); tag := DevCPM.SymRInt()
+			END;
+			IF tag >= Sxpro THEN
+				IF obj.conval = NIL THEN obj.conval := NewConst() END;
+				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;
+					s := DevCPM.SymRInt();
+					NEW(ext, s + 1); obj.conval.ext := ext;
+					ext^[0] := SHORT(CHR(s)); i := 1;
+					WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END
+				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	(* Constant *)
+				obj.conval := NewConst(); InConstant(tag, obj.conval);
+				IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END;
+				obj.mode := Con; obj.typ := impCtxt.ref[tag]; 
+			END ;
+			InName(obj.name)
+		END ;
+		FPrintObj(obj);
+		IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN
+			(* compute a global fingerprint to avoid structural type equivalence for anonymous types *)
+			DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct)
+		END ;
+		IF tag # Stype THEN
+			InsertIn(obj, GlbMod[mno], 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); FPrintStr(old.typ);	(* 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: Name; VAR name: Name; VAR done: BOOLEAN);
+		VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String;	(* done used in Browser *)
+	BEGIN
+		IF name = "SYSTEM" THEN
+			SYSimported := TRUE;
+			p := processor;
+			IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END;
+			INCL(DevCPM.options, p);	(* for sysflag handling *)
+			Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp;
+			h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h
+		ELSIF name = "COM" THEN
+			IF DevCPM.comAware IN DevCPM.options THEN
+				INCL(DevCPM.options, DevCPM.com);	(* for sysflag handling *)
+				Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp;
+				h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h;
+			ELSE err(151)
+			END;
+		ELSIF name = "JAVA" THEN
+			INCL(DevCPM.options, DevCPM.java)
+		ELSE
+			impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0;
+			impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0;
+			DevCPM.OldSym(name, done);
+			IF done THEN
+				lib := NIL;
+				impProc := SHORT(DevCPM.SymRInt());
+				IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END;
+				tag := DevCPM.SymRInt();
+				IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt()
+				ELSE version := 0
+				END;
+				IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
+				InMod(tag, mno);
+				IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN	(* symbol file name conflict *)
+					GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm);
+					DevCPM.CloseOldSym; done := FALSE
+				END;
+			END;
+			IF done THEN
+				GlbMod[mno].library := lib;
+				impCtxt.nextTag := DevCPM.SymRInt();
+				WHILE ~DevCPM.eofSF() DO
+					obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt()
+				END ;
+				Insert(aliasName, obj);
+				obj.mode := Mod; obj.scope := GlbMod[mno](*.right*);
+				GlbMod[mno].link := obj;
+				obj.mnolev  := SHORT(SHORT(-mno)); obj.typ := notyp;
+				DevCPM.CloseOldSym
+			ELSIF impCtxt.self THEN
+				sfpresent := FALSE
+			ELSE err(152)	(*sym file not found*)
+			END
+		END
+	END Import;
+
+(*-------------------------- Export --------------------------*)
+
+	PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR);
+		VAR i: SHORTINT; ch: SHORTCHAR;
+	BEGIN i := 0;
+		REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X
+	END OutName;
+	
+	PROCEDURE OutMod(mno: SHORTINT);
+		VAR mod: Object;
+	BEGIN
+		IF expCtxt.locmno[mno] < 0 THEN (* new mod *)
+			mod := GlbMod[mno];
+			IF mod.library # NIL THEN
+				DevCPM.SymWInt(Slib); OutName(mod.library^)
+			END;
+			DevCPM.SymWInt(Smname);
+			expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm);
+			OutName(mod.name^)
+		ELSE DevCPM.SymWInt(-expCtxt.locmno[mno])
+		END
+	END OutMod;
+
+	PROCEDURE ^OutStr(typ: Struct);
+	PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
+
+	PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER);
+		VAR i, j, n: INTEGER; 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 <= DevCPM.MaxHdFld) *) DO	(* !!! *)
+						INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i)
+					END
+				END
+			END
+		ELSIF DevCPM.ExpHdPtrFld &
+			((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN	(* !!! *)
+			DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld)
+		ELSIF DevCPM.ExpHdUtPtrFld &
+			((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN	(* !!! *)
+			DevCPM.SymWInt(Ssys);	(* DevCPM.SymWInt(Shdutptr); *)
+			IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END;
+			DevCPM.SymWInt(n);
+			DevCPM.SymWInt(adr); INC(nofhdfld);
+			IF n > 1 THEN portable := FALSE END	(* hidden untagged pointer are portable *)
+		ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
+			DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld)
+		END
+	END OutHdFld;
+
+	PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
+	BEGIN
+		WHILE (fld # NIL) & (fld.mode = Fld) DO
+			IF (fld.vis # internal) & visible THEN
+				IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ;
+				OutStr(fld.typ); OutName(fld.name^); DevCPM.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.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END;	
+			IF par.mode = Var THEN DevCPM.SymWInt(Svalpar)
+			ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar)
+			ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar)
+			ELSE DevCPM.SymWInt(Svarpar)
+			END ;
+			OutStr(par.typ);
+			DevCPM.SymWInt(par.adr);
+			OutName(par.name^); par := par.link
+		END ;
+		DevCPM.SymWInt(Send)
+	END OutSign;
+
+	PROCEDURE OutTProcs(typ: Struct; obj: Object);
+		VAR bObj: Object;
+	BEGIN
+		IF obj # NIL THEN
+			IF obj.mode = TProc THEN
+(*
+				IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN
+					FindBaseField(obj.name^, typ, bObj);
+					ASSERT((bObj # NIL) & (bObj.num = obj.num));
+					IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END
+					(* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *)
+				END;
+*)
+				IF obj.vis # internal THEN
+					IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END;
+					IF obj.entry # NIL THEN
+						DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
+					END;
+					IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro)
+					ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro)
+					ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro)
+					ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro)
+					ELSE DevCPM.SymWInt(Stpro)
+					END;
+					OutSign(obj.typ, obj.link); OutName(obj.name^);
+					DevCPM.SymWInt(obj.num)
+				ELSIF DevCPM.ExpHdTProc THEN
+					DevCPM.SymWInt(Shdtpro);
+					DevCPM.SymWInt(obj.num)
+				END
+			END;
+			OutTProcs(typ, obj.left);
+			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 DevCPM.SymWInt(-typ.ref)
+		ELSE
+			DevCPM.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 # null) 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 *)
+				END
+			ELSE DevCPM.SymWCh(0X)	(* anonymous => never inconsistent, pvfp influences the client fp *)
+			END;
+			IF typ.sysflag # 0 THEN	(* !!! *)
+				DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag);
+				IF typ.sysflag > 0 THEN portable := FALSE END
+			END;
+			IF strobj # NIL THEN
+				IF strobj.library # NIL THEN
+					DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE
+				END;
+				IF strobj.entry # NIL THEN
+					DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE
+				END
+			END;
+			IF typ.ext # NIL THEN
+				DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE
+			END;
+			CASE typ.form OF
+			| Pointer:
+				DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp)
+			| ProcTyp:
+				DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link)
+			| Comp:
+				CASE typ.comp OF
+				| Array:
+					DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n)
+				| DynArr:
+					DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp)
+				| Record:
+					IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec)
+					ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec)
+					ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec)
+					ELSE DevCPM.SymWInt(Srec)
+					END;
+					IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ;
+					(* BaseTyp should be Notyp, too late to change *)
+					DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n);
+					nofhdfld := 0; OutFlds(typ.link, 0, TRUE);
+(*
+					IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ;	(* !!! *)
+*)
+					OutTProcs(typ, typ.link); DevCPM.SymWInt(Send)
+				END
+			ELSE	(* alias structure *)
+				DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp)
+			END
+		END
+	END OutStr;
+
+	PROCEDURE OutConstant(obj: Object);
+		VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL;
+	BEGIN
+		f := obj.typ.form;
+(*
+		IF obj.typ = guidtyp THEN f := Guid END;
+*)
+		IF f = Int32 THEN
+			IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8
+			ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16
+			END
+		END;
+		DevCPM.SymWInt(f);
+		CASE f OF
+		| Bool, Char8:
+			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval)))
+		| Char16:
+			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256)));
+			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256)))
+		| Int8, Int16, Int32:
+			DevCPM.SymWInt(obj.conval.intval)
+		| Int64:
+			IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN
+				a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1
+			ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN
+				a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) /  2097152.0 (*2^21*)));
+				b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1
+			ELSE
+				a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*)));
+				r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*);
+				b := SHORT(ENTIER(r /  2097152.0 (*2^21*)));
+				c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*)))
+			END;
+			IF c >= 0 THEN
+				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
+				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
+				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128)))
+			END;
+			IF b >= 0 THEN
+				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
+				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
+				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128)))
+			END;
+			DevCPM.SymWInt(a)
+		| Set:
+			DevCPM.SymWSet(obj.conval.setval)
+		| Real32:
+			rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval)
+		| Real64:
+			DevCPM.SymWLReal(obj.conval.realval)
+		| String8, String16:
+			OutName(obj.conval.ext^)
+		| NilTyp:
+(*
+		| Guid:
+			i := 0;
+			WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END
+*)
+		ELSE err(127)
+		END
+	END OutConstant;
+
+	PROCEDURE OutObj(obj: Object);
+		VAR i, j: SHORTINT; 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:
+						IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END
+					| pvmodified:
+						IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END
+					END ;
+					IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END;
+					IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN
+						(* name alias for types handled in OutStr *)
+						IF obj.library # NIL THEN
+							DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE
+						END;
+						IF obj.entry # NIL THEN
+							DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
+						END
+					END;
+					CASE obj.mode OF
+					| Con:
+						OutConstant(obj); OutName(obj.name^)
+					| Typ:
+						IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ)
+						ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^)
+						END
+					| Var:
+						IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ;
+						OutStr(obj.typ); OutName(obj.name^);
+						IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN
+							(* compute fingerprint to avoid structural type equivalence *)
+							DevCPM.FPrint(expCtxt.reffp, obj.typ.ref)
+						END
+					| XProc:
+						DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^)
+					| IProc:
+						DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^)
+					| CProc:
+						DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext;
+						j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j);
+						WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ;
+						OutName(obj.name^); portable := FALSE
+					END
+				END
+			END ;
+			OutObj(obj.right)
+		END
+	END OutObj;
+
+	PROCEDURE Export*(VAR ext, new: BOOLEAN);
+			VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object;
+	BEGIN
+		symExtended := FALSE; symNew := FALSE; nofmod := nofGmod;
+		Import("@self", SelfName, done); nofGmod := nofmod;
+		ASSERT(GlbMod[0].name^ = SelfName);
+		IF DevCPM.noerr THEN	(* ~DevCPM.noerr => ~done *)
+			DevCPM.NewSym(SelfName);
+			IF DevCPM.noerr THEN
+				DevCPM.SymWInt(0);	(* portable symfile *)
+				DevCPM.SymWInt(actVersion);
+				old := GlbMod[0]; portable := TRUE;
+ 				IF libName # "" THEN
+					DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE;
+					IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN
+						FPrintErr(NIL, 252)
+					END
+				ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252)
+				END;
+				DevCPM.SymWInt(Smname); OutName(SelfName);
+				expCtxt.reffp := 0; expCtxt.ref := FirstRef;
+				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 DevCPM.noerr & ~portable THEN
+					DevCPM.SymReset;
+					DevCPM.SymWInt(processor)	(* nonportable symfile *)
+				END;
+				IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN
+					new := TRUE
+				END ;
+				IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END
+				(* DevCPM.RegisterNewSym is called in OP2 after writing the object file *)
+			END
+		END
+	END Export;	(* no new symbol file if ~DevCPM.noerr *)
+
+
+	PROCEDURE InitStruct(VAR typ: Struct; form: BYTE);
+	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: Name; val: INTEGER);
+		VAR obj: Object;
+	BEGIN
+		Insert(name, obj); obj.conval := NewConst();
+		obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val
+	END EnterBoolConst;
+
+	PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object);
+	BEGIN
+		Insert(name, obj); obj.conval := NewConst();
+		obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val
+	END EnterRealConst;
+
+	PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; 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: Name; num: SHORTINT);
+		VAR obj: Object;
+	BEGIN Insert(name, obj);
+		obj.mode := SProc; obj.typ := notyp; obj.adr := num
+	END EnterProc;
+	
+	PROCEDURE EnterAttr(name: Name; num: SHORTINT);
+		VAR obj: Object;
+	BEGIN Insert(name, obj);
+		obj.mode := Attr; obj.adr := num
+	END EnterAttr;
+
+	PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT);
+		VAR obj, par: Object;
+	BEGIN
+		InsertField(name, rec, obj);
+		obj.mnolev := -128;	(* for correct implement only behaviour *)
+		obj.mode := TProc; obj.num := num; obj.conval := NewConst();
+		obj.conval.setval := obj.conval.setval + {newAttr};
+		IF typ = 0 THEN	(* FINALIZE, RELEASE *)
+			obj.typ := notyp; obj.vis := externalR;
+			INCL(obj.conval.setval, empAttr)
+		ELSIF typ = 1 THEN	(* QueryInterface *)
+			par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar;
+			par.sysflag := 8; par.adr := 16; par.typ := punktyp;
+			par.link := obj.link; obj.link := par;
+			par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar;
+			par.sysflag := 16; par.adr := 12; par.typ := guidtyp;
+			par.link := obj.link; obj.link := par;
+			obj.typ := restyp; obj.vis := external;
+			INCL(obj.conval.setval, extAttr)
+		ELSIF typ = 2 THEN	(* AddRef, Release *)
+			obj.typ := notyp; obj.vis := externalR;
+			INCL(obj.conval.setval, isHidden);
+			INCL(obj.conval.setval, extAttr)
+		END;
+		par := NewObj(); par.name := NewName("this"); par.mode := Var;
+		par.adr := 8; par.typ := ptr;
+		par.link := obj.link; obj.link := par;
+	END EnterTProc;
+
+	PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT);
+		VAR obj: Object;
+	BEGIN
+		obj := NewObj(); obj.mode := Fld;
+		obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs;
+		obj.link := root; root := obj
+	END EnterHdField;
+
+BEGIN
+	NEW(null, 1); null^ := "";
+	topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0;
+	InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
+	InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize;
+	InitStruct(string16typ, String16);
+	undftyp.BaseTyp := undftyp;
+
+	(*initialization of module SYSTEM*)
+(*
+	EnterTyp("BYTE", Byte, 1, bytetyp);
+	EnterProc("NEW", sysnewfn);
+*)
+	EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp);
+	EnterProc("ADR", adrfn);
+	EnterProc("TYP", typfn);
+	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("MOVE", movefn);
+	EnterProc("THISRECORD", thisrecfn);
+	EnterProc("THISARRAY", thisarrfn);
+	syslink := topScope.right; topScope.right := NIL;
+	
+	(* initialization of module COM *)
+	EnterProc("ID", iidfn);
+	EnterProc("QUERY", queryfn);
+	EnterTyp("RESULT", Int32, 4, restyp);
+	restyp.ref := Res;
+	EnterTyp("GUID", Guid, 16, guidtyp);
+	guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16;
+	EnterTyp("IUnknown^", IUnk, 12, iunktyp);
+	iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3;
+	iunktyp.attribute := absAttr;
+(*
+	EnterHdField(iunktyp.link, 12);
+*)
+	iunktyp.BaseTyp := NIL; iunktyp.align := 4;
+	iunktyp.sysflag := interface; iunktyp.untagged := TRUE;
+	NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}";
+	EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp);
+	punktyp.form := Pointer; punktyp.BaseTyp := iunktyp;
+	punktyp.sysflag := interface; punktyp.untagged := TRUE;
+	EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1);
+	EnterTProc(punktyp, iunktyp, "AddRef", 1, 2);
+	EnterTProc(punktyp, iunktyp, "Release", 2, 2);
+	comlink := topScope.right; topScope.right := NIL;
+	
+	universe := topScope;
+	EnterProc("LCHR", lchrfn);
+	EnterProc("LENTIER", lentierfcn);
+	EnterTyp("ANYREC", AnyRec, 0, anytyp);
+	anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1;
+	anytyp.BaseTyp := NIL; anytyp.extlev := -1;	(* !!! *)
+	anytyp.attribute := absAttr;
+	EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp);
+	anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp;
+	EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0);
+	EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0);
+	EnterProc("VALID", validfn);
+
+	EnterTyp("SHORTCHAR", Char8, 1, char8typ);
+	string8typ.BaseTyp := char8typ;
+	EnterTyp("CHAR", Char16, 2, char16typ);
+	EnterTyp("LONGCHAR", Char16, 2, lchar16typ);
+	string16typ.BaseTyp := char16typ;
+	EnterTyp("SET", Set, 4, settyp);
+	EnterTyp("BYTE", Int8, 1, int8typ);
+	guidtyp.BaseTyp := int8typ;
+	EnterTyp("SHORTINT", Int16, 2, int16typ);
+	EnterTyp("INTEGER",  Int32, 4, int32typ);
+	EnterTyp("LONGINT", Int64, 8, int64typ);
+	EnterTyp("LARGEINT", Int64, 8, lint64typ);
+	EnterTyp("SHORTREAL", Real32, 4, real32typ);
+	EnterTyp("REAL", Real64, 8, real64typ);
+	EnterTyp("LONGREAL", Real64, 8, lreal64typ);
+	EnterTyp("BOOLEAN", Bool, 1, booltyp);
+	EnterBoolConst("FALSE", 0);	(* 0 and 1 are compiler internal representation only *)
+	EnterBoolConst("TRUE",  1);
+	EnterRealConst("INF", DevCPM.InfReal, infinity);
+	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);
+(*
+	EnterProc("ADR", adrfn);
+	EnterProc("TYP", typfn);
+*)
+	EnterProc("BITS", bitsfn);
+	EnterAttr("ABSTRACT", absAttr);
+	EnterAttr("LIMITED", limAttr);
+	EnterAttr("EMPTY", empAttr);
+	EnterAttr("EXTENSIBLE", extAttr);
+	NEW(intrealtyp); intrealtyp^ := real64typ^;
+	impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp;
+	impCtxt.ref[Bool] := booltyp;  impCtxt.ref[Char8] := char8typ;
+	impCtxt.ref[Int8] := int8typ;  impCtxt.ref[Int16] := int16typ;
+	impCtxt.ref[Int32] := int32typ;  impCtxt.ref[Real32] := real32typ;
+	impCtxt.ref[Real64] := real64typ;  impCtxt.ref[Set] := settyp;
+	impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp;
+	impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp;
+	impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp;
+	impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ;
+	impCtxt.ref[Int64] := int64typ;
+	impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp; 
+	impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp;
+END LindevCPT.
+
+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 Var parameter (vis = 0 | inPar | outPar)
+    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 | entry  sizes   firstpar scope    leaf   Bound procedure, mthno = obj.num
+                                                    
+		Structures:
+
+    form    comp  | n      BaseTyp   link     mno  txtpos   sysflag
+	----------------------------------------------------------------------------------
+    Undef   Basic |
+    Byte    Basic |
+    Bool    Basic |
+    Char8   Basic |
+    Int8    Basic |
+    Int16   Basic |
+    Int32   Basic |
+    Real32  Basic |
+    Real64  Basic |
+    Set     Basic |
+    String8 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
+    Char16  Basic |
+    String16Basic |
+    Int64   Basic |
+
+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    ptr/str            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
+                        bit                expr                nextexpr {x}
+                        adr                expr                nextexpr SYSTEM.ADR
+                        typ                expr                nextexpr SYSTEM.TYP
+                        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
+                        min                expr      expr      nextexpr MIN
+                        max                expr      expr      nextexpr MAX
+                        bit                expr      expr      nextexpr SYSTEM.BIT
+                        lsh                expr      expr      nextexpr SYSTEM.LSH
+                        rot                expr      expr      nextexpr SYSTEM.ROT
+              Ncall               fpar     design    nextexpr  nextexpr
+              Ncomp                        stat      expr      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    nextexp   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
+              Ncomp                        stat      stat      stat

BlackBox/Lindev/Mod/CPV486.txt

@@ -0,0 +1,1775 @@
+MODULE LindevCPV486;
+
+	(* THIS IS TEXT COPY OF CPV486.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, DevCPM := LindevCPM, DevCPT := LindevCPT, DevCPE := LindevCPE, 
+		DevCPH := LindevCPH, DevCPL486 := LindevCPL486, DevCPC486 := LindevCPC486;
+	
+	CONST
+		processor* = 10; (* for i386 *)
+
+		(* 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;
+		
+		(* item modes for i386 *)
+		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
+
+		(* symbol values and 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;
+		min = 34; max = 35; typfn = 36;
+		thisrecfn = 45; thisarrfn = 46;
+		shl = 50; shr = 51; lshr = 52; xor = 53;
+
+		(* structure forms *)
+		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
+		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
+		Pointer = 13; ProcTyp = 14; Comp = 15;
+		Char16 = 16; String16 = 17; Int64 = 18;
+		VString16to8 = 29; VString8 = 30; VString16 = 31;
+		realSet = {Real32, Real64};
+
+		(* 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; Ncomp = 30;
+		Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
+
+		(*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;
+		
+		(* COM function number *)
+		validfn = 40; queryfn = 42;
+		
+		(* procedure flags (conval.setval) *)
+		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31;
+
+		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
+		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
+		
+		(* case statement flags (conval.setval) *)
+		useTable = 1; useTree = 2;
+		
+		(* registers *)
+		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
+		stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24;
+		wreg = {AX, BX, CX, DX, SI, DI};
+
+		(* module visibility of objects *)
+		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
+
+		(* sysflag *)
+		untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7;
+		interface = 10; guarded = 8; noframe = 16;
+		nilBit = 1; enumBits = 8; new = 1; iid = 2;
+		stackArray = 120;
+		
+		(* system trap numbers *)
+		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
+		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
+		
+		ParOff = 8;
+		interfaceSize = 16;	(* SIZE(Kernel.Interface) *)
+		addRefFP = 4E27A847H;	(* fingerprint of AddRef and Release procedures *)
+		intHandlerFP = 24B0EAE3H;	(* fingerprint of InterfaceTrapHandler *)
+		numPreIntProc = 2;
+		
+		
+	VAR
+		Exit, Return: DevCPL486.Label;
+		assert, sequential: BOOLEAN;
+		nesting, actual: INTEGER;
+		query, addRef, release, release2: DevCPT.Object;
+		
+	PROCEDURE Init*(opt: SET);
+		CONST ass = 2;
+	BEGIN
+		DevCPL486.Init(opt); DevCPC486.Init(opt);
+		assert := ass IN opt;
+		DevCPM.breakpc := MAX(INTEGER);
+		query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL;
+	END Init;
+	
+	PROCEDURE Close*;
+	BEGIN
+		DevCPL486.Close
+	END Close;
+
+	PROCEDURE Align(VAR offset: INTEGER; align: INTEGER);
+	BEGIN
+		CASE align OF
+		   1: (* ok *)
+		| 2: INC(offset, offset MOD 2)
+		| 4: INC(offset, (-offset) MOD 4)
+		| 8: INC(offset, (-offset) MOD 8)
+		END
+	END Align;
+	
+	PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER);
+	BEGIN
+		CASE align OF
+		   1: (* ok *)
+		| 2: DEC(offset, offset MOD 2)
+		| 4: DEC(offset, offset MOD 4)
+		| 8: DEC(offset, offset MOD 8)
+		END
+	END NegAlign;
+	
+	PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER;	(* typ.comp # DynArr *)
+		VAR align: INTEGER;
+	BEGIN
+		WHILE typ.comp = Array DO typ := typ.BaseTyp END ;
+		IF typ.comp = Record THEN
+			align := typ.align
+		ELSE
+			align := typ.size;
+		END;
+		IF align > limit THEN RETURN limit ELSE RETURN align END
+	END Base;
+
+(* -----------------------------------------------------
+	reference implementation of TypeSize for portable symbol files
+	mandatory for all non-system structures
+
+	PROCEDURE TypeSize (typ: DevCPT.Struct);
+		VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
+	BEGIN
+		IF typ.size = -1 THEN
+			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
+			IF c = Record THEN
+				IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END;
+				fld := typ.link;
+				WHILE (fld # NIL) & (fld.mode = Fld) DO
+					btyp := fld.typ; TypeSize(btyp);
+					IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4)
+					ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2)
+					END;
+					fld.adr := offset; INC(offset, btyp.size);
+					fld := fld.link
+				END;
+				IF offset > 2 THEN INC(offset, (-offset) MOD 4) END;
+				typ.size := offset; typ.align := 4;
+				typ.n := -1  (* methods not counted yet *)
+			ELSIF c = Array THEN
+				TypeSize(btyp);
+				typ.size := typ.n * btyp.size
+			ELSIF f = Pointer THEN
+				typ.size := DevCPM.PointerSize
+			ELSIF f = ProcTyp THEN
+				typ.size := DevCPM.ProcSize
+			ELSE (* c = DynArr *)
+				TypeSize(btyp);
+				IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
+				ELSE typ.size := 8
+				END
+			END
+		END
+	END TypeSize;
+
+----------------------------------------------------- *)
+
+	PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN);
+		VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER;
+			fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name;
+	BEGIN
+		IF typ.untagged THEN guarded := TRUE END;
+		IF typ = DevCPT.undftyp THEN DevCPM.err(58)
+		ELSIF typ.size = -1 THEN
+			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
+			IF c = Record THEN
+				IF btyp = NIL THEN offset := 0; align := 1;
+				ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align
+				END ;
+				IF typ.sysflag = noAlign THEN alignLimit := 1
+				ELSIF typ.sysflag = align2 THEN alignLimit := 2
+				ELSIF typ.sysflag = align8 THEN alignLimit := 8
+				ELSE alignLimit := 4
+				END;
+				fld := typ.link;
+				WHILE (fld # NIL) & (fld.mode = Fld) DO
+					btyp := fld.typ; GTypeSize(btyp, guarded);
+					IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit)
+					ELSIF btyp.size >= 4 THEN falign := 4
+					ELSIF btyp.size >= 2 THEN falign := 2
+					ELSE falign := 1
+					END;
+					IF typ.sysflag = union THEN
+						fld.adr := 0;
+						IF btyp.size > offset THEN offset := btyp.size END;
+					ELSE
+						Align(offset, falign);
+						fld.adr := offset;
+						IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size)
+						ELSE offset := 4; DevCPM.Mark(214, typ.txtpos)
+						END						
+					END;
+					IF falign > align THEN align := falign END ;
+					fld := fld.link
+				END;
+(*
+				IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN
+					fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
+					fld.typ := DevCPT.undftyp; fld.adr := 8;
+					fld.right := typ.link; typ.link := fld;
+					fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
+					fld.typ := DevCPT.undftyp; fld.adr := 12;
+					typ.link.link := fld; typ.link.left := fld;
+					offset := interfaceSize; align := 4
+				END;
+*)
+				IF typ.sysflag <= 0 THEN align := 4 END;
+				typ.align := align;
+				IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END;
+				typ.size := offset;
+				typ.n := -1  (* methods not counted yet *)
+			ELSIF c = Array THEN
+				GTypeSize(btyp, guarded);
+				IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size
+				ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos)
+				END
+			ELSIF f = Pointer THEN
+				typ.size := DevCPM.PointerSize;
+				IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END
+			ELSIF f = ProcTyp THEN
+				typ.size := DevCPM.ProcSize
+			ELSE (* c = DynArr *)
+				GTypeSize(btyp, guarded);
+				IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4
+				ELSE
+					IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
+					ELSE typ.size := 8
+					END
+				END
+			END
+		END
+	END GTypeSize;
+	
+	PROCEDURE TypeSize*(typ: DevCPT.Struct);	(* also called from DevCPT.InStruct for arrays *)
+	BEGIN
+		GTypeSize(typ, FALSE)
+	END TypeSize;
+	
+	PROCEDURE GetComKernel;
+		VAR name: DevCPT.Name; mod: DevCPT.Object;
+	BEGIN
+		IF addRef = NIL THEN
+			DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL);
+			DevCPT.topScope.name := DevCPT.NewName("$$");
+			name := "AddRef"; DevCPT.Insert(name, addRef);
+			addRef.mode := XProc;
+			addRef.fprint := addRefFP;
+			addRef.fpdone := TRUE;
+			name := "Release"; DevCPT.Insert(name, release);
+			release.mode := XProc;
+			release.fprint := addRefFP;
+			release.fpdone := TRUE;
+			name := "Release2"; DevCPT.Insert(name, release2);
+			release2.mode := XProc;
+			release2.fprint := addRefFP;
+			release2.fpdone := TRUE;
+			name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler);
+			DevCPC486.intHandler.mode := XProc;
+			DevCPC486.intHandler.fprint := intHandlerFP;
+			DevCPC486.intHandler.fpdone := TRUE;
+			DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope;
+			INC(DevCPT.nofGmod);
+			DevCPT.CloseScope;
+		END
+	END GetComKernel;
+
+	PROCEDURE EnumTProcs(rec: DevCPT.Struct);	(* method numbers in declaration order *)
+		VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object;
+	BEGIN
+		IF rec.n = -1 THEN
+			rec.n := 0; btyp := rec.BaseTyp;
+			IF btyp # NIL THEN
+				EnumTProcs(btyp); rec.n := btyp.n;
+			END;
+			obj := rec.strobj.link;
+			WHILE obj # NIL DO
+				DevCPT.FindBaseField(obj.name^, rec, redef);
+				IF redef # NIL THEN obj.num := redef.num (*mthno*);
+					IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
+						DevCPM.Mark(119, rec.txtpos)
+					END
+				ELSE obj.num := rec.n; INC(rec.n)
+				END ;
+				IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END;
+				obj := obj.nlink
+			END
+		END
+	END EnumTProcs;
+
+	PROCEDURE CountTProcs(rec: DevCPT.Struct);
+		VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name;
+
+		PROCEDURE TProcs(obj: DevCPT.Object);	(* obj.mnolev = 0, TProcs of base type already counted *)
+			VAR redef: DevCPT.Object;
+		BEGIN
+			IF obj # NIL THEN
+				TProcs(obj.left);
+				IF obj.mode = TProc THEN
+					DevCPT.FindBaseField(obj.name^, rec, redef);
+					(* obj.adr := 0 *)
+					IF redef # NIL THEN
+						obj.num := redef.num (*mthno*);
+						IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN
+							obj.num := numPreIntProc + comProc - 1 - obj.num
+						END;
+						IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
+							DevCPM.Mark(119, rec.txtpos)
+						END
+					ELSE obj.num := rec.n; INC(rec.n)
+					END ;
+					IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END
+				END ;
+				TProcs(obj.right)
+			END
+		END TProcs;
+
+	BEGIN
+		IF rec.n = -1 THEN
+			comProc := 0;
+			IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END;
+			btyp := rec.BaseTyp;
+			IF btyp # NIL THEN
+				IF btyp.sysflag = interface THEN
+					EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n;
+				ELSE
+					CountTProcs(btyp); rec.n := btyp.n
+				END
+			END;
+			WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END;
+			IF (btyp # NIL) & (btyp.sysflag = interface) THEN
+				IF comProc > 0 THEN
+					name := "QueryInterface"; DevCPT.FindField(name, rec, m);
+					IF m.link.typ.sysflag = interface THEN
+						DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec;
+						m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr};
+						m.nlink := query; query := m
+					END;
+					name := "AddRef";
+					DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
+					m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
+					GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef;
+				END;
+				name := "RELEASE";
+				DevCPT.FindField(name, rec, rel);
+				IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END;
+				IF (comProc > 0) OR (rel # NIL) THEN
+					name := "Release";
+					DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
+					m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
+					GetComKernel; m.adr := -1;
+					IF rel # NIL THEN release2.used := TRUE; m.nlink := release2
+					ELSE release.used := TRUE; m.nlink := release
+					END
+				END
+			END;
+			TProcs(rec.link);
+		END
+	END CountTProcs;
+	
+	PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object);
+
+	PROCEDURE ^TProcedures(obj: DevCPT.Object);
+
+	PROCEDURE TypeAlloc(typ: DevCPT.Struct);
+		VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
+	BEGIN
+		IF ~typ.allocated THEN	(* not imported, not predefined, not allocated yet *)
+			typ.allocated := TRUE;
+			TypeSize(typ);
+			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
+			IF c = Record THEN
+				IF typ.sysflag = interface THEN
+					EnumTProcs(typ);
+				ELSE
+					CountTProcs(typ)
+				END;
+				IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END;
+				IF btyp # NIL THEN TypeAlloc(btyp) END;
+				IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END;
+				fld := typ.link;
+				WHILE (fld # NIL) & (fld.mode = Fld) DO
+					TypeAlloc(fld.typ); fld := fld.link
+				END;
+				TProcedures(typ.link)
+			ELSIF f = Pointer THEN
+				IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos)
+				ELSE TypeAlloc(btyp);
+				END
+			ELSIF f = ProcTyp THEN
+				TypeAlloc(btyp);
+				Parameters(typ.link, NIL)
+			ELSE (* c IN {Array, DynArr} *) 
+				TypeAlloc(btyp);
+				IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END;
+			END
+		END
+	END TypeAlloc;
+
+	PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
+	BEGIN
+		WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
+		IF typ # NIL THEN RETURN typ.n
+		ELSE RETURN 0
+		END
+	END NumOfIntProc;
+	
+	PROCEDURE Parameters(firstPar, proc: DevCPT.Object);
+	(* firstPar.mnolev = 0 *)
+		VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER;
+	BEGIN
+		padr := ParOff; par := firstPar;
+		WHILE par # NIL DO
+			typ := par.typ; TypeAlloc(typ);
+			par.adr := padr;
+			IF (par.mode = VarPar) & (typ.comp # DynArr) THEN
+				IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8)
+				ELSE INC(padr, 4)
+				END
+			ELSE
+				IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END;
+				INC(padr, typ.size); Align(padr, 4)
+			END;
+			par := par.link
+		END;
+		IF proc # NIL THEN
+			IF proc.mode = XProc THEN
+				INCL(proc.conval.setval, isCallback)
+			ELSIF (proc.mode = TProc)
+				& (proc.num >= numPreIntProc)
+				& (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ))
+			THEN
+				INCL(proc.conval.setval, isCallback);
+				INCL(proc.conval.setval, isGuarded)
+			END;
+			IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END;
+			IF isGuarded IN proc.conval.setval THEN
+				GetComKernel; vadr := -24
+			ELSE
+				vadr := 0;
+				IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END;
+				IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END
+			END;
+			proc.conval.intval := padr; proc.conval.intval2 := vadr;
+		END
+	END Parameters;
+	
+	PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER);
+	(* allocates only offsets, regs allocated in DevCPC486.Enter *)
+		VAR adr: INTEGER; typ: DevCPT.Struct;
+	BEGIN
+		adr := varSize;
+		WHILE var # NIL DO
+			typ := var.typ; TypeAlloc(typ);
+			DEC(adr, typ.size); NegAlign(adr, Base(typ, 4));
+			var.adr := adr;
+			var := var.link
+		END;
+		NegAlign(adr, 4); varSize := adr
+	END Variables;
+	
+	PROCEDURE ^Objects(obj: DevCPT.Object);
+
+	PROCEDURE Procedure(obj: DevCPT.Object);
+	(* obj.mnolev = 0 *)
+		VAR oldPos: INTEGER;
+	BEGIN
+		oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr;
+		TypeAlloc(obj.typ);
+		Parameters(obj.link, obj);
+		IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ;
+		Variables(obj.scope.scope, obj.conval.intval2);	(* local variables *)
+		Objects(obj.scope.right);
+		DevCPM.errpos := oldPos
+	END Procedure;
+
+	PROCEDURE TProcedures(obj: DevCPT.Object);
+	(* obj.mnolev = 0 *)
+		VAR par: DevCPT.Object; psize: INTEGER;
+	BEGIN
+		IF obj # NIL THEN
+			TProcedures(obj.left);
+			IF (obj.mode = TProc) & (obj.scope # NIL) THEN
+				TypeAlloc(obj.typ);
+				Parameters(obj.link, obj);
+				Variables(obj.scope.scope, obj.conval.intval2);	(* local variables *)
+				Objects(obj.scope.right);
+			END ;
+			TProcedures(obj.right)
+		END
+	END TProcedures;
+
+	PROCEDURE Objects(obj: DevCPT.Object);
+	BEGIN
+		IF obj # NIL THEN
+			Objects(obj.left);
+			IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN
+				IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ);
+				ELSE Procedure(obj)
+				END
+			END ;
+			Objects(obj.right)
+		END
+	END Objects;
+
+	PROCEDURE Allocate*;
+		VAR gvarSize: INTEGER; name: DevCPT.Name;
+	BEGIN
+		DevCPM.errpos := DevCPT.topScope.adr;	(* text position of scope used if error *)
+		gvarSize := 0;
+		Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize;
+		Objects(DevCPT.topScope.right)
+	END Allocate;
+	
+	(************************)
+
+	PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN;
+	BEGIN
+		WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO
+			CASE n1.class OF
+			| Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj
+			| Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval)
+			| Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END
+			| Nderef, Nguard:
+			| Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
+			| Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END
+			| Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
+			ELSE RETURN FALSE
+			END ;
+			n1 := n1.left; n2 := n2.left
+		END;
+		RETURN FALSE
+	END SameExp;
+	
+	PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER);
+		VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE;
+	BEGIN
+		used := {}; size := 0;
+		WHILE n # NIL DO
+			IF n.class # Ncomp THEN
+				Check(n.left, ux, sx);
+				Check(n.right, uy, sy)
+			END;
+			ux := ux + uy; sf := 0;
+			CASE n.class OF
+			| Nvar, Nvarpar:
+					IF (n.class = Nvarpar) OR  (n.typ.comp = DynArr) OR
+						(n.obj.mnolev > 0) &
+						(DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END
+			| Nguard: sf := 2
+			| Neguard, Nderef: sf := 1
+			| Nindex:
+					IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END;
+					IF sx > 0 THEN INC(sy) END
+			| Nmop:
+					CASE n.subcl OF
+					| is, adr, typfn, minus, abs, cap, val: sf := 1
+					| bit: sf := 2; INCL(ux, CX)
+					| conv:
+							IF n.typ.form = Int64 THEN sf := 2
+							ELSIF ~(n.typ.form IN realSet) THEN sf := 1;
+								IF n.left.typ.form IN realSet THEN INCL(ux, AX) END
+							END
+					| odd, cc, not:
+					END
+			| Ndop:
+					f := n.left.typ.form;
+					IF f # Bool THEN
+						CASE n.subcl OF
+						| times:
+								sf := 1;
+								IF f = Int8 THEN INCL(ux, AX) END
+						| div, mod:
+								sf := 3; INCL(ux, AX);
+								IF f > Int8 THEN INCL(ux, DX) END
+						| eql..geq:
+								IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4
+								ELSIF f IN realSet THEN INCL(ux, AX); sf := 1
+								ELSE sf := 1
+								END
+						| ash, lsh, rot:
+								IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END
+						| slash, plus, minus, msk, in, bit:
+								sf := 1
+						| len:
+								IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3
+								ELSE sf := 1
+								END
+						| min, max:
+								sf := 1;
+								IF f IN realSet THEN INCL(ux, AX) END
+						| queryfn:
+								ux := ux + {CX, SI, DI}; sf := 4
+						END;
+						IF sy > sx THEN INC(sx) ELSE INC(sy) END
+					END
+			| Nupto:
+					IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2
+					ELSE sf := 3
+					END;
+					INCL(ux, CX); INC(sx)
+			| Ncall, Ncomp:
+					sf := 10; ux := wreg + {float}
+			| Nfield, Nconst, Nproc, Ntype:
+			END;
+			used := used + ux;
+			IF sx > size THEN size := sx END;
+			IF sy > size THEN size := sy END;
+			IF sf > size THEN size := sf END;
+			n := n.link
+		END;
+		IF size > 10 THEN size := 10 END
+	END Check;
+	
+	PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
+	
+	PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET);
+		VAR ux, uy: SET; sx, sy: INTEGER;
+	BEGIN
+		Check(left, ux, sx); Check(right, uy, sy);
+		IF sy > sx THEN
+			expr(right, y, hy + stpy, ux + stpy * {AX, CX});
+			expr(left, x, hx, stpx);
+			DevCPC486.Assert(y, hy, stpy)
+		ELSE
+			expr(left, x, hx + stpx, uy);
+			expr(right, y, hy, stpy);
+			DevCPC486.Assert(x, hx, stpx)
+		END;
+	END DualExp;
+
+	PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET);
+		VAR y: DevCPL486.Item; rev: BOOLEAN;
+	BEGIN
+		DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk});
+		IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN
+			DevCPC486.IntDOp(x, y, n.subcl, FALSE)
+		ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN
+			DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
+		ELSIF x.mode # Reg THEN
+			DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
+		ELSIF y.mode # Reg THEN
+			DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
+		ELSE
+			DevCPC486.IntDOp(x, y, n.subcl, FALSE)
+		END
+	END IntDOp;
+	
+	PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item);
+		VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER;
+	BEGIN
+		Check(n.left, ux, sx); Check(n.right, uy, sy);
+		IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END;
+		IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN
+			expr(n.right, x, {}, ux + {mem, stk});
+			expr(n.left, y, {}, uf);
+			DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
+		ELSIF float IN uy THEN (* function calls in both operands *)
+			expr(n.left, y, {}, uy + {mem});
+			expr(n.right, x, {}, {mem, stk});
+			DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
+		ELSE
+			expr(n.left, x, {}, uy + {mem, stk});
+			expr(n.right, y, {}, uf);
+			DevCPC486.FloatDOp(x, y, n.subcl, FALSE)
+		END
+	END FloatDOp;
+	
+	PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER;
+	BEGIN
+		CASE n.class OF
+		  Nvar, Nvarpar:
+				obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0;
+				IF obj.typ.comp = DynArr THEN x.mode := VarPar END;
+				IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con
+				ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con
+				ELSE x.offset := 0; x.tmode := VarPar
+				END
+		| Nfield:
+				design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj)
+		| Nderef:
+				IF n.subcl # 0 THEN
+					expr(n.left, x, hint, stop);
+					IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END
+				ELSE
+					expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x)
+				END
+		| Nindex:
+				Check(n.left, ux, sx); Check(n.right, uy, sy);
+				IF wreg - uy = {} THEN
+					expr(n.right, y, hint + stop, ux);
+					design(n.left, x, hint, stop);
+					IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END
+				ELSE
+					design(n.left, x, hint, stop + uy);
+					IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {})
+					ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop)
+					END
+				END
+		| Nguard, Neguard:
+				IF n.typ.form = Pointer THEN
+					IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END
+				ELSE design(n.left, x, hint, stop)
+				END;
+				DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard)
+		| Nproc:
+				obj := n.obj; x.mode := obj.mode; x.obj := obj;
+				IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END
+		END;
+		x.typ := n.typ
+	END design;
+	
+	PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN;
+	BEGIN
+		IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN
+			WHILE x.class = Nindex DO x := x.left END;
+			IF x.class = Nderef THEN RETURN TRUE END
+		END;
+		RETURN FALSE
+	END IsAllocDynArr;
+	
+	PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN);
+		VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER;
+	BEGIN
+		Check(left, ux, sx);
+		expr(right, y, wreg - {SI} + ux, {});
+		ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux);
+		IF useLen & IsAllocDynArr(left) THEN	(* keep len descriptor *)
+			design(left, x, wreg - {CX}, {loaded});
+			DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI})
+		ELSE
+			expr(left, x, wreg - {DI}, {})
+		END;
+		ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con});
+		DevCPC486.Load(ay, {}, wreg - {SI} + {con});
+		DevCPC486.Free(ax); DevCPC486.Free(ay)
+	END StringOp;
+	
+	PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
+	BEGIN
+		IF n.class < Nconst THEN
+			design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop)
+		ELSE expr(n, x, hint, stop)
+		END
+	END AdrExpr;
+	
+	(* ---------- interface pointer reference counting ---------- *)
+	
+	PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN);
+	
+		PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER);
+			VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
+		BEGIN
+			IF (typ.form = Pointer) & (typ.sysflag = interface) THEN
+				IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END;
+				IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END
+			ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
+				btyp := typ.BaseTyp;
+				IF btyp # NIL THEN FindPtrs(btyp, adr) END ;
+				fld := typ.link;
+				WHILE (fld # NIL) & (fld.mode = Fld) DO
+					IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN
+						IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END;
+						IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END
+					ELSE FindPtrs(fld.typ, fld.adr + adr)
+					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 DevCPC486.ContainsIPtrs(btyp) THEN
+					i := 0;
+					WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END
+				END
+			ELSIF typ.comp = DynArr THEN 
+				IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END
+			END
+		END FindPtrs;
+	
+	BEGIN
+		FindPtrs(typ, 0)
+	END HandleIPtrs;
+	
+	PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN;
+	BEGIN
+		RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface)
+			& ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall))
+	END CountedPtr;
+	
+	PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET);
+		(* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
+	BEGIN
+		expr(ny, y, {}, wreg - {SI} + {mem, stk});
+		IF (ny.class # Nconst) & ~CountedPtr(ny) THEN
+			DevCPC486.IPAddRef(y, 0, TRUE)
+		END;
+		IF nx # NIL THEN
+			DevCPC486.Assert(y, {}, wreg - {SI} + ux);
+			expr(nx, x, wreg - {DI}, {loaded});
+			IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN
+				DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
+				x.mode := Ind; x.offset := 0; x.scale := 0
+			END;
+			DevCPC486.IPRelease(x, 0, TRUE, FALSE);
+		END
+	END IPAssign;
+	
+	PROCEDURE IPStructAssign (typ: DevCPT.Struct);
+		VAR x, y: DevCPL486.Item;
+	BEGIN
+		IF typ.comp = DynArr THEN DevCPM.err(270) END;
+		(* addresses in SI and DI *)
+		x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0;
+		y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0;
+		HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE)
+	END IPStructAssign;
+
+	PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item);
+	BEGIN
+		expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
+		x.mode := Ind; x.offset := 0; x.scale := 0;
+		IF nx.typ.form = Comp THEN
+			HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE)
+		ELSE	(* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
+			DevCPC486.IPRelease(x, 0, TRUE, TRUE);
+		END
+	END IPFree;
+	
+	(* unchanged val parameters allways counted because of aliasing problems REMOVED! *)
+	
+	PROCEDURE InitializeIPVars (proc: DevCPT.Object);
+		VAR x: DevCPL486.Item; obj: DevCPT.Object;
+	BEGIN
+		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
+		obj := proc.link;
+		WHILE obj # NIL DO
+			IF (obj.mode = Var) & obj.used THEN	(* changed value parameters *)
+				x.offset := obj.adr;
+				HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE)
+			END;
+			obj := obj.link
+		END
+	END InitializeIPVars;
+	
+	PROCEDURE ReleaseIPVars (proc: DevCPT.Object);
+		VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object;
+	BEGIN
+		obj := proc.link;
+		WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO
+			obj := obj.link
+		END;
+		IF obj = NIL THEN
+			obj := proc.scope.scope;
+			WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END;
+			IF obj = NIL THEN RETURN END
+		END;
+		DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32);
+		DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32);
+		IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END;
+		IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END;
+		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
+		obj := proc.link;
+		WHILE obj # NIL DO
+			IF (obj.mode = Var) & obj.used THEN	(* value parameters *)
+				x.offset := obj.adr;
+				HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE)
+			END;
+			obj := obj.link
+		END;
+		obj := proc.scope.scope;
+		WHILE obj # NIL DO	(* local variables *)
+			IF obj.used THEN
+				x.offset := obj.adr;
+				HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE);
+			END;
+			obj := obj.link
+		END;
+		IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END;
+		IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END
+	END ReleaseIPVars;
+	
+	PROCEDURE CompareIntTypes (
+		typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER
+	);
+		VAR x, y: DevCPL486.Item; local: DevCPL486.Label;
+	BEGIN
+		local := DevCPL486.NewLbl;
+		typ := typ.BaseTyp; num := 0;
+		WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO
+			IF (typ.sysflag = interface) & (typ.ext # NIL) THEN
+				IF num > 0 THEN DevCPC486.JumpT(x, local) END;
+				DevCPC486.GuidFromString(typ.ext, y);
+				x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem});
+				x := y; DevCPC486.GetAdr(x, wreg - {DI}, {});
+				x := id; DevCPC486.CmpString(x, y, eql, FALSE);
+				INC(num)
+			END;
+			typ := typ.BaseTyp
+		END;
+		IF num > 0 THEN DevCPC486.JumpF(x, exit) END;
+		IF num > 1 THEN DevCPL486.SetLabel(local) END
+	END CompareIntTypes;
+	
+	PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object);
+		VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER;
+	BEGIN
+		nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl;
+		this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp;
+		id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer;
+		int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer;
+		DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0;
+		DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c);
+		unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp;
+		DevCPC486.Load(unk, {}, {});
+		unk.mode := Ind; unk.offset := 8;
+		DevCPC486.Load(unk, {}, {});
+		DevCPL486.GenComp(c, unk);
+		DevCPL486.GenJump(4, nil, TRUE);
+		DevCPL486.MakeReg(c, int.reg, Pointer);
+		DevCPL486.GenPush(c);
+		c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer;
+		DevCPL486.GenPush(c);
+		DevCPL486.GenPush(unk);
+		c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer;
+		DevCPL486.GenMove(c, unk);
+		unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer;
+		DevCPL486.GenCall(unk);
+		DevCPC486.Free(unk);
+		DevCPL486.GenJump(-1, end, FALSE);
+		DevCPL486.SetLabel(nil);
+		DevCPL486.MakeConst(c, 80004002H, Int32);	(* E_NOINTERFACE *)
+		DevCPC486.Result(proc, c);
+		CompareIntTypes(typ, id, end, num);
+		IF num > 0 THEN
+			DevCPC486.Load(this, {}, {});
+			DevCPC486.Assign(int, this);
+			DevCPC486.IPAddRef(this, 0, FALSE);
+			DevCPL486.MakeConst(c, 0, Int32);	(* S_OK *)
+			DevCPC486.Result(proc, c);
+		END;
+		DevCPL486.SetLabel(end)
+	END InstallQueryInterface;
+
+	(* -------------------- *)
+
+	PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item);
+		VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN;
+	BEGIN
+		IF n # NIL THEN
+			ActualPar(n.link, fp.link, FALSE, ap);
+			niltest := FALSE;
+			IF fp.mode = VarPar THEN
+				IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN
+					expr(n.right, ap, {}, {}); DevCPC486.Push(ap);	(* push type/length *)
+					expr(n.left, ap, {}, {}); DevCPC486.Push(ap);	(* push adr *)
+					RETURN
+				ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN
+					IPFree(n, ap)
+				ELSE
+					x := n;
+					WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END;
+					niltest := x.class = Nderef;	(* explicit nil test needed *)
+					AdrExpr(n, ap, {}, {})
+				END
+			ELSIF (n.class = Nmop) & (n.subcl = conv) THEN
+				IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265)
+				ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form))
+					& (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high});
+				ELSE expr(n, ap, {}, {high});
+				END
+			ELSE expr(n, ap, {}, {high});
+				IF CountedPtr(n) THEN DevCPM.err(270) END
+			END;
+			DevCPC486.Param(fp, rec, niltest, ap, tag)
+		END
+	END ActualPar;
+	
+	PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item);
+		VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE;
+	BEGIN
+		IF n.left.class = Nproc THEN
+			proc := n.left.obj; m := proc.mode;
+		ELSE proc := NIL; m := 0
+		END;
+		IF (m = CProc) & (n.right # NIL) THEN
+			ActualPar(n.right.link, n.obj.link, FALSE, tag);
+			expr(n.right, tag, wreg - {AX}, {});	(* tag = first param *)
+		ELSE
+			IF proc # NIL THEN DevCPC486.PrepCall(proc) END;
+			ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag);
+		END;
+		IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END;
+		DevCPC486.Call(x, tag)
+	END Call;
+
+	PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
+		VAR offset: INTEGER;
+	BEGIN
+		IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN
+			expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval;
+			IF n.subcl = minus THEN offset := -offset END
+		ELSE
+			expr(n, x, hint, stop + {mem}); offset := 0
+		END;
+		DevCPC486.Mem(x, offset, typ)
+	END Mem;
+	
+	PROCEDURE^ CompStat (n: DevCPT.Node);
+	PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
+
+	PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label);
+		VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct;
+	BEGIN
+		IF n.class = Nmop THEN
+			CASE n.subcl OF
+			   not: condition(n.left, x, true, false); DevCPC486.Not(x)
+			| is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem})
+					ELSE design(n.left, x, {}, {})
+					END;
+					DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE)
+			| odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x)
+			| cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool
+			| val: DevCPM.err(220)
+			END
+		ELSIF n.class = Ndop THEN
+			CASE n.subcl OF
+			   and: local := DevCPL486.NewLbl; condition(n.left, y, false, local);
+					DevCPC486.JumpF(y, false);
+					IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
+					condition(n.right, x, false, true)
+			| or: local := DevCPL486.NewLbl; condition(n.left, y, local, true);
+					DevCPC486.JumpT(y, true);
+					IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
+					condition(n.right, x, false, true)
+			| eql..geq:
+					f := n.left.typ.form;
+					IF f = Int64 THEN DevCPM.err(260)
+					ELSIF f IN {String8, String16, Comp} THEN
+						IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN	(* converted must be source *)
+							StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE)
+						ELSE
+							StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE)
+						END
+					ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x)
+					ELSE
+						IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END;
+						DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk});
+						IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE)
+						ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
+						ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
+						END 
+					END
+			| in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk});
+					DevCPC486.In(x, y)
+			| bit: Check(n.left, ux, sx);
+					expr(n.right, x, {}, ux + {short});
+					Mem(n.left, y, DevCPT.notyp, {}, {});
+					DevCPC486.Load(x, {}, {short});
+					DevCPC486.In(x, y)
+			| queryfn:
+					AdrExpr(n.right, x, {}, {CX, SI, DI});
+					CompareIntTypes(n.left.typ, x, false, num);
+					IF num > 0 THEN 
+						Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y);
+						x.offset := 1	(* true *)
+					ELSE x.offset := 0	(* false *)
+					END;
+					x.mode := Con; DevCPC486.MakeCond(x)
+			END
+		ELSIF n.class = Ncomp THEN
+			CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x);
+			IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END
+		ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x)	(* const, var, or call *)
+		END
+	END condition;
+	
+	PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
+		VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label;
+			uy: SET; sy: INTEGER; r: REAL;
+	BEGIN
+		f := n.typ.form;
+		IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN
+			false := DevCPL486.NewLbl; true := DevCPL486.NewLbl;
+			condition(n, y, false, true);
+			DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem})
+		ELSE
+			CASE n.class OF
+			   Nconst:
+					IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END;
+					CASE f OF
+					   Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f)
+					| Int64:
+						DevCPL486.MakeConst(x, cval.intval, f);
+						DevCPE.GetLongWords(cval, x.scale, x.offset)
+					| Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set)
+					| String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f)
+					| Comp: 
+						ASSERT(n.typ = DevCPT.guidtyp);
+						IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x)
+						ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x)
+						END
+					END
+			| Nupto:	(* n.typ = DevCPT.settyp *)
+					Check(n.right, uy, sy);
+					expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
+					DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {});
+					DevCPC486.Assert(x, {}, uy);
+					expr(n.right, y, {}, wreg - {CX} + {high, mem, stk});
+					DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {});
+					DevCPC486.Load(x, hint + stop, {});
+					IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y
+					ELSE DevCPC486.IntDOp(x, y, msk, FALSE)
+					END
+			| Nmop:
+					CASE n.subcl OF
+					| bit:
+							expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
+							DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {})
+					| conv:
+							IF f IN {String8, String16} THEN
+								expr(n.left, x, hint, stop);
+								IF f = String8 THEN x.form := VString16to8 END	(* SHORT *)
+							ELSE
+								IF n.left.class = Nconst THEN	(* largeint -> longreal *)
+									ASSERT((n.left.typ.form = Int64) & (f = Real64));
+									DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form);
+								ELSE
+									expr(n.left, x, hint + stop, {high});
+								END;
+								DevCPC486.Convert(x, f, -1, hint + stop, {})	(* ??? *)
+							END
+					| val:
+							expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop)	(* ??? *)
+					| adr:
+							IF n.left.class = Ntype THEN
+								x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
+							ELSE
+								AdrExpr(n.left, x, hint + stop, {});
+							END;
+							DevCPC486.GetAdr(x, hint + stop, {})
+					| typfn:
+							IF n.left.class = Ntype THEN
+								x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
+								IF x.obj.typ.untagged THEN DevCPM.err(111) END
+							ELSE
+								expr(n.left, x, hint + stop, {});
+								DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y
+							END;
+							DevCPC486.Load(x, hint + stop, {})
+					| minus, abs, cap:
+							expr(n.left, x, hint + stop, {mem, stk});
+							IF f = Int64 THEN DevCPM.err(260)
+							ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl)
+							ELSE DevCPC486.IntMOp(x, n.subcl)
+							END
+					END
+			| Ndop:
+					IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN
+						IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN
+							expr(n.left, x, {}, {mem, stk});
+							cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1;
+							WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END;
+							DevCPL486.AllocConst(y, cval, Real32);
+							DevCPC486.FloatDOp(x, y, times, FALSE)
+						ELSE FloatDOp(n, x)
+						END
+					ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {})
+					ELSE
+						CASE n.subcl OF
+						   times:
+								IF f = Int8 THEN
+									DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk});
+									DevCPC486.IntDOp(x, y, times, FALSE)
+								ELSE IntDOp(n, x, hint + stop)
+								END
+						| div, mod:
+								DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk});
+								DevCPC486.DivMod(x, y, n.subcl = mod)
+						| plus:
+								IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {})
+								ELSE IntDOp(n, x, hint + stop)
+								END
+						| slash, minus, msk, min, max:
+								IntDOp(n, x, hint + stop)
+						| ash, lsh, rot:
+								uy := {}; IF n.right.class # Nconst THEN uy := {CX} END;
+								DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk});
+								DevCPC486.Shift(x, y, n^.subcl)
+						| len:
+								IF n.left.typ.form IN {String8, String16} THEN
+									expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
+									DevCPC486.StrLen(x, n.left.typ, FALSE)
+								ELSE
+									design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y)
+								END
+						END
+					END
+			| Ncall:
+					Call(n, x)
+			| Ncomp:
+					CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x);
+					IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END
+			ELSE
+				design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {})	(* ??? *)
+			END
+		END;
+		x.typ := n.typ;
+		DevCPC486.Assert(x, hint, stop)
+	END expr;
+	
+	PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN);
+		VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER;
+	BEGIN
+		Check(n, u, s);
+		DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX});
+		IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END;
+		expr(n, src, wreg - {SI}, {});
+		adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con});
+		IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END;
+		DevCPC486.Load(dadr, {}, wreg - {DI} + {con});
+		DevCPC486.AddCopy(dest, src, last)
+	END AddCopy;
+	
+	PROCEDURE StringCopy (left, right: DevCPT.Node);
+		VAR x, y, ax, ay, len: DevCPL486.Item;
+	BEGIN
+		IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI})	(* keep len descriptor *)
+		ELSE expr(left, x, wreg - {DI}, {})
+		END;
+		ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI});
+		DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {});
+		WHILE right.class = Ndop DO
+			ASSERT(right.subcl = plus);
+			AddCopy(right.left, x, ax, len, FALSE);
+			right := right.right
+		END;
+		AddCopy(right, x, ax, len, TRUE);
+		DevCPC486.Free(len)
+	END StringCopy;
+	
+	PROCEDURE Checkpc;
+	BEGIN
+		DevCPE.OutSourceRef(DevCPM.errpos)
+	END Checkpc;
+
+	PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
+	
+	PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label);
+		VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node;
+	BEGIN
+		local := DevCPL486.NewLbl;
+		DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left;
+		IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq)
+				& (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq)
+				& SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN	(*  reuse comparison *)
+			DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2)
+		ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is)
+				& SameExp(cond.left, last.left) THEN
+			DevCPC486.ShortTypTest(x, cond.obj.typ)	(* !!! *)
+		ELSE condition(cond, x, else, local)
+		END;
+		hint := x.reg;
+		DevCPC486.JumpF(x, else);
+		IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
+		stat(if.right, end);
+	END CondStat;
+
+	PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label);
+		VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER;
+	BEGIN	(* n.class = Nifelse *)
+		if := n.left; last := NIL;
+		WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO
+			else := DevCPL486.NewLbl; 
+			CondStat(if, last, hint, else, end);
+			IF sequential THEN DevCPC486.Jump(end) END;
+			DevCPL486.SetLabel(else); last := if.left; if := if.link
+		END;
+		IF n.right # NIL THEN stat(n.right, end)
+		ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE
+		ELSE CondStat(if, last, hint, end, end)
+		END
+	END IfStat;
+	
+	PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN);
+		VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER;
+	BEGIN
+		IF n # NIL THEN
+			this := SHORT(ENTIER(n.conval.realval));
+			IF useTree IN n.conval.setval THEN
+				IF n.left # NIL THEN
+					IF n.right # NIL THEN
+						higher := DevCPL486.NewLbl;
+						DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE);
+						CasePart(n.left, x, else, FALSE);
+						DevCPL486.SetLabel(higher);
+						CasePart(n.right, x, else, last)
+					ELSE
+						DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE);
+						CasePart(n.left, x, else, last);
+					END
+				ELSE
+					DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE);
+					IF n.right # NIL THEN CasePart(n.right, x, else, last)
+					ELSIF ~last THEN DevCPC486.Jump(else)
+					END
+				END
+			ELSE
+				IF useTable IN n.conval.setval THEN
+					m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval;
+					m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2;
+					DevCPC486.CaseTableJump(x, low, high, else);
+					actual := low; last := TRUE
+				END;
+				CasePart(n.left, x, else, FALSE);
+				WHILE actual < n.conval.intval DO
+					DevCPL486.GenCaseEntry(else, FALSE); INC(actual)
+				END;
+				WHILE actual < n.conval.intval2 DO
+					DevCPL486.GenCaseEntry(this, FALSE); INC(actual)
+				END;
+				DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual);
+				CasePart(n.right, x, else, last)
+			END;
+			n.conval.realval := this
+		END
+	END CasePart;
+	
+	PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label);
+		VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label;
+	BEGIN
+		expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl;
+		IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN	(* jump to goto optimization *)
+			CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x);
+			n.right.right.right.conval.intval2 := else; sequential := FALSE
+		ELSE
+			CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x);
+			DevCPL486.SetLabel(else);
+			IF n.right.conval.setval # {} THEN stat(n.right.right, end)
+			ELSE DevCPC486.Trap(caseTrap); sequential := FALSE
+			END
+		END;
+		case := n.right.left;
+		WHILE case # NIL DO	(* case.class = Ncasedo *)
+			IF sequential THEN DevCPC486.Jump(end) END;
+			lab := case.left;
+			IF (case.right # NIL) & (case.right.class = Ngoto) THEN	(* jump to goto optimization *)
+				case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval));
+				ASSERT(lab.link = NIL); sequential := FALSE
+			ELSE
+				WHILE lab # NIL DO
+					this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link
+				END;
+				stat(case.right, end)
+			END;
+			case := case.link
+		END
+	END CaseStat;
+
+	PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct);
+		VAR len: DevCPL486.Item; u: SET; s: INTEGER;
+	BEGIN
+		Check(n, u, s);
+		IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END;
+		expr(n, len, {}, {mem, short});
+		IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END;
+		IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END;
+		DevCPC486.MulDim(len, nofel, fact, dimtyp);
+		IF n.link # NIL THEN
+			Dim(n.link, x, nofel, fact, dimtyp.BaseTyp);
+		ELSE
+			DevCPC486.New(x, nofel, fact)
+		END;
+		DevCPC486.SetDim(x, len, dimtyp)
+	END Dim;
+
+	PROCEDURE CompStat (n: DevCPT.Node);
+		VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct;
+	BEGIN
+		Checkpc;
+		WHILE (n # NIL) & DevCPM.noerr DO
+			ASSERT(n.class = Nassign);
+			IF n.subcl = assign THEN
+				IF n.right.typ.form IN {String8, String16} THEN
+					StringCopy(n.left, n.right)
+				ELSE
+					IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN
+						IPAssign(NIL, n.right, x, y, {});	(* no Release *)
+					ELSE expr(n.right, y, {}, {})
+					END;
+					expr(n.left, x, {}, {});
+					DevCPC486.Assign(x, y)
+				END
+			ELSE ASSERT(n.subcl = newfn);
+				typ := n.left.typ.BaseTyp;
+				ASSERT(typ.comp = DynArr);
+				ASSERT(n.right.link = NIL);
+				expr(n.right, y, {}, wreg - {CX} + {mem, stk});
+				DevCPL486.MakeReg(sp, SP, Int32);
+				DevCPC486.CopyReg(sp, old, {}, {CX});
+				DevCPC486.CopyReg(y, len, {}, {CX});
+				IF typ.BaseTyp.form = Char16 THEN
+					DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE)
+				END;
+				DevCPC486.StackAlloc;
+				DevCPC486.Free(y);
+				expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp);
+				DevCPC486.Push(len);
+				DevCPC486.Push(old);
+				typ.sysflag := stackArray
+			END;
+			n := n.link
+		END
+	END CompStat;
+	
+	PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
+		VAR x, y, sp: DevCPL486.Item;
+	BEGIN
+		IF n.link # NIL THEN CompRelease(n.link, res) END;
+		ASSERT(n.class = Nassign);
+		IF n.subcl = assign THEN
+			IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN
+				IF res.mode = Cond THEN
+					DevCPL486.GenCode(9CH); (* push flags *)
+					res.mode := Stk
+				ELSIF res.mode = Reg THEN
+					IF res.form < Int16 THEN DevCPC486.Push(res)
+					ELSE DevCPC486.Assert(res, {}, {AX, CX, DX})
+					END
+				END;
+				expr(n.left, x, wreg - {DI}, {loaded});
+				DevCPC486.IPRelease(x, 0, TRUE, TRUE);
+				n.left.obj.used := FALSE
+			END
+		ELSE ASSERT(n.subcl = newfn);
+			DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp);
+			DevCPL486.MakeConst(y, 0, Pointer);
+			expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
+		END
+	END CompRelease;
+	
+	PROCEDURE Assign(n: DevCPT.Node; ux: SET);
+		VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER;
+	BEGIN
+		r := n.right; f := r.typ.form; uf := {};
+		IF (r.class IN {Nmop, Ndop}) THEN
+			IF (r.subcl = conv) & (f # Set) &
+(*
+				(DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left;
+				IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *)
+*)
+				(DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) &
+				((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left
+			ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN
+				IF r.class = Ndop THEN
+					IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN
+						expr(r.right, y, {}, ux); expr(n.left, x, {}, {});
+						DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE);
+						RETURN
+					ELSIF r.subcl IN {ash, lsh, rot} THEN
+						expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {});
+						DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl);
+						RETURN
+					END
+				ELSE
+					IF r.subcl IN {minus, abs, cap} THEN
+						expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN
+					END
+				END
+			ELSIF f = Bool THEN
+				IF (r.subcl = not) & SameExp(n.left, r.left) THEN
+					expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN
+				END
+			END
+		END;
+		IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux)
+		ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded});	(* high ??? *)
+		END;
+		DevCPC486.Assign(x, y)
+	END Assign;
+	
+	PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
+		VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET;
+	BEGIN
+		sequential := TRUE; INC(nesting);
+		WHILE (n # NIL) & DevCPM.noerr DO
+			IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END;
+			DevCPM.errpos := n.conval.intval; DevCPL486.BegStat;
+			CASE n.class OF
+			| Ninittd:
+					(* done at load-time *)
+			| Nassign:
+					Checkpc;
+					Check(n.left, ux, sx);
+					CASE n.subcl OF
+					   assign:
+							IF n.left.typ.form = Comp THEN
+								IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN
+									StringCopy(n.left, n.right)
+								ELSE
+									StringOp(n.left, n.right, x, y, TRUE);
+									IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END;
+									DevCPC486.Copy(x, y, FALSE)
+								END
+							ELSE Assign(n, ux)
+							END
+					| getfn:
+							Mem(n.right, y, n.left.typ, {}, ux);
+							expr(n.left, x, {}, {loaded});
+							DevCPC486.Assign(x, y)
+					| putfn:
+							expr(n.right, y, {}, ux);
+							Mem(n.left, x, n.right.typ, {}, {});
+							DevCPC486.Assign(x, y)
+					| incfn, decfn:
+							expr(n.right, y, {}, ux); expr(n.left, x, {}, {});
+							IF n.left.typ.form = Int64 THEN 
+								DevCPC486.LargeInc(x, y, n.subcl = decfn)
+							ELSE
+								DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE)
+							END
+					| inclfn:
+							expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {});
+							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
+							DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE)
+					| exclfn:
+							expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {});
+							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
+							DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE)
+					| getrfn:
+							expr(n.right, y, {}, {});
+							IF y.offset < 8 THEN	
+								DevCPL486.MakeReg(y, y.offset, n.left.typ.form);	(* ??? *)
+								expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
+							ELSE DevCPM.err(220)
+							END
+					| putrfn:
+							expr(n.left, x, {}, {});
+							IF x.offset < 8 THEN
+								DevCPL486.MakeReg(x, x.offset, n.right.typ.form);	(* ??? *)
+								expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y)
+							ELSE DevCPM.err(220)
+							END
+					| newfn:
+							y.typ := n.left.typ;
+							IF n.right # NIL THEN
+								IF y.typ.BaseTyp.comp = Record THEN
+									expr(n.right, nofel, {}, {AX, CX, DX, mem, stk});
+									DevCPC486.New(y, nofel, 1);
+								ELSE (*open array*)
+									nofel.mode := Con; nofel.form := Int32; fact := 1;
+									Dim(n.right, y, nofel, fact, y.typ.BaseTyp)
+								END
+							ELSE
+								DevCPL486.MakeConst(nofel, 0, Int32);
+								DevCPC486.New(y, nofel, 1);
+							END;
+							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
+					| sysnewfn:
+							expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y);
+							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
+					| copyfn:
+							StringOp(n.left, n.right, x, y, TRUE);
+							DevCPC486.Copy(x, y, TRUE)
+					| movefn:
+							Check(n.right.link, uz, sz);
+							expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz);
+							expr(n.left, x, {}, wreg - {DI} + {short} + uz);
+							expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short});
+							DevCPC486.Load(x, {}, wreg - {DI} + {con});
+							DevCPC486.Load(y, {}, wreg - {SI} + {con}); 
+							DevCPC486.SysMove(nofel)
+					END;
+					sequential := TRUE
+			| Ncall:
+					Checkpc;
+					Call(n, x); sequential := TRUE
+			| Nifelse:
+					IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END
+			| Ncase:
+					Checkpc;
+					CaseStat(n, next)
+			| Nwhile:
+					local := DevCPL486.NewLbl;
+					IF n.right # NIL THEN DevCPC486.Jump(local) END;
+					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
+					stat(n.right, local); DevCPL486.SetLabel(local);
+					DevCPM.errpos := n.conval.intval; Checkpc;
+					condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE
+			| Nrepeat:
+					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
+					local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local);
+					DevCPM.errpos := n.conval.intval; Checkpc;
+					condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE
+			| Nloop:
+					prevExit := Exit; Exit := next;
+					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop);
+					IF sequential THEN DevCPC486.Jump(loop) END;
+					next := Exit; Exit := prevExit; sequential := FALSE
+			| Nexit:
+					Checkpc;
+					DevCPC486.Jump(Exit); sequential := FALSE
+			| Nreturn:
+					IF n.left # NIL THEN
+						Checkpc;
+						IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer)
+							& (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {})
+						ELSE expr(n.left, x, wreg - {AX}, {})
+						END;
+						DevCPC486.Result(n.obj, x)
+					END;
+					IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END;
+					sequential := FALSE
+			| Nwith:
+					IfStat(n, n.subcl = 0, next)
+			| Ntrap:
+					Checkpc;
+					DevCPC486.Trap(n.right.conval.intval); sequential := TRUE
+			| Ncomp:
+					CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x)
+			| Ndrop:
+					Checkpc;
+					expr(n.left, x, {}, {}); DevCPC486.Free(x)
+			| Ngoto:
+					IF n.left # NIL THEN
+						Checkpc;
+						condition(n.left, x, next, n.right.conval.intval2);
+						DevCPC486.JumpT(x, n.right.conval.intval2)
+					ELSE
+						DevCPC486.Jump(n.right.conval.intval2);
+						sequential := FALSE
+					END
+			| Njsr:
+					DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE)	(* call n.right *)
+			| Nret:
+					DevCPL486.GenReturn(0); sequential := FALSE	(* ret 0 *)
+			| Nlabel:
+					DevCPL486.SetLabel(n.conval.intval2)
+			END;
+			DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link;
+			IF n = NIL THEN end := next
+			ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next)
+			END
+		END;
+		DEC(nesting)
+	END stat;
+	
+	PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN);
+	BEGIN
+		WHILE n # NIL DO
+			IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END;
+			CASE n.class OF
+			| Ncase:
+				CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu)
+			| Ncasedo:
+				CheckFpu(n.right, useFpu)
+			| Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
+				CheckFpu(n.left, useFpu)
+			| Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
+				CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu)
+			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
+			END;
+			n := n.link
+		END
+	END CheckFpu;
+	
+	PROCEDURE procs(n: DevCPT.Node);
+		VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label;
+			ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN;
+	BEGIN
+		INC(DevCPL486.level); nesting := 0;
+		WHILE (n # NIL) & DevCPM.noerr DO
+			DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj; 
+			IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END;
+			procs(n.left);
+			DevCPM.errpos := n.conval.intval;
+			useFpu := FALSE; CheckFpu(n.right, useFpu);
+			DevCPC486.Enter(proc, n.right = NIL, useFpu);
+			InitializeIPVars(proc);
+			end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end);
+			DevCPM.errpos := n.conval.intval2; Checkpc;
+			IF sequential OR (end # DevCPL486.NewLbl) THEN
+				DevCPL486.SetLabel(end);
+				IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END
+			END;
+			DevCPL486.SetLabel(Return);
+			ReleaseIPVars(proc);
+			DevCPC486.Exit(proc, n.right = NIL);
+			IF proc.mode = TProc THEN
+				name := proc.link.typ.strobj.name^$; i := 0;
+				WHILE name[i] # 0X DO INC(i) END;
+				name[i] := "."; INC(i); j := 0; ch := proc.name[0];
+				WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ;
+				name[i] := 0X;
+			ELSE name := proc.name^$
+			END;
+			DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right);
+			n := n.link
+		END;
+		DEC(DevCPL486.level)
+	END procs;
+	
+	PROCEDURE Module*(prog: DevCPT.Node);
+		VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node;
+			aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN;
+	BEGIN
+		DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop});
+		DevCPM.NewObj(DevCPT.SelfName);
+		IF DevCPM.noerr THEN
+			DevCPE.OutHeader; n := prog.right;
+			WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END;
+			useFpu := FALSE; CheckFpu(n, useFpu);
+			DevCPC486.Enter(NIL, n = NIL, useFpu);
+			end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end);
+			DevCPM.errpos := prog.conval.intval2; Checkpc;
+			DevCPC486.Exit(NIL, n = NIL);
+			IF prog.link # NIL THEN	(* close section *)
+				DevCPL486.SetLabel(DevCPE.closeLbl);
+				useFpu := FALSE; CheckFpu(prog.link, useFpu);
+				DevCPC486.Enter(NIL, FALSE, useFpu);
+				end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end);
+				DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc;
+				DevCPC486.Exit(NIL, FALSE)
+			END;
+			name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right);
+			DevCPM.errpos := prog.conval.intval;
+			WHILE query # NIL DO
+				typ := query.typ; query.typ := DevCPT.int32typ;
+				query.conval.intval := 20;	(* parameters *)
+				query.conval.intval2 := -8;	(* saved registers *)
+				DevCPC486.Enter(query, FALSE, FALSE);
+				InstallQueryInterface(typ, query);
+				DevCPC486.Exit(query, FALSE);
+				name := "QueryInterface"; DevCPE.OutRefName(name);
+				query := query.nlink
+			END;
+			procs(prog.left);
+			DevCPC486.InstallStackAlloc;
+			addRef := NIL; release := NIL; release2 := NIL;
+			DevCPC486.intHandler := NIL;
+			IF DevCPM.noerr THEN DevCPE.OutCode END;
+			IF ~DevCPM.noerr THEN DevCPM.DeleteObj END
+		END
+	END Module;
+
+END LindevCPV486.

BlackBox/LindevCompiler.txt

@@ -0,0 +1,140 @@
+MODULE LindevCompiler;
+
+	(* THIS IS TEXT COPY OF LindevCompiler.odc *)
+	(* DO NOT EDIT *)
+
+	(*
+		A. V. Shiryaev, 2012.09
+
+		Based on DevCompiler
+	*)
+
+	IMPORT Files, Console, Kernel, Strings,
+		DevCPM := LindevCPM, DevCPT:= LindevCPT, DevCPB := LindevCPB, DevCPP := LindevCPP,
+		DevCPE := LindevCPE, DevCPV := LindevCPV486;
+
+	CONST
+		(* compiler options: *)
+		checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; srcpos = 6; reallib = 7; signatures = 8;
+		hint = 29; oberon = 30; errorTrap = 31;
+		defopt = {checks, assert, obj, ref, allref, srcpos, signatures};
+
+	PROCEDURE WriteInt (x: INTEGER);
+		VAR s: ARRAY 16 OF CHAR;
+	BEGIN
+		Strings.IntToString(x, s);
+		Console.WriteStr(s)
+	END WriteInt;
+
+	PROCEDURE Module (source: Files.Reader; opt: SET; VAR error: BOOLEAN);
+		VAR ext, new: BOOLEAN; p: DevCPT.Node;
+			i: INTEGER;
+	BEGIN
+		DevCPM.Init(source);
+		(* IF found THEN INCL(DevCPM.options, DevCPM.comAware) END; *)
+		IF errorTrap IN opt THEN INCL(DevCPM.options, DevCPM.trap) END;
+		IF oberon IN opt THEN INCL(DevCPM.options, DevCPM.oberon) END;
+		DevCPT.Init(opt);
+		DevCPB.typSize := DevCPV.TypeSize;
+		DevCPT.processor := DevCPV.processor;
+		DevCPP.Module(p);
+		IF DevCPM.noerr THEN
+			IF DevCPT.libName # "" THEN EXCL(opt, obj) END;
+(*
+			IF errorTrap IN opt THEN DevCPDump.DumpTree(p) END;
+*)
+			DevCPV.Init(opt); DevCPV.Allocate; DevCPT.Export(ext, new);
+			IF DevCPM.noerr & (obj IN opt) THEN
+				DevCPV.Module(p)
+			END;
+			DevCPV.Close
+		END;
+		IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym
+		ELSE DevCPM.DeleteNewSym
+		END;
+		DevCPT.Close;
+		error := ~DevCPM.noerr;
+		DevCPM.Close;
+		p := NIL;
+		Kernel.FastCollect;
+		IF error THEN
+			IF DevCPM.errors = 1 THEN
+				Console.WriteStr("one error detected")
+			ELSE
+				WriteInt(DevCPM.errors); Console.WriteStr(" errors detected")
+			END;
+			Console.WriteLn;
+			i := 0;
+			WHILE i < DevCPM.errors DO
+				Console.WriteStr("  pos = "); WriteInt(DevCPM.errPos[i]); Console.WriteStr("  err = ");
+					WriteInt(DevCPM.errNo[i]); Console.WriteLn;
+				INC(i)
+			END
+		ELSE
+			Console.WriteStr(" "); WriteInt(DevCPE.pc); Console.WriteStr(" "); WriteInt(DevCPE.dsize)
+		END;
+		Console.WriteLn
+	END Module;
+
+	PROCEDURE Do (IN path, name: ARRAY OF CHAR; opt: SET);
+		VAR loc: Files.Locator;
+			f: Files.File; r: Files.Reader; error: BOOLEAN;
+	BEGIN
+		loc := Files.dir.This(path);
+		IF loc # NIL THEN
+			f := Files.dir.Old(loc, name$, FALSE);
+			IF f # NIL THEN
+				r := f.NewReader(NIL);
+				Module(r, opt, error);
+				IF error THEN Console.WriteStr("error(s)"); Console.WriteLn END;
+				f.Close
+			ELSE
+				Console.WriteStr("file not found: ");
+					Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name); Console.WriteLn
+			END
+		ELSE
+			Console.WriteStr("path not found: ");
+				Console.WriteStr(path); Console.WriteLn
+		END
+	END Do;
+
+	PROCEDURE Compile* (IN path, name: ARRAY OF CHAR);
+	BEGIN
+		Console.WriteStr("compiling ");
+			Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name);
+			Console.WriteLn;
+		Do(path, name, defopt)
+	END Compile;
+
+	PROCEDURE CompileOpt* (IN path, name: ARRAY OF CHAR; IN opt: ARRAY OF CHAR);
+		VAR loc: Files.Locator;
+			f: Files.File; r: Files.Reader; error: BOOLEAN; i: INTEGER; opts: SET;
+	BEGIN
+		i := 0; opts := defopt;
+		WHILE opt[i] # 0X DO
+			IF opt[i] = "-" THEN
+				IF srcpos IN opts THEN EXCL(opts, srcpos)
+				ELSIF allref IN opts THEN EXCL(opts, allref)
+				ELSIF ref IN opts THEN EXCL(opts, ref)
+				ELSE EXCL(opts, obj)
+				END
+			ELSIF opt[i] = "!" THEN
+				IF assert IN opts THEN EXCL(opts, assert)
+				ELSE EXCL(opts, checks)
+				END
+			ELSIF opt[i] = "+" THEN INCL(opts, allchecks)
+			ELSIF opt[i] = "?" THEN INCL(opts, hint)
+			ELSIF opt[i] = "@" THEN INCL(opts, errorTrap)
+			ELSIF opt[i] = "$" THEN INCL(opts, oberon)
+			END;
+			INC(i)
+		END;
+
+		Console.WriteStr("compiling ");
+			Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name);
+			IF opt # "" THEN Console.WriteStr(" "); Console.WriteStr(opt); END;
+			Console.WriteLn;
+		Do(path, name, opts)
+	END CompileOpt;
+
+END LindevCompiler.

BlackBox/LindevElfLinker16.txt

@@ -0,0 +1,1880 @@
+MODULE LindevElfLinker;
+
+	(* THIS IS TEXT COPY OF LindevElfLinker16.odc *)
+	(* DO NOT EDIT *)
+
+(*
+	DevElfLinker version compatible with BlackBox Component Builder release 1.6.
+	This module will replace DevElfLinker, once the final version of BlackBox 1.6 will be released.
+*)
+
+(*
+	A. V. Shiryaev, 2012.09
+
+	Based on DevElfLinker16; modified to not depend on TextModels (TextModels -> Console)
+*)
+
+	IMPORT
+		Strings,
+		Kernel, Files, (* Dialog, TextMappers, StdLog, DevCommanders *) Console;
+
+	CONST
+		NewRecFP = 4E27A847H;
+		NewArrFP = 76068C78H;
+
+		OFdir = "Code";
+		SYSdir = "System";
+
+		(* meta interface consts *)
+		mConst = 1; mTyp = 2; mVar = 3; mProc = 4;
+		mInternal = 1; mExported = 4;
+
+		(* mod desc fields *)
+		modOpts = 4; modRefcnt = 8; modTerm = 40; modNames = 84; modImports = 92; modExports = 96;
+
+		(* .dynsym entries *)
+		stbLocal = 0; stbGlobal = 1;
+		sttNotype = 0; sttObject = 1; sttFunc = 2; sttSection = 3;
+		shnUnd = 0; shnAbs = 0FFF1H;
+
+		fixup = 0;
+		noSymbol = MIN(INTEGER);
+		noAddr = MIN(INTEGER);
+		firstDllSymbolVal = 12;
+
+		(* distinguished section header indexes. *)
+		textIndexVal = 1;	(* index of the .text section header in the section header table *)
+		rodataIndexVal = 3;	(* index of the .rodata section header in the section header table *)
+		dynsymIndexVal = 5;	(* index of the .dynsym section header in the section header table *)
+		dynstrIndexVal = 6;	(* index of the .dynstr section header in the section header table *)
+
+		(* fixed elements dimensions *)
+		elfHeaderSizeVal = 52;	(* size of the ELF file header *)
+		shEntrySizeVal = 40;	(* size of an entry in the section header table *)
+		dynsymEntrySizeVal = 16; (* size of a symbol table entry *)
+		dynamicEntrySizeVal = 8; (* size of an entry in the dynamic section *)
+		gotEntrySizeVal = 4; (* size of an entry in the got section *)
+		relEntrySizeVal = 8; (* size of an entry in a relocation section *)
+		phEntrySizeVal = 32; (* size of an entry in the program header *)
+
+		shNumVal = 12; (* number of entries in the section header table. See WriteSectionHeaderTable *)
+		shStrndxVal = shNumVal - 1; (* index of the string table for section names. See WriteSectionHeaderTable *)
+		phNumVal = 3; (* number of entries in the program header table *)
+
+		(* sections alignments (in bytes) *)
+		textAlign = 4H;
+		dynsymAlign = 4H;
+		dynstrAlign = 1H;
+		hashAlign = 4H;
+		gotAlign = 4H;
+		dynamicAlign = 4H;
+		shstrtabAlign = 1H;
+		bssAlign = 4H;
+		rodataAlign = 8H;
+		relAlign = 4H;
+
+		pageSize = 1000H; (* I386 page size *)
+
+		r38632 = 1; r386pc32 = 2; r386Relative = 8; (* ELF relocation types *)
+
+	
+		(* A. V. Shiryaev: Scanner *)
+		TMChar = 0; TMString = 1; TMEOT = 2;
+
+	TYPE
+		Name = ARRAY 40 OF SHORTCHAR;
+
+		Export = POINTER TO RECORD
+			next: Export;
+			name: Name;
+			adr: INTEGER
+		END;
+
+		Module = POINTER TO RECORD
+			next: Module;
+			name: Name;
+			fileName: Files.Name;
+			file: Files.File;
+			hs, ms, ds, cs, vs, ni, ma, ca, va: INTEGER;
+			dll, intf: BOOLEAN;
+			exp: Export;
+			imp: POINTER TO ARRAY OF Module;
+			data: POINTER TO ARRAY OF BYTE
+		END;
+
+		Strtab = RECORD
+			tab: ARRAY 4096 OF SHORTCHAR;
+			cur: INTEGER
+		END;
+
+		Relocation = RECORD
+			offset, type: INTEGER
+		END;
+
+		RelTab = RECORD
+			tab: ARRAY 65536 OF Relocation;
+			cur: INTEGER
+		END;
+
+		Section = RECORD
+			fileOffset,
+			memOffset,
+			size: INTEGER
+		END;
+
+		(* A. V. Shiryaev: Scanner *)
+			ScanRider = RECORD
+				s: POINTER TO ARRAY OF CHAR;
+				i: INTEGER
+			END;
+			Scanner = RECORD
+				rider: ScanRider;
+				start, type: INTEGER;
+
+				string: ARRAY 100 OF CHAR;
+				char: CHAR
+			END;
+	
+	VAR
+		Out: Files.File;
+		R: Files.Reader;
+		Ro: Files.Writer;
+		error, isDll, isStatic: BOOLEAN;
+		modList, kernel, main, last, impg, impd: Module;
+		numMod, lastTerm: INTEGER;
+		firstExp, lastExp: Export;
+		CodeSize, DataSize, ConSize: INTEGER;
+		maxCode, numExp: INTEGER;
+		newRec, newArr: Name;
+		code: POINTER TO ARRAY OF BYTE;
+
+		(* fixup positions *)
+		entryPos,
+		expPos,
+		shstrtabPos,
+		finiPos: INTEGER;
+
+		(* sections *)
+		text, reltext, relrodata, rodata, dynstr, shstrtab, hash, got, dynsym, dynamic, bss: Section;
+
+		(* distinguished file and memory offsets *)
+		shOffsetVal,	(* section header table file offset *)
+		phOffsetVal,	(* program header table file offset *)
+		finiMemOffsetVal: INTEGER;	(* memory offset (aka virtual address) of the finalization code (CLOSE sections) *)
+
+		dynsymInfoVal,	(* value of the info field for the .dynsym section *)
+		sonameStrIndexVal: INTEGER;	(* string table index of the name of hte library *)
+
+		(* segment dimensions *)
+		textSegmentSizeVal,
+		dataSegmentSizeVal,
+		dynamicSegmentSizeVal: INTEGER;
+
+		headerstrtab, dynstrtab: Strtab;
+		hashtab: ARRAY 256 OF Name;
+
+		neededIdx: ARRAY 256 OF INTEGER;
+
+		relTextTab, relRodataTab: RelTab;
+
+		soName: Name;
+
+		doWrite: BOOLEAN;
+
+	PROCEDURE (VAR t: Strtab) AddName (IN s: ARRAY OF SHORTCHAR; OUT idx: INTEGER), NEW;
+		VAR i: INTEGER;
+	BEGIN
+		ASSERT((t.cur + LEN(s$)) <= LEN(t.tab), 20); (* table buffer not large enough: TODO enlarge? *)
+		idx := t.cur;
+		i := 0;
+		WHILE s[i] # 0X DO
+			t.tab[t.cur] := s[i];
+			INC(i); INC(t.cur)
+		END;
+		t.tab[t.cur] := s[i]; (* copy the 0X *)
+		INC(t.cur)
+	END AddName;
+
+	PROCEDURE (VAR t: RelTab) Add (offset, type: INTEGER), NEW;
+	BEGIN
+		ASSERT(t.cur < LEN(t.tab), 20); (* table buffer not large enough: TODO enlarge? *)
+		t.tab[t.cur].offset := offset;		
+		t.tab[t.cur].type := type;
+		INC(t.cur)
+	END Add;
+
+	PROCEDURE AddNeededIdx (idx: INTEGER);
+		VAR i, len: INTEGER;
+	BEGIN
+		ASSERT(idx > 0, 20);	(* index must be positive *)
+		len := LEN(neededIdx);
+		i := 0;
+		WHILE (i # len) & (neededIdx[i] # 0) DO INC(i) END;
+		IF i # len THEN
+			neededIdx[i] := idx
+		ELSE
+			HALT(21)	(* no more space for indexes *)
+		END
+	END AddNeededIdx;
+
+	(* A. V. Shiryaev: Console *)
+
+		PROCEDURE WriteString (s: ARRAY OF CHAR);
+		BEGIN
+			Console.WriteStr(s)
+		END WriteString;
+
+		PROCEDURE WriteChar (c: CHAR);
+			VAR s: ARRAY 2 OF CHAR;
+		BEGIN
+			s[0] := c; s[1] := 0X;
+			Console.WriteStr(s)
+		END WriteChar;
+
+		PROCEDURE WriteSString (ss: ARRAY OF SHORTCHAR);
+		BEGIN
+			Console.WriteStr(ss$)
+		END WriteSString;
+
+		PROCEDURE WriteInt (x: INTEGER);
+			VAR s: ARRAY 16 OF CHAR;
+		BEGIN
+			Strings.IntToString(x, s);
+			Console.WriteStr(s)
+		END WriteInt;
+
+		PROCEDURE WriteLn;
+		BEGIN
+			Console.WriteLn
+		END WriteLn;
+
+		PROCEDURE FlushW;
+		BEGIN
+		END FlushW;
+
+	PROCEDURE ThisFile (modname: ARRAY OF CHAR): Files.File;
+		VAR dir, name: Files.Name; loc: Files.Locator; f: Files.File;
+	BEGIN
+		Kernel.SplitName(modname, dir, name);
+		Kernel.MakeFileName(name, Kernel.objType);
+		loc := Files.dir.This(dir); loc := loc.This(OFdir);
+		f := Files.dir.Old(loc, name, TRUE);
+		IF (f = NIL) & (dir = "") THEN
+			loc := Files.dir.This(SYSdir); loc := loc.This(OFdir);
+			f := Files.dir.Old(loc, name, TRUE)
+		END;
+		RETURN f
+	END ThisFile;
+
+	PROCEDURE Read4 (VAR x: INTEGER);
+		VAR b: BYTE;
+	BEGIN
+		R.ReadByte(b); x := b MOD 256;
+		R.ReadByte(b); x := x + 100H * (b MOD 256);
+		R.ReadByte(b); x := x + 10000H * (b MOD 256);
+		R.ReadByte(b); x := x + 1000000H * b
+	END Read4;
+
+	PROCEDURE ReadName (VAR name: ARRAY OF SHORTCHAR);
+		VAR i: INTEGER; b: BYTE;
+	BEGIN i := 0;
+		REPEAT
+			R.ReadByte(b); name[i] := SHORT(CHR(b)); INC(i)
+		UNTIL b = 0
+	END ReadName;
+
+	PROCEDURE RNum (VAR i: INTEGER);
+		VAR b: BYTE; s, y: INTEGER;
+	BEGIN
+		s := 0; y := 0; R.ReadByte(b);
+		WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); R.ReadByte(b) END;
+		i := ASH((b + 64) MOD 128 - 64, s) + y
+	END RNum;
+
+	PROCEDURE WriteCh (ch: SHORTCHAR);
+	BEGIN
+		IF doWrite THEN
+		Ro.WriteByte(SHORT(ORD(ch)))
+		END
+	END WriteCh;
+
+	PROCEDURE Write2 (x: INTEGER);
+	BEGIN
+		IF doWrite THEN
+			Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
+			Ro.WriteByte(SHORT(SHORT(x MOD 256)))
+		END
+	END Write2;
+
+	PROCEDURE Write4 (x: INTEGER);
+	BEGIN
+		IF doWrite THEN
+			Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
+			Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
+			Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
+			Ro.WriteByte(SHORT(SHORT(x MOD 256)))
+		END
+	END Write4;
+
+	PROCEDURE WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER);
+	BEGIN
+		IF doWrite THEN
+			Ro.WriteBytes(x, beg, len)
+		END
+	END WriteBytes;
+
+	PROCEDURE Align (alignment: INTEGER);
+	BEGIN
+		WHILE Ro.Pos() MOD alignment # 0 DO WriteCh(0X) END
+	END Align;
+	
+	PROCEDURE Aligned (pos, alignment: INTEGER): INTEGER;
+	BEGIN
+		RETURN (pos + (alignment - 1)) DIV alignment * alignment
+	END Aligned;
+	
+	PROCEDURE Put (mod: Module; a, x: INTEGER);
+	BEGIN
+		ASSERT((mod.data # NIL) & ((a >= 0) & (a <= LEN(mod.data))), 20);
+		mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
+		mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
+		mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
+		mod.data[a] := SHORT(SHORT(x))
+	END Put;
+
+	PROCEDURE Get (mod: Module; a: INTEGER; VAR x: INTEGER);
+	BEGIN
+		ASSERT((mod.data # NIL) & ((a >= 0) & (a + 3 <= LEN(mod.data))), 20);
+		x := ((mod.data[a + 3] * 256 +
+			(mod.data[a + 2] MOD 256)) * 256 +
+			(mod.data[a + 1] MOD 256)) * 256 +
+			(mod.data[a] MOD 256)
+	END Get;
+
+	PROCEDURE CheckDllImports (mod: Module);
+		VAR i, x, y: INTEGER; name: Name; imp: Module; exp: Export;
+
+		PROCEDURE SkipLink;
+			VAR a: INTEGER;
+		BEGIN
+			RNum(a);
+			WHILE a # 0 DO RNum(a); RNum(a) END
+		END SkipLink;
+
+	BEGIN
+		R := mod.file.NewReader(R);
+		R.SetPos(mod.hs + mod.ms + mod.ds + mod.cs);
+		SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; SkipLink;
+		i := 0;
+		WHILE i < mod.ni DO
+			imp := mod.imp[i];
+			IF imp # NIL THEN
+				RNum(x);
+				WHILE x # 0 DO
+					ReadName(name); RNum(y);
+					IF x = mVar THEN
+						SkipLink;
+						IF imp.dll THEN
+							exp := imp.exp;
+							WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END;
+							IF exp = NIL THEN
+								NEW(exp); exp.name := name$;
+								exp.next := imp.exp; imp.exp := exp
+							 END
+						END
+					ELSIF x = mTyp THEN RNum(y);
+						IF imp.dll THEN
+							RNum(y);
+							IF y # 0 THEN
+								WriteString("type descriptor (");
+								WriteString(imp.name$); WriteChar(".");
+								WriteSString(name);
+								WriteString(") imported from DLL in ");
+								WriteString(mod.name$);
+								WriteLn; FlushW; error := TRUE;
+								RETURN
+							END
+						ELSE SkipLink
+						END
+					ELSIF x = mProc THEN
+						IF imp.dll THEN
+							SkipLink;
+							exp := imp.exp;
+							WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END;
+							IF exp = NIL THEN
+								NEW(exp); exp.name := name$;
+								exp.next := imp.exp; imp.exp := exp
+							 END
+						END
+					END;
+					RNum(x)
+				END
+			END;
+			INC(i)
+		END
+	END CheckDllImports;
+
+	PROCEDURE ReadHeaders;
+		VAR mod, im, t: Module; x, i, pos: INTEGER; impdll: BOOLEAN; name: Name;
+	BEGIN
+		ASSERT(isDll, 126);
+		mod := modList; modList := NIL; numMod := 0;
+		WHILE mod # NIL DO	(* reverse mod list & count modules *)
+			IF ~mod.dll THEN INC(numMod) END;
+			t := mod; mod := t.next; t.next := modList; modList := t
+		END;
+		IF isStatic THEN
+			CodeSize :=
+				6 + 5 * numMod + 2	(* _init() *)
+				+ 1 + 5 * numMod + 2	(* _fini() *)
+		ELSE
+			CodeSize :=
+				6 + 5 + 2	(* _init() *)
+				+ 1 + 5 + 2	(* _fini() *)
+		END;
+		DataSize := 0; ConSize := 0;
+		maxCode := 0; numExp := 0;
+		mod := modList;
+		WHILE mod # NIL DO
+			IF ~mod.dll THEN
+				mod.file := ThisFile(mod.fileName);
+				IF mod.file # NIL THEN
+					R := mod.file.NewReader(R); R.SetPos(0);
+					Read4(x);
+					IF x = 6F4F4346H THEN
+						Read4(x);
+						Read4(mod.hs); Read4(mod.ms); Read4(mod.ds); Read4(mod.cs);
+						Read4(mod.vs); RNum(mod.ni); ReadName(mod.name); impdll := FALSE;
+						IF mod.ni > 0 THEN
+							NEW(mod.imp, mod.ni);
+							x := 0;
+							WHILE x < mod.ni DO
+								ReadName(name);
+								IF name = "$$" THEN
+									IF (mod # kernel) & (kernel # NIL) THEN
+										mod.imp[x] := kernel
+									ELSE
+										WriteSString("no kernel"); WriteLn;
+										FlushW; error := TRUE
+									END
+								ELSIF name[0] = "$" THEN
+									(* StdLog.String(name$);  *)
+									Console.WriteStr(name$);
+									i := 1;
+									WHILE name[i] # 0X DO name[i-1] := name[i]; INC(i) END;
+									name[i-1] := 0X; 
+									IF i # 1 THEN
+										Strings.Find(name$, ".so", 0, pos);
+										IF pos = -1 THEN
+											name[i - 1] := "."; name[i] := "s"; name[i + 1] := "o"; name[i + 2] := 0X
+										END
+									END;
+									(* StdLog.String("  "); StdLog.String(name$); StdLog.Ln; *)
+									Console.WriteStr(" "); Console.WriteStr(name$); Console.WriteLn;
+									impdll := TRUE; im := modList;
+									WHILE (im # mod) & (im.name # name) DO im := im.next END;
+									IF (im = NIL) OR ~im.dll THEN
+										NEW(im); im.next := modList; modList := im;
+										im.dll := TRUE;
+										im.name := name$; 
+										dynstrtab.AddName(name, i);
+										AddNeededIdx(i)
+									END;
+									mod.imp[x] := im
+								ELSE
+									im := modList;
+									WHILE (im # mod) & (im.name # name) DO im := im.next END;
+									IF im # mod THEN
+										mod.imp[x] := im
+									ELSE
+										WriteSString(name);
+										WriteString(" not present (imported in ");
+										WriteString(mod.name$); WriteChar(")");
+										WriteLn; FlushW; error := TRUE
+									END
+								END;
+								INC(x)
+							END
+						END;
+						IF impdll & ~error THEN CheckDllImports(mod) END;
+						mod.ma := ConSize; INC(ConSize, mod.ms + mod.ds);
+						mod.va := DataSize; INC(DataSize, mod.vs);
+						mod.ca := CodeSize; INC(CodeSize, mod.cs);
+						IF mod.cs > maxCode THEN maxCode := mod.cs END
+					ELSE
+						WriteString(mod.name$); WriteString(": wrong file type"); 
+						WriteLn; FlushW; error := TRUE
+					END;
+					mod.file.Close; mod.file := NIL
+				ELSE
+					WriteString(mod.fileName$ (* A. V. Shiryaev *)); WriteString(" not found"); 
+					WriteLn; FlushW; error := TRUE
+				END;
+				last := mod
+			END;
+			mod := mod.next
+		END;
+		IF ~isStatic & (main = NIL) THEN
+			WriteSString("no main module specified"); WriteLn;
+			FlushW; error := TRUE
+		END;
+		IF DataSize = 0 THEN DataSize := 1 END
+	END ReadHeaders;
+
+	PROCEDURE WriteElfHeader;
+	BEGIN
+		ASSERT(Ro.Pos() = 0, 100);
+		dynstrtab.AddName(soName$, sonameStrIndexVal);
+		Write4(464C457FH); Write4(00010101H); Write4(0); Write4(0); (* Magic *)
+		Write2(3); (* ET_DYN e_type Object file type *)
+		Write2(3); (* EM_386 e_machine Architecture *)
+		Write4(1); (* EV_CURRENT e_version Object file version *)
+		Write4(text.memOffset); (* e_entry Entry point virtual address *)
+		entryPos := Ro.Pos();
+		Write4(fixup); (* e_phoff Program header table file offset *)
+		Write4(fixup); (* e_shoff: Section header table file offset *)
+		Write4(0); (* e_flags Processor-specific flags *)
+		Write2(elfHeaderSizeVal); (* e_ehsize ELF header size in bytes *)
+		Write2(phEntrySizeVal); (* e_phentsize Program header table entry size *)
+		Write2(phNumVal); (* e_phnum Program header table entry count *)
+		Write2(shEntrySizeVal); (* e_shentsize Section header table entry size *)
+		Write2(shNumVal); (* e_shnum Section header table entry count *)
+		Write2(shStrndxVal); (* e_shstrndx Section header string table index *)
+		ASSERT(Ro.Pos() = elfHeaderSizeVal, 101)
+	END WriteElfHeader;
+
+	PROCEDURE FixupElfHeader;
+	BEGIN
+		Ro.SetPos(entryPos);
+		Write4(phOffsetVal);
+		Write4(shOffsetVal)
+	END FixupElfHeader;
+
+	PROCEDURE WriteNullSectionHeader;
+	BEGIN
+		Write4(0); (* sh_name Section name (string tbl index) *)
+		Write4(0); (* SHT_NULL sh_type Section type *)
+		Write4(0); (* sh_flags Section flags *)
+		Write4(0); (* ELF header + program header table; sh_addr Section virtual addr at execution *)
+		Write4(0); (* sh_offset Section file offset *)
+		Write4(0); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(0); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteNullSectionHeader;
+
+	PROCEDURE WriteTextSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".text", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(1); (* SHT_PROGBITS sh_type Section type *)
+		Write4(2H + 4H); (* SHF_ALLOC + SHF_EXECINSTR sh_flags Section flags *)
+		Write4(text.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(text.fileOffset); (* sh_offset Section file offset *)
+		Write4(text.size); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(textAlign); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteTextSectionHeader;
+
+	PROCEDURE WriteRelTextSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".rel.text", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(9); (* SHT_REL sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(reltext.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(reltext.fileOffset); (* sh_offset Section file offset *)
+		Write4(reltext.size); (* sh_size Section size in bytes *)
+		Write4(dynsymIndexVal); (* sh_link Link to another section -> index of the associated symbol table *)
+		Write4(textIndexVal); (* sh_info Additional section information -> index of the relocated section *)
+		Write4(relAlign); (* sh_addralign Section alignment *)
+		Write4(relEntrySizeVal) (* sh_entsize Entry size if section holds table *)
+	END WriteRelTextSectionHeader;
+
+	PROCEDURE WriteRelRodataSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".rel.rodata", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(9); (* SHT_REL sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(relrodata.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(relrodata.fileOffset); (* sh_offset Section file offset *)
+		Write4(relrodata.size); (* sh_size Section size in bytes *)
+		Write4(dynsymIndexVal); (* sh_link Link to another section -> index of the associated symbol table *)
+		Write4(rodataIndexVal); (* sh_info Additional section information -> index of the relocated section *)
+		Write4(relAlign); (* sh_addralign Section alignment *)
+		Write4(relEntrySizeVal) (* sh_entsize Entry size if section holds table *)
+	END WriteRelRodataSectionHeader;
+
+	PROCEDURE WriteRodataSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".rodata", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(1); (* SHT_PROGBITS sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(rodata.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(rodata.fileOffset); (* sh_offset Section file offset *)
+		Write4(rodata.size); (* sh_size Section size in bytes *)
+		Write4(0); (* sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(rodataAlign); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteRodataSectionHeader;
+
+	PROCEDURE WriteDynsymSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".dynsym", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(11); (* SHT_DYNSYM sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(dynsym.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(dynsym.fileOffset); (* sh_offset Section file offset *)
+		Write4(dynsym.size); (* sh_size Section size in bytes *)
+		Write4(dynstrIndexVal); (* sh_link Link to another section -> index of the associated string table *)
+		expPos := Ro.Pos();
+		Write4(fixup); (* sh_info Additional section information -> see docu 4-17 *)
+		Write4(dynsymAlign); (* sh_addralign Section alignment *)
+		Write4(dynsymEntrySizeVal) (* sh_entsize Entry size if section holds table *)
+	END WriteDynsymSectionHeader;
+
+	PROCEDURE FixupDynsymSectionHeader;
+	BEGIN
+		Ro.SetPos(expPos);
+		Write4(dynsymInfoVal)
+	END FixupDynsymSectionHeader;
+	
+	PROCEDURE WriteDynstrSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".dynstr", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(3); (* SHT_STRTAB sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(dynstr.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(dynstr.fileOffset); (* sh_offset Section file offset *)
+		Write4(dynstr.size); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(dynstrAlign); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteDynstrSectionHeader;
+	
+	PROCEDURE WriteHashSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".hash", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(5); (* SHT_HASH sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(hash.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(hash.fileOffset); (* sh_offset Section file offset *)
+		Write4(hash.size); (* sh_size Section size in bytes *)
+		Write4(dynsymIndexVal); (* sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(hashAlign); (* sh_addralign Section alignment *)
+		Write4(4H) (* sh_entsize Entry size if section holds table *)
+	END WriteHashSectionHeader;
+
+	PROCEDURE WriteGotSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".got", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(1); (* SHT_PROGBITS sh_type Section type *)
+		Write4(2H + 1H); (* SHF_ALLOC + SHF_WRITE sh_flags Section flags *)
+		Write4(got.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(got.fileOffset); (* sh_offset Section file offset *)
+		Write4(got.size); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(gotAlign); (* sh_addralign Section alignment *)
+		Write4(gotEntrySizeVal) (* sh_entsize Entry size if section holds table *)
+	END WriteGotSectionHeader;
+	
+	PROCEDURE WriteBssSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".bss", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(8); (* SHT_NOBITS sh_type Section type *)
+		Write4(2H + 1H); (* SHF_ALLOC + SHF_WRITE sh_flags Section flags *)
+		Write4(bss.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(bss.fileOffset); (* sh_offset Section file offset *)
+		Write4(bss.size); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(bssAlign); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteBssSectionHeader;
+	
+	PROCEDURE WriteDynamicSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".dynamic", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(6); (* SHT_DYNAMIC sh_type Section type *)
+		Write4(2H); (* SHF_ALLOC sh_flags Section flags *)
+		Write4(dynamic.memOffset); (* sh_addr Section virtual addr at execution *)
+		Write4(dynamic.fileOffset); (* sh_offset Section file offset *)
+		Write4(dynamic.size); (* sh_size Section size in bytes *)
+		Write4(dynstrIndexVal); (* sh_link Link to another section -> index of the associated symbol table *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(dynamicAlign); (* sh_addralign Section alignment *)
+		Write4(dynamicEntrySizeVal) (* sh_entsize Entry size if section holds table *)
+	END WriteDynamicSectionHeader;
+	
+	PROCEDURE WriteShstrtabSectionHeader;
+		VAR i: INTEGER;
+	BEGIN
+		headerstrtab.AddName(".shstrtab", i);
+		Write4(i); (* sh_name Section name (string tbl index) *)
+		Write4(3); (* SHT_STRTAB sh_type Section type *)
+		Write4(0); (* sh_flags Section flags *)
+		Write4(0); (* sh_addr Section virtual addr at execution *)
+		Write4(shstrtab.fileOffset); (* sh_offset Section file offset *)
+		shstrtabPos := Ro.Pos();
+		Write4(fixup); (* sh_size Section size in bytes *)
+		Write4(0); (* SHN_UNDEF sh_link Link to another section *)
+		Write4(0); (* sh_info Additional section information *)
+		Write4(shstrtabAlign); (* sh_addralign Section alignment *)
+		Write4(0) (* sh_entsize Entry size if section holds table *)
+	END WriteShstrtabSectionHeader;
+	
+	PROCEDURE FixupShstrtabSectionHeader;
+	BEGIN
+		Ro.SetPos(shstrtabPos);
+		Write4(shstrtab.size)
+	END FixupShstrtabSectionHeader;
+
+	PROCEDURE WriteRelSectionHeaders;
+	BEGIN
+		WriteRelTextSectionHeader;
+		WriteRelRodataSectionHeader
+	END WriteRelSectionHeaders;
+	
+	PROCEDURE WriteSectionHeaderTable;
+	BEGIN
+		shOffsetVal := Ro.Pos();
+		WriteNullSectionHeader;
+		WriteTextSectionHeader;
+		WriteRodataSectionHeader;
+		WriteRelSectionHeaders;
+		WriteDynsymSectionHeader;
+		WriteDynstrSectionHeader;
+		WriteHashSectionHeader;
+		WriteGotSectionHeader;
+		WriteDynamicSectionHeader;
+		WriteBssSectionHeader;
+		WriteShstrtabSectionHeader	(* see shStrndxVal *)
+		(* see shNumVal *)
+	END WriteSectionHeaderTable;
+
+	PROCEDURE FixupSectionHeaderTable;
+	BEGIN
+		FixupDynsymSectionHeader;
+		FixupShstrtabSectionHeader
+	END FixupSectionHeaderTable;
+
+	PROCEDURE WriteTextSegment;
+	BEGIN
+		Write4(1); (* PT_LOAD *)
+		Write4(0); (* offset *)
+		Write4(0); (* vaddr *)
+		Write4(0); (* paddr *)
+		Write4(textSegmentSizeVal); (* file size *)
+		Write4(textSegmentSizeVal); (* mem size *)
+		Write4(4H + 1H + 2H); (* flags: R+E+W *)
+		Write4(pageSize) (* I386 page size *)
+	END WriteTextSegment;
+	
+	PROCEDURE WriteDataSegment;
+	BEGIN
+		Write4(1); (* PT_LOAD *)
+		Write4(got.fileOffset); (* offset text segment size *)
+		Write4(got.memOffset); (* vaddr: offset + alignment * nof pages of text segment *)
+		Write4(got.memOffset); (* paddr: offset + alignment * nof pages of text segment *)
+		Write4(dataSegmentSizeVal); (* file size *)
+		Write4(dataSegmentSizeVal + bss.size); (* mem size -> dataSegmentSizeVal + NOBITS sections *)
+		Write4(4H + 2H); (* flags: R+W *)
+		Write4(pageSize) (* I386 page size *)
+	END WriteDataSegment;
+	
+	PROCEDURE WriteDynamicSegment;
+	BEGIN
+		Write4(2); (* PT_DYNAMIC *)
+		Write4(dynamic.fileOffset); (* offset text segment size *)
+		Write4(dynamic.memOffset); (* vaddr: offset of .dynamic section *)
+		Write4(dynamic.memOffset); (* paddr: vaddr + alignment * nof pages of text segment *)
+		Write4(dynamicSegmentSizeVal); (* file size *)
+		Write4(dynamicSegmentSizeVal); (* mem size *)
+		Write4(4H + 2H); (* flags: R+W *)
+		Write4(dynamicAlign) (* dynamic section alignement*)
+	END WriteDynamicSegment;
+	
+	PROCEDURE WriteProgramHeaderTable;
+	BEGIN
+		phOffsetVal := Ro.Pos();
+		WriteTextSegment; (* .text .rel.text .rodata .dynsym .dynstr .hash *)
+		WriteDataSegment; (* .got .dynamic .bss *)
+		WriteDynamicSegment (* .dynamic *)
+	END WriteProgramHeaderTable;
+	
+	PROCEDURE SearchObj (mod: Module; VAR name: ARRAY OF SHORTCHAR; m, fp, opt: INTEGER; VAR adr: INTEGER);
+		VAR dir, len, ntab, f, id, l, r, p, n, i, j: INTEGER; nch, och: SHORTCHAR;
+	BEGIN
+		Get(mod, mod.ms + modExports, dir); DEC(dir, rodata.memOffset + mod.ma); Get(mod, dir, len); INC(dir, 4);
+		Get(mod, mod.ms + modNames, ntab); DEC(ntab, rodata.memOffset + mod.ma);
+		IF name # "" THEN
+			l := 0; r := len;
+			WHILE l < r DO	(* binary search *)
+				n := (l + r) DIV 2; p := dir + n * 16;
+				Get(mod, p + 8, id);
+				i := 0; j := ntab + id DIV 256; nch := name[0]; och := SHORT(CHR(mod.data[j]));
+				WHILE (nch = och) & (nch # 0X) DO INC(i); INC(j); nch := name[i]; och := SHORT(CHR(mod.data[j])) END;
+				IF och = nch THEN
+					IF id MOD 16 = m THEN
+						Get(mod, p, f);
+						IF m = mTyp THEN
+							IF ODD(opt) THEN Get(mod, p + 4, f) END;
+							IF (opt > 1) & (id DIV 16 MOD 16 # mExported) THEN
+								WriteString(mod.name$); WriteChar("."); WriteSString(name);
+								WriteString(" imported from "); WriteString(impg.name$);
+								WriteString(" has wrong visibility"); WriteLn; error := TRUE
+							END;
+							Get(mod, p + 12, adr)
+						ELSIF m = mVar THEN
+							Get(mod, p + 4, adr); INC(adr, bss.memOffset + mod.va)
+						ELSIF m = mProc THEN
+							Get(mod, p + 4, adr); INC(adr, text.memOffset + mod.ca)
+						END;
+						IF f # fp THEN
+							WriteString(mod.name$); WriteChar("."); WriteSString(name);
+							WriteString(" imported from "); WriteString(impg.name$);
+							WriteString(" has wrong fprint"); WriteLn; error := TRUE
+						END
+					ELSE
+						WriteString(mod.name$); WriteChar("."); WriteSString(name);
+						WriteString(" imported from "); WriteString(impg.name$);
+						WriteString(" has wrong class"); WriteLn; error := TRUE
+					END;
+					RETURN
+				END;
+				IF och < nch THEN l := n + 1 ELSE r := n END
+			END;
+			WriteString(mod.name$); WriteChar("."); WriteSString(name);
+			WriteString(" not found (imported from "); WriteString(impg.name$);
+			WriteChar(")"); WriteLn; error := TRUE
+		ELSE (* anonymous type *)
+			WHILE len > 0 DO
+				Get(mod, dir + 4, f); Get(mod, dir + 8, id);
+				IF (f = fp) & (id MOD 16 = mTyp) & (id DIV 256 = 0) THEN
+					Get(mod, dir + 12, adr); RETURN
+				END;
+				DEC(len); INC(dir, 16)
+			END;
+			WriteString("anonymous type in "); WriteString(mod.name$);
+			WriteString(" not found"); WriteLn; error := TRUE
+		END
+	END SearchObj;
+	
+	PROCEDURE CollectExports (mod: Module);
+		VAR dir, len, ntab, id, i, j, n: INTEGER; e, exp: Export;
+	BEGIN
+		ASSERT(mod.intf & ~mod.dll, 20);
+		Get(mod, mod.ms + modExports, dir);
+		DEC(dir, rodata.memOffset + mod.ma); Get(mod, dir, len); INC(dir, 4);
+		Get(mod, mod.ms + modNames, ntab); DEC(ntab, rodata.memOffset + mod.ma); n := 0;
+		WHILE n < len DO
+			Get(mod, dir + 8, id);
+			IF (id DIV 16 MOD 16 # mInternal) & (id MOD 16 = mProc) THEN	(* exported procedure *)
+				NEW(exp);
+				i := 0; j := ntab + id DIV 256;
+				WHILE mod.data[j] # 0 DO exp.name[i] := SHORT(CHR(mod.data[j])); INC(i); INC(j) END;
+				exp.name[i] := 0X;
+				Get(mod, dir + 4, exp.adr);
+				IF id MOD 16 = mProc THEN
+					INC(exp.adr, text.memOffset + mod.ca)
+				ELSE
+					HALT(126);
+					ASSERT(id MOD 16 = mVar); INC(exp.adr, bss.memOffset + mod.va)
+				END;
+				IF (firstExp = NIL) OR (exp.name < firstExp.name) THEN
+					exp.next := firstExp; firstExp := exp;
+					IF lastExp = NIL THEN lastExp := exp END
+				ELSE
+					e := firstExp;
+					WHILE (e.next # NIL) & (exp.name > e.next.name) DO e := e.next END;
+					exp.next := e.next; e.next := exp;
+					IF lastExp = e THEN lastExp := exp END
+				END;
+				INC(numExp)
+			END;
+			INC(n); INC(dir, 16)
+		END
+	END CollectExports;
+
+	PROCEDURE Relocate0 (link, adr, sym: INTEGER);
+		CONST
+			absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; (* BB fixup types *)
+			noElfType = MIN(INTEGER);
+		VAR
+			offset, linkadr, bbType, elfType, n, x: INTEGER; relText: BOOLEAN;
+	BEGIN
+		WHILE link # 0 DO
+			RNum(offset);
+			WHILE link # 0 DO
+				IF link > 0 THEN
+					n := (code[link] MOD 256) + (code[link+1] MOD 256) * 256 + code[link+2] * 65536;
+					bbType := code[link+3];
+					linkadr := text.memOffset + impg.ca + link
+				ELSE
+					n := (impg.data[-link] MOD 256) + (impg.data[-link+1] MOD 256) * 256 + impg.data[-link+2] * 65536;
+					bbType := impg.data[-link+3];
+					linkadr := rodata.memOffset + impg.ma - link
+				END;
+				elfType := noElfType;
+				IF bbType = absolute THEN
+					IF sym = noSymbol THEN
+						x := adr + offset;
+						elfType := r386Relative
+					ELSE
+						x := 0H;
+						elfType := r38632 + sym * 256
+					END
+				ELSIF bbType = relative THEN
+					IF sym = noSymbol THEN
+						x := adr + offset - linkadr - 4
+					ELSE
+						x := 0FFFFFFFCH;
+						elfType := r386pc32 + sym * 256
+					END
+				ELSIF bbType = copy THEN
+					Get(impd, adr + offset - rodata.memOffset - impd.ma, x);
+					IF x # 0 THEN elfType := r386Relative END
+				ELSIF bbType = table THEN
+					x := adr + n; n := link + 4;
+					elfType := r386Relative
+				ELSIF bbType = tableend THEN
+					x := adr + n; n := 0;
+					elfType := r386Relative
+				ELSE HALT(99)
+				END;
+				relText := link > 0; 
+				IF link > 0 THEN
+					code[link] := SHORT(SHORT(x));
+					code[link+1] := SHORT(SHORT(x DIV 100H));
+					code[link+2] := SHORT(SHORT(x DIV 10000H));
+					code[link+3] := SHORT(SHORT(x DIV 1000000H))
+				ELSE
+					link := -link;
+					impg.data[link] := SHORT(SHORT(x));
+					impg.data[link+1] := SHORT(SHORT(x DIV 100H));
+					impg.data[link+2] := SHORT(SHORT(x DIV 10000H));
+					impg.data[link+3] := SHORT(SHORT(x DIV 1000000H))
+				END;
+				IF elfType # noElfType THEN
+					IF relText THEN
+						relTextTab.Add(linkadr, elfType)
+					ELSE
+						relRodataTab.Add(linkadr, elfType)
+					END
+				END;
+				link := n
+			END;
+			RNum(link)
+		END
+	END Relocate0;
+	
+	PROCEDURE Relocate (adr: INTEGER);
+		VAR link: INTEGER;
+	BEGIN
+		RNum(link); Relocate0(link, adr, noSymbol)
+	END Relocate;
+
+	PROCEDURE RelocateSymbol (adr, sym: INTEGER);
+		VAR link: INTEGER;
+	BEGIN
+		RNum(link); Relocate0(link, adr, sym)
+	END RelocateSymbol;
+	
+	PROCEDURE SymbolIndex (IN name: Name): INTEGER;
+		VAR n: INTEGER; exp: Export; m: Module;
+	BEGIN
+		n := 0; exp := NIL;
+		m := modList;
+		WHILE (m # NIL) & (exp = NIL) DO
+			IF m.dll THEN
+				exp := m.exp;
+				WHILE (exp # NIL) & (exp.name$ # name$) DO
+					INC(n);
+					exp := exp.next
+				END
+			END;
+			m := m.next
+		END;
+		ASSERT((exp # NIL) & (exp.name$ = name$), 60);
+		RETURN firstDllSymbolVal + n
+	END SymbolIndex;
+
+	PROCEDURE WriteTextSection;
+		VAR mod, m: Module; i, x, a, sym, fp, opt: INTEGER; exp: Export; name: Name;
+	BEGIN
+		ASSERT(isDll, 126);
+		ASSERT(~doWrite OR (Ro.Pos() = text.fileOffset), 100);
+		WriteCh(053X);	(* push ebx *)	(* _init() *)
+		a := 1;
+		WriteCh(0BBX); Write4(rodata.memOffset  + last.ma + last.ms);	(* mov bx, modlist *)
+		relTextTab.Add(text.memOffset + a + 1, r386Relative);
+		INC(a, 5);
+		IF isStatic THEN
+			m := modList;
+			WHILE m # NIL DO
+				IF ~m.dll THEN
+					WriteCh(0E8X); INC(a, 5); Write4(m.ca - a)	(* call body *)
+				END;
+				m := m.next
+			END
+		ELSE
+			WriteCh(0E8X); INC(a, 5); Write4(main.ca - a)	(* call main *)
+		END;
+		WriteCh(05BX); 	(* pop ebx *)
+		WriteCh(0C3X);	(* ret *)
+		INC(a, 2);
+		finiMemOffsetVal := text.memOffset + a;
+		WriteCh(053X);	(* push ebx *)	(* _fini() *)
+		INC(a);
+		finiPos := text.memOffset + a;
+		IF isStatic THEN
+			i := 0;
+			WHILE i < numMod DO	(* nop for call terminator *)
+				WriteCh(02DX); Write4(0);	(* sub EAX, 0 *)
+				INC(i); INC(a, 5)
+			END
+		ELSE
+			WriteCh(02DX); Write4(0);	(* sub EAX, 0 *)
+			INC(a, 5)
+		END;
+		lastTerm := a;
+		WriteCh(05BX); 	(* pop ebx *)
+		WriteCh(0C3X);	(* ret *)	
+		IF ~doWrite THEN NEW(code, maxCode) END;
+		mod := modList;
+		WHILE mod # NIL DO
+			impg := mod;
+			impd := mod;
+			IF ~mod.dll THEN
+				mod.file := ThisFile(mod.fileName);
+				R := mod.file.NewReader(R);
+				R.SetPos(mod.hs);
+				IF ~doWrite THEN NEW(mod.data, mod.ms + mod.ds) END;
+				R.ReadBytes(mod.data^, 0, mod.ms + mod.ds);
+				R.ReadBytes(code^, 0, mod.cs);
+				RNum(x);
+				IF x # 0 THEN
+					IF (mod # kernel) & (kernel # NIL) THEN
+						SearchObj(kernel, newRec, mProc, NewRecFP, 0, a);
+						IF error THEN RETURN END;
+						Relocate0(x, a, noSymbol)
+					ELSE
+						WriteSString("no kernel"); WriteLn;
+						FlushW;
+						error := TRUE;
+						RETURN
+					END
+				END;
+				RNum(x);
+				IF x # 0 THEN
+					IF (mod # kernel) & (kernel # NIL) THEN
+						SearchObj(kernel, newArr, mProc, NewArrFP, 0, a);
+						IF error THEN RETURN END;
+						Relocate0(x, a, noSymbol)
+					ELSE
+						WriteSString("no kernel"); WriteLn;
+						FlushW; error := TRUE;
+						RETURN
+					END
+				END;
+				Relocate(rodata.memOffset + mod.ma); (* metalink *)
+				Relocate(rodata.memOffset + mod.ma + mod.ms); (* desclink *)
+				Relocate(text.memOffset + mod.ca); (* codelink *)
+				Relocate(bss.memOffset + mod.va); (* datalink *)
+				i := 0;
+				WHILE i < mod.ni DO
+					m := mod.imp[i]; impd := m; RNum(x);
+					WHILE x # 0 DO
+						ReadName(name); RNum(fp); opt := 0;
+						IF x = mTyp THEN RNum(opt) END;
+						sym := noSymbol;
+						IF m.dll THEN
+							IF (x = mProc) OR (x = mVar) THEN
+								exp := m.exp;
+								WHILE exp.name # name DO exp := exp.next END;
+								a := noAddr;
+								sym := SymbolIndex(name)
+							END
+						ELSE
+							SearchObj(m, name, x, fp, opt, a);
+							IF error THEN RETURN END
+						END;
+						IF x # mConst THEN
+							RelocateSymbol(a, sym)
+						END;
+						RNum(x)
+					END;
+					IF ~m.dll THEN
+						Get(mod, mod.ms + modImports, x); DEC(x, rodata.memOffset + mod.ma); INC(x, 4 * i);
+						Put(mod, x, rodata.memOffset + m.ma + m.ms);	(* imp ref *)
+						relRodataTab.Add(rodata.memOffset + mod.ma + x, r386Relative);
+						Get(m, m.ms + modRefcnt, x); Put(m, m.ms + modRefcnt, x + 1)	(* inc ref count *)
+					END;
+					INC(i)
+				END;
+				WriteBytes(code^, 0, mod.cs);
+				IF mod.intf THEN CollectExports(mod) END;
+				mod.file.Close; mod.file := NIL
+			END;
+			mod := mod.next
+		END;
+		ASSERT(~doWrite OR (text.size = Ro.Pos() - text.fileOffset), 101)
+	END WriteTextSection;
+
+	PROCEDURE WriteTermCode (m: Module; i: INTEGER);
+		VAR x: INTEGER;
+	BEGIN
+		IF m # NIL THEN
+			IF m.dll THEN WriteTermCode(m.next, i)
+			ELSE
+				IF isStatic THEN WriteTermCode(m.next, i + 1) END;
+				Get(m, m.ms + modTerm, x);	(* terminator address in mod desc*)
+				IF x = 0 THEN
+					WriteCh(005X); Write4(0)	(* add EAX, 0 (nop) *)
+				ELSE
+					WriteCh(0E8X); Write4(x - lastTerm + 5 * i - text.memOffset)	(* call term *)
+				END
+			END
+		END
+	END WriteTermCode;
+
+	PROCEDURE FixupTextSection;
+	BEGIN
+		ASSERT(isDll, 126);
+		Ro.SetPos(finiPos);
+		IF isStatic THEN
+			WriteTermCode(modList, 0)
+		ELSE
+			WriteTermCode(main, 0)
+		END
+	END FixupTextSection;
+
+	PROCEDURE WriteRelSection (IN s: Section; IN t: RelTab);
+		VAR i: INTEGER;
+	BEGIN
+		ASSERT(s.fileOffset = Ro.Pos(), 100);
+		i := 0;
+		WHILE i # t.cur DO
+			Write4(t.tab[i].offset);
+			Write4(t.tab[i].type);
+			INC(i)
+		END;
+		ASSERT(s.size = Ro.Pos() - s.fileOffset, 101)
+	END WriteRelSection;
+
+	PROCEDURE WriteRelSections;
+	BEGIN
+		WriteRelSection(reltext, relTextTab);
+		WriteRelSection(relrodata, relRodataTab)
+	END WriteRelSections;
+	
+	PROCEDURE WriteRodataSection;
+		VAR mod, lastMod: Module; x: INTEGER;
+	BEGIN
+		ASSERT(~doWrite OR (rodata.fileOffset = Ro.Pos()), 100);
+		mod := modList; lastMod := NIL;
+		WHILE mod # NIL DO
+			IF ~mod.dll THEN
+				IF lastMod # NIL THEN
+					Put(mod, mod.ms, rodata.memOffset + lastMod.ma + lastMod.ms);	(* mod list *)
+					relRodataTab.Add(rodata.memOffset + mod.ma + mod.ms, r386Relative)
+				END;
+				Get(mod, mod.ms + modOpts, x);
+				IF isStatic THEN INC(x, 10000H) END;	(* set init bit (16) *)
+				IF isDll THEN INC(x, 1000000H) END;	(* set dll bit (24) *)
+				Put(mod, mod.ms + modOpts, x);
+				WriteBytes(mod.data^, 0, mod.ms + mod.ds);
+				lastMod := mod
+			END;
+			mod := mod.next
+		END;		
+		ASSERT(~doWrite OR (rodata.size = Ro.Pos() - rodata.fileOffset), 101)
+	END WriteRodataSection;
+		
+	PROCEDURE WriteSymbolTableEntry (IN name: ARRAY OF SHORTCHAR; val, size: INTEGER; bind, type: BYTE; shndx: INTEGER);
+		VAR i: INTEGER; info: SHORTCHAR;
+	BEGIN
+		IF name # "" THEN dynstrtab.AddName(name, i)
+		ELSE i := 0
+		END;
+		Write4(i);
+		Write4(val);
+		Write4(size);
+		info := SHORT(CHR(bind * 16 + type));
+		WriteCh(info);
+		WriteCh(0X); (* Symbol visibility *)
+		Write2(shndx)
+	END WriteSymbolTableEntry;
+	
+	PROCEDURE FixupSymbolTableEntry (val, size: INTEGER; bind, type: BYTE; shndx: INTEGER);
+		VAR info: SHORTCHAR;
+	BEGIN
+		Ro.SetPos(Ro.Pos() + 4); (* skip name *)
+		Write4(val);
+		Write4(size);
+		info := SHORT(CHR(bind * 16 + type));
+		WriteCh(info);
+		WriteCh(0X); (* Symbol visibility *)
+		Write2(shndx)
+	END FixupSymbolTableEntry;
+	
+	PROCEDURE WriteDynsymSection;
+		VAR e: Export; m: Module; i: INTEGER;
+	BEGIN
+		ASSERT(Ro.Pos() = dynsym.fileOffset, 100);
+		WriteSymbolTableEntry("", 0, 0, 0, 0, 0);
+		WriteSymbolTableEntry("", text.memOffset, 0, stbLocal, sttSection, 1); (* .text section *)
+		WriteSymbolTableEntry("", rodata.memOffset, 0, stbLocal, sttSection, 2); (* .rodata section *)
+		WriteSymbolTableEntry("", reltext.memOffset, 0, stbLocal, sttSection, 3); (* .rel.text.section *)
+		WriteSymbolTableEntry("", relrodata.memOffset, 0, stbLocal, sttSection, 4); (* .rel.rodata section *)
+		WriteSymbolTableEntry("", dynsym.memOffset, 0, stbLocal, sttSection, 5); (* .dynsym section *)
+		WriteSymbolTableEntry("", dynstr.memOffset, 0, stbLocal, sttSection, 6); (* .dynstr section *)
+		WriteSymbolTableEntry("", hash.memOffset, 0, stbLocal, sttSection, 7); (* .hash section *)
+		WriteSymbolTableEntry("", got.memOffset, 0, stbLocal, sttSection, 8); (* .got section *)
+		WriteSymbolTableEntry("", dynamic.memOffset, 0, stbLocal, sttSection, 9); (* .dynamic section *)
+		WriteSymbolTableEntry("", bss.memOffset, 0, stbLocal, sttSection, 10); (* .bss section *)
+		dynsymInfoVal := 11;
+		i := dynsymInfoVal;
+		WriteSymbolTableEntry("_DYNAMIC", dynamic.memOffset, 0, stbGlobal, sttObject, shnAbs);
+		hashtab[i] := "_DYNAMIC";
+		INC(i);
+		ASSERT(i = firstDllSymbolVal);
+		m := modList;
+		WHILE m # NIL DO
+			IF m.dll THEN
+				e := m.exp;
+				WHILE e # NIL DO
+					WriteSymbolTableEntry(e.name, 0, 0, stbGlobal, sttNotype, shnUnd);
+					hashtab[i] := e.name$;
+					INC(i);
+					e := e.next
+				END
+			END;
+			m := m.next
+		END;
+		e := firstExp;
+		WHILE e # NIL DO
+			WriteSymbolTableEntry(e.name, fixup, 0, stbGlobal, sttFunc, textIndexVal);
+			hashtab[i] := e.name$; INC(i);
+			e := e.next
+		END;
+		WriteSymbolTableEntry("_GLOBAL_OFFSET_TABLE_", got.memOffset, 0, stbGlobal, sttObject, shnAbs);
+		hashtab[i] := "_GLOBAL_OFFSET_TABLE_";
+		ASSERT(dynsym.size = Ro.Pos() - dynsym.fileOffset, 101)
+	END WriteDynsymSection;
+	
+	PROCEDURE FixupDynsymSection;
+		VAR e: Export; m: Module;
+	BEGIN
+		Ro.SetPos(dynsym.fileOffset + dynsymEntrySizeVal * firstDllSymbolVal);
+		m := modList;
+		WHILE m # NIL DO
+			IF m.dll THEN
+				e := m.exp;
+				WHILE e # NIL DO
+					Ro.SetPos(Ro.Pos() + dynsymEntrySizeVal);
+					e := e.next
+				END
+			END;
+			m := m.next
+		END;
+		Ro.SetPos(Ro.Pos() + 4);
+		e := firstExp;
+		WHILE e # NIL DO
+			Write4(e.adr);
+			Ro.SetPos(Ro.Pos() + 12);
+			e := e.next
+		END
+	END FixupDynsymSection;
+
+	PROCEDURE WriteStringTable (IN t: Strtab);
+		VAR i: INTEGER;
+	BEGIN
+		i := 0;
+		WHILE i # t.cur DO
+			WriteCh(t.tab[i]);
+			INC(i)
+		END
+	END WriteStringTable;
+
+	PROCEDURE WriteDynstrSection;
+	BEGIN
+		ASSERT(Ro.Pos() = dynstr.fileOffset, 100);
+		WriteStringTable(dynstrtab);
+		ASSERT(dynstr.size = Ro.Pos() - dynstr.fileOffset, 101)
+	END WriteDynstrSection;
+
+	PROCEDURE Hash (name: ARRAY OF SHORTCHAR): INTEGER;
+		VAR i, h, g: INTEGER;
+	BEGIN
+		h := 0; i := 0;
+		WHILE name[i] # 0X DO
+			h := ASH(h, 4) + ORD(name[i]);
+			g := ORD(BITS(h) * BITS(0F0000000H));
+			IF g # 0 THEN
+				h := ORD(BITS(h) / BITS(SHORT((g MOD 100000000L) DIV 1000000H)))
+			END;
+			h := ORD(BITS(h) * (-BITS(g)));
+			INC(i)
+		END;
+		RETURN h
+	END Hash;
+
+	PROCEDURE AddToChain (VAR c: ARRAY OF INTEGER; i, idx: INTEGER);
+		VAR k: INTEGER;
+	BEGIN
+		IF c[i] # 0 THEN
+			k := i;
+			WHILE c[k] # 0 DO k := c[k] END;
+			c[k] := idx
+		ELSE
+			c[i] := idx
+		END
+	END AddToChain;
+
+	PROCEDURE WriteHashSection;
+		VAR n, i, hi: INTEGER; b, c: POINTER TO ARRAY OF INTEGER;
+	BEGIN
+		ASSERT(hash.fileOffset = Ro.Pos(), 100);
+		n := dynsym.size DIV dynsymEntrySizeVal; (* number of enties in the symbol table *)
+		NEW(b, n);
+		NEW(c, n);
+		i := 0;
+		WHILE i # n DO
+			c[i] := 0; (* STN_UNDEF *)
+			IF hashtab[i] # "" THEN
+				hi := Hash(hashtab[i]) MOD n;
+				IF b[hi] # 0 THEN (* another word has the same index *)
+					AddToChain(c, i, b[hi])  (*c[i] := b[hi]*)
+				END;
+				b[hi] := i
+			END;
+			INC(i)
+		END;
+		Write4(n); (* nbucket *)
+		Write4(n); (* nchain *)
+		i := 0;
+		WHILE i # n DO
+			Write4(b[i]);
+			INC(i)
+		END;
+		i := 0;
+		WHILE i # n DO
+			Write4(c[i]);
+			INC(i)
+		END;
+		ASSERT(hash.size = Ro.Pos() - hash.fileOffset, 101)
+	END WriteHashSection;
+	
+	PROCEDURE WriteGotSection;
+	BEGIN
+		ASSERT(got.fileOffset = Ro.Pos(), 100);
+		Write4(dynamic.memOffset); (* addr of .dynamic section *)
+		Write4(0); (* reserved for ? *)
+		Write4(0); (* reserved for ? *)
+		ASSERT(got.size = Ro.Pos() - got.fileOffset, 101)
+	END WriteGotSection;
+	
+	PROCEDURE WriteDynamicSectionEntry (tag, val: INTEGER);
+	BEGIN
+		Write4(tag);
+		Write4(val)
+	END WriteDynamicSectionEntry;
+	
+	PROCEDURE WriteDynamicSection;
+		CONST dtNull = 0; dtNeeded = 1; dtHash = 4; dtStrtab = 5; dtSymtab = 6;
+			dtStrsz = 10; dtSyment = 11; dtInit = 12; dtFini = 13; dtSoname = 14; dtRel = 17; dtRelsz = 18; dtRelent = 19;
+			dtTextrel = 22;
+		VAR i: INTEGER;
+	BEGIN
+		ASSERT(dynamic.fileOffset = Ro.Pos(), 100);
+		WriteDynamicSectionEntry(dtSoname, fixup);
+		WriteDynamicSectionEntry(dtFini, fixup);
+		WriteDynamicSectionEntry(dtInit, text.memOffset);
+		WriteDynamicSectionEntry(dtHash, hash.memOffset);
+		WriteDynamicSectionEntry(dtStrtab, dynstr.memOffset);
+		WriteDynamicSectionEntry(dtSymtab, dynsym.memOffset);
+		WriteDynamicSectionEntry(dtStrsz, dynstr.size);
+		WriteDynamicSectionEntry(dtSyment, dynsymEntrySizeVal);
+		WriteDynamicSectionEntry(dtRel, reltext.memOffset);
+		WriteDynamicSectionEntry(dtRelsz, reltext.size + relrodata.size);
+		WriteDynamicSectionEntry(dtRelent, relEntrySizeVal);
+		i := 0;
+		WHILE neededIdx[i] # 0 DO
+			WriteDynamicSectionEntry(dtNeeded, neededIdx[i]);
+			INC(i)
+		END;
+		WriteDynamicSectionEntry(dtTextrel, 0);
+		WriteDynamicSectionEntry(dtNull, 0); (* DT_NULL: marks the end *)
+		ASSERT(dynamic.size = Ro.Pos() - dynamic.fileOffset, 101)
+	END WriteDynamicSection;
+	
+	PROCEDURE FixupDynamicSection;
+		VAR i: INTEGER;
+	BEGIN
+		Ro.SetPos(dynamic.fileOffset + 4);
+		Write4(sonameStrIndexVal);
+		Ro.SetPos(Ro.Pos() + 4);
+		Write4(finiMemOffsetVal)
+	END FixupDynamicSection;
+	
+	PROCEDURE WriteBssSection;
+	BEGIN
+(*
+		The .bss section does not take space in the file.
+		This procedure serves consistency-check purposes.
+*)
+		ASSERT(bss.fileOffset = Ro.Pos(), 100)
+	END WriteBssSection;
+
+	PROCEDURE WriteShstrtabSection;
+	BEGIN
+		ASSERT(shstrtab.fileOffset = Ro.Pos(), 100);
+		WriteStringTable(headerstrtab);
+		shstrtab.size := Ro.Pos() - shstrtab.fileOffset
+	END WriteShstrtabSection;
+
+	PROCEDURE GetImpListSize (OUT len: INTEGER; OUT count: INTEGER);
+		VAR m: Module; e: Export;
+	BEGIN
+		len := 0; count := 0;
+		m := modList;
+		WHILE m # NIL DO
+			IF m.dll THEN
+				e := m.exp;
+				WHILE e # NIL DO
+					INC(len, LEN(e.name$) + 1);
+					INC(count);
+					e := e.next
+				END
+			END;
+			m := m.next
+		END
+	END GetImpListSize;
+	
+	PROCEDURE GetExpListSize (OUT len: INTEGER; OUT count: INTEGER);
+		VAR e: Export;
+	BEGIN
+		count := 0; len := 0;
+		e := firstExp;
+		WHILE e # NIL DO
+			INC(len, LEN(e.name$) + 1);
+			INC(count);
+			e := e.next
+		END
+	END GetExpListSize;
+	
+	PROCEDURE DynsymSize (init: INTEGER): INTEGER;
+		VAR size: INTEGER;
+	BEGIN
+		size := init;
+		INC(size, dynsymEntrySizeVal * 11); (* sections entries *)
+		INC(size, dynsymEntrySizeVal); (* _DYNAMIC symbol *)
+		INC(size, dynsymEntrySizeVal); (* _GLOBAL_OFFSET_TABLE_ symbol *)
+		RETURN size
+	END DynsymSize;
+	
+	PROCEDURE DynstrSize (init: INTEGER): INTEGER;
+		VAR size: INTEGER;
+	BEGIN
+		size := init + 1;
+		INC(size, dynstrtab.cur - 1);
+		INC(size, LEN(soName$) + 1); (* library name *)
+		INC(size, 9); (* "_DYNAMIC" symbol + 0X *)
+		INC(size, 21 + 1); (* "_GLOBAL_OFFSET_TABLE_" symbol + trailing 0X *)
+		RETURN size
+	END DynstrSize;
+	
+	PROCEDURE DynamicSize (init: INTEGER): INTEGER;
+		VAR i, size: INTEGER;
+	BEGIN
+		size := init;
+		i := 0;
+		WHILE neededIdx[i] # 0 DO
+			INC(size, dynamicEntrySizeVal);
+			INC(i)
+		END;
+		RETURN size
+	END DynamicSize;
+	
+	PROCEDURE CalculateLayout;
+		VAR headerSize, impCount, expCount, impLen, expLen: INTEGER;
+	BEGIN
+		ASSERT(~error, 20);
+		headerSize := elfHeaderSizeVal + shEntrySizeVal * shNumVal + phEntrySizeVal * phNumVal;
+		text.fileOffset := Aligned(headerSize, textAlign);
+		text.memOffset := text.fileOffset;
+		text.size := CodeSize;
+		rodata.fileOffset := Aligned(text.fileOffset + text.size, rodataAlign);
+		rodata.memOffset := rodata.fileOffset;
+		rodata.size := ConSize;
+		reltext.fileOffset := Aligned(rodata.fileOffset + rodata.size, relAlign);
+		reltext.memOffset := reltext.fileOffset;
+		doWrite := FALSE;
+		WriteTextSection;	(* this only calculates the number of text relocations *)
+		IF error THEN RETURN END;
+		reltext.size := relEntrySizeVal * relTextTab.cur;
+		relrodata.fileOffset := reltext.fileOffset + reltext.size;
+		relrodata.memOffset := relrodata.fileOffset;
+		IF ~error THEN
+			WriteRodataSection	(* this only calculates the number of data relocations *)
+		ELSE
+			RETURN
+		END;
+		relrodata.size := relEntrySizeVal * relRodataTab.cur;
+		dynsym.fileOffset := Aligned(relrodata.fileOffset + relrodata.size, dynsymAlign);
+		dynsym.memOffset := dynsym.fileOffset;
+		GetImpListSize(impLen, impCount);
+		GetExpListSize(expLen, expCount);
+		dynsym.size := DynsymSize((impCount + expCount) * dynsymEntrySizeVal);
+		dynstr.fileOffset := Aligned(dynsym.fileOffset + dynsym.size, dynstrAlign);
+		dynstr.memOffset := dynstr.fileOffset;
+		dynstr.size := DynstrSize(impLen + expLen);
+		hash.fileOffset := Aligned(dynstr.fileOffset + dynstr.size, hashAlign);
+		hash.memOffset := hash.fileOffset;
+		hash.size := 8 + dynsym.size DIV dynsymEntrySizeVal * 4 * 2;
+		got.fileOffset := Aligned(hash.fileOffset + hash.size, gotAlign);
+		got.memOffset := Aligned(got.fileOffset, pageSize) + got.fileOffset MOD pageSize;
+		got.size := 3 * gotEntrySizeVal;
+		dynamic.fileOffset := Aligned(got.fileOffset + got.size, dynamicAlign);
+		dynamic.memOffset := got.memOffset + dynamic.fileOffset - got.fileOffset;
+		dynamic.size := DynamicSize(13 * dynamicEntrySizeVal);
+		bss.fileOffset := Aligned(dynamic.fileOffset + dynamic.size, bssAlign);
+		bss.memOffset := dynamic.memOffset + bss.fileOffset - dynamic.fileOffset;		
+		bss.size := DataSize;
+		shstrtab.fileOffset := Aligned(bss.fileOffset, shstrtabAlign);
+		shstrtab.size := fixup;
+		textSegmentSizeVal := got.fileOffset;
+		dataSegmentSizeVal := shstrtab.fileOffset - got.fileOffset;
+		dynamicSegmentSizeVal := shstrtab.fileOffset - dynamic.fileOffset;
+		relTextTab.cur := 0;
+		relRodataTab.cur := 0;
+		firstExp := NIL; lastExp := NIL;
+		doWrite := TRUE
+	END CalculateLayout;
+
+	PROCEDURE WriteOut;
+		VAR res: INTEGER;
+	BEGIN
+		ASSERT(~error, 20);
+		Out := Files.dir.New(Files.dir.This(""), Files.ask);
+		IF Out # NIL THEN
+			Ro := Out.NewWriter(Ro); Ro.SetPos(0);
+			CalculateLayout;
+			IF ~error THEN WriteElfHeader END;
+			IF ~error THEN WriteSectionHeaderTable END;
+			IF ~error THEN WriteProgramHeaderTable END;
+			IF ~error THEN Align(textAlign); WriteTextSection END;
+			IF ~error THEN Align(rodataAlign); WriteRodataSection END;
+			IF ~error THEN Align(relAlign); WriteRelSections END;
+			IF ~error THEN Align(dynsymAlign); WriteDynsymSection END;
+			IF ~error THEN Align(dynstrAlign); WriteDynstrSection END;
+			IF ~error THEN Align(hashAlign); WriteHashSection END;
+			IF ~error THEN Align(gotAlign); WriteGotSection END;
+			IF ~error THEN Align(dynamicAlign); WriteDynamicSection END;
+			IF ~error THEN Align(bssAlign); WriteBssSection END;
+			IF ~error THEN Align(shstrtabAlign); WriteShstrtabSection END;
+
+			IF ~error THEN FixupElfHeader END;
+			IF ~error THEN FixupSectionHeaderTable END;
+			IF ~error THEN FixupTextSection END;
+			IF ~error THEN FixupDynsymSection END;
+			IF ~error THEN FixupDynamicSection END;
+			Out.Register(soName$, "so", Files.ask, res);
+			IF res # 0 THEN error := TRUE END
+		ELSE
+			error := TRUE
+		END
+	END WriteOut;
+	
+	PROCEDURE ResetHashtab;
+		VAR i: INTEGER;
+	BEGIN
+		i := 0;
+		WHILE i # LEN(hashtab) DO
+			hashtab[i] := "";
+			INC(i)
+		END
+	END ResetHashtab;
+
+	PROCEDURE ResetNeededIdx;
+		VAR i: INTEGER;
+	BEGIN
+		i := 0;
+		WHILE i # LEN(neededIdx) DO
+			neededIdx[i] := 0;
+			INC(i)
+		END
+	END ResetNeededIdx;
+
+	PROCEDURE MakeSoName (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
+		VAR i, j: INTEGER; ext: Files.Name; ch: CHAR;
+	BEGIN
+		ASSERT((type = "") OR (type[0] = "."), 20);
+		i := 0;
+		WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
+		IF name[i] = "." THEN
+			IF name[i + 1] = 0X THEN name[i] := 0X END
+		ELSIF i < LEN(name) - (LEN(type$) + 1) THEN
+			IF type = "" THEN ext := ".so" ELSE ext := type$ END;
+			j := 0; ch := ext[0];
+			WHILE ch # 0X DO
+				IF (ch >= "A") & (ch <= "Z") THEN
+					ch := CHR(ORD(ch) + ORD("a") - ORD("A"))
+				END;
+				name[i] := ch; INC(i); INC(j); ch := ext[j]
+			END;
+			name[i] := 0X
+		END
+	END MakeSoName;
+
+	(* A. V. Shiryaev: Scanner *)
+
+		PROCEDURE (VAR S: Scanner) SetPos (x: INTEGER), NEW;
+		BEGIN
+			S.rider.i := x
+		END SetPos;
+
+		PROCEDURE (VAR S: Scanner) ConnectTo (IN src: ARRAY OF CHAR), NEW;
+		BEGIN
+			NEW(S.rider.s, LEN(src$) + 1);
+			S.rider.s^ := src$;
+			S.rider.i := 0;
+			S.start := 0;
+			S.type := TMEOT
+		END ConnectTo;
+
+		PROCEDURE (VAR R: ScanRider) ReadPrevChar (VAR ch: CHAR), NEW;
+		BEGIN
+			ch := R.s[R.i]
+		END ReadPrevChar;
+
+		PROCEDURE (VAR R: ScanRider) ReadChar (VAR ch: CHAR), NEW;
+		BEGIN
+			ch := R.s[R.i];
+			INC(R.i)
+		END ReadChar;
+
+		PROCEDURE (VAR R: ScanRider) Pos (): INTEGER, NEW;
+		BEGIN
+			RETURN R.i
+		END Pos;
+
+		PROCEDURE (VAR S: Scanner) Scan, NEW;
+			VAR j: INTEGER;
+		
+			PROCEDURE IsLetter (c: CHAR): BOOLEAN;
+			BEGIN
+				RETURN ((c >= 'A') & (c <= 'Z')) OR ((c >= 'a') & (c <= 'z')) OR (c = '_')
+			END IsLetter;
+
+			PROCEDURE IsDigit (c: CHAR): BOOLEAN;
+			BEGIN
+				RETURN (c >= '0') & (c <= '9')
+			END IsDigit;
+
+		BEGIN
+			WHILE (S.rider.i < LEN(S.rider.s$)) & (S.rider.s[S.rider.i] = ' ') DO
+				INC(S.rider.i)
+			END;
+			IF S.rider.i < LEN(S.rider.s$) THEN
+				S.start := S.rider.i;
+				IF IsDigit(S.rider.s[S.rider.i]) THEN
+					S.type := TMEOT (* XXX *)
+				ELSIF IsLetter(S.rider.s[S.rider.i]) THEN
+					S.type := TMString;
+					j := 0;
+					WHILE (S.rider.i < LEN(S.rider.s$)) & (IsLetter(S.rider.s[S.rider.i]) OR IsDigit(S.rider.s[S.rider.i])) DO
+						S.string[j] := S.rider.s[S.rider.i];
+						INC(j);
+						INC(S.rider.i)
+					END;
+					S.string[j] := 0X
+				ELSE
+					S.type := TMChar;
+					S.char := S.rider.s[S.rider.i];
+					INC(S.rider.i)
+				END
+			ELSE
+				S.type := TMEOT
+			END
+		END Scan;
+
+	PROCEDURE ParseExt (IN S: Scanner; OUT ext: Files.Name);
+		VAR ch: CHAR; i: INTEGER;
+	BEGIN
+		ext := "";
+		S.rider.ReadPrevChar(ch);
+		IF ch = "." THEN
+			S.rider.ReadChar(ch);
+			i := 0;
+			WHILE (ch # 20X) & (ch # 9X) DO
+				ext[i] := ch;
+				INC(i);
+				S.rider.ReadChar(ch)
+			END;
+			ext[i] := 0X
+		ELSIF (ch # 20X) & (ch # 9X) THEN
+			WriteSString("Invalid character '");WriteChar(ch); WriteSString("' for file name.");
+			WriteLn; FlushW; error := TRUE
+		END;
+		S.SetPos(S.rider.Pos())
+	END ParseExt;
+
+	PROCEDURE ParseModList (S: Scanner; end: INTEGER);
+		VAR mod: Module;
+	BEGIN
+		WHILE (S.start < end) & (S.type = TMString) DO
+			NEW(mod); mod.fileName := S.string$;
+			mod.next := modList; modList := mod;
+			S.Scan;
+			WHILE (S.start < end) & (S.type = TMChar) &
+				((S.char = "*") OR (S.char = "+") OR (S.char = "$") OR (S.char = "#")) DO
+				IF S.char = "*" THEN mod.dll := TRUE
+				ELSIF S.char = "+" THEN kernel := mod
+				ELSIF S.char = "$" THEN main := mod
+				ELSE mod.intf := TRUE;
+					ASSERT(isDll, 126);
+					IF ~isDll THEN
+						WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll.");
+						WriteLn; FlushW; error := TRUE
+					END
+				END;
+				S.Scan
+			END
+		END
+	END ParseModList;
+
+	PROCEDURE LinkIt (IN txt: ARRAY OF CHAR);
+		VAR S: Scanner; name, ext: Files.Name; end: INTEGER;
+	BEGIN
+		doWrite := TRUE;
+		headerstrtab.tab[0] := 0X;
+		headerstrtab.cur := 1;
+		dynstrtab.tab[0] := 0X;
+		dynstrtab.cur := 1;
+		relTextTab.cur := 0;
+		relRodataTab.cur := 0;
+		ResetHashtab;
+		ResetNeededIdx;
+		modList := NIL; kernel := NIL; main := NIL;
+		last := NIL; impg := NIL; impd := NIL;
+		firstExp := NIL; lastExp := NIL;
+		(* Dialog.ShowStatus("linking"); *)
+		Console.WriteStr("linking"); Console.WriteLn;
+		error := FALSE; modList := NIL;
+
+		(*
+		IF DevCommanders.par = NIL THEN RETURN END;
+		S.ConnectTo(DevCommanders.par.text);
+		S.SetPos(DevCommanders.par.beg);
+		end := DevCommanders.par.end;
+		DevCommanders.par := NIL;
+		*)
+
+		S.ConnectTo(txt);
+		S.SetPos(0);
+		end := LEN(txt$);
+
+		S.Scan;
+
+		IF S.type = TMString THEN
+			name := S.string$;
+			ext := "";
+			ParseExt(S, ext); S.Scan;
+			IF ~error THEN
+				MakeSoName(name, ext);
+				IF (S.type = TMChar) & (S.char = ":") THEN S.Scan;
+					IF (S.type = TMChar) & (S.char = "=") THEN S.Scan;
+						ParseModList(S, end);
+						ReadHeaders;
+						soName := SHORT(name$);
+						IF ~error THEN
+							WriteOut
+						END;
+						IF ~error THEN
+							WriteString("Library " + name + " written: ");
+							WriteInt(Out.Length()); WriteString("    "); WriteInt(text.size)
+						END
+					ELSE
+						error := TRUE;
+						WriteString(" := missing")
+					END
+				ELSE
+					error := TRUE;
+					WriteString(" := missing")
+				END;
+				WriteLn; FlushW
+			END
+		END;
+		(* IF error THEN Dialog.ShowStatus("Failed to write library") ELSE Dialog.ShowStatus("Ok") END; *)
+		IF error THEN Console.WriteStr("Failed to write library"); Console.WriteLn ELSE Console.WriteStr("Ok"); Console.WriteLn END;
+		S.ConnectTo("");
+		modList := NIL; kernel := NIL; main := NIL; firstExp := NIL; lastExp := NIL;
+		last := NIL; impg := NIL; impd := NIL; code := NIL
+	END LinkIt;
+
+(*
+	exes are not supported
+
+	PROCEDURE Link*;
+	BEGIN
+		HALT(126);
+		isDll := FALSE; isStatic := FALSE;
+		LinkIt
+	END Link;
+	
+	PROCEDURE LinkExe*;
+	BEGIN
+		HALT(126);
+		isDll := FALSE; isStatic := TRUE;
+		LinkIt
+	END LinkExe;
+*)
+	
+	PROCEDURE LinkDll* (IN txt: ARRAY OF CHAR);
+	BEGIN
+		isDll := TRUE; isStatic := TRUE;
+		LinkIt(txt)
+	END LinkDll;
+	
+	PROCEDURE LinkDynDll* (IN txt: ARRAY OF CHAR);
+	BEGIN
+		isDll := TRUE; isStatic := FALSE;
+		LinkIt(txt)
+	END LinkDynDll;
+		
+BEGIN
+	newRec := "NewRec"; newArr := "NewArr"
+END LindevElfLinker.
+
+LinTestSo LinTestSo2 LinKernel
+
+(!)DevElfLinker.LinkDynDll libtestbb.so := LinKernel+$ LinTestSo2 LinTestSo# ~
+(!)DevElfLinker.LinkDll libtestbb.so := LinTestSo2 LinTestSo# ~
+

BlackBox/Std/Mod/Interpreter.txt

@@ -0,0 +1,234 @@
+MODULE StdInterpreter;
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Interpreter.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT Kernel, Meta, Strings, Views, Dialog;
+
+	TYPE
+		IntValue = POINTER TO RECORD (Meta.Value)
+			int: INTEGER;
+		END;
+		StrValue = POINTER TO RECORD (Meta.Value)
+			str: Dialog.String;
+		END;
+		CallHook = POINTER TO RECORD (Dialog.CallHook) END;
+
+		
+	PROCEDURE (hook: CallHook) Call (IN proc, errorMsg: ARRAY OF CHAR; VAR res: INTEGER);
+		TYPE Ident = ARRAY 32 OF CHAR;
+		CONST
+			modNotFound = 10; procNotFound = 11; identExpected = 12; unknownIdent = 13;
+			depositExpected = 14; noDepositExpected = 15; syntaxError = 16;
+			lparenExpected = 17; rparenExpected = 18; containerExpected = 19; quoteExpected = 20;
+			fileNotFound = 21; noController = 22; noDialog = 23; cannotUnload = 24; commaExpected = 25;
+			incompParList = 26;
+		CONST
+			 ident = 0; dot = 1; semicolon = 2; eot = 3; lparen = 4; rparen = 5; quote = 6; comma = 7; int = 8;
+		VAR
+			i, type: INTEGER; ch: CHAR; id: Ident; x: INTEGER;
+			par: ARRAY 100 OF POINTER TO Meta.Value; numPar: INTEGER;
+			
+		PROCEDURE Concat (a, b: ARRAY OF CHAR; VAR c: ARRAY OF CHAR);
+			VAR i, j: INTEGER; ch: CHAR;
+		BEGIN
+			IF a = " " THEN Dialog.MapString("#System:CommandError", c) ELSE c := a$ END;
+			i := 0; WHILE c[i] # 0X DO INC(i) END;
+			c[i] := " "; INC(i);
+			j := 0; ch := b[0]; WHILE ch # 0X DO c[i] := ch; INC(i); INC(j); ch := b[j] END;
+			c[i] := 0X
+		END Concat;
+
+		PROCEDURE Error (n: INTEGER; msg, par0, par1: ARRAY OF CHAR);
+			VAR e, f: ARRAY 256 OF CHAR;
+		BEGIN
+			IF res = 0 THEN
+				res := n;
+				IF errorMsg # "" THEN
+					Dialog.MapString(errorMsg, e);
+					Dialog.MapParamString(msg, par0, par1, "", f);
+					Concat(e, f, f);
+					Dialog.ShowMsg(f)
+				END
+			END
+		END Error;
+		
+		PROCEDURE Init (VAR s: ARRAY OF CHAR);
+			VAR i: INTEGER;
+		BEGIN
+			i := 0; WHILE i < LEN(s) DO s[i] := 0X; INC(i) END
+		END Init;
+		
+		PROCEDURE ShowLoaderResult (IN mod: ARRAY OF CHAR);
+			VAR res: INTEGER; importing, imported, object: ARRAY 256 OF CHAR;
+		BEGIN
+			Kernel.GetLoaderResult(res, importing, imported, object);
+			CASE res OF
+			| Kernel.fileNotFound:
+				Error(Kernel.fileNotFound, "#System:CodeFileNotFound", imported, "")
+			| Kernel.syntaxError:
+				Error(Kernel.syntaxError, "#System:CorruptedCodeFileFor", imported, "")
+			| Kernel.objNotFound:
+				Error(Kernel.objNotFound, "#System:ObjNotFoundImpFrom", imported, importing)
+			| Kernel.illegalFPrint:
+				Error(Kernel.illegalFPrint, "#System:ObjInconsImpFrom", imported, importing)
+			| Kernel.cyclicImport:
+				Error(Kernel.cyclicImport, "#System:CyclicImpFrom", imported, importing)
+			| Kernel.noMem:
+				Error(Kernel.noMem, "#System:NotEnoughMemoryFor", imported, "")
+			ELSE
+				Error(res, "#System:CannotLoadModule", mod, "")
+			END
+		END ShowLoaderResult;
+
+		PROCEDURE CallProc (IN mod, proc: ARRAY OF CHAR);
+			VAR i, t: Meta.Item; ok: BOOLEAN;
+		BEGIN
+			ok := FALSE;
+			Meta.Lookup(mod, i);
+			IF i.obj = Meta.modObj THEN
+				i.Lookup(proc, i);
+				IF i.obj = Meta.procObj THEN
+					i.GetReturnType(t);
+					IF (t.typ = 0) & (i.NumParam() = numPar) THEN
+						i.ParamCallVal(par, t, ok)
+					ELSE ok := FALSE
+					END;
+					IF ~ok THEN
+						Error(incompParList, "#System:IncompatibleParList", mod, proc)
+					END
+				ELSE
+					Error(Kernel.commNotFound, "#System:CommandNotFoundIn", proc, mod)
+				END
+			ELSE
+				ShowLoaderResult(mod)
+			END
+		END CallProc;
+
+		PROCEDURE GetCh;
+		BEGIN
+			IF i < LEN(proc) THEN ch := proc[i]; INC(i) ELSE ch := 0X END
+		END GetCh;
+
+		PROCEDURE Scan;
+			VAR j: INTEGER; num: ARRAY 32 OF CHAR; r: INTEGER;
+		BEGIN
+			IF res = 0 THEN
+				WHILE (ch # 0X) & (ch <= " ") DO GetCh END;
+				IF ch = 0X THEN
+					type := eot
+				ELSIF ch = "." THEN
+					type := dot; GetCh
+				ELSIF ch = ";" THEN
+					type := semicolon; GetCh
+				ELSIF ch = "(" THEN
+					type := lparen; GetCh
+				ELSIF ch = ")" THEN
+					type := rparen; GetCh
+				ELSIF ch = "'" THEN
+					type := quote; GetCh
+				ELSIF ch = "," THEN
+					type := comma; GetCh
+				ELSIF (ch >= "0") & (ch <= "9") OR (ch = "-") THEN
+					type := int; j := 0;
+					REPEAT num[j] := ch; INC(j); GetCh UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "H");
+					num[j] := 0X; Strings.StringToInt(num, x, r)
+				ELSIF (ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR
+						(ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN
+					type := ident;
+					id[0] := ch; j := 1; GetCh;
+					WHILE (ch # 0X) & (i < LEN(proc)) &
+								((ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR
+								(ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR
+								(ch = "_") OR (ch >= "0") & (ch <= "9")) DO
+						id[j] := ch; INC(j); GetCh
+					END;
+					id[j] := 0X
+				ELSE Error(syntaxError, "#System:SyntaxError", "", "")
+				END
+			END
+		END Scan;
+		
+		PROCEDURE String (VAR s: ARRAY OF CHAR);
+			VAR j: INTEGER;
+		BEGIN
+			IF type = quote THEN
+				j := 0;
+				WHILE (ch # 0X) & (ch # "'") & (j < LEN(s) - 1) DO s[j] := ch; INC(j); GetCh END; s[j] := 0X;
+				IF ch = "'" THEN
+					GetCh; Scan
+				ELSE Error(quoteExpected, "#System:QuoteExpected", "", "")
+				END
+			ELSE Error(quoteExpected, "#System:QuoteExpected", "", "")
+			END
+		END String;
+
+		PROCEDURE ParamList ();
+			VAR iv: IntValue; sv: StrValue;
+		BEGIN
+			numPar := 0;
+			IF type = lparen THEN Scan;
+				WHILE (numPar < LEN(par)) & (type # rparen) & (res = 0) DO
+					IF type = quote THEN
+						NEW(sv);
+						String(sv.str);
+						par[numPar] := sv;
+						INC(numPar)
+					ELSIF type = int THEN
+						NEW(iv);
+						iv.int := x; Scan;
+						par[numPar] := iv;
+						INC(numPar)
+					ELSE Error(syntaxError, "#System:SyntaxError", "", "")
+					END;
+					IF type = comma THEN Scan
+					ELSIF type # rparen THEN Error(rparenExpected, "#System:RParenExpected", "", "")
+					END
+				END;
+				Scan
+			END
+		END ParamList;
+
+		PROCEDURE Command;
+			VAR left, right: Ident;
+		BEGIN
+			(* protect from parasitic anchors on stack *)
+			Init(left); Init(right);
+			left := id; Scan;
+			IF type = dot THEN	(* Oberon command *)
+				Scan;
+				IF type = ident THEN
+					right := id; Scan; ParamList();
+					CallProc(left, right)
+				ELSE Error(identExpected, "#System:IdentExpected", "", "")
+				END
+			ELSE Error(unknownIdent, "#System:UnknownIdent", id, "")
+			END
+		END Command;
+
+	BEGIN
+		(* protect from parasitic anchors on stack *)
+		i := 0; type := 0; Init(id); x := 0;
+		Views.ClearQueue;
+		res := 0; i := 0; GetCh;
+		Scan;
+		IF type = ident THEN
+			Command; WHILE (type = semicolon) & (res = 0) DO Scan; Command END;
+			IF type # eot THEN Error(syntaxError, "#System:SyntaxError", "", "") END
+		ELSE Error(syntaxError, "#System:SyntaxError", "", "")
+		END;
+		IF (res = 0) & (Views.Available() > 0) THEN
+			Error(noDepositExpected, "#System:NoDepositExpected", "", "")
+		END;
+		Views.ClearQueue
+	END Call;
+	
+	PROCEDURE Init;
+		VAR hook: CallHook;
+	BEGIN
+		NEW(hook); Dialog.SetCallHook(hook)
+	END Init;
+
+BEGIN
+	Init
+END StdInterpreter.

BlackBox/Std/Mod/Loader.txt

@@ -0,0 +1,336 @@
+MODULE StdLoader;
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Loader.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT S := SYSTEM, Kernel, Files;
+	
+	CONST
+		done = Kernel.done;
+		fileNotFound = Kernel.fileNotFound;
+		syntaxError = Kernel.syntaxError;
+		objNotFound = Kernel.objNotFound;
+		illegalFPrint = Kernel.illegalFPrint;
+		cyclicImport = Kernel.cyclicImport;
+		noMem = Kernel.noMem;
+		commNotFound = Kernel.commNotFound;
+		commSyntaxError = Kernel.commSyntaxError;
+		descNotFound = -1;
+
+		OFdir = "Code";
+		SYSdir = "System";
+		initMod = "Init";
+		OFtag = 6F4F4346H;
+		
+		(* meta interface consts *)
+		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+		mBool = 1; mChar = 2; mLChar = 3; mSInt = 4; mInt = 5; mLInt = 6;
+		mReal = 7; mLReal = 8; mSet = 9; mString = 10; mLString = 11;
+		mRecord = 1; mArray = 2; mPointer = 3; mProctyp = 4;
+		mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
+		
+		(* fixup types *)
+		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; deref = 105; halfword = 106;
+		
+	TYPE
+		Name = ARRAY 256 OF CHAR;
+		ModSpec = POINTER TO RECORD
+			next, link, imp: ModSpec;
+			name: Name;
+			file: Files.File;
+			mod: Kernel.Module;
+			hs, ms, ds, cs, vs, mad, dad: INTEGER
+		END;
+		
+		Hook = POINTER TO RECORD (Kernel.LoaderHook) END;
+
+	VAR
+		res-: INTEGER;
+		importing-, imported-, object-: Name;
+		inp: Files.Reader;
+		m: Kernel.Module;
+	
+	PROCEDURE Error (r: INTEGER; impd, impg: ModSpec);
+	BEGIN
+		res := r; imported := impd.name$;
+		IF impg # NIL THEN importing := impg.name$ END;
+	END Error;
+	
+	PROCEDURE Append (VAR s: ARRAY OF CHAR; t: ARRAY OF CHAR);
+		VAR len, i, j: INTEGER; ch: CHAR;
+	BEGIN
+		len := LEN(s);
+		i := 0; WHILE s[i] # 0X DO INC(i) END;
+		j := 0; REPEAT ch := t[j]; s[i] := ch; INC(j); INC(i) UNTIL (ch = 0X) OR (i = len);
+		s[len - 1] := 0X
+	END Append;
+
+	PROCEDURE ThisObjFile (VAR name: ARRAY OF CHAR): Files.File;
+		VAR f: Files.File; loc: Files.Locator; dir, fname: Files.Name;
+	BEGIN
+		Kernel.SplitName(name, dir, fname);
+		Kernel.MakeFileName(fname, Kernel.objType);
+		loc := Files.dir.This(dir); loc := loc.This(OFdir);
+		f := Files.dir.Old(loc, fname, TRUE);
+		IF (f = NIL) & (dir = "") THEN
+			loc := Files.dir.This(SYSdir); loc := loc.This(OFdir);
+			f := Files.dir.Old(loc, fname, TRUE)
+		END;
+		RETURN f
+	END ThisObjFile;
+	
+	PROCEDURE RWord (VAR x: INTEGER);
+		VAR b: BYTE; y: INTEGER;
+	BEGIN
+		inp.ReadByte(b); y := b MOD 256;
+		inp.ReadByte(b); y := y + 100H * (b MOD 256);
+		inp.ReadByte(b); y := y + 10000H * (b MOD 256);
+		inp.ReadByte(b); x := y + 1000000H * b
+	END RWord;
+	
+	PROCEDURE RNum (VAR x: INTEGER);
+		VAR b: BYTE; s, y: INTEGER;
+	BEGIN
+		s := 0; y := 0; inp.ReadByte(b);
+		WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); inp.ReadByte(b) END;
+		x := ASH((b + 64) MOD 128 - 64, s) + y
+	END RNum;
+	
+	PROCEDURE RName (VAR name: ARRAY OF CHAR);
+		VAR b: BYTE; i, n: INTEGER;
+	BEGIN
+		i := 0; n := LEN(name) - 1; inp.ReadByte(b);
+		WHILE (i < n) & (b # 0) DO name[i] := CHR(b MOD 256); INC(i); inp.ReadByte(b) END;
+		WHILE b # 0 DO inp.ReadByte(b) END;
+		name[i] := 0X
+	END RName;
+
+	PROCEDURE Fixup (adr: INTEGER; mod: ModSpec);
+		VAR link, offset, linkadr, t, n, x, low, hi: INTEGER;
+	BEGIN
+		RNum(link);
+		WHILE link # 0 DO
+			RNum(offset);
+			WHILE link # 0 DO
+				IF link > 0 THEN linkadr := mod.mad + mod.ms + link
+				ELSE link := -link;
+					IF link < mod.ms THEN linkadr := mod.mad + link
+					ELSE linkadr := mod.dad + link - mod.ms
+					END
+				END;
+				S.GET(linkadr, x); t := x DIV 1000000H;
+				n := (x + 800000H) MOD 1000000H - 800000H;
+				IF t = absolute THEN x := adr + offset
+				ELSIF t = relative THEN x := adr + offset - linkadr - 4
+				ELSIF t = copy THEN S.GET(adr + offset, x)
+				ELSIF t = table THEN x := adr + n; n := link + 4
+				ELSIF t = tableend THEN x := adr + n; n := 0
+				ELSIF t = deref THEN S.GET(adr+2, x); INC(x, offset);
+				ELSIF t = halfword THEN
+					x := adr + offset;
+					low := (x + 8000H) MOD 10000H - 8000H;
+					hi := (x - low) DIV 10000H;
+					S.GET(linkadr + 4, x);
+					S.PUT(linkadr + 4, x DIV 10000H * 10000H + low MOD 10000H);
+					x := x * 10000H + hi MOD 10000H
+				ELSE Error(syntaxError, mod, NIL)
+				END;
+				S.PUT(linkadr, x); link := n
+			END;
+			RNum(link)
+		END
+	END Fixup;
+	
+	PROCEDURE ReadHeader (mod: ModSpec);
+		VAR n, p: INTEGER; name: Name; imp, last: ModSpec;
+	BEGIN
+		mod.file := ThisObjFile(mod.name);
+		IF (mod.file = NIL) & (mod.link # NIL) THEN	(* try closing importing obj file *)
+			mod.link.file.Close; mod.link.file := NIL;
+			mod.file := ThisObjFile(mod.name)
+		END;
+		IF mod.file # NIL THEN
+			inp := mod.file.NewReader(inp);
+			IF inp # NIL THEN
+				inp.SetPos(0); RWord(n); RWord(p);
+				IF (n = OFtag) & (p = Kernel.processor) THEN
+					RWord(mod.hs); RWord(mod.ms); RWord(mod.ds); RWord(mod.cs); RWord(mod.vs); 
+					RNum(n); RName(name);
+					IF name = mod.name THEN
+						mod.imp := NIL; last := NIL;
+						WHILE n > 0 DO
+							NEW(imp); RName(imp.name);
+							IF last = NIL THEN mod.imp := imp ELSE last.next := imp END;
+							last := imp; imp.next := NIL; DEC(n) 
+						END
+					ELSE Error(fileNotFound, mod, NIL)
+					END
+				ELSE Error(syntaxError, mod, NIL)
+				END
+			ELSE Error(noMem, mod, NIL)
+			END
+		ELSE Error(fileNotFound, mod, NIL)
+		END
+	END ReadHeader;
+	
+	PROCEDURE ReadModule (mod: ModSpec);
+		TYPE BlockPtr = POINTER TO ARRAY [1] 1000000H OF BYTE;
+		VAR imptab, x, fp, ofp, opt, a: INTEGER;
+			name: Name; dp, mp: BlockPtr; imp: ModSpec; obj: Kernel.Object; in, n: Kernel.Name;
+	BEGIN
+		IF mod.file = NIL THEN mod.file := ThisObjFile(mod.name) END;
+		inp := mod.file.NewReader(inp);
+		IF inp # NIL THEN
+			inp.SetPos(mod.hs);
+			Kernel.AllocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad);
+			IF (mod.dad # 0) & (mod.mad # 0) THEN
+				dp := S.VAL(BlockPtr, mod.dad); mp := S.VAL(BlockPtr, mod.mad);
+				inp.ReadBytes(mp^, 0, mod.ms);
+				inp.ReadBytes(dp^, 0, mod.ds);
+				inp.ReadBytes(mp^, mod.ms, mod.cs);
+				mod.mod := S.VAL(Kernel.Module, mod.dad);
+				Fixup(S.ADR(Kernel.NewRec), mod);
+				Fixup(S.ADR(Kernel.NewArr), mod);
+				Fixup(mod.mad, mod);
+				Fixup(mod.dad, mod);
+				Fixup(mod.mad + mod.ms, mod);
+				Fixup(mod.mad + mod.ms + mod.cs, mod);
+				imp := mod.imp; imptab := S.VAL(INTEGER, mod.mod.imports);
+				WHILE (res = done) & (imp # NIL) DO
+					RNum(x);
+					WHILE (res <= done) & (x # 0) DO
+						RName(name); RNum(fp); opt := 0;
+						IF imp.mod # NIL THEN
+							IF name = "" THEN obj := Kernel.ThisDesc(imp.mod, fp)
+							ELSE n := SHORT(name$); obj := Kernel.ThisObject(imp.mod, n)
+							END;
+							IF (obj # NIL) & (obj.id MOD 16 = x) THEN
+								ofp := obj.fprint;
+								IF x = mTyp THEN
+									RNum(opt);
+									IF ODD(opt) THEN ofp := obj.offs END;
+									IF (opt > 1) & (obj.id DIV 16 MOD 16 # mExported) THEN
+										Error(objNotFound, imp, mod); object := name$
+									END;
+									Fixup(S.VAL(INTEGER, obj.struct), mod)
+								ELSIF x = mVar THEN
+									Fixup(imp.mod.varBase + obj.offs, mod)
+								ELSIF x = mProc THEN
+									Fixup(imp.mod.procBase + obj.offs, mod)
+								END;
+								IF ofp # fp THEN Error(illegalFPrint, imp, mod); object := name$ END
+							ELSIF name # "" THEN
+								Error(objNotFound, imp, mod); object := name$
+							ELSE
+								Error(descNotFound, imp, mod);	(* proceed to find failing named object *)
+								RNum(opt); Fixup(0, mod)
+							END
+						ELSE	(* imp is dll *)
+							IF x IN {mVar, mProc} THEN
+								in := SHORT(imp.name$); n := SHORT(name$);
+								a := Kernel.ThisDllObj(x, fp, in, n);
+								IF a # 0 THEN Fixup(a, mod)
+								ELSE Error(objNotFound, imp, mod); object := name$
+								END
+							ELSIF x = mTyp THEN
+								RNum(opt); RNum(x);
+								IF x # 0 THEN Error(objNotFound, imp, mod); object := name$ END
+							END
+						END;
+						RNum(x)
+					END;
+					S.PUT(imptab, imp.mod); INC(imptab, 4); imp := imp.next
+				END;
+				IF res # done THEN
+					Kernel.DeallocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad); mod.mod := NIL
+				END
+			ELSE Error(noMem, mod, NIL)
+			END
+		ELSE Error(noMem, mod, NIL)
+		END;
+		mod.file.Close; mod.file := NIL
+	END ReadModule;
+	
+	PROCEDURE LoadMod (mod: ModSpec);
+		VAR i: ModSpec; ok: BOOLEAN; j: INTEGER; n: Kernel.Name;
+	BEGIN
+		importing := ""; imported := ""; object := ""; i := mod;
+		WHILE (i.link # NIL) & (i.link.name # mod.name) DO i := i.link END;
+		IF i.link = NIL THEN ReadHeader(mod)
+		ELSE Error(cyclicImport, i, i.link)
+		END;
+		i := mod.imp;
+		WHILE (res = done) & (i # NIL) DO	(* get imported module *)
+			IF i.name = "$$" THEN i.name := "Kernel" END;
+			IF i.name[0] = "$" THEN	(* dll *)
+				j := 1;
+				WHILE i.name[j] # 0X DO i.name[j - 1] := i.name[j]; INC(j) END;
+				i.name[j - 1] := 0X; n := SHORT(i.name$);
+				Kernel.LoadDll(n, ok);
+				IF ~ok THEN Error(fileNotFound, i, NIL) END
+			ELSE
+				n := SHORT(i.name$);
+				i.mod := Kernel.ThisLoadedMod(n);	(* loaded module *)
+				IF i.mod = NIL THEN i.link := mod; LoadMod(i) END	(* new module *)
+			END;
+			i := i.next
+		END;
+		IF res = done THEN
+			n := SHORT(mod.name$);
+			mod.mod := Kernel.ThisLoadedMod(n);	(* guaranties uniqueness *)
+			IF mod.mod = NIL THEN
+				ReadModule(mod);
+				IF res = done THEN
+					Kernel.RegisterMod(mod.mod);
+					res := done
+				END
+			END
+		END;
+		IF res = descNotFound THEN res := objNotFound; object := "<TypeDesc>" END;
+		IF object # "" THEN Append(imported, "."); Append(imported, object); object := "" END
+	END LoadMod;
+
+	PROCEDURE (h: Hook) ThisMod (IN name: ARRAY OF SHORTCHAR): Kernel.Module;
+		VAR m: Kernel.Module; ms: ModSpec;
+	BEGIN
+		res := done;
+		m := Kernel.ThisLoadedMod(name);
+		IF m = NIL THEN
+			NEW(ms); ms.link := NIL; ms.name := name$;
+			LoadMod(ms);
+			m := ms.mod;
+			inp := NIL	(* free last file *)
+		END;
+		h.res := res;
+		h.importing := importing$;
+		h.imported := imported$;
+		h.object := object$;
+		RETURN m
+	END ThisMod;
+
+	PROCEDURE Init;
+		VAR h: Hook;
+	BEGIN
+		NEW(h); Kernel.SetLoaderHook(h)
+	END Init;
+
+BEGIN
+	Init;
+	m := Kernel.ThisMod("Init");
+	IF res # 0 THEN
+		CASE res OF
+		| fileNotFound: Append(imported, ": code file not found")
+		| syntaxError: Append(imported, ": corrupted code file")
+		| objNotFound: Append(imported, " not found")
+		| illegalFPrint: Append(imported, ": wrong fingerprint")
+		| cyclicImport: Append(imported, ": cyclic import")
+		| noMem: Append(imported, ": not enough memory")
+		ELSE Append(imported, ": loader error")
+		END;
+		IF res IN {objNotFound, illegalFPrint, cyclicImport} THEN
+			Append(imported, " (imported from "); Append(imported, importing); Append(imported, ")")
+		 END;
+		Kernel.FatalError(res, imported)
+	END
+END StdLoader.
+

BlackBox/System/Mod/Console.txt

@@ -0,0 +1,103 @@
+MODULE Console;
+
+	(* THIS IS TEXT COPY OF OpenBUGS System/Mod/Console.odc *)
+	(* DO NOT EDIT *)
+
+	TYPE
+		Console* = POINTER TO ABSTRACT RECORD END;
+
+		Process* = POINTER TO ABSTRACT RECORD END;
+
+	VAR
+		cons-, stdCon-: Console;
+		version-: INTEGER;
+		maintainer-: ARRAY 40 OF CHAR;
+
+	PROCEDURE (console: Console) WriteStr- (IN text: ARRAY OF CHAR), NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) WriteChar- (c: CHAR), NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) WriteLn-, NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) ReadLn- (OUT text: ARRAY OF CHAR), NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) Open-, NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) Close-, NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) CreateProcess- (cmdLine: ARRAY OF CHAR): Process, NEW, ABSTRACT;
+
+	PROCEDURE (console: Console) CommandLine- (OUT cmdLine: ARRAY OF CHAR), NEW, ABSTRACT;
+
+	PROCEDURE (p: Process) Terminate-, NEW, ABSTRACT;
+
+	PROCEDURE WriteStr* (IN text: ARRAY OF CHAR);
+	BEGIN
+		cons.WriteStr(text)
+	END WriteStr;
+
+	PROCEDURE WriteChar* (c: CHAR);
+	BEGIN
+		cons.WriteChar(c)
+	END WriteChar;
+
+	PROCEDURE WriteLn*;
+	BEGIN
+		cons.WriteLn
+	END WriteLn;
+
+	PROCEDURE ReadLn* (OUT text: ARRAY OF CHAR);
+	BEGIN
+		cons.ReadLn(text)
+	END ReadLn;
+
+	PROCEDURE Open*;
+	BEGIN
+		cons.Open
+	END Open;
+
+	PROCEDURE Close*;
+	BEGIN
+		cons.Close
+	END Close;
+
+	PROCEDURE CreateProcess* (cmdLine: ARRAY OF CHAR): Process;
+		VAR
+			p: Process;
+	BEGIN
+		p := cons.CreateProcess(cmdLine);
+		RETURN p
+	END CreateProcess;
+
+	PROCEDURE CommandLine* (OUT cmdLine: ARRAY OF CHAR);
+	BEGIN
+		cons.CommandLine(cmdLine)
+	END CommandLine;
+
+	PROCEDURE TerminateProcess* (p: Process);
+	BEGIN
+		p.Terminate
+	END TerminateProcess;
+
+	PROCEDURE SetConsole* (console: Console);
+	BEGIN
+		cons := console;
+		IF stdCon = NIL THEN stdCon := console END
+	END SetConsole;
+
+	PROCEDURE Maintainer;
+	BEGIN
+		version := 310;
+		maintainer := "A.Thomas"
+	END Maintainer;
+
+	PROCEDURE Init;
+	BEGIN
+		Maintainer;
+		cons := NIL;
+		stdCon := NIL
+	END Init;
+
+BEGIN
+	Init
+END Console.

BlackBox/System/Mod/Dialog.txt

@@ -0,0 +1,1202 @@
+MODULE Dialog;
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Dialog.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, Kernel, Files;
+
+	CONST
+		pressed* = 1; released* = 2; changed* = 3; included* = 5; excluded* = 6; set* = 7;	(** notify ops **)
+		ok* = 1; yes* = 2; no* = 3; cancel* = 4;	(** GetOK forms & results **)
+		persistent* = TRUE; nonPersistent* = FALSE;	(** constants for SetLanguage **)
+
+		stringLen = 256;
+		bufLen = 252;
+
+		rsrcDir = "Rsrc";
+		stringFile = "Strings";
+		TAB = 09X; CR = 0DX;
+		update = 2;	(* notify options *)
+		listUpdate = 3;
+		guardCheck = 4;
+
+		windows32s* = 11;
+		windows95* = 12;
+		windowsNT3* = 13;
+		windowsNT4* = 14;
+		windows2000* = 15;
+		windows98* = 16;
+		windowsXP* = 17;
+		windowsVista* = 18;
+		macOS* = 21;
+		macOSX* = 22;
+		linux* = 30;
+		tru64* = 40;
+
+		firstPos* = 0;
+		lastPos* = -1;
+
+	TYPE
+		String* = ARRAY stringLen OF CHAR;
+
+		Buf = POINTER TO RECORD
+			next: Buf;
+			s: ARRAY bufLen OF CHAR
+		END;
+
+		StrList = RECORD
+			len, max: INTEGER;	(* number of items, max number of items *)
+			strings: Buf;	(* string buffer list. strings[0] = 0X -> uninitialized items appear as empty *)
+			end: INTEGER;	(* next free position in string buffer list *)
+			scnt: INTEGER;	(* number of strings in list, including unused entries *)
+			items: POINTER TO ARRAY OF INTEGER	(* indices into string buffer list *)
+		END;
+
+		List* = RECORD
+			index*: INTEGER;	(** val IN [0, n-1] **)
+			len-: INTEGER;
+			l: StrList
+		END;
+
+		Combo* = RECORD
+			item*: String;
+			len-: INTEGER;
+			l: StrList
+		END;
+
+		Selection* = RECORD
+			len-: INTEGER;
+			sel: POINTER TO ARRAY OF SET;
+			l: StrList
+		END;
+
+		Currency* = RECORD	(* number = val * 10^-scale *)
+			val*: LONGINT;
+			scale*: INTEGER
+		END;
+
+		Color* = RECORD
+			val*: INTEGER
+		END;
+
+		TreeNode* = POINTER TO LIMITED RECORD
+			nofChildren: INTEGER;
+			name: String;
+			parent, next, prev, firstChild: TreeNode;
+			viewAsFolder, expanded: BOOLEAN;
+			data: ANYPTR;
+			tree: INTEGER
+		END;
+
+		Tree* = RECORD
+			nofRoots, nofNodes: INTEGER;
+			firstRoot, selected: TreeNode
+		END;
+
+		(** command procedure types**)
+
+		Par* = RECORD	(** parameter for guard procedures **)
+			disabled*: BOOLEAN;	(** OUT, preset to FALSE **)
+			checked*: BOOLEAN;	(** OUT, preset to default **)
+			undef*: BOOLEAN;	(** OUT, preset to default **)
+			readOnly*: BOOLEAN;	(** OUT, preset to default **)
+			label*: String	(** OUT, preset to "" **)
+		END;
+
+		GuardProc* = PROCEDURE (VAR par: Par);
+		NotifierProc* = PROCEDURE (op, from, to: INTEGER);
+
+		StringPtr = POINTER TO ARRAY [untagged] OF CHAR;
+		StringTab = POINTER TO RECORD
+			next: StringTab;
+			name: Files.Name;
+			key: POINTER TO ARRAY OF StringPtr;
+			str: POINTER TO ARRAY OF StringPtr;
+			data: POINTER TO ARRAY OF CHAR
+		END;
+
+		LangNotifier* = POINTER TO ABSTRACT RECORD next: LangNotifier END;
+		Language* = ARRAY 3 OF CHAR;
+
+		LangTrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END;
+
+		GetHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
+		ShowHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
+		CallHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
+		NotifyHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
+		LanguageHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
+
+	VAR
+		metricSystem*: BOOLEAN;
+		showsStatus*: BOOLEAN;
+		platform*: INTEGER;
+		commandLinePars*: String;
+		version*: INTEGER;
+		appName*: ARRAY 32 OF CHAR;
+		language-: Language;
+		user*: ARRAY 32 OF CHAR;
+		caretPeriod*: INTEGER;
+		thickCaret*: BOOLEAN;
+
+		tabList: StringTab;
+		langNotifiers: LangNotifier;
+		currentNotifier: LangNotifier;
+
+		gethook: GetHook;
+		showHook: ShowHook;
+		callHook: CallHook;
+		notifyHook: NotifyHook;
+		languageHook: LanguageHook;
+
+	PROCEDURE (h: GetHook) GetOK* (IN str, p0, p1, p2: ARRAY OF CHAR; form: SET;
+															OUT res: INTEGER), NEW, ABSTRACT;
+	PROCEDURE (h: GetHook) GetColor* (in: INTEGER; OUT out: INTEGER;
+																OUT set: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (h: GetHook) GetIntSpec* (IN defType: Files.Type; VAR loc: Files.Locator;
+														OUT name: Files.Name), NEW, ABSTRACT;
+	PROCEDURE (h: GetHook) GetExtSpec* (IN defName: Files.Name; IN defType: Files.Type;
+																VAR loc: Files.Locator; OUT name: Files.Name), NEW, ABSTRACT;
+
+	PROCEDURE SetGetHook*(h: GetHook);
+	BEGIN
+		gethook := h
+	END SetGetHook;
+
+	PROCEDURE (h: ShowHook) ShowParamMsg* (IN str, p0, p1, p2: ARRAY OF CHAR), NEW, ABSTRACT;
+	PROCEDURE (h: ShowHook) ShowParamStatus* (IN str, p0, p1, p2: ARRAY OF CHAR), NEW, ABSTRACT;
+
+	PROCEDURE SetShowHook* (h: ShowHook);
+	BEGIN
+		showHook := h
+	END SetShowHook;
+
+	PROCEDURE (h: CallHook) Call* (IN proc, errorMsg: ARRAY OF CHAR; VAR res: INTEGER), NEW, ABSTRACT;
+
+	PROCEDURE SetCallHook* (h: CallHook);
+	BEGIN
+		callHook := h
+	END SetCallHook;
+
+	PROCEDURE (h: NotifyHook) Notify* (id0, id1: INTEGER; opts: SET), NEW, ABSTRACT;
+
+	PROCEDURE SetNotifyHook* (h: NotifyHook);
+	BEGIN
+		notifyHook := h
+	END SetNotifyHook;
+
+	PROCEDURE (h: LanguageHook) SetLanguage* (lang: Language; persistent: BOOLEAN;
+																				OUT ok: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (h: LanguageHook) GetPersistentLanguage* (OUT lang: Language), NEW, ABSTRACT;
+
+	PROCEDURE SetLanguageHook* (h: LanguageHook);
+	BEGIN
+		languageHook := h
+	END SetLanguageHook;
+
+	PROCEDURE ReadStringFile (subsys: Files.Name; f: Files.File; VAR tab: StringTab);
+		VAR i, j, h, n, s, x, len, next, down, end: INTEGER; in, in1: Files.Reader;
+			ch: CHAR; b: BYTE; p, q: StringPtr;
+			
+		PROCEDURE ReadInt (OUT x: INTEGER);
+			VAR b: BYTE;
+		BEGIN
+			in.ReadByte(b); x := b MOD 256;
+			in.ReadByte(b); x := x + (b MOD 256) * 100H;
+			in.ReadByte(b); x := x + (b MOD 256) * 10000H;
+			in.ReadByte(b); x := x + b * 1000000H
+		END ReadInt;
+		
+		PROCEDURE ReadHead (OUT next, down, end: INTEGER);
+			VAR b, t: BYTE; n: INTEGER;
+		BEGIN
+			in.ReadByte(b);
+			REPEAT
+				in.ReadByte(t);
+				IF t = -14 THEN ReadInt(n)
+				ELSE
+					REPEAT in.ReadByte(b) UNTIL b = 0
+				END
+			UNTIL t # -15;
+			ReadInt(n);
+			ReadInt(next); next := next + in.Pos();
+			ReadInt(down); down := down + in.Pos();
+			ReadInt(end); end := end + in.Pos()
+		END ReadHead;
+	
+	BEGIN
+		tab := NIL;
+		IF f # NIL THEN	(* read text file *)
+			in := f.NewReader(NIL); in1 :=  f.NewReader(NIL);
+			IF (in # NIL) & (in1 # NIL) THEN
+				in.SetPos(8); ReadHead(next, down, end);	(* document view *)
+				in.SetPos(down); ReadHead(next, down, end);	(* document model *)
+				in.SetPos(down); ReadHead(next, down, end);	(* text view *)
+				in.SetPos(down); ReadHead(next, down, end);	(* text model *)
+				in.ReadByte(b); in.ReadByte(b); in.ReadByte(b);	(* versions *)
+				in.ReadByte(b); in.ReadByte(b); in.ReadByte(b);
+				ReadInt(x); in1.SetPos(in.Pos() + x);	(* text offset *)
+				next := down;
+				NEW(tab); tab.name := subsys$;
+				NEW(tab.data, f.Length());
+				n := 0; i := 0; s := 0; in.ReadByte(b);
+				WHILE b # -1 DO
+					IF next = in.Pos() THEN ReadHead(next, down, end); in.SetPos(end) END;	(* skip attributes *)
+					ReadInt(len);
+					IF len > 0 THEN	(* shortchar run *)
+						WHILE len > 0 DO
+							in1.ReadByte(b); ch := CHR(b MOD 256);
+							IF ch >= " " THEN
+								IF s = 0 THEN j := i; s := 1 END;	(* start of left part *)
+								tab.data[j] := ch; INC(j)
+							ELSIF (s = 1) & (ch = TAB) THEN
+								tab.data[j] := 0X; INC(j);
+								s := 2	(* start of right part *)
+							ELSIF (s = 2) & (ch = CR) THEN
+								tab.data[j] := 0X; INC(j);
+								INC(n); i := j; s := 0	(* end of line *)
+							ELSE
+								s := 0	(* reset *)
+							END;
+							DEC(len)
+						END
+					ELSIF len < 0 THEN		(* longchar run *)
+						WHILE len < 0 DO
+							in1.ReadByte(b); x := b MOD 256; in1.ReadByte(b); ch := CHR(x + 256 * (b + 128));
+							IF s = 0 THEN j := i; s := 1 END;	(* start of left part *)
+							tab.data[j] := ch; INC(j);
+							INC(len, 2)
+						END
+					ELSE	(* view *)
+						ReadInt(x); ReadInt(x); in1.ReadByte(b);	(* ignore *)
+					END;
+					IF next = in.Pos() THEN ReadHead(next, down, end); in.SetPos(end) END;	(* skip view data *)
+					in.ReadByte(b);
+				END;
+				IF n > 0 THEN
+					NEW(tab.key, n); NEW(tab.str, n); i := 0; j := 0;
+					WHILE j < n DO
+						tab.key[j] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[i]));
+						WHILE tab.data[i] >= " " DO INC(i) END;
+						INC(i);
+						tab.str[j] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[i]));
+						WHILE tab.data[i] >= " " DO INC(i) END;
+						INC(i); INC(j)
+					END;
+					(* sort keys (shellsort) *)
+					h := 1; REPEAT h := h*3 + 1 UNTIL h > n;
+					REPEAT h := h DIV 3; i := h;
+						WHILE i < n DO p := tab.key[i]; q := tab.str[i]; j := i;
+							WHILE (j >= h) & (tab.key[j-h]^ > p^) DO
+								tab.key[j] := tab.key[j-h]; tab.str[j] := tab.str[j-h]; j := j-h
+							END;
+							tab.key[j] := p; tab.str[j] := q; INC(i)
+						END
+					UNTIL h = 1
+				END
+			END
+		END
+	END ReadStringFile;
+
+	PROCEDURE MergeTabs (VAR master, extra: StringTab): StringTab;
+		VAR tab: StringTab; nofKeys, datalength, di, mi, ei, ml, el, ti, i: INTEGER;
+	BEGIN
+		IF (extra = NIL) OR (extra.key = NIL) THEN RETURN master END;
+		IF (master = NIL) OR (master.key = NIL)  THEN RETURN extra END;
+		ml := LEN(master.key); el := LEN(extra.key);
+		mi := 0; ei := 0; datalength := 0; nofKeys := 0;
+		(* find out how big the resulting table will be *)
+		WHILE (mi < ml) OR (ei < el) DO
+			INC(nofKeys);
+			IF (mi < ml) & (ei < el) & (master.key[mi]$ = extra.key[ei]$) THEN
+				datalength := datalength + LEN(master.key[mi]$) + LEN(master.str[mi]$) + 2; INC(mi); INC(ei)
+			ELSIF (ei < el) & ((mi >= ml) OR (master.key[mi]$ > extra.key[ei]$)) THEN
+				datalength := datalength + LEN(extra.key[ei]$) + LEN(extra.str[ei]$) + 2; INC(ei)
+			ELSE
+				datalength := datalength + LEN(master.key[mi]$) + LEN(master.str[mi]$) + 2; INC(mi)
+			END
+		END;
+		NEW(tab); tab.name := master.name;
+		NEW(tab.key, nofKeys); NEW(tab.str, nofKeys); NEW(tab.data, datalength);
+		mi := 0; ei := 0; di := 0; ti := 0;
+		(* do the merge *)
+		WHILE (mi < ml) OR (ei < el) DO
+			IF  (mi < ml) & (ei < el) & (master.key[mi]$ = extra.key[ei]$)  THEN
+				i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE  master.key[mi][i] # 0X DO tab.data[di] := master.key[mi][i]; INC(di); INC(i) END;
+				tab.data[di] :=0X; INC(di); i := 0;
+				tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE master.str[mi][i] # 0X DO tab.data[di] := master.str[mi][i]; INC(di); INC(i) END;
+				 tab.data[di] :=0X; INC(di);
+				INC(mi); INC(ei)
+			ELSIF (ei < el) & ((mi >= ml) OR (master.key[mi]$ > extra.key[ei]$)) THEN
+				i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE extra.key[ei][i] # 0X DO tab.data[di] := extra.key[ei][i]; INC(di); INC(i) END;
+				tab.data[di] :=0X; INC(di); i := 0;
+				tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE  extra.str[ei][i] # 0X DO tab.data[di] := extra.str[ei][i]; INC(di); INC(i) END;
+				 tab.data[di] :=0X; INC(di);
+				INC(ei)
+			ELSE
+				i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE master.key[mi][i] # 0X DO  tab.data[di] := master.key[mi][i]; INC(di); INC(i) END;
+				tab.data[di] :=0X; INC(di); i := 0;
+				tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di]));
+				WHILE master.str[mi][i] # 0X DO  tab.data[di] := master.str[mi][i]; INC(di); INC(i) END;
+				 tab.data[di] :=0X; INC(di);
+				INC(mi)
+			END;
+			INC(ti)
+		END;
+		RETURN tab
+	END MergeTabs;
+
+	PROCEDURE LoadStringTab (subsys: Files.Name; VAR tab: StringTab);
+		VAR loc: Files.Locator; f: Files.File; name: Files.Name; ltab: StringTab;
+	BEGIN
+		tab := NIL;
+		name := stringFile; Kernel.MakeFileName(name, "");
+		loc := Files.dir.This(subsys); loc := loc.This(rsrcDir);
+		IF loc # NIL THEN
+			 f := Files.dir.Old(loc, name, Files.shared);
+			ReadStringFile(subsys, f, tab);
+			IF language # "" THEN
+				loc := loc.This(language);
+				IF loc # NIL THEN
+					 f := Files.dir.Old(loc, name, Files.shared);
+					ReadStringFile(subsys, f, ltab);
+					tab := MergeTabs(ltab, tab)
+				END
+			END;
+			IF tab # NIL THEN tab.next := tabList; tabList := tab END
+		END
+	END LoadStringTab;
+
+	PROCEDURE SearchString (VAR in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+		VAR i, j, k, len: INTEGER; ch: CHAR; subsys: Files.Name; tab: StringTab;
+	BEGIN
+		out := "";
+		IF in[0] = "#" THEN
+			i := 0; ch := in[1];
+			WHILE (ch # 0X) (* & (ch # ".") *) & (ch # ":") DO subsys[i] := ch; INC(i); ch := in[i + 1] END;
+			subsys[i] := 0X;
+			IF ch # 0X THEN
+				INC(i, 2); ch := in[i]; j := 0;
+				WHILE (ch # 0X) DO in[j] := ch; INC(i); INC(j); ch := in[i] END;
+				in[j] := 0X
+			ELSE
+				RETURN
+			END;
+			tab := tabList;
+			WHILE (tab # NIL) & (tab.name # subsys) DO tab := tab.next END;
+			IF tab = NIL THEN LoadStringTab(subsys, tab) END;
+			IF tab # NIL THEN
+				i := 0;
+				IF tab.key = NIL THEN j := 0 ELSE j := LEN(tab.key^) END;
+				WHILE i < j DO	(* binary search *)
+					k := (i + j) DIV 2;
+					IF tab.key[k]^ < in THEN i := k + 1 ELSE j := k END
+				END;
+				IF (tab.key # NIL) & (j < LEN(tab.key^)) & (tab.key[j]^ = in) THEN
+					k := 0; len := LEN(out)-1;
+					WHILE (k < len) & (tab.str[j][k] # 0X) DO
+						out[k] := tab.str[j][k]; INC(k)
+					END;
+					out[k] := 0X
+				END
+			END
+		END
+	END SearchString;
+
+
+	PROCEDURE Init (VAR l: StrList);
+	BEGIN
+		l.len := 0; l.max := 0; l.end := 0; l.scnt := 0
+	END Init;
+
+	PROCEDURE Compact (VAR l: StrList);
+		VAR i, j, k: INTEGER; ibuf, jbuf: Buf; ch: CHAR;
+	BEGIN
+		i := 1; ibuf := l.strings; j := 1; jbuf := l.strings;
+		WHILE j < l.end DO
+			(* find index entry k pointing to position j *)
+			k := 0; WHILE (k < l.len) & (l.items[k] # j) DO INC(k) END;
+			IF k < l.len THEN	(* copy string *)
+				l.items[k] := i;
+				REPEAT
+					ch := jbuf.s[j MOD bufLen]; INC(j);
+					IF j MOD bufLen = 0 THEN jbuf := jbuf.next END;
+					ibuf.s[i MOD bufLen] := ch; INC(i);
+					IF i MOD bufLen = 0 THEN ibuf := ibuf.next END
+				UNTIL ch = 0X
+			ELSE (* skip next string *)
+				REPEAT
+					ch := jbuf.s[j MOD bufLen]; INC(j);
+					IF j MOD bufLen = 0 THEN jbuf := jbuf.next END
+				UNTIL ch = 0X
+			END
+		END;
+		ibuf.next := NIL;	(* release superfluous buffers *)
+		l.end := i; l.scnt := l.len
+	END Compact;
+
+	PROCEDURE SetLen (VAR l: StrList; len: INTEGER);
+		CONST D = 32;
+		VAR i, newmax: INTEGER;
+			items: POINTER TO ARRAY OF INTEGER;
+	BEGIN
+		IF l.items = NIL THEN Init(l) END;
+		IF (l.max - D < len) & (len <= l.max) THEN
+			(* we do not reallocate anything *)
+		ELSE
+			newmax := (len + D-1) DIV D * D;
+			IF newmax > 0 THEN
+				IF l.strings = NIL THEN NEW(l.strings); (* l.strings[0] := 0X; *) l.end := 1 END;
+				NEW(items, newmax);
+				IF len < l.len THEN i := len ELSE i := l.len END;
+				WHILE i > 0 DO DEC(i); items[i] := l.items[i] END;
+				l.items := items
+			END;
+			l.max := newmax
+		END;
+		l.len := len;
+		IF (l.scnt > 32) & (l.scnt > 2 * l.len) THEN Compact(l) END
+	END SetLen;
+
+	PROCEDURE GetItem (VAR l: StrList; index: INTEGER; VAR item: String);
+		VAR i, j, k: INTEGER; b: Buf; ch: CHAR;
+	BEGIN
+		IF l.items = NIL THEN Init(l) END;
+		IF (index >= 0) & (index < l.len) THEN
+			i := l.items[index]; j := i MOD bufLen; i := i DIV bufLen;
+			b := l.strings; WHILE i # 0 DO b := b.next; DEC(i) END;
+			k := 0;
+			REPEAT
+				ch := b.s[j]; INC(j); IF j = bufLen THEN j := 0; b := b.next END;
+				item[k] := ch; INC(k)
+			UNTIL ch = 0X
+		ELSE
+			item := ""
+		END
+	END GetItem;
+
+	PROCEDURE SetItem (VAR l: StrList; index: INTEGER; item: ARRAY OF CHAR);
+		VAR len, i, j, k: INTEGER; b: Buf; ch: CHAR;
+	BEGIN
+		IF l.items = NIL THEN Init(l) END;
+		IF index >= l.len THEN SetLen(l, index + 1) END;
+		IF (l.scnt > 32) & (l.scnt > 2 * l.len) THEN Compact(l) END;
+		len := 0; WHILE item[len] # 0X DO INC(len) END;
+		IF len >= stringLen THEN len := stringLen - 1; item[len] := 0X END;	(* clip long strings *)
+		l.items[index] := l.end;
+		i := l.end; j := i MOD bufLen; i := i DIV bufLen;
+		b := l.strings; WHILE i # 0 DO b := b.next; DEC(i) END;
+		k := 0;
+		REPEAT
+			ch := item[k]; INC(k); INC(l.end);
+			b.s[j] := ch; INC(j); IF j = bufLen THEN j := 0; NEW(b.next); b := b.next END
+		UNTIL ch = 0X;
+		INC(l.scnt)
+	END SetItem;
+
+	PROCEDURE SetResources (VAR l: StrList; IN key: ARRAY OF CHAR);
+		VAR i, k, j, x: INTEGER; ch: CHAR; s, a: ARRAY 16 OF CHAR; h, item: ARRAY 256 OF CHAR;
+	BEGIN
+		IF l.items = NIL THEN Init(l) END;
+		i := 0;
+		REPEAT
+			x := i;
+			j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0;
+			k := 0; REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
+			s[k] := 0X;
+			h := key + "[" + s + "]";
+			SearchString(h, item);
+			IF item # "" THEN SetItem(l, i, item) END;
+			INC(i)
+		UNTIL item = ""
+	END SetResources;
+
+
+	(** List **)
+
+	PROCEDURE (VAR l: List) SetLen* (len: INTEGER), NEW;
+	BEGIN
+		ASSERT(len >= 0, 20);
+		SetLen(l.l, len);
+		l.len := l.l.len
+	END SetLen;
+
+	PROCEDURE (VAR l: List) GetItem* (index: INTEGER; OUT item: String), NEW;
+	BEGIN
+		GetItem(l.l, index, item);
+		l.len := l.l.len
+	END GetItem;
+
+	PROCEDURE (VAR l: List) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(index >= 0, 20); ASSERT(item # "", 21);
+		SetItem(l.l, index, item);
+		l.len := l.l.len
+	END SetItem;
+
+	PROCEDURE (VAR l: List) SetResources* (IN key: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(key # "", 20);
+		SetResources(l.l, key);
+		l.len := l.l.len
+	END SetResources;
+
+
+	(** Selection **)
+
+	PROCEDURE (VAR s: Selection) SetLen* (len: INTEGER), NEW;
+		VAR sel: POINTER TO ARRAY OF SET; i: INTEGER;
+	BEGIN
+		ASSERT(len >= 0, 20);
+		SetLen(s.l, len);
+		len := len + (MAX(SET) - 1) DIV MAX(SET);
+		IF len  = 0 THEN s.sel := NIL
+		ELSIF s.sel = NIL THEN NEW(s.sel, len)
+		ELSIF LEN(s.sel^) # len THEN
+			NEW(sel, len);
+			IF LEN(s.sel^) < len THEN len := LEN(s.sel^) END;
+			i := 0; WHILE i < len DO sel[i] := s.sel[i]; INC(i) END;
+			s.sel := sel
+		END;
+		s.len := s.l.len
+	END SetLen;
+
+	PROCEDURE (VAR s: Selection) GetItem* (index: INTEGER; OUT item: String), NEW;
+	BEGIN
+		GetItem(s.l, index, item);
+		s.len := s.l.len
+	END GetItem;
+
+	PROCEDURE (VAR s: Selection) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(index >= 0, 20); (*ASSERT(index < s.l.len, 21);*) ASSERT(item # "", 21);
+		SetItem(s.l, index, item);
+		IF s.l.len > s.len THEN s.SetLen(s.l.len) END
+	END SetItem;
+
+	PROCEDURE (VAR s: Selection) SetResources* (IN key: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(key # "", 20);
+		SetResources(s.l, key);
+		IF s.l.len > s.len THEN s.SetLen(s.l.len) END
+	END SetResources;
+
+	PROCEDURE (VAR s: Selection) In* (index: INTEGER): BOOLEAN, NEW;
+	BEGIN
+		IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END;
+		IF s.sel # NIL THEN RETURN (index MOD 32) IN (s.sel[index DIV 32]) ELSE RETURN FALSE END
+	END In;
+
+	PROCEDURE (VAR s: Selection) Excl* (from, to: INTEGER), NEW;
+	BEGIN
+		IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END;
+		IF from < 0 THEN from := 0 END;
+		IF to >= s.l.len THEN to := s.l.len - 1 END;
+		WHILE from <= to DO EXCL(s.sel[from DIV 32], from MOD 32); INC(from) END
+	END Excl;
+
+	PROCEDURE (VAR s: Selection) Incl* (from, to: INTEGER), NEW;
+	BEGIN
+		IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END;
+		IF from < 0 THEN from := 0 END;
+		IF to >= s.l.len THEN to := s.l.len - 1 END;
+		WHILE from <= to DO INCL(s.sel[from DIV 32], from MOD 32); INC(from) END
+	END Incl;
+
+
+	(** Combo **)
+
+	PROCEDURE (VAR c: Combo) SetLen* (len: INTEGER), NEW;
+	BEGIN
+		ASSERT(len >= 0, 20);
+		SetLen(c.l, len);
+		c.len := c.l.len
+	END SetLen;
+
+	PROCEDURE (VAR c: Combo) GetItem* (index: INTEGER; OUT item: String), NEW;
+	BEGIN
+		GetItem(c.l, index, item);
+		c.len := c.l.len
+	END GetItem;
+
+	PROCEDURE (VAR c: Combo) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(index >= 0, 20); ASSERT(item # "", 21);
+		SetItem(c.l, index, item);
+		c.len := c.l.len
+	END SetItem;
+
+	PROCEDURE (VAR c: Combo) SetResources* (IN key: ARRAY OF CHAR), NEW;
+	BEGIN
+		ASSERT(key # "", 20);
+		SetResources(c.l, key);
+		c.len := c.l.len
+	END SetResources;
+
+
+	(* Tree and TreeNode *)
+
+	PROCEDURE (tn: TreeNode) SetName* (name: String), NEW;
+	BEGIN
+		tn.name := name
+	END SetName;
+
+	PROCEDURE (tn: TreeNode) GetName* (OUT name: String), NEW;
+	BEGIN
+		name := tn.name
+	END GetName;
+
+	PROCEDURE (tn: TreeNode) SetData* (data: ANYPTR), NEW;
+	BEGIN
+		tn.data := data
+	END SetData;
+
+	PROCEDURE (tn: TreeNode) Data* (): ANYPTR, NEW;
+	BEGIN
+		RETURN tn.data
+	END Data;
+
+	PROCEDURE (tn: TreeNode) NofChildren* (): INTEGER, NEW;
+	BEGIN
+		RETURN tn.nofChildren
+	END NofChildren;
+
+	PROCEDURE (tn: TreeNode) SetExpansion* (expanded: BOOLEAN), NEW;
+	BEGIN
+		tn.expanded := expanded
+	END SetExpansion;
+
+	PROCEDURE (tn: TreeNode) IsExpanded* (): BOOLEAN, NEW;
+	BEGIN
+		RETURN tn.expanded
+	END IsExpanded;
+
+	PROCEDURE (tn: TreeNode) IsFolder* (): BOOLEAN, NEW;
+	BEGIN
+		IF (~tn.viewAsFolder) & (tn.firstChild = NIL) THEN
+			RETURN FALSE
+		ELSE
+			RETURN TRUE
+		END
+	END IsFolder;
+
+	PROCEDURE (tn: TreeNode) ViewAsFolder* (isFolder: BOOLEAN), NEW;
+	BEGIN
+		tn.viewAsFolder := isFolder
+	END ViewAsFolder;
+
+	PROCEDURE (VAR t: Tree) NofNodes* (): INTEGER, NEW;
+	BEGIN
+		IF t.firstRoot = NIL THEN
+			RETURN 0
+		ELSE
+			RETURN MAX(0, t.nofNodes)
+		END
+	END NofNodes;
+
+	PROCEDURE (VAR t: Tree) NofRoots* (): INTEGER, NEW;
+	BEGIN
+		IF t.firstRoot = NIL THEN
+			RETURN 0
+		ELSE
+			RETURN MAX(0, t.nofRoots)
+		END
+	END NofRoots;
+
+	PROCEDURE (VAR t: Tree) Parent* (node: TreeNode): TreeNode, NEW;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21);
+		RETURN node.parent
+	END Parent;
+
+	PROCEDURE (VAR t: Tree) Next* (node: TreeNode): TreeNode, NEW;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21);
+		RETURN node.next
+	END Next;
+
+	PROCEDURE (VAR t: Tree) Prev* (node: TreeNode): TreeNode, NEW;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21);
+		RETURN node.prev
+	END Prev;
+
+	PROCEDURE (VAR t: Tree) Child* (node: TreeNode; pos: INTEGER): TreeNode, NEW;
+		VAR cur: TreeNode;
+	BEGIN
+		ASSERT(pos >= lastPos, 20); ASSERT((node = NIL) OR (node.tree = SYSTEM.ADR(t)), 21);
+		IF node = NIL THEN cur := t.firstRoot
+		ELSE cur := node.firstChild END;
+		IF pos = lastPos THEN
+			WHILE (cur # NIL) & (cur.next # NIL) DO cur := cur.next END
+		ELSE
+			WHILE (cur # NIL) & (pos > 0) DO cur := cur.next; DEC(pos) END
+		END;
+		RETURN cur
+	END Child;
+
+	PROCEDURE (VAR t: Tree) Selected* (): TreeNode, NEW;
+	BEGIN
+		RETURN t.selected
+	END Selected;
+
+	PROCEDURE (VAR t: Tree) Select* (node: TreeNode), NEW;
+	BEGIN
+		ASSERT((node = NIL) OR (node.tree = SYSTEM.ADR(t)), 20);
+		IF (node # NIL) OR (t.nofRoots = 0) THEN
+			t.selected := node
+		ELSE
+			t.selected := t.Child(NIL, 0)
+		END
+	END Select;
+
+	PROCEDURE Include (IN t: Tree; node: TreeNode);
+		VAR c: TreeNode;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = 0, 100);
+		node.tree := SYSTEM.ADR(t);
+		c := node.firstChild;
+		WHILE c # NIL DO Include(t, c); c := c.next END
+	END Include;
+
+	PROCEDURE (VAR t: Tree) InsertAt (parent: TreeNode; pos: INTEGER; node: TreeNode), NEW;
+		VAR
+			cur, prev: TreeNode;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(pos >= lastPos, 21);
+		ASSERT((parent = NIL) OR (parent.tree = SYSTEM.ADR(t)), 22); ASSERT(node.tree = 0, 23);
+		Include(t, node);
+		IF parent = NIL THEN	(* Add new root *)
+			IF (t.firstRoot = NIL) OR (pos = 0) THEN
+				node.next := t.firstRoot; node.prev := NIL;
+				IF t.firstRoot # NIL THEN t.firstRoot.prev := node END;
+				t.firstRoot := node
+			ELSE
+				cur := t.firstRoot;
+				IF pos = lastPos THEN pos := t.nofRoots END;
+				WHILE (cur # NIL) & (pos > 0) DO
+					prev := cur; cur := t.Next(cur); DEC(pos)
+				END;
+				IF cur = NIL THEN
+					prev.next := node; node.prev := prev
+				ELSE
+					node.next := cur; node.prev := cur.prev; cur.prev := node; prev.next := node
+				END
+			END;
+			INC(t.nofRoots)
+		ELSE	(* Add child *)
+			IF pos = lastPos THEN pos := parent.nofChildren END;
+			IF (parent.firstChild = NIL) OR (pos = 0) THEN
+				IF parent.firstChild # NIL THEN parent.firstChild.prev := node END;
+				node.prev := NIL; node.next := parent.firstChild; parent.firstChild := node
+			ELSE
+				cur := parent.firstChild;
+				WHILE (cur # NIL) & (pos > 0) DO
+					prev := cur; cur := t.Next(cur); DEC(pos)
+				END;
+				IF cur = NIL THEN
+					prev.next := node; node.prev := prev
+				ELSE
+					node.next := cur; node.prev := cur.prev; cur.prev := node; prev.next := node
+				END
+			END;
+			INC(parent.nofChildren)
+		END;
+		node.parent := parent;
+		INC(t.nofNodes)
+	END InsertAt;
+
+	PROCEDURE (VAR t: Tree) NewChild* (parent: TreeNode; pos: INTEGER; name: String): TreeNode, NEW;
+		VAR
+			new: TreeNode;
+	BEGIN
+		NEW(new); new.tree := 0;
+		new.SetName(name); new.expanded := FALSE; new.nofChildren := 0;
+		new.viewAsFolder := FALSE;
+		t.InsertAt(parent, pos, new);
+		RETURN new
+	END NewChild;
+
+	PROCEDURE (VAR t: Tree) CountChildren (node: TreeNode): INTEGER, NEW;
+		VAR tot, nofc, i: INTEGER;
+	BEGIN
+		tot := 0;
+		IF node # NIL THEN
+			nofc := node.nofChildren; tot := nofc;
+			FOR i := 0 TO nofc -1 DO
+				tot := tot + t.CountChildren(t.Child(node, i))
+			END
+		END;
+		RETURN tot
+	END CountChildren;
+
+	PROCEDURE Exclude (IN t: Tree; node: TreeNode);
+		VAR c: TreeNode;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 100);
+		IF t.Selected() = node THEN t.Select(NIL) END;
+		node.tree := 0;
+		c := node.firstChild;
+		WHILE c # NIL DO Exclude(t, c); c := c.next END
+	END Exclude;
+
+	PROCEDURE (VAR t: Tree) Delete* (node: TreeNode): INTEGER, NEW;
+		VAR
+			ndel: INTEGER;
+	BEGIN
+		ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21);
+		ndel := t.CountChildren(node);
+		IF node.parent = NIL THEN	(* root node *)
+			IF node.prev = NIL THEN
+				IF node.next # NIL THEN
+					t.firstRoot := node.next;
+					node.next.prev := NIL
+				ELSE
+					t.firstRoot := NIL
+				END
+			ELSE
+				node.prev.next := node.next;
+				IF node.next # NIL THEN node.next.prev := node.prev END
+			END;
+			DEC(t.nofRoots)
+		ELSE
+			IF node.prev = NIL THEN
+				IF node.next # NIL THEN
+					node.parent.firstChild := node.next;
+					node.next.prev := NIL
+				ELSE
+					node.parent.firstChild := NIL
+				END
+			ELSE
+				node.prev.next := node.next;
+				IF node.next # NIL THEN node.next.prev := node.prev END
+			END;
+			DEC(node.parent.nofChildren)
+		END;
+		node.parent := NIL; node.next := NIL; node.prev := NIL;
+		Exclude(t, node);
+		ndel := ndel + 1;
+		t.nofNodes := t.nofNodes - ndel;
+		RETURN ndel
+	END Delete;
+
+	PROCEDURE (VAR t: Tree) Move* (node, parent: TreeNode; pos: INTEGER), NEW;
+		VAR ndel, nofn: INTEGER; s: TreeNode;
+	BEGIN
+		ASSERT(node # NIL, 20);  ASSERT(pos >= lastPos, 21);
+		ASSERT(node.tree = SYSTEM.ADR(t), 22);
+		nofn := t.NofNodes();
+		s := t.Selected();
+		ndel := t.Delete(node); t.InsertAt(parent, pos, node);
+		t.nofNodes := t.nofNodes + ndel - 1;
+		IF (s # NIL) & (t.Selected() # s) THEN t.Select(s) END;
+		ASSERT(nofn = t.NofNodes(), 60)
+	END Move;
+
+	PROCEDURE (VAR t: Tree) DeleteAll*, NEW;
+	BEGIN
+		t.nofRoots := 0; t.nofNodes := 0; t.firstRoot := NIL; t.selected := NIL
+	END DeleteAll;
+
+
+	PROCEDURE Notify* (id0, id1: INTEGER; opts: SET);
+	BEGIN
+		ASSERT(notifyHook # NIL, 100);
+		notifyHook.Notify(id0, id1, opts)
+	END Notify;
+
+	PROCEDURE Update* (IN x: ANYREC);
+		VAR type: Kernel.Type; adr, size: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		type := Kernel.TypeOf(x);
+		size := type.size;
+		IF size = 0 THEN size := 1 END;
+		Notify(adr, adr + size, {update, guardCheck})
+	END Update;
+
+	PROCEDURE UpdateBool* (VAR x: BOOLEAN);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(BOOLEAN), {update, guardCheck})
+	END UpdateBool;
+
+	PROCEDURE UpdateSChar* (VAR x: SHORTCHAR);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(SHORTCHAR), {update, guardCheck})
+	END UpdateSChar;
+
+	PROCEDURE UpdateChar* (VAR x: CHAR);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(CHAR), {update, guardCheck})
+	END UpdateChar;
+
+	PROCEDURE UpdateByte* (VAR x: BYTE);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(BYTE), {update, guardCheck})
+	END UpdateByte;
+
+	PROCEDURE UpdateSInt* (VAR x: SHORTINT);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(SHORTINT), {update, guardCheck})
+	END UpdateSInt;
+
+	PROCEDURE UpdateInt* (VAR x: INTEGER);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(INTEGER), {update, guardCheck})
+	END UpdateInt;
+
+	PROCEDURE UpdateLInt* (VAR x: LONGINT);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(LONGINT), {update, guardCheck})
+	END UpdateLInt;
+
+	PROCEDURE UpdateSReal* (VAR x: SHORTREAL);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(SHORTREAL), {update, guardCheck})
+	END UpdateSReal;
+
+	PROCEDURE UpdateReal* (VAR x: REAL);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(REAL), {update, guardCheck})
+	END UpdateReal;
+
+	PROCEDURE UpdateSet* (VAR x: SET);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + SIZE(SET), {update, guardCheck})
+	END UpdateSet;
+
+	PROCEDURE UpdateSString* (IN x: ARRAY OF SHORTCHAR);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + LEN(x) * SIZE(SHORTCHAR), {update, guardCheck})
+	END UpdateSString;
+
+	PROCEDURE UpdateString* (IN x: ARRAY OF CHAR);
+		VAR adr: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		Notify(adr, adr + LEN(x) * SIZE(CHAR), {update, guardCheck})
+	END UpdateString;
+
+	PROCEDURE UpdateList* (IN x: ANYREC);
+		VAR type: Kernel.Type; adr, size: INTEGER;
+	BEGIN
+		adr := SYSTEM.ADR(x);
+		type := Kernel.TypeOf(x);
+		size := type.size;
+		IF size = 0 THEN size := 1 END;
+		Notify(adr, adr + size, {listUpdate, guardCheck})
+	END UpdateList;
+
+
+	PROCEDURE GetOK* (IN str, p0, p1, p2: ARRAY OF CHAR; form: SET; OUT res: INTEGER);
+	BEGIN
+		ASSERT(((yes IN form) = (no IN form)) & ((yes IN form) # (ok IN form)), 20);
+		ASSERT(gethook # NIL, 100);
+		gethook.GetOK(str, p0, p1, p2, form, res)
+	END GetOK;
+
+	PROCEDURE GetIntSpec* (defType: Files.Type; VAR loc: Files.Locator; OUT name: Files.Name);
+	BEGIN
+		ASSERT(gethook # NIL, 100);
+		gethook.GetIntSpec(defType, loc, name)
+	END GetIntSpec;
+
+	PROCEDURE GetExtSpec* (defName: Files.Name; defType: Files.Type; VAR loc: Files.Locator;
+												OUT name: Files.Name);
+	BEGIN
+		ASSERT(gethook # NIL, 100);
+		gethook.GetExtSpec(defName, defType, loc, name)
+	END GetExtSpec;
+
+	PROCEDURE GetColor* (in: INTEGER; OUT out: INTEGER; OUT set: BOOLEAN);
+	BEGIN
+		ASSERT(gethook # NIL, 100);
+		gethook.GetColor(in, out, set)
+	END GetColor;
+
+
+	PROCEDURE Subst (in: ARRAY OF CHAR; IN p0, p1, p2: ARRAY OF CHAR; VAR out: ARRAY OF CHAR);
+		VAR len, i, j, k: INTEGER; ch, c: CHAR;
+	BEGIN
+		i := 0; ch := in[i]; j := 0; len := LEN(out) - 1;
+		WHILE (ch # 0X) & (j < len) DO
+			IF ch = "^" THEN
+				INC(i); ch := in[i];
+				IF ch = "0" THEN
+					k := 0; c := p0[0];
+					WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p0[k] END;
+					INC(i); ch := in[i]
+				ELSIF ch = "1" THEN
+					k := 0; c := p1[0];
+					WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p1[k] END;
+					INC(i); ch := in[i]
+				ELSIF ch = "2" THEN
+					k := 0; c := p2[0];
+					WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p2[k] END;
+					INC(i); ch := in[i]
+				ELSE out[j] := "^"; INC(j)
+				END
+			ELSE out[j] := ch; INC(j); INC(i); ch := in[i]
+			END
+		END;
+		out[j] := 0X
+	END Subst;
+
+	PROCEDURE FlushMappings*;
+	BEGIN
+		tabList := NIL
+	END FlushMappings;
+
+	PROCEDURE MapParamString* (in, p0, p1, p2: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+	(* use in as key in string table file, and return corresponding string in out.
+		If the resource lookup fails, return in in out *)
+	BEGIN
+		SearchString(in, out);
+		IF out # "" THEN Subst(out, p0, p1, p2, out)
+		ELSE Subst(in, p0, p1, p2, out)
+		END
+	END MapParamString;
+
+	PROCEDURE MapString* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+		VAR len, k: INTEGER;
+	BEGIN
+		SearchString(in, out);
+		IF out = "" THEN
+			k := 0; len := LEN(out)-1;
+			WHILE (k < len) & (in[k] # 0X) DO out[k] := in[k]; INC(k) END;
+			out[k] := 0X
+		END
+	END MapString;
+
+	PROCEDURE ShowMsg* (IN str: ARRAY OF CHAR);
+	BEGIN
+		ASSERT(str # "", 20);
+		ASSERT(showHook # NIL, 100);
+		showHook.ShowParamMsg(str, "", "", "")
+	END ShowMsg;
+
+	PROCEDURE ShowParamMsg* (IN str, p0, p1, p2: ARRAY OF CHAR);
+	BEGIN
+		ASSERT(str # "", 20);
+		ASSERT(showHook # NIL, 100);
+		showHook.ShowParamMsg(str,p0, p1, p2)
+	END ShowParamMsg;
+
+	PROCEDURE ShowStatus* (IN str: ARRAY OF CHAR);
+	BEGIN
+		ASSERT(showHook # NIL, 100);
+		showHook.ShowParamStatus(str, "", "", "")
+	END ShowStatus;
+
+	PROCEDURE ShowParamStatus* (IN str, p0, p1, p2: ARRAY OF CHAR);
+	BEGIN
+		ASSERT(showHook # NIL, 100);
+		showHook.ShowParamStatus(str, p0, p1, p2)
+	END ShowParamStatus;
+
+
+	PROCEDURE Call* (IN proc, errorMsg: ARRAY OF CHAR; OUT res: INTEGER);
+	BEGIN
+		ASSERT(callHook # NIL, 100);
+		callHook.Call(proc, errorMsg, res)
+	END Call;
+
+	PROCEDURE Beep*;
+	BEGIN
+		Kernel.Beep
+	END Beep;
+
+	PROCEDURE (n: LangNotifier) Notify-(), NEW, ABSTRACT;
+
+	PROCEDURE RegisterLangNotifier* (notifier: LangNotifier);
+		VAR nl: LangNotifier;
+	BEGIN
+		ASSERT(notifier # NIL, 20);
+		nl := langNotifiers;
+		WHILE (nl # NIL) & (nl # notifier) DO nl := nl.next END;
+		IF nl = NIL THEN
+			notifier.next := langNotifiers; langNotifiers := notifier
+		END
+	END RegisterLangNotifier;
+
+	PROCEDURE RemoveLangNotifier* (notifier: LangNotifier);
+		VAR nl, prev: LangNotifier;
+	BEGIN
+		ASSERT(notifier # NIL, 20);
+		nl := langNotifiers; prev := NIL;
+		WHILE (nl # NIL) & (nl # notifier) DO prev := nl; nl := nl.next END;
+		IF nl # NIL THEN
+			IF prev = NIL THEN  langNotifiers := langNotifiers.next ELSE prev.next := nl.next END;
+			nl.next := NIL
+		END
+	END RemoveLangNotifier;
+
+	PROCEDURE Exec (a, b, c: INTEGER);
+		VAR nl: LangNotifier;
+	BEGIN
+		nl := currentNotifier; currentNotifier := NIL;
+		nl.Notify;
+		currentNotifier := nl
+	END Exec;
+
+	PROCEDURE SetLanguage* (lang: Language; persistent: BOOLEAN);
+		VAR nl, t: LangNotifier; ok: BOOLEAN;
+	BEGIN
+		ASSERT((lang = "") OR (LEN(lang$) = 2), 20);
+		ASSERT(languageHook # NIL, 100);
+		IF lang # language THEN
+			languageHook.SetLanguage(lang, persistent, ok);
+			IF ok THEN
+				language := lang; FlushMappings;
+				nl := langNotifiers;
+				WHILE nl # NIL DO
+					currentNotifier := nl;
+					Kernel.Try(Exec, 0, 0, 0);
+					IF currentNotifier = NIL THEN
+						t := nl; nl := nl.next; RemoveLangNotifier(t)	(* Notifier trapped, remove it *)
+					ELSE
+						nl := nl.next
+					END
+				END
+			END;
+			currentNotifier := NIL
+		END
+	END SetLanguage;
+
+	PROCEDURE ResetLanguage*;
+		VAR lang: Language;
+	BEGIN
+		ASSERT(languageHook # NIL, 100);
+		languageHook.GetPersistentLanguage(lang);
+		SetLanguage(lang, nonPersistent)
+	END ResetLanguage;
+
+BEGIN
+	appName := "BlackBox"; showsStatus := FALSE; caretPeriod := 500; thickCaret := FALSE; user := ""
+END Dialog.

BlackBox/System/Mod/Files.txt

@@ -0,0 +1,110 @@
+MODULE Files;
+
+	(* THIS IS TEXT COPY OF BlackBox-1.6 System/Mod/Files.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT Kernel;
+
+	CONST 
+		shared* = TRUE; exclusive* = FALSE;
+		dontAsk* = FALSE; ask* = TRUE; (** File.Register, Directory.New and Directory.Rename  **)
+
+	CONST
+		readOnly* = 0;
+		hidden* = 1;
+		system* = 2;
+		archive* = 3;
+		stationery* = 4;
+
+	TYPE
+		Name* = ARRAY 256 OF CHAR;
+		Type* = ARRAY 16 OF CHAR;
+
+		FileInfo* = POINTER TO RECORD
+			next*: FileInfo;
+			name*: Name;
+			length*: INTEGER;
+			type*: Type;
+			modified*: RECORD year*, month*, day*, hour*, minute*, second*: INTEGER END;
+			attr*: SET
+		END;
+
+		LocInfo* = POINTER TO RECORD
+			next*: LocInfo;
+			name*: Name;
+			attr*: SET;
+		END;
+
+		Locator* = POINTER TO ABSTRACT RECORD
+			res*: INTEGER;
+		END;
+
+		File* = POINTER TO ABSTRACT RECORD
+			type-: Type;
+			init: BOOLEAN;
+		END;
+
+		Reader* = POINTER TO ABSTRACT RECORD
+			eof*: BOOLEAN;
+		END;
+
+		Writer* = POINTER TO ABSTRACT RECORD END;
+
+		Directory* = POINTER TO ABSTRACT RECORD END;
+
+	VAR dir-, stdDir-: Directory;
+		objType-, symType-, docType- : Type;	(* file types *)
+
+
+	PROCEDURE (l: Locator) This* (IN path: ARRAY OF CHAR): Locator, NEW, ABSTRACT;
+
+	PROCEDURE (f: File) InitType* (type: Type), NEW;
+	BEGIN
+		ASSERT(~f.init, 20);
+		f.type := type$; f.init := TRUE
+	END InitType;
+
+	PROCEDURE (f: File) Length* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (f: File) NewReader* (old: Reader): Reader, NEW, ABSTRACT;
+	PROCEDURE (f: File) NewWriter* (old: Writer): Writer, NEW, ABSTRACT;
+	PROCEDURE (f: File) Flush* (), NEW, ABSTRACT;
+	PROCEDURE (f: File) Register* (name: Name; type: Type; ask: BOOLEAN;
+													OUT res: INTEGER), NEW, ABSTRACT;
+	PROCEDURE (f: File) Close* (), NEW, ABSTRACT;
+	
+	PROCEDURE (r: Reader) Base* (): File, NEW, ABSTRACT;
+	PROCEDURE (r: Reader) Pos* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (r: Reader) SetPos* (pos: INTEGER), NEW, ABSTRACT;
+	PROCEDURE (r: Reader) ReadByte* (OUT x: BYTE), NEW, ABSTRACT;
+	PROCEDURE (r: Reader) ReadBytes* (VAR x: ARRAY OF BYTE; beg, len: INTEGER), NEW, ABSTRACT;
+	
+	PROCEDURE (w: Writer) Base* (): File, NEW, ABSTRACT;
+	PROCEDURE (w: Writer) Pos* (): INTEGER, NEW, ABSTRACT;
+	PROCEDURE (w: Writer) SetPos* (pos: INTEGER), NEW, ABSTRACT;
+	PROCEDURE (w: Writer) WriteByte* (x: BYTE), NEW, ABSTRACT;
+	PROCEDURE (w: Writer) WriteBytes* (IN x: ARRAY OF BYTE; beg, len: INTEGER), NEW, ABSTRACT;
+	
+	PROCEDURE (d: Directory) This* (IN path: ARRAY OF CHAR): Locator, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) New* (loc: Locator; ask: BOOLEAN): File, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) Old* (loc: Locator; name: Name; shared: BOOLEAN): File, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) Temp* (): File, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) Delete* (loc: Locator; name: Name), NEW, ABSTRACT;
+	PROCEDURE (d: Directory) Rename* (loc: Locator; old, new: Name; ask: BOOLEAN), NEW, ABSTRACT;
+	PROCEDURE (d: Directory) SameFile* (loc0: Locator; name0: Name; loc1: Locator;
+																name1: Name): BOOLEAN, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) FileList* (loc: Locator): FileInfo, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) LocList* (loc: Locator): LocInfo, NEW, ABSTRACT;
+	PROCEDURE (d: Directory) GetFileName* (name: Name; type: Type; OUT filename: Name), NEW, ABSTRACT;
+			
+	PROCEDURE SetDir* (d: Directory);
+	BEGIN
+		ASSERT(d # NIL, 20);
+		dir := d;
+		IF stdDir = NIL THEN stdDir := d END
+	END SetDir;
+
+BEGIN
+	objType := Kernel.objType;
+	symType := Kernel.symType;
+	docType := Kernel.docType;
+END Files.

BlackBox/System/Mod/Math.txt

@@ -0,0 +1,532 @@
+MODULE Math; 
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Math.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM;
+
+	VAR eps, e: REAL;
+
+
+	(* code procedures for 80387 math coprocessor *)
+
+	PROCEDURE [code] FLD (x: REAL);
+	PROCEDURE [code] TOP (): REAL;
+	PROCEDURE [code] FSW (): INTEGER 0DFH, 0E0H;
+	PROCEDURE [code] FSWs (): SET 0DFH, 0E0H;
+	PROCEDURE [code] ST0 (): REAL 0D9H, 0C0H;
+	PROCEDURE [code] ST1 (): REAL 0D9H, 0C1H;
+
+	PROCEDURE [code] FXCH 0D9H, 0C9H;
+	PROCEDURE [code] FLDst0 0D9H, 0C0H;	(* doublicate st[0] *)
+	PROCEDURE [code] FSTPst0 0DDH, 0D8H;	(* remove st[0] *)
+	PROCEDURE [code] FSTPst1 0DDH, 0D9H;	(* remove st[1] *)
+	PROCEDURE [code] FSTPDe 0DBH, 05DH, 0F4H;	(* FSTPD -12[FP] *)	(* COMPILER DEPENDENT *)
+	PROCEDURE [code] WAIT 09BH;
+	PROCEDURE [code] FNOP 0D9H, 0D0H;
+
+	PROCEDURE [code] FLD0 0D9H, 0EEH;
+	PROCEDURE [code] FLD1 0D9H, 0E8H;
+	PROCEDURE [code] FLDPI 0D9H, 0EBH;
+	PROCEDURE [code] FLDLN2 0D9H, 0EDH;
+	PROCEDURE [code] FLDLG2 0D9H, 0ECH;
+	PROCEDURE [code] FLDL2E 0D9H, 0EAH;
+
+	PROCEDURE [code] FADD 0DEH, 0C1H;
+	PROCEDURE [code] FADDst0 0D8H, 0C0H;
+	PROCEDURE [code] FSUB 0DEH, 0E9H;
+	PROCEDURE [code] FSUBn 0DCH, 0E9H;	(* no pop *)
+	PROCEDURE [code] FSUBR 0DEH, 0E1H;
+	PROCEDURE [code] FSUBst1 0D8H, 0E1H;
+	PROCEDURE [code] FMUL 0DEH, 0C9H;
+	PROCEDURE [code] FMULst0 0D8H, 0C8H;
+	PROCEDURE [code] FMULst1st0 0DCH, 0C9H;
+	PROCEDURE [code] FDIV 0DEH, 0F9H;
+	PROCEDURE [code] FDIVR 0DEH, 0F1H;
+	PROCEDURE [code] FDIVRst1 0D8H, 0F9H;
+	PROCEDURE [code] FCHS 0D9H, 0E0H;
+
+	PROCEDURE [code] FCOM 0D8H, 0D1H;
+	PROCEDURE [code] FSWax 0DFH, 0E0H;
+	PROCEDURE [code] SAHF 09EH;
+	PROCEDURE [code] JBE4 076H, 004H;
+	PROCEDURE [code] JAE4 073H, 004H;
+
+	PROCEDURE [code] FRNDINT 0D9H, 0FCH;
+	PROCEDURE [code] FSCALE 0D9H, 0FDH;	(* st[0] * 2^FLOOR(st[1]) *)
+	PROCEDURE [code] FXTRACT 0D9H, 0F4H;	(* exp -> st[1]; mant -> st[0] *)
+	PROCEDURE [code] FXAM 0D9H, 0E5H;
+
+	PROCEDURE [code] FSQRT 0D9H, 0FAH;	(* st[0] >= 0 *)
+	PROCEDURE [code] FSIN 0D9H, 0FEH;	(* |st[0]| < 2^63 *)
+	PROCEDURE [code] FCOS 0D9H, 0FFH;	(* |st[0]| < 2^63 *)
+	PROCEDURE [code] FTAN 0D9H, 0F2H;	(* |st[0]| < 2^63 *)
+	PROCEDURE [code] FATAN 0D9H, 0F3H;	(* atan2(st[1], st[0]) *)
+	PROCEDURE [code] FYL2X 0D9H, 0F1H;	(* st[1] * log2(st[0]), st[0] > 0 *)
+	PROCEDURE [code] FYL2XP1 0D9H, 0F9H;	(* st[1] * log2(1 + st[0]), |st[0]| < 1-sqrt(2)/2 *)
+	PROCEDURE [code] F2XM1 0D9H, 0F0H;	(* 2^st[0] - 1, |st[0]| <= 1 *)
+
+
+	PROCEDURE IsNan (x: REAL): BOOLEAN;
+	BEGIN
+		FLD(x); FXAM; FSTPst0; WAIT; RETURN FSWs() * {8, 10} = {8}
+	END IsNan;
+
+
+	(* sin, cos, tan argument reduction *)
+
+	PROCEDURE Reduce;
+	BEGIN
+		FXAM; WAIT;
+		IF ~(8 IN FSWs()) & (ABS(ST0()) > 1.0E18) THEN
+			(* to be completed *)
+			FSTPst0; FLD0
+		END;
+	END Reduce;
+
+
+	(** REAL precision **)
+
+	PROCEDURE Pi* (): REAL;
+	BEGIN
+		FLDPI; RETURN TOP()
+	END Pi;
+
+	PROCEDURE Eps* (): REAL;
+	BEGIN
+		RETURN eps
+	END Eps;
+
+
+	PROCEDURE Sqrt* (x: REAL): REAL;
+	BEGIN
+		(* 20, argument of Sqrt must not be negative *)
+		FLD(x); FSQRT; WAIT; RETURN TOP()
+	END Sqrt;
+
+
+	PROCEDURE Exp* (x: REAL): REAL;
+	BEGIN
+		(* 2 ^ (x * 1/ln(2)) *)
+		FLD(x); FLDL2E; FMUL;
+		IF ABS(ST0()) = INF THEN FLD1
+		ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD
+		END;
+		FSCALE; FSTPst1; RETURN TOP()
+	END Exp;
+
+	PROCEDURE Ln* (x: REAL): REAL;
+	BEGIN
+		(* 20, argument of Ln must not be negative *)
+		(* ln(2) * ld(x) *)
+		FLDLN2; FLD(x); FYL2X; WAIT; RETURN TOP()
+	END Ln;
+
+	PROCEDURE Log* (x: REAL): REAL;
+	BEGIN
+		(* 20, argument of Log must not be negative *)
+		(* log(2) * ld(x) *)
+		FLDLG2; FLD(x); FYL2X; WAIT; RETURN TOP()
+	END Log;
+
+	PROCEDURE Power* (x, y: REAL): REAL;
+	BEGIN
+		ASSERT(x >= 0, 20);
+		ASSERT((x # 0.0)  OR  (y # 0.0), 21);
+		ASSERT((x # INF)  OR  (y # 0.0), 22);
+		ASSERT((x # 1.0)  OR  (ABS(y) # INF), 23);
+		(* 2 ^ (y * ld(x)) *)
+		FLD(y); FLD(x); FYL2X;
+		IF ABS(ST0()) = INF THEN FLD1
+		ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD
+		END;
+		FSCALE; FSTPst1; WAIT; RETURN TOP()
+	END Power;
+
+	PROCEDURE IntPower* (x: REAL; n: INTEGER): REAL;
+	BEGIN 
+		FLD1; FLD(x);
+		IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END;
+		IF n <= 0 THEN FDIVRst1; (* 1 / x *) n := -n END;
+		WHILE n > 0 DO
+			IF ODD(n) THEN FMULst1st0; (* y := y * x *) DEC(n)
+			ELSE FMULst0; (* x := x * x *) n := n DIV 2
+			END
+		END;
+		FSTPst0; RETURN TOP()
+	END IntPower;
+
+
+	PROCEDURE Sin* (x: REAL): REAL;
+	BEGIN
+		(* 20, ABS(x) # INF *)
+		FLD(x); Reduce; FSIN; WAIT; RETURN TOP()
+	END Sin;
+
+	PROCEDURE Cos* (x: REAL): REAL;
+	BEGIN
+		(* 20, ABS(x) # INF *)
+		FLD(x); Reduce; FCOS; WAIT; RETURN TOP()
+	END Cos;
+
+	PROCEDURE Tan* (x: REAL): REAL;
+	BEGIN
+		(* 20, ABS(x) # INF *)
+		FLD(x); Reduce; FTAN; FSTPst0; WAIT; RETURN TOP()
+	END Tan;
+
+	PROCEDURE ArcSin* (x: REAL): REAL;
+	BEGIN
+		(* 20, -1.0 <= x <= 1.0 *)
+		(* atan2(x, sqrt(1 - x*x)) *)
+		FLD(x); FLDst0; FMULst0; FLD1; FSUBR; FSQRT; FNOP; FATAN; WAIT; RETURN TOP()
+	END ArcSin;
+
+	PROCEDURE ArcCos* (x: REAL): REAL;
+	BEGIN
+		(* 20, -1.0 <= x <= 1.0 *)
+		(* atan2(sqrt(1 - x*x), x) *)
+		FLD(x); FMULst0; FLD1; FSUBR; FSQRT; FLD(x); FATAN; WAIT; RETURN TOP()
+	END ArcCos;
+
+	PROCEDURE ArcTan* (x: REAL): REAL;
+	BEGIN
+		(* atan2(x, 1) *)
+		FLD(x); FLD1; FATAN; RETURN TOP()
+	END ArcTan;
+
+	PROCEDURE ArcTan2* (y, x: REAL): REAL;
+	BEGIN
+		ASSERT((y # 0)  OR (x # 0), 20);
+		ASSERT((ABS(y) # INF)  OR  (ABS(x)  # INF), 21);
+		FLD(y); FLD(x); FATAN; WAIT; RETURN TOP()
+	END ArcTan2;
+
+
+	PROCEDURE Sinh* (x: REAL): REAL;
+	BEGIN
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* abs(x) * 1/ln(2) *)
+		FLD(ABS(x)); FLDL2E; FMUL;
+		IF ST0() < 0.5 THEN
+			(* (2^z - 1) + (2^z - 1) / ((2^z - 1) + 1) *)
+			F2XM1; FLDst0; FLDst0; FLD1; FADD; FDIV; FADD
+		ELSIF ST0() # INF THEN
+			(* 2^z - 1 / 2^z *)
+			FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE;
+			FSTPst1; FLDst0; FLD1; FDIVR; FSUB
+		END;
+		IF x < 0 THEN FCHS END;
+		RETURN TOP() * 0.5
+	END Sinh;
+
+	PROCEDURE Cosh* (x: REAL): REAL;
+	BEGIN
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* 2^(abs(x) * 1/ln(2)) *)
+		FLD(ABS(x));
+		IF ST0() # INF THEN 
+			FLDL2E; FMUL; FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE;
+			FSTPst1;
+			(* z + 1/z *)
+			FLDst0; FLD1; FDIVR; FADD
+		END;
+		RETURN TOP() * 0.5
+	END Cosh;
+
+	PROCEDURE Tanh* (x: REAL): REAL;
+	BEGIN
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* abs(x) * 1/ln(2) * 2 *)
+		FLD(ABS(x)); FLDL2E; FMUL; FADDst0;
+		IF ST0() < 0.5 THEN
+			(* (2^z - 1) / (2^z + 1) *)
+			F2XM1; FLDst0; FLD(2); FADD; FDIV
+		ELSIF ST0() < 65 THEN
+			(* 1 - 2 / (2^z + 1) *)
+			FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE;
+			FSTPst1; FLD1; FADD; FLD(2); FDIVR; FLD1; FSUBR
+		ELSE
+			FSTPst0; FLD1
+		END;
+		IF x < 0 THEN FCHS END;
+		RETURN TOP()
+	END Tanh;
+
+	PROCEDURE ArcSinh* (x: REAL): REAL;
+	BEGIN
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* x*x *)
+		FLDLN2; FLD(ABS(x)); FLDst0; FMULst0;
+		IF ST0() < 0.067 THEN
+			(* ln(2) * ld(1 + x*x / (sqrt(x*x + 1) + 1) + x) *)
+			FLDst0; FLD1; FADD; FSQRT; FLD1; FADD; FDIV; FADD; FYL2XP1
+		ELSE
+			(* ln(2) * ld(x + sqrt(x*x + 1)) *)
+			FLD1; FADD; FSQRT; FADD; FYL2X
+		END;
+		IF x < 0 THEN FCHS END;
+		RETURN TOP()
+	END ArcSinh;
+
+	PROCEDURE ArcCosh* (x: REAL): REAL;
+	BEGIN
+		(* 20, x >= 1.0 *)
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* ln(2) * ld(x + sqrt(x*x - 1)) *)
+		FLDLN2; FLD(x); FLDst0; FMULst0; FLD1; FSUB; FSQRT; FADD; FYL2X; WAIT; RETURN TOP()
+	END ArcCosh;
+
+	PROCEDURE ArcTanh* (x: REAL): REAL;
+	BEGIN
+		(* 20, -1.0 <= x <= 1.0 *)
+		(* IF IsNan(x) THEN RETURN x END; *)
+		(* |x| *)
+		FLDLN2; FLD(ABS(x)); 
+		IF ST0() < 0.12 THEN
+			(* ln(2) * ld(1 + 2*x / (1 - x)) *)
+			FLDst0; FLD1; FSUBR; FDIV; FADDst0; FYL2XP1
+		ELSE
+			(* ln(2) * ld((1 + x) / (1 - x)) *)
+			FLDst0; FLD1; FADD; FXCH; FLD1; FSUBR; FDIV; FNOP; FYL2X
+		END;
+		IF x < 0 THEN FCHS END;
+		WAIT;
+		RETURN TOP() * 0.5
+	END ArcTanh;
+
+
+	PROCEDURE Floor* (x: REAL): REAL;
+	BEGIN
+		FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB; RETURN TOP()
+	END Floor;
+
+	PROCEDURE Ceiling* (x: REAL): REAL;
+	BEGIN
+		FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD; RETURN TOP()
+	END Ceiling;
+
+	PROCEDURE Round* (x: REAL): REAL;
+	BEGIN
+		FLD(x); 
+		IF ABS(ST0()) = INF THEN RETURN TOP() END;
+		FLDst0; FRNDINT; FSUBn; FXCH;
+		IF TOP() = 0.5 THEN FLD1; FADD END;
+		RETURN TOP()
+	END Round;
+
+	PROCEDURE Trunc* (x: REAL): REAL;
+	BEGIN 
+		FLD(x); FLDst0; FRNDINT;
+		IF ST1() >= 0 THEN
+			FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB
+		ELSE
+			FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD
+		END;
+		RETURN TOP()
+	END Trunc;
+
+	PROCEDURE Frac* (x: REAL): REAL;
+	BEGIN
+		(* 20, x # INF  &  x # -INF *)
+		FLD(x); FLDst0; FRNDINT;
+		IF ST1() >= 0 THEN
+			FCOM; FSWax; SAHF; JBE4; FLD1; FSUB
+		ELSE
+			FCOM; FSWax; SAHF; JAE4; FLD1; FADD
+		END;
+		FSUB; WAIT; RETURN TOP()
+	END Frac;
+
+
+	PROCEDURE Sign* (x: REAL): REAL;
+	BEGIN
+		FLD(x); FXAM; WAIT;
+		CASE FSW() DIV 256 MOD 8 OF
+		| 0, 2: FSTPst0; RETURN 0.0
+		| 1, 4, 5: FSTPst0; RETURN 1.0
+		| 3, 6, 7: FSTPst0; RETURN -1.0
+		END
+	END Sign;
+
+	PROCEDURE Mantissa* (x: REAL): REAL;
+	BEGIN
+		FLD(x); FXAM; WAIT;
+		CASE FSW() DIV 256 MOD 8 OF
+		| 4, 6: FXTRACT; FSTPst1; RETURN TOP()
+		| 0, 2: FSTPst0; RETURN 0.0	(* zero *)
+		| 5: FSTPst0; RETURN 1.0	(* inf *)
+		| 7: FSTPst0; RETURN -1.0	(* -inf *)
+		| 1: FSTPst0; RETURN 1.5	(* nan *)
+		| 3: FSTPst0; RETURN -1.5	(* -nan *)
+		END
+	END Mantissa;
+
+	PROCEDURE Exponent* (x: REAL): INTEGER;	(* COMPILER DEPENDENT *)
+		VAR e: INTEGER;	(* e is set by FSTPDe! *)
+	BEGIN
+		FLD(x); FXAM; WAIT;
+		CASE FSW() DIV 256 MOD 8 OF
+		| 4, 6: FXTRACT; FSTPst0; FSTPDe; WAIT; RETURN e
+		| 0, 2: FSTPst0; RETURN 0	(* zero *)
+		| 1, 3, 5, 7: FSTPst0; RETURN MAX(INTEGER)	(* inf or nan*)
+		END
+	END Exponent;
+
+	PROCEDURE Real* (m: REAL; e: INTEGER): REAL;
+		VAR s: SET;
+	BEGIN
+		IF (m = 0) THEN RETURN 0.0 END;
+		ASSERT(~IsNan(m) & (1 <= ABS(m)) & (ABS(m) < 2), 20);
+		IF e = MAX(INTEGER) THEN
+			SYSTEM.GET(SYSTEM.ADR(m) + 4, s);
+			SYSTEM.PUT(SYSTEM.ADR(m) + 4, s + {20..30});
+			RETURN m
+		ELSE
+			FLD(e); FLD(m); FSCALE; FSTPst1; RETURN TOP()
+		END
+	END Real;
+
+BEGIN
+	eps := 1.0E+0; e := 2.0E+0;
+	WHILE e > 1.0E+0 DO eps := eps/2.0E+0; e := 1.0E+0 + eps END; eps := 2.0E+0 * eps;
+END Math.
+
+
+
+	PROCEDURE Log* (x: REAL): REAL;
+	BEGIN
+		RETURN Ln(x)/ln10
+	END Log;
+	
+	PROCEDURE Power* (x, y: REAL): REAL;
+	BEGIN
+		RETURN Exp(y * Ln(x))
+	END Power;
+	
+	PROCEDURE IntPower* (x: REAL; n: LONGINT): REAL;
+		VAR y: REAL;
+	BEGIN y := 1.0E+0;
+		IF n < 0 THEN x := 1.0E+0/x; n := -n END;
+		WHILE n > 0 DO
+			IF ODD(n) THEN y := y*x; DEC(n)
+			ELSE x := x * x; n := n DIV 2
+			END
+		END;
+		RETURN y
+	END IntPower;
+
+	PROCEDURE Tan* (x: REAL): REAL;
+	BEGIN
+		RETURN Sin(x)/Cos(x)
+	END Tan;
+	
+	PROCEDURE ArcSin* (x: REAL): REAL;
+	BEGIN
+		RETURN  2.0E+0 * ArcTan(x/(1.0E+0 + Sqrt(1.0E+0 - x*x)))
+	END ArcSin;
+	
+	PROCEDURE ArcCos* (x: REAL): REAL;
+	BEGIN (* pi/2 - arcsin(x) *)
+		RETURN Pi()/2.0E+0 - 2.0E+0 * ArcTan(x/(1.0E+0 + Sqrt(1.0E+0 - x*x)))
+(*
+		IF x = -1 THEN RETURN Pi()
+		ELSE RETURN 2 * ArcTan(Sqrt((1 - x) / (1 + x)))
+		END
+*)	END ArcCos;
+
+	PROCEDURE ArcTan2* (y, x: REAL): REAL;
+	BEGIN
+		IF x = 0.0 THEN
+			RETURN Sign(y) * Pi() / 2.0
+		ELSIF y = 0.0 THEN
+			RETURN (1.0 - Sign(x)) * Pi() / 2.0
+		ELSE
+			RETURN ArcTan(y/x) + (1.0 - Sign(x)) * Sign(y) * Pi() / 2.0
+		END 
+	END ArcTan2;
+
+	PROCEDURE Sinh* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) < -lneps THEN RETURN (Exp(x)-Exp(-x))/2.0E+0
+		ELSE RETURN Sign(x)*Exp(ABS(x))/2.0E+0
+		END
+	END Sinh;
+	
+	PROCEDURE Cosh* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) < -lneps THEN RETURN (Exp(x)+Exp(-x))/2.0E+0
+		ELSE RETURN Exp(ABS(x))/2.0E+0
+		END
+	END Cosh;
+	
+	PROCEDURE Tanh* (x: REAL): REAL;
+		VAR e1, e2: REAL;
+	BEGIN 
+		IF ABS(x) < -lneps THEN
+			e1 := Exp(x); e2 := 1.0E+0/e1;
+			RETURN (e1-e2)/(e1+e2)
+		ELSE
+			RETURN Sign(x)
+		END
+	END Tanh;
+	
+	PROCEDURE ArcSinh* (x: REAL): REAL;
+	BEGIN
+		IF x >= 0.0E+0 THEN RETURN Ln(x + Sqrt(x*x + 1.0E+0))
+		ELSE RETURN  - Ln(-x + Sqrt(x*x + 1.0E+0))
+		END
+	END ArcSinh;
+	
+	PROCEDURE ArcCosh* (x: REAL): REAL;
+	BEGIN
+		RETURN Ln(x + Sqrt(x*x - 1.0E+0))
+	END ArcCosh;
+	
+	PROCEDURE ArcTanh* (x: REAL): REAL;
+	BEGIN
+		RETURN Ln((1.0E+0 + x)/(1.0E+0 - x))/2.0E+0
+		(* Variants:
+			(Ln(1+x)-Ln(1-x))/2.0E+0
+			-Ln((1-x)/Sqrt(1-x*x))
+			arcsinh(x/sqrt(1-x*x))
+		*)
+	END ArcTanh;
+	
+	PROCEDURE Floor* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) >= 1.0E16 THEN RETURN x
+		ELSE RETURN ENTIER(x)
+		END
+	END Floor;
+	
+	PROCEDURE Ceiling* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) >= 1.0E16 THEN RETURN x
+		ELSE RETURN -ENTIER(-x)
+		END
+	END Ceiling;
+	
+	PROCEDURE Round* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) >= 1.0E16 THEN RETURN x
+		ELSE RETURN ENTIER(x + 0.5)
+		END
+	END Round;
+
+	PROCEDURE Trunc* (x: REAL): REAL;
+	BEGIN 
+		IF ABS(x) >= 1.0E16 THEN RETURN x
+		ELSIF x >= 0 THEN RETURN ENTIER(x)
+		ELSE RETURN -ENTIER(-x)
+		END
+	END Trunc;
+
+	PROCEDURE Frac* (x: REAL): REAL;
+	BEGIN
+		IF ABS(x) >= 1.0E16 THEN RETURN 0.0
+		ELSIF x >= 0 THEN RETURN x - ENTIER(x)
+		ELSE RETURN x + ENTIER(-x)
+		END
+	END Frac;
+	

BlackBox/System/Mod/Meta.txt

@@ -0,0 +1,1214 @@
+MODULE Meta;
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc System/Mod/Meta.odc *)
+	(* DO NOT EDIT *)
+
+	IMPORT SYSTEM, Kernel;
+
+	CONST
+		(** result codes for object classes, type classes, visibility classes **)
+		undef* = 0;
+
+		(** object classes **)
+		typObj* = 2; varObj* = 3; procObj* = 4; fieldObj* = 5; modObj* = 6; parObj* = 7;
+
+		(** type classes **)
+		boolTyp* = 1; sCharTyp* = 2; charTyp* = 3;
+		byteTyp* = 4; sIntTyp* = 5; intTyp* = 6;
+		sRealTyp* = 7; realTyp* = 8; setTyp* = 9;
+		longTyp* = 10; anyRecTyp* = 11; anyPtrTyp* = 12;
+		sysPtrTyp = 13; 
+		procTyp* = 16; recTyp* = 17; arrTyp* = 18; ptrTyp* = 19;
+		
+		(** record attributes **)
+		final* = 0; extensible* = 1; limited* = 2; abstract* = 3;
+		
+		(** visibility **)
+		hidden* = 1; readOnly* = 2; private = 3; exported* = 4;
+		value* = 10; in* = 11; out* = 12; var* = 13;
+
+		(* scanner modes *)
+		modScan = 1; globScan = 2; recVarScan = 3; recTypeScan = 4;
+
+	TYPE
+		Name* = ARRAY 256 OF CHAR;
+
+		Value* = ABSTRACT RECORD END;	(* to be extended once with a single field of any type *)
+		
+		ArrayPtr = POINTER TO Array;
+
+		Item* = RECORD (Value)
+			obj-: INTEGER;			(* typObj, varObj, procObj, fieldObj, modObj, parObj *)
+			typ-: INTEGER;			(* typObj, varObj, fieldObj, parObj: type;	else: 0 *)
+			vis-: INTEGER;			(* varObj, procObj, fieldObj, parObj: vis;	else: 0 *)
+			adr-: INTEGER;			(* varObj, procObj: adr;	fieldObj: offs;	parObj: num;	else: 0 *)
+			mod: Kernel.Module;	(* static varObj, procObj, modObj: mod;	else: NIL *)
+			desc: Kernel.Type;		(* typObj, varObj, fieldObj, parObj: struct;	procObj: sig;	else: NIL *)
+			ptr: ArrayPtr;				  (* # NIL => item valid;	dynamic varObj: ptr;	else: dummy *)
+			ext: Kernel.ItemExt		(* all method calls forwarded if # NIL *)
+		END;
+
+		Scanner* = RECORD
+			this-: Item;
+			eos-: BOOLEAN;	(* end of scan *)
+			mode: INTEGER;	(* modScan, globScan, recVarScan, recTypeScan *)
+			base: INTEGER;	(* recVarScan, recTypeScan: base level index *)
+			vis: INTEGER;		(* recVarScan: record vis *)
+			adr: INTEGER;		(* recVarScan: record adr *)
+			idx: INTEGER;		(* globScan, recVarScan, recTypeScan: object index *)
+			desc: Kernel.Type;	(* recVarScan, recTypeScan: record desc *)
+			mod: Kernel.Module;	(* modScan: next mod;	globScan, recVarScan: source mod *)
+			obj: Kernel.Object	(* globScan, recVarScan, recTypeScan: actual object *)
+		END;
+		
+		LookupFilter* = PROCEDURE (IN path: ARRAY OF CHAR; OUT i: Item; OUT done: BOOLEAN);
+	
+		FilterHook = POINTER TO RECORD
+			next: FilterHook;
+			filter: LookupFilter
+		END;
+
+		Array = EXTENSIBLE RECORD
+			w0, w1, w2: INTEGER;	(* gc header *)
+			len: ARRAY 16 OF INTEGER	(* dynamic array length table *)
+		END;
+		
+		SStringPtr = POINTER TO ARRAY [1] OF SHORTCHAR;
+		StringPtr = POINTER TO ARRAY [1] OF CHAR;
+	
+	VAR
+		dummy: ArrayPtr;	(* dummy object for item.ptr *)
+		filterHook: FilterHook;
+
+
+	(* preconditions:
+		ASSERT(i.ptr # NIL, 20);	(* invalid item *)
+		ASSERT(i.typ >= recTyp, 21);	(* wrong type *)
+		ASSERT(i.obj = varObj, 22);	(* wrong object class *)
+		ASSERT((i.mod = NIL) OR (i.mod.refcnt >= 0), 23);	(* unloaded object module *)
+		ASSERT(i.desc.mod.refcnt >= 0, 24);	(* unloaded type module *)
+		ASSERT(d.id DIV 16 MOD 16 = 1, 25);	(* value not extended once *)
+		ASSERT(d.fields.num = 1, 26);	(* not a single value field *)
+		ASSERT(i.vis = exported, 27);	(* write protected destination *)
+		ASSERT(type.desc.base[t.id DIV 16 MOD 16] = t, 28);	(* wrong pointer type *)
+		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);	(* unexported type *)
+		ASSERT(type.desc.id DIV 4 MOD 4 < limited, 30);	(* limited or abstract type *)
+		ASSERT(i.ext = NIL, 31);	(* unsupported extension *)
+	*)
+
+
+	PROCEDURE DescOf (IN x: ANYREC): Kernel.Type;
+	BEGIN
+		RETURN SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(x))
+	END DescOf;
+
+	PROCEDURE TypOf (struct: Kernel.Type): INTEGER;
+	BEGIN
+		IF SYSTEM.VAL(INTEGER, struct) DIV 256 = 0 THEN
+			RETURN SYSTEM.VAL(INTEGER, struct)
+		ELSE
+			RETURN 16 + struct.id MOD 4
+		END
+	END TypOf;
+	
+	PROCEDURE LenOf (IN i: Item): INTEGER;
+	BEGIN
+		IF i.desc.size # 0 THEN RETURN i.desc.size
+		ELSIF i.ptr = dummy THEN RETURN 0
+		ELSE RETURN i.ptr.len[i.desc.id DIV 16 MOD 16 - 1]
+		END
+	END LenOf;
+	
+	PROCEDURE SizeOf (IN i: Item): INTEGER;
+		VAR el: Item;
+	BEGIN
+		CASE i.typ OF
+		| anyRecTyp: RETURN 0
+		| boolTyp, sCharTyp, byteTyp: RETURN 1
+		| charTyp, sIntTyp: RETURN 2
+		| longTyp, realTyp: RETURN 8
+		| recTyp: RETURN i.desc.size
+		| arrTyp:
+			el.desc := i.desc.base[0]; el.typ := TypOf(el.desc); el.ptr := i.ptr; 
+			RETURN LenOf(i) * SizeOf(el)
+		ELSE RETURN 4
+		END
+	END SizeOf;
+	
+	PROCEDURE SignatureOf (IN i: Item): Kernel.Signature;
+	BEGIN
+		IF i.obj = procObj THEN
+			RETURN SYSTEM.VAL(Kernel.Signature, i.desc)
+		ELSE
+			RETURN SYSTEM.VAL(Kernel.Signature, i.desc.base[0])
+		END
+	END SignatureOf;
+	
+	
+	PROCEDURE GetName (IN path: ARRAY OF CHAR; OUT name: ARRAY OF CHAR; VAR i: INTEGER);
+		VAR j: INTEGER; ch: CHAR;
+	BEGIN
+		j := 0; ch := path[i];
+		WHILE (j < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z")
+											OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO
+			name[j] := ch; INC(i); INC(j); ch := path[i]
+		END;
+		IF (ch = 0X) OR (ch = ".") OR (ch = "[") OR (ch = "^") THEN name[j] := 0X
+		ELSE name[0] := 0X
+		END
+	END GetName;
+	
+	PROCEDURE LegalName (IN name: ARRAY OF CHAR): BOOLEAN;
+		VAR i: INTEGER; ch: CHAR;
+	BEGIN
+		i := 0; ch := name[0];
+		WHILE (i < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z")
+											OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO
+			INC(i); ch := name[i]
+		END;
+		RETURN (i > 0) & (ch = 0X)
+	END LegalName;
+	
+
+	(* ---------- Item properties ---------- *)
+	
+	PROCEDURE (VAR i: Item) Valid* (): BOOLEAN, NEW;
+	BEGIN
+		IF i.ext # NIL THEN RETURN i.ext.Valid() END;
+		RETURN (i.ptr # NIL) & ((i.mod = NIL) OR (i.mod.refcnt >= 0)) & ((i.typ < recTyp) OR (i.desc.mod.refcnt >= 0))
+	END Valid;
+
+	PROCEDURE (VAR i: Item) GetTypeName* (OUT mod, type: Name), NEW;
+		VAR n: Kernel.Name;
+	BEGIN
+		ASSERT(i.ext = NIL, 31);
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ >= recTyp, 21);
+		ASSERT(i.desc.mod.refcnt >= 0, 24);
+		mod := i.desc.mod.name$;
+		Kernel.GetTypeName(i.desc, n);
+		type := n$
+	END GetTypeName;
+
+	PROCEDURE (VAR i: Item) BaseTyp* (): INTEGER, NEW;
+	BEGIN
+		IF i.ext # NIL THEN RETURN i.ext.BaseTyp() END;
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21);
+		RETURN TypOf(i.desc.base[0])
+	END BaseTyp;
+
+	PROCEDURE (VAR i: Item) Level* (): INTEGER, NEW;
+	BEGIN
+		ASSERT(i.ext = NIL, 31);
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ IN {recTyp, arrTyp}, 21);
+		RETURN i.desc.id DIV 16 MOD 16
+	END Level;
+
+	PROCEDURE (VAR i: Item) Attribute* (): INTEGER, NEW;
+	BEGIN
+		ASSERT(i.ext = NIL, 31);
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ = recTyp, 21);
+		RETURN i.desc.id DIV 4 MOD 4
+	END Attribute;
+
+	PROCEDURE (VAR i: Item) Size* (): INTEGER, NEW;
+	BEGIN
+		IF i.ext # NIL THEN RETURN i.ext.Size() END;
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ # undef, 21);
+		RETURN SizeOf(i)
+	END Size;
+	
+	PROCEDURE (VAR arr: Item) Len* (): INTEGER, NEW;
+	BEGIN
+		IF arr.ext # NIL THEN RETURN arr.ext.Len() END;
+		ASSERT(arr.ptr # NIL, 20);
+		ASSERT(arr.typ = arrTyp, 21);
+		RETURN LenOf(arr)
+	END Len;
+	
+	(* ---------- Item generation ---------- *)
+
+	PROCEDURE SetUndef (VAR i: Item);
+	BEGIN
+		i.typ := undef; i.obj := undef; i.vis := undef;
+		i.adr := undef; i.mod := NIL; i.desc := NIL; i.ptr := NIL; i.ext := NIL;
+	END SetUndef;
+	
+	PROCEDURE SetItem (VAR i: Item; obj: Kernel.Object; mod: Kernel.Module);
+		VAR t: Kernel.Type;
+	BEGIN
+		i.obj := obj.id MOD 16;
+		i.vis := obj.id DIV 16 MOD 16;
+		IF i.obj = procObj THEN
+			i.typ := undef; i.desc := SYSTEM.VAL(Kernel.Type, obj.struct);
+			i.adr := mod.procBase + obj.offs; i.mod := mod
+		ELSE
+			i.typ := TypOf(obj.struct); i.desc := obj.struct;
+			IF i.obj = varObj THEN i.adr := mod.varBase + obj.offs; i.mod := mod
+			ELSIF i.obj = fieldObj THEN i.adr := obj.offs; i.mod := NIL
+			ELSE i.adr := undef; i.mod := NIL
+			END
+		END;
+		i.ext := NIL
+	END SetItem;
+	
+	PROCEDURE SetMod (VAR i: Item; mod: Kernel.Module);
+	BEGIN
+		i.obj := modObj; i.typ := undef; i.vis := undef;
+		i.adr := undef; i.mod := mod; i.desc := NIL; i.ptr := dummy; i.ext := NIL
+	END SetMod;
+
+
+	PROCEDURE GetItem* (obj: ANYPTR; OUT i: Item);
+	BEGIN
+		ASSERT(obj # NIL, 28);
+		i.obj := varObj; i.typ := recTyp; i.vis := exported;
+		i.adr := SYSTEM.ADR(obj^); i.ptr := SYSTEM.VAL(ArrayPtr, obj);
+		i.mod := NIL; i.desc := Kernel.TypeOf(obj); i.ext := NIL
+	END GetItem;
+
+	PROCEDURE Lookup* (IN name: ARRAY OF CHAR; OUT mod: Item);
+		VAR m: Kernel.Module; done: BOOLEAN; filter: FilterHook;
+	BEGIN
+		done := FALSE; filter := filterHook;
+		WHILE ~done & (filter # NIL) DO filter.filter(name, mod, done); filter := filter.next END;
+		IF ~done & LegalName(name) THEN
+			m := Kernel.ThisMod(name);
+			IF m # NIL THEN SetMod(mod, m)
+			ELSE SetUndef(mod)
+			END
+		ELSE SetUndef(mod)
+		END
+	END Lookup;
+
+	PROCEDURE (VAR in: Item) Lookup* (IN name: ARRAY OF CHAR; VAR i: Item), NEW;
+		VAR obj: Kernel.Object; o, v, lev, j, a: INTEGER; m: Kernel.Module; n: Kernel.Name;
+	BEGIN
+		IF in.ext # NIL THEN in.ext.Lookup(name, i); RETURN END;
+		ASSERT(in.ptr # NIL, 20);
+		IF LegalName(name) THEN
+			IF in.obj = modObj THEN
+				n := SHORT(name$);
+				obj := Kernel.ThisObject(in.mod, n);
+				IF obj # NIL THEN
+					SetItem(i, obj, in.mod); i.ptr := dummy;
+					IF (i.vis = hidden) OR (i.obj < typObj) THEN SetUndef(i) END
+				ELSE SetUndef(i)
+				END	
+			ELSIF in.typ = recTyp THEN
+				ASSERT(in.desc.mod.refcnt >= 0, 24);
+				lev := in.desc.id DIV 16 MOD 16; j := 0;
+				n := SHORT(name$);
+				REPEAT
+					obj := Kernel.ThisField(in.desc.base[j], n); INC(j)
+				UNTIL (obj # NIL) OR (j > lev);
+				IF obj # NIL THEN
+					o := in.obj; a := in.adr; v := in.vis; m := in.mod;
+					SetItem(i, obj, m); i.ptr := in.ptr;
+					IF i.vis # hidden THEN
+						IF o = varObj THEN
+							i.obj := varObj; INC(i.adr, a); i.mod := m;
+							IF v < i.vis THEN i.vis := v END
+						END
+					ELSE SetUndef(i)
+					END
+				ELSE SetUndef(i)
+				END
+			ELSE HALT(21)
+			END
+		ELSE SetUndef(i)
+		END
+	END Lookup;
+	
+	PROCEDURE (VAR i: Item) GetBaseType* (VAR base: Item), NEW;
+		VAR n: INTEGER;
+	BEGIN
+		ASSERT(i.ext = NIL, 31);
+		ASSERT(i.ptr # NIL, 20);
+		ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21); n := 0;
+		IF i.typ = recTyp THEN n := i.desc.id DIV 16 MOD 16 - 1 END;
+		IF n >= 0 THEN
+			base.obj := typObj; base.vis := undef; base.adr := undef;
+			base.mod := NIL; base.ptr := dummy; base.ext := NIL;
+			base.desc := i.desc.base[n];
+			base.typ := TypOf(base.desc)
+		ELSE
+			SetUndef(base)
+		END
+	END GetBaseType;
+
+	PROCEDURE (VAR rec: Item) GetThisBaseType* (level: INTEGER; VAR base: Item), NEW;
+	BEGIN
+		ASSERT(rec.ext = NIL, 31);
+		ASSERT(rec.ptr # NIL, 20);
+		ASSERT(rec.typ = recTyp, 21);
+		ASSERT((level >= 0) & (level < 16), 28);
+		IF level <= rec.desc.id DIV 16 MOD 16 THEN
+			base.obj := typObj; base.vis := undef; base.adr := undef;
+			base.mod := NIL; base.ptr := dummy; base.ext := NIL;
+			base.desc := rec.desc.base[level];
+			base.typ := TypOf(base.desc)
+		ELSE
+			SetUndef(base)
+		END
+	END GetThisBaseType;
+	
+	PROCEDURE (VAR proc: Item) NumParam* (): INTEGER, NEW;
+		VAR sig: Kernel.Signature;
+	BEGIN
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
+		sig := SignatureOf(proc);
+		IF sig # NIL THEN RETURN sig.num ELSE RETURN -1 END
+	END NumParam;
+
+	PROCEDURE (VAR proc: Item) GetParam* (n: INTEGER; VAR par: Item), NEW;
+		VAR sig: Kernel.Signature;
+	BEGIN
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
+		sig := SignatureOf(proc);
+		IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN
+			par.obj := parObj; par.adr := n;
+			par.vis := sig.par[n].id MOD 16; 
+			par.mod := NIL; par.ptr := dummy; par.ext := NIL;
+			par.desc := sig.par[n].struct; par.typ := TypOf(par.desc)
+		ELSE
+			SetUndef(par)
+		END
+	END GetParam;
+
+	PROCEDURE (VAR proc: Item) GetParamName* (n: INTEGER; OUT name: Name), NEW;
+		VAR sig: Kernel.Signature; mod: Kernel.Module; nm: Kernel.Name;
+	BEGIN
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		IF proc.obj = procObj THEN mod := proc.mod
+		ELSE ASSERT(proc.typ = procTyp, 21); mod := proc.desc.mod
+		END;
+		ASSERT(mod.refcnt >= 0, 23);
+		sig := SignatureOf(proc);
+		IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN
+			Kernel.GetObjName(mod, SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(sig.par[n]) - 8), nm);
+			name := nm$
+		ELSE
+			name := ""
+		END
+	END GetParamName;
+
+	PROCEDURE (VAR proc: Item) GetReturnType* (VAR type: Item), NEW;
+		VAR sig: Kernel.Signature;
+	BEGIN
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
+		sig := SignatureOf(proc);
+		IF sig # NIL THEN
+			type.obj := typObj; type.vis := undef; type.adr := undef;
+			type.mod := NIL; type.ptr := dummy; type.ext := NIL;
+			type.desc := sig.retStruct; type.typ := TypOf(type.desc)
+		ELSE
+			SetUndef(type)
+		END
+	END GetReturnType;
+
+	PROCEDURE (VAR rec: Item) Is* (IN type: Value): BOOLEAN, NEW;
+		VAR d: Kernel.Type;
+	BEGIN
+		ASSERT(rec.ext = NIL, 31);
+		ASSERT(rec.ptr # NIL, 20);
+		ASSERT(rec.typ = recTyp, 21);
+		WITH type: Item DO
+			ASSERT(type.ptr # NIL, 20);
+			ASSERT(type.typ = recTyp, 21);
+			d := type.desc
+		ELSE
+			d := DescOf(type);	(* type of value rec *)
+			ASSERT(d.id DIV 16 MOD 16 = 1, 25);	(* level of type = 1*)
+			ASSERT(d.fields.num = 1, 26);	(* one field in type *)
+			d := d.fields.obj[0].struct;	(* type of field *)
+			ASSERT(SYSTEM.VAL(INTEGER, d) DIV 256 # 0, 21);	(* type is structured *)
+			IF d.id MOD 4 = 3 THEN d := d.base[0] END	(* deref ptr *)
+		END;
+		RETURN rec.desc.base[d.id DIV 16 MOD 16] = d	(* rec IS d *)
+	END Is;
+
+	PROCEDURE (VAR ptr: Item) Deref* (VAR ref: Item), NEW;
+	BEGIN
+		IF ptr.ext # NIL THEN ptr.ext.Deref(ref); RETURN END;
+		ASSERT(ptr.ptr # NIL, 20);
+		ASSERT(ptr.typ IN {sysPtrTyp, anyPtrTyp, ptrTyp}, 21);
+		ASSERT(ptr.obj = varObj, 22);
+		ASSERT((ptr.mod = NIL) OR (ptr.mod.refcnt >= 0), 23);
+		SYSTEM.GET(ptr.adr, ref.adr);
+		IF ref.adr # 0 THEN
+			IF ptr.typ # ptrTyp THEN ref.typ := recTyp
+			ELSE ref.desc := ptr.desc.base[0]; ref.typ := TypOf(ref.desc)
+			END;
+			ref.obj := varObj; ref.mod := NIL; ref.vis := exported;	(* !!! *)
+			ref.ptr := SYSTEM.VAL(ArrayPtr, ref.adr);
+			IF ref.typ = recTyp THEN
+				ref.desc := DescOf(ref.ptr^);	(* dynamic type *)
+			ELSIF ref.typ = arrTyp THEN
+				ref.adr := SYSTEM.ADR(ref.ptr.len[ref.desc.id DIV 16 MOD 16]);	(* descriptor offset *)
+			ELSE HALT(100)
+			END
+		ELSE SetUndef(ref)
+		END
+	END Deref;
+	
+	PROCEDURE (VAR arr: Item) Index* (index: INTEGER; VAR elem: Item), NEW;
+	BEGIN
+		IF arr.ext # NIL THEN arr.ext.Index(index, elem); RETURN END;
+		ASSERT(arr.ptr # NIL, 20);
+		ASSERT(arr.typ = arrTyp, 21);
+		ASSERT(arr.obj = varObj, 22);
+		IF (index >= 0) & (index < LenOf(arr)) THEN
+			elem.obj := varObj; elem.vis := arr.vis;
+			elem.mod := arr.mod; elem.ptr := arr.ptr; elem.ext := NIL;
+			elem.desc := arr.desc.base[0]; elem.typ := TypOf(elem.desc);
+			elem.adr := arr.adr + index * SizeOf(elem)
+		ELSE
+			SetUndef(elem)
+		END
+	END Index;
+	
+	PROCEDURE LookupPath* (IN path: ARRAY OF CHAR; OUT i: Item);
+		VAR j, n: INTEGER; name: Name; ch: CHAR; done: BOOLEAN; filter: FilterHook;
+	BEGIN
+		done := FALSE; filter := filterHook;
+		WHILE ~done & (filter # NIL) DO filter.filter(path, i, done); filter := filter.next END;
+		IF ~done THEN
+			j := 0;
+			GetName(path, name, j);
+			Lookup(name, i);
+			IF (i.obj = modObj) & (path[j] = ".") THEN
+				INC(j); GetName(path, name, j);
+				i.Lookup(name, i); ch := path[j]; INC(j);
+				WHILE (i.obj = varObj) & (ch # 0X) DO
+					IF i.typ = ptrTyp THEN i.Deref(i) END;
+					IF ch = "." THEN
+						GetName(path, name, j);
+						IF i.typ = recTyp THEN i.Lookup(name, i) ELSE SetUndef(i) END
+					ELSIF ch = "[" THEN
+						n := 0; ch := path[j]; INC(j);
+						WHILE (ch >= "0") & (ch <= "9") DO n := 10 * n + ORD(ch) - ORD("0"); ch := path[j]; INC(j) END;
+						IF (ch = "]") & (i.typ = arrTyp) THEN i.Index(n, i) ELSE SetUndef(i) END
+					END;
+					ch := path[j]; INC(j)
+				END
+			END
+		END
+	END LookupPath;
+
+	(* ---------- Scanner ---------- *)
+
+	PROCEDURE (VAR s: Scanner) ConnectToMods*, NEW;
+	BEGIN
+		SetUndef(s.this);
+		s.this.ptr := dummy;
+		s.mod := Kernel.modList;
+		s.mode := modScan;
+		s.eos := FALSE
+	END ConnectToMods;
+
+	PROCEDURE (VAR s: Scanner) ConnectTo* (IN obj: Item), NEW;
+	BEGIN
+		ASSERT(obj.ptr # NIL, 20);
+		SetUndef(s.this); s.vis := obj.vis;
+		s.this.ptr := obj.ptr; s.mod := obj.mod; s.idx := 0;
+		IF obj.obj = modObj THEN
+			ASSERT(s.mod.refcnt >= 0, 23);
+			s.mode := globScan
+		ELSIF obj.typ = recTyp THEN
+			ASSERT(obj.desc.mod.refcnt >= 0, 24);
+			s.desc := obj.desc; s.base := 0;
+			IF obj.obj = varObj THEN s.mode := recVarScan; s.adr := obj.adr
+			ELSE s.mode := recTypeScan
+			END
+		ELSE HALT(21)
+		END;
+		s.eos := FALSE
+	END ConnectTo;
+
+	PROCEDURE (VAR s: Scanner) Scan*, NEW;
+		VAR desc: Kernel.Type;
+	BEGIN
+		ASSERT(s.this.ptr # NIL, 20);
+		IF s.mode = modScan THEN
+			IF s.mod # NIL THEN SetMod(s.this, s.mod); s.mod := s.mod.next
+			ELSE SetUndef(s.this); s.eos := TRUE
+			END
+		ELSIF s.mode = globScan THEN
+			ASSERT(s.mod.refcnt >= 0, 23);
+			REPEAT
+				IF s.idx >= s.mod.export.num THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
+				s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(s.mod.export.obj[s.idx]));
+				SetItem(s.this, s.obj, s.mod); INC(s.idx)
+			UNTIL (s.this.obj IN {procObj, varObj, typObj}) & (s.this.vis # hidden)
+		ELSE
+			ASSERT(s.desc.mod.refcnt >= 0, 24);
+			desc := s.desc.base[s.base];
+			REPEAT
+				WHILE s.idx >= desc.fields.num DO
+					IF desc = s.desc THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
+					INC(s.base); desc := s.desc.base[s.base]; s.idx := 0
+				END;
+				s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(desc.fields.obj[s.idx]));
+				SetItem(s.this, s.obj, s.mod); INC(s.idx)
+			UNTIL s.this.vis # hidden;
+			IF s.mode = recVarScan THEN
+				s.this.obj := varObj; INC(s.this.adr, s.adr); s.this.mod := s.mod; 
+				IF s.vis < s.this.vis THEN s.this.vis := s.vis END
+			END
+		END
+	END Scan;
+
+	PROCEDURE (VAR s: Scanner) GetObjName* (OUT name: Name), NEW;
+		VAR mod: Kernel.Module; n: Kernel.Name;
+	BEGIN
+		ASSERT(s.this.ptr # NIL, 20);
+		IF s.mode = modScan THEN
+			name := s.this.mod.name$	(* mf 24.08.2004 *)
+		ELSE
+			IF s.mode = globScan THEN mod := s.mod
+			ELSE mod := s.desc.base[s.base].mod
+			END;
+			ASSERT(mod.refcnt >= 0, 23);
+			Kernel.GetObjName(mod, s.obj, n);
+			name := n$;
+		END
+	END GetObjName;
+	
+	PROCEDURE (VAR s: Scanner) Level* (): INTEGER, NEW;
+	BEGIN
+		ASSERT(s.this.ptr # NIL, 20);
+		ASSERT(s.mode >= recVarScan, 22);
+		RETURN s.base
+	END Level;
+
+	(* ---------- access to item values ---------- *)
+
+	PROCEDURE ValToItem (IN x: Value; VAR i: Item);
+		VAR desc: Kernel.Type;
+	BEGIN
+		desc := DescOf(x);
+		ASSERT(desc.id DIV 16 MOD 16 = 1, 25);	(* level of x = 1*)
+		ASSERT(desc.fields.num = 1, 26);	(* one field in x *)
+		i.desc := desc.fields.obj[0].struct;
+		i.typ := TypOf(i.desc); i.obj := varObj; i.ext := NIL; i.vis := exported;
+		i.ptr := dummy; i.adr := SYSTEM.ADR(x)
+	END ValToItem;
+	
+	PROCEDURE^ EqualSignature (a, b: Kernel.Signature): BOOLEAN;
+	
+	PROCEDURE EqualType (a, b: Kernel.Type): BOOLEAN;
+	BEGIN
+		LOOP
+			IF a = b THEN RETURN TRUE END;
+			IF (SYSTEM.VAL(INTEGER, a) DIV 256 = 0)
+				OR (SYSTEM.VAL(INTEGER, b) DIV 256 = 0)
+				OR (a.id MOD 4 # b.id MOD 4) THEN RETURN FALSE END;
+			CASE a.id MOD 4 OF
+			| recTyp - 16: RETURN FALSE
+			| arrTyp - 16: IF (a.size # 0) OR (b.size # 0) THEN RETURN FALSE END
+			| procTyp - 16: RETURN EqualSignature(SYSTEM.VAL(Kernel.Signature, a.base[0]),
+																	 SYSTEM.VAL(Kernel.Signature, b.base[0]))
+			ELSE (* ptrTyp *)
+			END;
+			a := a.base[0]; b := b.base[0]
+		END
+	END EqualType;
+	
+	PROCEDURE EqualSignature (a, b: Kernel.Signature): BOOLEAN;
+		VAR i: INTEGER;
+	BEGIN
+		IF (a.num # b.num) OR ~EqualType(a.retStruct, b.retStruct) THEN RETURN FALSE END;
+		i := 0;
+		WHILE i < a.num DO
+			IF (a.par[i].id MOD 256 # b.par[i].id MOD 256)
+				OR ~EqualType(a.par[i].struct, b.par[i].struct) THEN RETURN FALSE END;
+			INC(i)
+		END;
+		RETURN TRUE
+	END EqualSignature;
+	
+	PROCEDURE Copy (IN a, b: Item; OUT ok: BOOLEAN);	(* b := a *)
+		VAR n: INTEGER; at, bt: Item;
+	BEGIN
+		ok := FALSE;
+		IF a.obj = procObj THEN
+			IF (b.typ # procTyp)
+				OR ~EqualSignature(SignatureOf(a), SignatureOf(b)) THEN RETURN END;
+			SYSTEM.PUT(b.adr, a.adr); 
+		ELSE	(* a.obj = varObj *)
+			IF a.typ # b.typ THEN RETURN END;
+			IF a.typ >= recTyp THEN
+				IF a.typ = ptrTyp THEN
+					at.desc := a.desc.base[0]; at.typ := TypOf(at.desc); at.ptr := dummy; at.ext := NIL;
+					bt.desc := b.desc.base[0]; bt.typ := TypOf(bt.desc); bt.ptr := dummy; bt.ext := NIL;
+					SYSTEM.GET(a.adr, n);
+					IF (at.typ = recTyp) & (n # 0) THEN
+						SYSTEM.GET(SYSTEM.VAL(INTEGER, n) - 4, at.desc);	(* dynamic type *)
+						at.desc :=  at.desc.base[bt.desc.id DIV 16 MOD 16]	(* projection to b *)
+					END
+				ELSE at := a; bt := b
+				END;
+				WHILE (at.typ = arrTyp) & (bt.typ = arrTyp) DO
+					IF LenOf(at) # LenOf(bt) THEN RETURN END;
+					at.desc := at.desc.base[0]; at.typ := TypOf(at.desc);
+					bt.desc := bt.desc.base[0]; bt.typ := TypOf(bt.desc)
+				END;
+				IF (at.desc # bt.desc) &
+					~((at.typ = procTyp) & (bt.typ = procTyp)
+						& EqualSignature(SignatureOf(at), SignatureOf(bt))) THEN RETURN END
+			END;
+			SYSTEM.MOVE(a.adr, b.adr, SizeOf(b))
+		END;
+		ok := TRUE
+	END Copy;
+	
+	PROCEDURE (VAR proc: Item) Call* (OUT ok: BOOLEAN), NEW;
+		VAR p: Kernel.Command; sig: Kernel.Signature;
+	BEGIN
+		IF proc.ext # NIL THEN proc.ext.Call(ok); RETURN END;
+		ASSERT(proc.ptr # NIL, 20);
+		IF proc.obj = procObj THEN
+			p := SYSTEM.VAL(Kernel.Command, proc.adr)
+		ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
+			SYSTEM.GET(proc.adr, p)
+		END;
+		ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
+		sig := SignatureOf(proc);
+		IF (sig.retStruct = NIL) & (sig.num = 0) & (p # NIL) THEN p(); ok := TRUE
+		ELSE ok := FALSE
+		END
+	END Call;
+	
+	PROCEDURE PutParam (IN par: Item; sig: Kernel.Signature; p: INTEGER;
+										VAR data: ARRAY OF INTEGER; VAR n: INTEGER;
+										OUT ok: BOOLEAN);	(* check & assign a parameter *)
+		VAR mode, fTyp, aTyp, padr, i: INTEGER; fDesc, aDesc: Kernel.Type;
+			l: LONGINT; s: SHORTINT; b: BYTE;
+	BEGIN
+		ok := FALSE;
+		ASSERT(par.ext = NIL, 31);
+		ASSERT(par.ptr # NIL, 20);
+		ASSERT(par.obj = varObj, 22);
+		ASSERT((par.mod = NIL) OR (par.mod.refcnt >= 0), 23);
+		mode := sig.par[p].id MOD 16;
+		IF mode >= out THEN ASSERT(par.vis = exported, 27) END;
+		fDesc := sig.par[p].struct;
+		fTyp := TypOf(fDesc);
+		aDesc := par.desc;
+		aTyp := TypOf(aDesc);
+		padr := par.adr;
+		IF (fTyp = recTyp) OR (fTyp = anyRecTyp) THEN
+			IF (aTyp # recTyp)
+				OR (mode = value) & (aDesc # fDesc)
+				OR (fTyp = recTyp) & (aDesc.base[fDesc.id DIV 16 MOD 16] # fDesc) THEN RETURN END;
+			data[n] := padr; INC(n);
+			data[n] := SYSTEM.VAL(INTEGER, aDesc); INC(n)
+		ELSIF fTyp = arrTyp THEN
+			data[n] := padr; INC(n);
+			IF fDesc.size # 0 THEN data[n] := SizeOf(par); INC(n) END;
+			WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO
+				IF aDesc.size # 0 THEN i := aDesc.size	(* actual static size *)
+				ELSE i := par.ptr.len[aDesc.id DIV 16 MOD 16 - 1]	(* actual dynamic size *)
+				END;
+				IF fDesc.size = 0 THEN data[n] := i; INC(n)
+				ELSIF fDesc.size # i THEN RETURN
+				END;
+				fDesc := fDesc.base[0]; aDesc := aDesc.base[0]
+			END;
+			IF fDesc # aDesc THEN RETURN END
+		ELSIF fTyp >= anyPtrTyp THEN	(* pointer *)
+			IF fTyp = ptrTyp THEN
+				fDesc := fDesc.base[0];	(* formal base type *)
+				IF (mode = value) & (TypOf(fDesc) = recTyp) THEN
+					IF (aTyp # ptrTyp) & (aTyp # anyPtrTyp) THEN RETURN END;
+					SYSTEM.GET(padr, i); SYSTEM.GET(i - 4, aDesc);	(* dynamic record type *)
+					aDesc := aDesc.base[fDesc.id DIV 16 MOD 16]	(* projection *)
+				ELSE
+					IF aTyp # ptrTyp THEN RETURN END;
+					aDesc := aDesc.base[0];	(* actual base type *)
+					WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO
+						IF fDesc.size # aDesc.size THEN RETURN END;
+						fDesc := fDesc.base[0]; aDesc := aDesc.base[0]
+					END
+				END;
+				IF fDesc # aDesc THEN RETURN END
+			ELSIF fTyp = anyPtrTyp THEN
+				IF (aTyp # anyPtrTyp) & ((aTyp # ptrTyp) OR (TypOf(aDesc.base[0]) # recTyp)) THEN RETURN END
+			ELSIF fTyp = procTyp THEN
+				IF (aTyp # procTyp) OR (fDesc.size # aDesc.size) THEN RETURN END	(* same fingerprint *)
+			END;
+			IF mode = value THEN SYSTEM.GET(padr, data[n]); INC(n)
+			ELSE data[n] := padr; INC(n)
+			END
+		ELSE	(* basic type *)
+			IF fTyp # aTyp THEN RETURN END;
+			IF mode = value THEN
+				CASE SizeOf(par) OF
+				| 1: SYSTEM.GET(padr, b); data[n] := b; INC(n)
+				| 2: SYSTEM.GET(padr, s); data[n] := s; INC(n)
+				| 4: SYSTEM.GET(padr, i); data[n] := i; INC(n)
+				| 8: SYSTEM.GET(padr, l); data[n] := SHORT(l); INC(n); data[n] := SHORT(l DIV 100000000L); INC(n)
+				END
+			ELSE	(* var par *)
+				data[n] := padr; INC(n)
+			END
+		END;
+		ok := TRUE
+	END PutParam;
+	
+	PROCEDURE GetResult (ret: LONGINT; VAR dest: Item; sig: Kernel.Signature;
+											OUT ok: BOOLEAN);	(* assign return value *)
+		VAR x: Item; i: INTEGER; s: SHORTINT; b: BYTE;
+	BEGIN
+		ASSERT(dest.ext = NIL, 31);
+		ASSERT(dest.ptr # NIL, 20);
+		ASSERT(dest.obj = varObj, 22);
+		ASSERT((dest.mod = NIL) OR (dest.mod.refcnt >= 0), 23);
+		ASSERT(dest.vis = exported, 27);
+		x.desc := sig.retStruct; x.typ := TypOf(x.desc);
+		x.obj := varObj; x.ptr := dummy;
+		CASE TypOf(sig.retStruct) OF
+		| boolTyp, sCharTyp, byteTyp: b := SHORT(SHORT(SHORT(ret))); x.adr := SYSTEM.ADR(b);
+		| charTyp, sIntTyp: s := SHORT(SHORT(ret)); x.adr := SYSTEM.ADR(s);
+		| longTyp, realTyp: x.adr := SYSTEM.ADR(ret);
+		| intTyp, sRealTyp, setTyp, anyPtrTyp, procTyp, ptrTyp: i := SHORT(ret); x.adr := SYSTEM.ADR(i);
+		END;
+		Copy(x, dest, ok)
+	END GetResult;
+	
+	PROCEDURE (VAR proc: Item) ParamCall* (IN par: ARRAY OF Item; VAR dest: Item;
+																			OUT ok: BOOLEAN), NEW;
+		VAR n, p, adr, padr: INTEGER; ret: LONGINT;
+			data: ARRAY 256 OF INTEGER; sig: Kernel.Signature;
+	BEGIN
+		ok := TRUE;
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		IF proc.obj = procObj THEN adr := proc.adr
+		ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
+			SYSTEM.GET(proc.adr, adr);
+			IF adr = 0 THEN ok := FALSE; RETURN END
+		END;
+		ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
+		sig := SignatureOf(proc);
+		ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32);
+		n := 0; p := 0;
+		WHILE ok & (p < sig.num) DO	(* check & assign parameters *)
+			PutParam(par[p], sig, p, data, n, ok);
+			INC(p)
+		END;
+		IF ok THEN
+			ret := Kernel.Call(adr, sig, data, n);
+			IF sig.retStruct # NIL THEN GetResult(ret, dest, sig, ok) END
+		END
+	END ParamCall;
+
+	PROCEDURE (VAR proc: Item) ParamCallVal* (IN par: ARRAY OF POINTER TO Value; VAR dest: Value;
+																			OUT ok: BOOLEAN), NEW;
+		TYPE IP = POINTER TO Item;
+		VAR n, p, adr, padr: INTEGER; ret: LONGINT; x: Item;
+			data: ARRAY 256 OF INTEGER; sig: Kernel.Signature;
+	BEGIN
+		ok := TRUE;
+		ASSERT(proc.ext = NIL, 31);
+		ASSERT(proc.ptr # NIL, 20);
+		IF proc.obj = procObj THEN adr := proc.adr
+		ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
+			SYSTEM.GET(proc.adr, adr);
+			IF adr = 0 THEN ok := FALSE; RETURN END
+		END;
+		ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
+		sig := SignatureOf(proc);
+		ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32);
+		n := 0; p := 0;
+		WHILE ok & (p < sig.num) DO	(* check & assign parameters *)
+			IF par[p] IS IP THEN
+				PutParam(par[p](IP)^, sig, p, data, n, ok)
+			ELSE
+				ValToItem(par[p]^, x);
+				PutParam(x, sig, p, data, n, ok)
+			END;
+			INC(p)
+		END;
+		IF ok THEN
+			ret := Kernel.Call(adr, sig, data, n);
+			IF sig.retStruct # NIL THEN
+				WITH dest: Item DO
+					GetResult(ret, dest, sig, ok)
+				ELSE
+					ValToItem(dest, x);
+					GetResult(ret, x, sig, ok)
+				END
+			END
+		END
+	END ParamCallVal;
+
+	PROCEDURE (VAR var: Item) GetVal* (VAR x: Value; OUT ok: BOOLEAN), NEW;
+		VAR xi: Item;
+	BEGIN
+		ASSERT(var.ext = NIL, 31);
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj IN {varObj, procObj}, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		WITH x: Item DO
+			ASSERT(x.ptr # NIL, 20);
+			ASSERT(x.obj = varObj, 22);
+			ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
+			ASSERT(x.vis = exported, 27);
+			Copy(var, x, ok)
+		ELSE
+			ValToItem(x, xi); Copy(var, xi, ok)
+		END
+	END GetVal;
+
+	PROCEDURE (VAR var: Item) PutVal* (IN x: Value; OUT ok: BOOLEAN), NEW;
+		VAR xi: Item;
+	BEGIN
+		ASSERT(var.ext = NIL, 31);
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		WITH x: Item DO
+			ASSERT(x.ptr # NIL, 20);
+			ASSERT(x.obj IN {varObj, procObj}, 22);
+			ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
+			Copy(x, var, ok)
+		ELSE
+			ValToItem(x, xi); Copy(xi, var, ok)
+		END
+	END PutVal;
+
+	PROCEDURE (VAR var: Item) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
+		VAR i, n: INTEGER; p: StringPtr;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.GetStringVal(x, ok); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		p := SYSTEM.VAL(StringPtr, var.adr); i := 0; n := LenOf(var);
+		WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
+		IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
+		ELSE x := ""; ok := FALSE
+		END
+	END GetStringVal;
+
+	PROCEDURE (VAR var: Item) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
+		VAR i, n: INTEGER; p: SStringPtr;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.GetSStringVal(x, ok); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		p := SYSTEM.VAL(SStringPtr, var.adr); i := 0; n := LenOf(var);
+		WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
+		IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
+		ELSE x := ""; ok := FALSE
+		END
+	END GetSStringVal;
+
+	PROCEDURE (VAR var: Item) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
+		VAR i: INTEGER; p: StringPtr;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutStringVal(x, ok); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		p := SYSTEM.VAL(StringPtr, var.adr); i := 0;
+		WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
+		IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
+		ELSE ok := FALSE
+		END
+	END PutStringVal;
+
+	PROCEDURE (VAR var: Item) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
+		VAR i: INTEGER; p: SStringPtr;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutSStringVal(x, ok); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		p := SYSTEM.VAL(SStringPtr, var.adr); i := 0;
+		WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
+		IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
+		ELSE ok := FALSE
+		END
+	END PutSStringVal;
+
+	PROCEDURE  (VAR var: Item) PtrVal* (): ANYPTR, NEW;
+		VAR p: ANYPTR;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.PtrVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		SYSTEM.GET(var.adr, p);
+		RETURN p
+	END PtrVal;
+
+	PROCEDURE (VAR var: Item) PutPtrVal* (x: ANYPTR), NEW;
+		VAR vt, xt: Kernel.Type;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutPtrVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		IF (x # NIL) & (var.typ = ptrTyp) THEN
+			vt := var.desc.base[0]; xt := Kernel.TypeOf(x);
+			ASSERT(xt.base[vt.id DIV 16 MOD 16] = vt, 28);	(* xt IS vt *)
+		END;
+		SYSTEM.PUT(var.adr, x)
+	END PutPtrVal;
+
+	PROCEDURE (VAR var: Item) IntVal* (): INTEGER, NEW;
+		VAR sc: SHORTCHAR; ch: CHAR; s: BYTE; i: SHORTINT; x: INTEGER;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.IntVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, sc); x := ORD(sc)
+		ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, ch); x := ORD(ch)
+		ELSIF var.typ = byteTyp THEN SYSTEM.GET(var.adr, s); x := s
+		ELSIF var.typ = sIntTyp THEN SYSTEM.GET(var.adr, i); x := i
+		ELSIF var.typ = intTyp THEN SYSTEM.GET(var.adr, x)
+		ELSE HALT(21)
+		END;
+		RETURN x
+	END IntVal;
+
+	PROCEDURE (VAR var: Item) PutIntVal* (x: INTEGER), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutIntVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(CHR(x)))
+		ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, CHR(x))
+		ELSIF var.typ = byteTyp THEN SYSTEM.PUT(var.adr, SHORT(SHORT(x)))
+		ELSIF var.typ = sIntTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
+		ELSIF var.typ = intTyp THEN SYSTEM.PUT(var.adr, x)
+		ELSE HALT(21)
+		END
+	END PutIntVal;
+
+	PROCEDURE (VAR var: Item) RealVal* (): REAL, NEW;
+		VAR r: SHORTREAL; x: REAL;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.RealVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		IF var.typ = sRealTyp THEN SYSTEM.GET(var.adr, r); x := r
+		ELSIF var.typ = realTyp THEN SYSTEM.GET(var.adr, x)
+		ELSE HALT(21)
+		END;
+		RETURN x
+	END RealVal;
+
+	PROCEDURE (VAR var: Item) PutRealVal* (x: REAL), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutRealVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		IF var.typ = sRealTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
+		ELSIF var.typ = realTyp THEN SYSTEM.PUT(var.adr, x)
+		ELSE HALT(21)
+		END
+	END PutRealVal;
+
+	PROCEDURE (VAR var: Item) LongVal* (): LONGINT, NEW;
+		VAR x: LONGINT;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.LongVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = longTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		SYSTEM.GET(var.adr, x);
+		RETURN x
+	END LongVal;
+
+	PROCEDURE (VAR var: Item) PutLongVal* (x: LONGINT), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutLongVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = longTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		SYSTEM.PUT(var.adr, x)
+	END PutLongVal;
+
+	PROCEDURE (VAR var: Item) CharVal* (): CHAR, NEW;
+		VAR x: CHAR; s: SHORTCHAR;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.CharVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, s); x := s
+		ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, x)
+		ELSE HALT(21)
+		END;
+		RETURN x
+	END CharVal;
+
+	PROCEDURE (VAR var: Item) PutCharVal* (x: CHAR), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutCharVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
+		ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, x)
+		ELSE HALT(21)
+		END
+	END PutCharVal;
+
+	PROCEDURE (VAR var: Item) BoolVal* (): BOOLEAN, NEW;
+		VAR x: BOOLEAN;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.BoolVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = boolTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		SYSTEM.GET(var.adr, x);
+		RETURN x
+	END BoolVal;
+
+	PROCEDURE (VAR var: Item) PutBoolVal* (x: BOOLEAN), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutBoolVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = boolTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		SYSTEM.PUT(var.adr, x)
+	END PutBoolVal;
+
+	PROCEDURE (VAR var: Item) SetVal* (): SET, NEW;
+		VAR x: SET;
+	BEGIN
+		IF var.ext # NIL THEN RETURN var.ext.SetVal() END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = setTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		SYSTEM.GET(var.adr, x);
+		RETURN x
+	END SetVal;
+
+	PROCEDURE (VAR var: Item) PutSetVal* (x: SET), NEW;
+	BEGIN
+		IF var.ext # NIL THEN var.ext.PutSetVal(x); RETURN END;
+		ASSERT(var.ptr # NIL, 20);
+		ASSERT(var.typ = setTyp, 21);
+		ASSERT(var.obj = varObj, 22);
+		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
+		ASSERT(var.vis = exported, 27);
+		SYSTEM.PUT(var.adr, x)
+	END PutSetVal;
+
+	PROCEDURE (VAR  type: Item) New* (): ANYPTR, NEW;
+		VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory; desc: Kernel.Type;
+	BEGIN
+		ASSERT(type.ext = NIL, 31);
+		ASSERT(type.ptr # NIL, 20);
+		desc := type.desc;
+		IF type.typ = ptrTyp THEN desc := desc.base[0] END;
+		ASSERT(TypOf(desc) = recTyp, 21);
+		ASSERT(desc.mod.refcnt >= 0, 24);
+		i := 0; d := type.desc.mod.export; n := d.num; id := type.desc.id DIV 256;
+		WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
+		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
+		ASSERT(desc.id DIV 4 MOD 4 < limited, 30);
+		Kernel.NewObj(p, desc);
+		RETURN p
+	END New;
+
+	PROCEDURE (VAR  val: Item) Copy* (): ANYPTR, NEW;
+		VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory;
+	BEGIN
+		ASSERT(val.ext = NIL, 31);
+		ASSERT(val.ptr # NIL, 20);
+		ASSERT(val.typ = recTyp, 21);
+		ASSERT(val.obj = varObj, 22);
+		ASSERT(val.desc.mod.refcnt >= 0, 24);
+		i := 0; d := val.desc.mod.export; n := d.num; id := val.desc.id DIV 256;
+		WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
+		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
+		ASSERT(val.desc.id DIV 4 MOD 4 < limited, 30);
+		Kernel.NewObj(p, val.desc);
+		SYSTEM.MOVE(val.adr, p, val.desc.size);
+		RETURN p
+	END Copy;
+
+	PROCEDURE (VAR rec: Item) CallWith* (proc: PROCEDURE(VAR rec, par: ANYREC); VAR par: ANYREC), NEW;
+	BEGIN
+		ASSERT(rec.ext = NIL, 31);
+		ASSERT(rec.ptr # NIL, 20);
+		ASSERT(rec.typ = recTyp, 21);
+		ASSERT(rec.obj = varObj, 22);
+		ASSERT((rec.mod = NIL) OR (rec.mod.refcnt >= 0), 23);
+		proc(SYSTEM.THISRECORD(rec.adr, SYSTEM.VAL(INTEGER, rec.desc)), par)
+	END CallWith;
+
+
+	PROCEDURE InstallFilter* (filter: LookupFilter);
+		VAR h: FilterHook;
+	BEGIN
+		ASSERT(filter # NIL, 20);
+		NEW(h); h.filter := filter; h.next := filterHook; filterHook := h
+	END InstallFilter;
+
+	PROCEDURE UninstallFilter* (filter: LookupFilter);
+		VAR h, a: FilterHook;
+	BEGIN
+		ASSERT(filter # NIL, 20);
+		h := filterHook; a := NIL;
+		WHILE (h # NIL) & (h.filter # filter) DO a := h; h := h.next END;
+		IF h # NIL THEN
+			IF a = NIL THEN filterHook := h.next ELSE a.next := h.next END
+		END
+	END UninstallFilter;
+
+	PROCEDURE GetThisItem* (IN attr: ANYREC; OUT i: Item);
+	BEGIN
+		WITH attr: Kernel.ItemAttr DO
+			i.obj := attr.obj; i.vis := attr.vis; i.typ := attr.typ; i.adr := attr.adr;
+			i.mod := attr.mod; i.desc := attr.desc; i.ptr := attr.ptr; i.ext := attr.ext;
+			IF i.ptr = NIL THEN i.ptr := dummy END
+		END
+	END GetThisItem;
+
+BEGIN
+	NEW(dummy)
+END Meta.

BlackBox/System/Mod/Strings.txt

@@ -0,0 +1,565 @@
+MODULE Strings;
+
+	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Strings.txt *)
+	(* DO NOT EDIT *)
+
+	IMPORT Math;
+
+	CONST
+		charCode* = -1; decimal* = 10; hexadecimal* = -2; roman*= -3;
+		digitspace* = 08FX;
+		showBase* = TRUE; hideBase* = FALSE;
+		minLongIntRev = "8085774586302733229";	(* reversed string of -MIN(LONGINT) *)
+
+	VAR
+		maxExp: INTEGER;
+		maxDig: INTEGER;
+		factor: REAL;	(* 10^maxDig *)
+		digits: ARRAY 17 OF CHAR;
+		toUpper, toLower: ARRAY 256 OF CHAR;
+
+
+	(* integer conversions *)
+
+	PROCEDURE IntToString* (x: LONGINT; OUT s: ARRAY OF CHAR);
+		VAR j, k: INTEGER; ch: CHAR; a: ARRAY 32 OF CHAR;
+	BEGIN
+		IF x # MIN(LONGINT) THEN
+			IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
+			j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
+		ELSE
+			a := minLongIntRev; s[0] := "-"; k := 1;
+			j := 0; WHILE a[j] # 0X DO INC(j) END
+		END;
+		ASSERT(k + j < LEN(s), 23);
+		REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
+		s[k] := 0X
+	END IntToString;
+
+	PROCEDURE IntToStringForm* (x: LONGINT; form, minWidth: INTEGER; fillCh: CHAR;
+														showBase: BOOLEAN; OUT s: ARRAY OF CHAR);
+		VAR base, i, j, k, si: INTEGER; mSign: BOOLEAN; a: ARRAY 128 OF CHAR; c1, c5, c10: CHAR;
+	BEGIN
+		ASSERT((form = charCode) OR (form = hexadecimal) OR (form = roman) OR ((form >= 2) & (form <= 16)), 20);
+		ASSERT(minWidth >= 0, 22);
+		IF form = charCode THEN base := 16
+		ELSIF form = hexadecimal THEN base := 16
+		ELSE base := form
+		END;
+		
+		IF form = roman THEN
+			ASSERT((x > 0) & (x < 3999), 21); 
+			base := 1000; i := 0; mSign := FALSE;
+			WHILE (base > 0) & (x > 0) DO
+				IF base = 1 THEN c1 := "I"; c5 := "V"; c10 := "X"
+				ELSIF base = 10 THEN c1 := "X"; c5 := "L"; c10 := "C"
+				ELSIF base = 100 THEN c1 := "C"; c5 := "D"; c10 := "M"
+				ELSE c1 := "M"
+				END;
+				k := SHORT(x DIV base); x := x MOD base;
+				IF k IN {4, 9} THEN a[i] := c1; INC(i) END;
+				IF k IN {4 .. 8} THEN a[i] := c5; INC(i) END;
+				IF k = 9 THEN a[i] := c10; INC(i)
+				ELSIF k IN {1 .. 3, 6 .. 8} THEN
+					j := k MOD 5;
+					REPEAT a[i] := c1; INC(i); DEC(j) UNTIL j = 0
+				END;
+				base := base DIV 10
+			END
+		ELSIF (form = hexadecimal) OR (form = charCode) THEN
+			i := 0; mSign := FALSE;
+			IF showBase THEN DEC(minWidth) END;
+			REPEAT
+				a[i] := digits[x MOD base]; x := x DIV base; INC(i)
+			UNTIL (x = 0) OR (x = -1) OR (i = LEN(a));
+			IF x = -1 THEN fillCh := "F" END
+		ELSE
+			IF x < 0 THEN
+				i := 0; mSign := TRUE; DEC(minWidth);
+				REPEAT
+					IF x MOD base = 0 THEN
+						a[i] := digits[0]; x := x DIV base
+					ELSE
+						a[i] := digits[base - x MOD base]; x := x DIV base + 1
+					END;
+					INC(i)
+				UNTIL (x = 0) OR (i = LEN(a))
+			ELSE
+				i := 0; mSign := FALSE;
+				REPEAT
+					a[i] := digits[x MOD base]; x := x DIV base; INC(i)
+				UNTIL (x = 0) OR (i = LEN(a))
+			END;
+			IF showBase THEN DEC(minWidth);
+				IF base < 10 THEN DEC(minWidth) ELSE DEC(minWidth,2) END
+			END
+		END;
+		si := 0;
+		IF mSign & (fillCh = "0") & (si < LEN(s)) THEN s[si] := "-"; INC(si); mSign := FALSE END;
+		WHILE minWidth > i DO
+			IF si < LEN(s) THEN s[si] := fillCh; INC(si) END;
+			DEC(minWidth)
+		END;
+		IF mSign & (si < LEN(s)) THEN s[si] := "-"; INC(si) END;
+		IF form = roman THEN
+			j := 0;
+			WHILE j < i DO 
+				IF si < LEN(s) THEN s[si] := a[j]; INC(si) END; 
+				INC(j)
+			END
+		ELSE
+			REPEAT DEC(i);
+				IF si < LEN(s) THEN s[si] := a[i]; INC(si) END
+			UNTIL i = 0
+		END;
+		IF showBase & (form # roman) THEN
+			IF (form = charCode) & (si < LEN(s)) THEN s[si] := "X"; INC(si)
+			ELSIF (form = hexadecimal) & (si < LEN(s)) THEN s[si] := "H"; INC(si)
+			ELSIF (form < 10) & (si < LEN(s)-1) THEN s[si] := "%"; s[si+1] := digits[base]; INC(si, 2)
+			ELSIF (si < LEN(s) - 2) THEN
+				s[si] := "%"; s[si+1] := digits[base DIV 10]; s[si+2] := digits[base MOD 10]; INC(si, 3)
+			END
+		END;
+		IF si < LEN(s) THEN s[si] := 0X ELSE HALT(23) END
+	END IntToStringForm;
+
+	PROCEDURE StringToInt* (IN s: ARRAY OF CHAR; OUT x: INTEGER; OUT res: INTEGER);
+		CONST hexLimit = MAX(INTEGER) DIV 8 + 1;
+		VAR i, j, k, digits: INTEGER; ch, top: CHAR; neg: BOOLEAN; base: INTEGER;
+	BEGIN
+		res := 0; i := 0; ch := s[0];
+		WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO	(* ignore leading blanks *)
+			INC(i); ch := s[i]
+		END;
+		j := i; top := "0";
+		WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO 
+			IF ch > top THEN top := ch END;
+			INC(j); ch := s[j]
+		END;
+		IF (ch = "H") OR (ch = "X") THEN
+			x := 0; ch := s[i];
+			IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
+				WHILE ch = "0" DO INC(i); ch := s[i] END;
+				digits := 0;
+				WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO
+					IF ch < "A" THEN k := ORD(ch) - ORD("0")
+					ELSE k := ORD(ch) - ORD("A") + 10
+					END;
+					IF digits < 8 THEN
+						x := x MOD hexLimit;
+						IF x >= hexLimit DIV 2 THEN x := x - hexLimit END;
+						x := x * 16 + k; INC(i); ch := s[i]
+					ELSE res := 1
+					END;
+					INC(digits)
+				END;
+				IF res = 0 THEN
+					IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END
+				END
+			ELSE res := 2
+			END
+		ELSE
+			IF ch = "%" THEN
+				INC(j); ch := s[j]; base := 0;
+				IF ("0" <= ch) & (ch <= "9") THEN
+					k := ORD(ch) - ORD("0");
+					REPEAT
+						base := base * 10 + k;
+						INC(j); ch := s[j]; k := ORD(ch) - ORD("0")
+					UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(INTEGER) - k) DIV 10);
+					IF ("0" <= ch) & (ch <= "9") THEN base := 0 END
+				END
+			ELSE
+				base := 10
+			END;
+			
+			IF (base < 2) OR (base > 16) THEN
+				res := 2
+			ELSIF (base <= 10) & (ORD(top) < base + ORD("0"))
+			OR (base > 10) & (ORD(top) < base - 10 + ORD("A")) THEN
+				x := 0; ch := s[i]; neg := FALSE;
+				IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END;
+				WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; 
+				IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
+					IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END;
+					WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO
+						IF x >= (MIN(INTEGER) + (base - 1) + k) DIV base THEN
+							x := x * base - k; INC(i); ch := s[i];
+							IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END
+						ELSE res := 1
+						END
+					END
+				ELSE res := 2
+				END;
+				IF res = 0 THEN
+					IF ~neg THEN
+						IF x > MIN(INTEGER) THEN x := -x ELSE res := 1 END
+					END;
+					IF (ch # 0X) & (ch # "%") THEN res := 2 END
+				END
+			ELSE
+				res := 2
+			END
+		END
+	END StringToInt;
+
+	PROCEDURE StringToLInt* (IN s: ARRAY OF CHAR; OUT x: LONGINT; OUT res: INTEGER);
+		CONST hexLimit = MAX(LONGINT) DIV 8 + 1;
+		VAR i, j, k, digits: INTEGER; ch, top: CHAR; neg: BOOLEAN; base: INTEGER;
+	BEGIN
+		res := 0; i := 0; ch := s[0];
+		WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO	(* ignore leading blanks *)
+			INC(i); ch := s[i]
+		END;
+		j := i; top := "0";
+		WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO 
+			IF ch > top THEN top := ch END;
+			INC(j); ch := s[j]
+		END;
+		IF (ch = "H") OR (ch = "X") THEN
+			x := 0; ch := s[i];
+			IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
+				WHILE ch = "0" DO INC(i); ch := s[i] END;
+				digits := 0;
+				WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO
+					IF ch < "A" THEN k := ORD(ch) - ORD("0")
+					ELSE k := ORD(ch) - ORD("A") + 10
+					END;
+					IF digits < 16 THEN
+						x := x MOD hexLimit;
+						IF x >= hexLimit DIV 2 THEN x := x - hexLimit END;
+						x := x * 16 + k; INC(i); ch := s[i]
+					ELSE res := 1
+					END;
+					INC(digits)
+				END;
+				IF res = 0 THEN
+					IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END
+				END
+			ELSE res := 2
+			END
+		ELSE
+			IF ch = "%" THEN
+				INC(j); ch := s[j]; base := 0;
+				IF ("0" <= ch) & (ch <= "9") THEN
+					k := ORD(ch) - ORD("0");
+					REPEAT
+						base := base * 10 + k;
+						INC(j); ch := s[j]; k := ORD(ch) - ORD("0")
+					UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(INTEGER) - k) DIV 10);
+					IF ("0" <= ch) & (ch <= "9") THEN base := 0 END
+				END
+			ELSE
+				base := 10
+			END;
+			
+			IF (base < 2) OR (base > 16) THEN
+				res := 2
+			ELSIF (base <= 10) & (ORD(top) < base + ORD("0"))
+			OR (base > 10) & (ORD(top) < base -10 + ORD("A")) THEN
+				x := 0; ch := s[i]; neg := FALSE;
+				IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END;
+				WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; 
+				IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
+					IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END;
+					WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO
+						IF x >= (MIN(LONGINT) + (base - 1) + k) DIV base THEN
+							x := x * base - k; INC(i); ch := s[i];
+							IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END
+						ELSE res := 1
+						END
+					END
+				ELSE res := 2
+				END;
+				IF res = 0 THEN
+					IF ~neg THEN
+						IF x > MIN(LONGINT) THEN x := -x ELSE res := 1 END
+					END;
+					IF (ch # 0X) & (ch # "%") THEN res := 2 END
+				END
+			ELSE
+				res := 2
+			END
+		END
+	END StringToLInt;
+
+
+	(* real conversions *)
+
+	PROCEDURE RealToStringForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR;
+														OUT s: ARRAY OF CHAR);
+		VAR exp, len, i, j, n, k, p: INTEGER; m: ARRAY 80 OF CHAR; neg: BOOLEAN;
+	BEGIN
+		ASSERT((precision > 0) (*& (precision <= 18)*), 20);
+		ASSERT((minW >= 0) & (minW < LEN(s)), 21);
+		ASSERT((expW > -LEN(s)) & (expW <= 3), 22);
+		exp := Math.Exponent(x);
+		IF exp = MAX(INTEGER) THEN
+			IF fillCh = "0" THEN fillCh := digitspace END;
+			x := Math.Mantissa(x);
+			IF x = -1 THEN m := "-inf"; n := 4
+			ELSIF x = 1 THEN m := "inf"; n := 3
+			ELSE m := "nan"; n := 3
+			END;
+			i := 0; j := 0;
+			WHILE minW > n DO s[i] := fillCh; INC(i); DEC(minW) END;
+			WHILE (j <= n) & (i < LEN(s)) DO s[i] := m[j]; INC(i); INC(j) END
+		ELSE
+			neg := FALSE; len := 1; m := "00";
+			IF x < 0 THEN x := -x; neg := TRUE; DEC(minW) END;
+			IF x # 0 THEN
+				exp := (exp - 8) * 30103 DIV 100000;	(* * log(2) *)
+				IF exp > 0 THEN
+					n := SHORT(ENTIER(x / Math.IntPower(10, exp)));
+					x := x / Math.IntPower(10, exp) - n
+				ELSIF exp > -maxExp THEN
+					n := SHORT(ENTIER(x * Math.IntPower(10, -exp)));
+					x := x * Math.IntPower(10, -exp) - n
+				ELSE
+					n := SHORT(ENTIER(x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor));
+					x := x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor - n
+				END;
+				(* x0 = (n + x) * 10^exp, 200 < n < 5000 *)
+				p := precision - 4;
+				IF n < 1000 THEN INC(p) END;
+				IF (expW < 0) & (p > exp - expW) THEN p := exp - expW END;
+				IF p >= 0 THEN
+					x := x + 0.5 / Math.IntPower(10, p);	(* rounding correction *)
+					IF x >= 1 THEN INC(n); x := x - 1 END
+				ELSIF p = -1 THEN INC(n, 5)
+				ELSIF p = -2 THEN INC(n, 50)
+				ELSIF p = -3 THEN INC(n, 500)
+				END;
+				i := 0; k := 1000; INC(exp, 3);
+				IF n < 1000 THEN k := 100; DEC(exp) END;
+				WHILE (i < precision) & ((k > 0) OR (x # 0)) DO
+					IF k > 0 THEN p := n DIV k; n := n MOD k; k := k DIV 10
+					ELSE x := x * 10; p := SHORT(ENTIER(x)); x := x - p
+					END;
+					m[i] := CHR(p + ORD("0")); INC(i);
+					IF p # 0 THEN len := i END
+				END
+			END;
+			(* x0 = m[0].m[1]...m[len-1] * 10^exp *)
+			i := 0;
+			IF (expW < 0) OR (expW = 0) & (exp >= -3) & (exp <= len + 1) THEN
+				n := exp + 1; k := len - n;
+				IF n < 1 THEN n := 1 END;
+				IF expW < 0 THEN k := -expW ELSIF k < 1 THEN k := 1 END;
+				j := minW - n - k - 1; p := -exp;
+				IF neg & (p >= MAX(0, n) + MAX(0, k)) THEN neg := FALSE; INC(j) END
+			ELSE
+				IF ABS(exp) >= 100 THEN expW := 3
+				ELSIF (expW < 2) & (ABS(exp) >= 10) THEN expW := 2
+				ELSIF expW < 1 THEN expW := 1
+				END;
+				IF len < 2 THEN len := 2 END;
+				j := minW - len - 3 - expW; k := len;
+				IF j > 0 THEN
+					k := k + j; j := 0;
+					IF k > precision THEN j := k - precision; k := precision END
+				END;
+				n := 1; DEC(k); p := 0
+			END;
+			IF neg & (fillCh = "0") THEN s[i] := "-"; INC(i); neg := FALSE END;
+			WHILE j > 0 DO s[i] := fillCh; INC(i); DEC(j) END;
+			IF neg & (i < LEN(s)) THEN s[i] := "-"; INC(i) END;
+			j := 0;
+			WHILE (n > 0) & (i < LEN(s)) DO
+				IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END;
+				INC(i); DEC(n); DEC(p)
+			END;
+			IF i < LEN(s) THEN s[i] := "."; INC(i) END;
+			WHILE (k > 0) & (i < LEN(s)) DO
+				IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END;
+				INC(i); DEC(k); DEC(p)
+			END;
+			IF expW > 0 THEN
+				IF i < LEN(s) THEN s[i] := "E"; INC(i) END;
+				IF i < LEN(s) THEN
+					IF exp < 0 THEN s[i] := "-"; exp := -exp ELSE s[i] := "+" END;
+					INC(i)
+				END;
+				IF (expW = 3) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 100 + ORD("0")); INC(i) END;
+				IF (expW >= 2) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 10 MOD 10 + ORD("0")); INC(i) END;
+				IF i < LEN(s) THEN s[i] := CHR(exp MOD 10 + ORD("0")); INC(i) END
+			END
+		END;
+		IF i < LEN(s) THEN s[i] := 0X ELSE HALT(23) END
+	END RealToStringForm;
+
+	PROCEDURE RealToString* (x: REAL; OUT s: ARRAY OF CHAR);
+	BEGIN
+		RealToStringForm(x, 16, 0, 0, digitspace, s)
+	END RealToString;
+
+
+	PROCEDURE StringToReal* (IN s: ARRAY OF CHAR; OUT x: REAL; OUT res: INTEGER);
+		VAR first, last, point, e, n, i, exp: INTEGER; y: REAL; ch: CHAR; neg, negExp, dig: BOOLEAN;
+	BEGIN
+		res := 0; i := 0; ch := s[0]; dig := FALSE;
+		WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO INC(i); ch := s[i] END;
+		IF ch = "+" THEN
+			neg := FALSE; INC(i); ch := s[i]
+		ELSIF ch = "-" THEN
+			neg := TRUE; INC(i); ch := s[i]
+		ELSE
+			neg := FALSE
+		END;
+		WHILE ch = "0" DO INC(i); ch := s[i]; dig := TRUE END;
+		first := i; e := 0;
+		WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; INC(e); dig := TRUE END;
+		point := i;
+		IF ch = "." THEN
+			INC(i); ch := s[i];
+			IF e = 0 THEN
+				WHILE ch = "0" DO INC(i); ch := s[i]; DEC(e); dig := TRUE END;
+				first := i
+			END;
+			WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; dig := TRUE END
+		END;
+		last := i - 1; exp := 0;
+		IF (ch = "E") OR (ch = "D") THEN
+			INC(i); ch := s[i]; negExp := FALSE;
+			IF ch = "-" THEN negExp := TRUE; INC(i); ch := s[i]
+			ELSIF ch = "+" THEN INC(i); ch := s[i]
+			END;
+			WHILE ("0" <= ch) & (ch <= "9") & (exp < 1000) DO
+				exp := exp * 10 + (ORD(ch) - ORD("0"));
+				INC(i); ch := s[i]
+			END;
+			IF negExp THEN exp := -exp END
+		END;
+		exp := exp + e; x := 0; y := 0; n := 0; 
+		WHILE (n < maxDig) & (first <= last) DO
+			IF first # point THEN x := x * 10 + (ORD(s[first]) - ORD("0")); INC(n) END;
+			INC(first)
+		END;
+		WHILE last >= first DO
+			IF last # point THEN y := (y + (ORD(s[last]) - ORD("0"))) / 10 END;
+			DEC(last)
+		END;
+		IF ~dig OR (ch # 0X) THEN res := 2	(* syntax error *)
+		ELSIF exp < -maxExp - maxDig THEN
+			x := 0.0
+		ELSIF exp < -maxExp + maxDig THEN
+			x := (x + y) / Math.IntPower(10, n - exp - 2 * maxDig) / factor / factor
+		ELSIF exp < n THEN
+			x := (x + y) / Math.IntPower(10, n - exp)
+		ELSIF exp < maxExp THEN
+			x := (x + y) * Math.IntPower(10, exp - n)
+		ELSIF exp = maxExp THEN
+			x := (x + y) * (Math.IntPower(10, exp - n) / 16);
+			IF x <= MAX(REAL) / 16 THEN x := x * 16
+			ELSE res := 1	(* overflow *)
+			END
+		ELSE res := 1	(* overflow *)
+		END;
+		IF neg THEN x := -x END
+	END StringToReal;
+
+	(* ----------------------------- string manipulation routines --------------------------- *)
+
+	PROCEDURE Valid* (IN s: ARRAY OF CHAR): BOOLEAN;
+		VAR i: INTEGER;
+	BEGIN i := 0;
+		WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
+		RETURN i < LEN(s)
+	END Valid;
+
+	PROCEDURE Upper* (ch: CHAR): CHAR;
+	BEGIN
+		IF ORD(ch) < 256 THEN RETURN toUpper[ORD(ch)] ELSE RETURN ch END
+	END Upper;
+
+	PROCEDURE ToUpper* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+		VAR i, max: INTEGER;
+	BEGIN i := 0; max := LEN(out)-1;
+		WHILE (in[i] # 0X) & (i < max) DO
+			IF ORD(in[i]) < 256 THEN out[i] := toUpper[ORD(in[i])] ELSE out[i] := in[i] END;
+			INC(i)
+		END;
+		out[i] := 0X
+	END ToUpper;
+
+	PROCEDURE Lower* (ch: CHAR): CHAR;
+	BEGIN 
+		IF ORD(ch) < 256 THEN RETURN toLower[ORD(ch)] ELSE RETURN ch END
+	END Lower;
+
+	PROCEDURE ToLower* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR);
+		VAR i, max: INTEGER;
+	BEGIN i := 0; max := LEN(out)-1;
+		WHILE (in[i] # 0X) & (i < max) DO
+			IF ORD(in[i]) < 256 THEN out[i] := toLower[ORD(in[i])] ELSE out[i] := in[i] END;
+			INC(i)
+		END;
+		out[i] := 0X
+	END ToLower;
+
+	PROCEDURE Replace* (VAR s: ARRAY OF CHAR; pos, len: INTEGER; IN rep: ARRAY OF CHAR);
+		(* replace stretch s[pos]..s[pos+len-1] with rep *)
+		(* insert semantics if len = 0; delete semantics if Len(rep) = 0 *)
+		VAR i, j, k, max, lenS: INTEGER; ch: CHAR;
+	BEGIN
+		ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21);
+		lenS := LEN(s$); max := LEN(s) - 1;
+		IF pos <= lenS THEN i := pos; j := 0;
+			IF pos+len > lenS THEN len := lenS - pos END;
+			WHILE (rep[j] # 0X) & (len > 0) DO
+				s[i] := rep[j]; INC(i); INC(j); DEC(len)
+			END;
+			IF len > 0 THEN (* delete the remaining part of the stretch [pos, pos+len) *)
+				REPEAT ch := s[i+len]; s[i] := ch; INC(i) UNTIL ch = 0X
+			ELSE (* insert the remaining part of rep *)
+				len := LEN(rep$) - j; k := lenS + len;
+				IF k > max THEN k := max END;
+				s[k] := 0X;
+				WHILE k - len >= i DO s[k] := s[k-len]; DEC(k) END;
+				WHILE (rep[j] # 0X) & (i < max) DO s[i] := rep[j]; INC(i); INC(j) END
+			END
+		END
+	END Replace;
+
+	PROCEDURE Extract* (s: ARRAY OF CHAR; pos, len: INTEGER; OUT res: ARRAY OF CHAR);
+		VAR i, j, max: INTEGER;
+	BEGIN
+		ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21);
+		i := 0; j := 0; max := LEN(res) - 1;
+		WHILE (i < pos) & (s[i] # 0X) DO INC(i) END;
+		WHILE (j < len) & (j < max) & (s[i] # 0X) DO res[j] := s[i]; INC(j); INC(i) END;
+		res[j] := 0X
+	END Extract;
+
+	PROCEDURE Find* (IN s: ARRAY OF CHAR; IN pat: ARRAY OF CHAR; start: INTEGER; OUT pos: INTEGER);
+		VAR j: INTEGER;
+	BEGIN
+		ASSERT(start >= 0, 20);
+		IF (start = 0) OR (start <= LEN(s$) - LEN(pat$)) THEN
+			(* start = 0 is optimization: need not call Len *)
+			pos := start;
+			WHILE s[pos] # 0X DO j := 0;
+				WHILE (s[pos+j] = pat[j]) & (pat[j] # 0X) DO INC(j) END;
+				IF pat[j] = 0X THEN RETURN END;
+				INC(pos)
+			END
+		END;
+		pos := -1	(* pattern not found *)
+	END Find;
+
+	PROCEDURE Init;
+		VAR i: INTEGER;
+	BEGIN
+		FOR i := 0 TO 255 DO toUpper[i] :=  CHR(i); toLower[i] := CHR(i) END;
+		FOR i := ORD("A") TO ORD("Z") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
+		FOR i := ORD("À") TO ORD ("Ö") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
+		FOR i := ORD("Ø") TO ORD ("Þ") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
+		digits := "0123456789ABCDEF"; 
+		maxExp := SHORT(ENTIER(Math.Log(MAX(REAL)))) + 1;
+		maxDig := SHORT(ENTIER(-Math.Log(Math.Eps())));
+		factor := Math.IntPower(10, maxDig)
+	END Init;
+
+BEGIN
+	Init
+END Strings.

BlackBox/Views.txt

@@ -0,0 +1,14 @@
+MODULE Views;
+
+	(* TO COMPILE StdInterpreter *)
+
+	PROCEDURE Available* (): INTEGER;
+	BEGIN
+	RETURN 0
+	END Available;
+
+	PROCEDURE ClearQueue*;
+	BEGIN
+	END ClearQueue;
+
+END Views.

BlackBox/build

@@ -0,0 +1,41 @@
+#!/bin/sh
+
+./run-interp <<DATA
+LindevCompiler.Compile('Lin/Mod', 'Obsd.Dl.txt')
+LindevCompiler.Compile('Lin/Mod', 'Obsd.Libc.txt')
+LindevCompiler.Compile('Lin/Mod', 'Obsd.linKernel.txt')
+LindevCompiler.Compile('System/Mod', 'Files.txt')
+LindevCompiler.Compile('System/Mod', 'Dialog.txt')
+LindevCompiler.Compile('System/Mod', 'Math.txt')
+LindevCompiler.Compile('System/Mod', 'Strings.txt')
+LindevCompiler.Compile('Lin/Mod', 'Obsd.linHostFiles.txt')
+LindevCompiler.Compile('System/Mod', 'Meta.txt')
+LindevCompiler.Compile('Std/Mod', 'Loader.txt')
+LindevCompiler.Compile('System/Mod', 'Console.txt')
+LindevCompiler.Compile('Lin/Mod', 'Console.txt')
+LindevCompiler.Compile('Lin/Mod', 'Kernel_so_init.txt')
+LindevCompiler.Compile('', 'Views.txt')
+LindevCompiler.Compile('Std/Mod', 'Interpreter.txt')
+
+LindevCompiler.Compile('Lindev/Mod', 'CPM.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPT.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPS.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPH.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPB.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPP.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPE.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPL486.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPC486.txt')
+LindevCompiler.Compile('Lindev/Mod', 'CPV486.txt')
+
+LindevCompiler.Compile('', 'LindevCompiler.txt')
+LindevCompiler.Compile('', 'LindevElfLinker16.txt')
+
+LindevCompiler.Compile('', 'Interp.txt')
+LindevCompiler.Compile('', 'Init-Interp.txt')
+
+LindevElfLinker.LinkDll('libBB.so := Kernel+ Files HostFiles StdLoader')
+
+# LindevElfLinker.LinkDll('libBBInterp.so := Kernel+ Kernel_so_init# Console Math Strings LinConsole Files HostFiles LindevCPM LindevCPT LindevCPS LindevCPH LindevCPB LindevCPP LindevCPE LindevCPL486 LindevCPC486 LindevCPV486 LindevCompiler LindevElfLinker Dialog Meta Views StdInterpreter Interp#')
+LindevElfLinker.LinkDll('libBBInterp.so := Kernel+ Console Math Strings LinConsole Files HostFiles LindevCPM LindevCPT LindevCPS LindevCPH LindevCPB LindevCPP LindevCPE LindevCPL486 LindevCPC486 LindevCPV486 LindevCompiler LindevElfLinker Dialog Meta Views StdInterpreter Interp#')
+DATA

BlackBox/clean

@@ -0,0 +1,4 @@
+#!/bin/sh
+
+find . -type f -name "*.ocf" -exec rm -f {} \;
+find . -type f -name "*.osf" -exec rm -f {} \;

BlackBox/interp

@@ -0,0 +1 @@
+../c/interp

BlackBox/license

@@ -0,0 +1 @@
+See BlackBox and OpenBUGS licenses

BlackBox/run-BlackBox

@@ -0,0 +1,4 @@
+#!/bin/sh
+
+# env LD_LIBRARY_PATH=. env LD_DEBUG=1 ./BlackBox
+env LD_LIBRARY_PATH=. ./BlackBox

BlackBox/run-interp

@@ -0,0 +1 @@
+../c/run-interp

README

@@ -0,0 +1,63 @@
+Oberon Microsystems BlackBox Component Builder (http://www.oberon.ch/)
+Port for OpenBSD/i386
+
+Port based on OpenBUGS (http://www.openbugs.info/)
+
+How to build:
+	compile loader executable (BlackBox itself and simple interpreter):
+		libBB*.so must be present (can be cross-linked from Windows)
+
+		cd c; make
+
+	compile self:
+
+		cd BlackBox; ./clean; ./build
+
+Files:
+	original:
+		BlackBox:
+			Std/Mod/Loader.*
+			Std/Mod/Interpreter.*
+			Dev/Rsrc/Errors.odc
+			Docu/BB-License.odc
+			Docu/BB-Licensing-Policy.odc
+			Docu/BB-Open-Source-License.odc
+			System/Mod/
+				Dialog.*
+				Files.*
+				Math.*
+				Meta.*
+				Strings.*
+		OpenBUGS:
+			Dev/Mod/ElfLinker16.odc
+			Dev/Docu/ElfLinker.odc
+			Lin/Mod/Console.*
+			System/Mod/Console.*
+			Lindev/*
+			Docu/OpenBUGS-License.odc
+		oberoncore.ru:
+			Lin/Mod/Kernel_so_init.*
+	modified:
+		Lin/Mod/Obsd.linKernel.odc:
+			OpenBUGS Lin/Mod/linKernel.odc modified with OpenBSD specific:
+				Kernel.TrapHandler
+					OpenBSD sigcontext related
+				Kernel.Time
+					CLOCKS_PER_SEC related
+				Kernel.InitModule
+					mprotect added
+		Lin/Mod/Obsd.linHostFiles.odc:
+			OpenBUGS Lin/Mod/linHostFiles.odc:
+				size_t specific
+		Lin/Mod/Obsd.Libc.txt:
+			OpenBUGS Lin/Mod/Libc.odc:
+				OpenBSD-specific
+		LindevCompiler.odc:
+			modified original BlackBox Dev/Mod/Compiler.odc
+		LindevElfLinker16.odc:
+			modified OpenBUGS Dev/Mod/ElfLinker16.odc
+
+Notes:
+	Lindev:
+		OpenBUGS/Lindev compiler outdated, not in sync with original BlackBox/Dev compiler
+		Lindev* is temporary solution until TextModels ported

TODO

@@ -0,0 +1,12 @@
+By priority:
+	Converters: odc -> txt
+		simple TextModels; HostTexts
+
+	original Dev compiler instead of Lindev:
+		simple TextModels
+		...
+
+	Services
+
+	GUI:
+		...

c/BlackBox.c

@@ -0,0 +1,6 @@
+#include <stdio.h>
+
+int main (int argc, char *argv[])
+{
+	return 0;
+}

c/BlackBox1.c

@@ -0,0 +1,24 @@
+#include <stdio.h>
+
+// extern void SetKernelBaseStack (int);
+extern void Init (void);
+
+int main (int argc, char *argv[])
+{
+	// int res;
+
+	// printf("START\n");
+
+	/* 2012.09.02: This is from oberoncore.ru
+		2012.09.05: not required in case of static linking of shared library (-lBB) */
+	// asm ("movl %%esp, %[res]" : [res] "=m" (res) );
+	// SetKernelBaseStack(res - 8);
+	// printf("SetKernelBaseStack(0x%02x): done\n", res - 8);
+	// <return adr> <caller ebp> -> base stack = locals of main proc
+
+	Init();
+
+	// printf("END\n");
+
+	return 0;
+}

c/Makefile

@@ -0,0 +1,10 @@
+all: interp BlackBox
+
+BlackBox: BlackBox.c openbsd.c
+	${CC} ${CFLAGS} -O0 -g -o ${.TARGET} ${.ALLSRC} -L. -lBB -Wl,-E
+
+interp: BlackBox1.c openbsd.c
+	${CC} ${CFLAGS} -O0 -g -o ${.TARGET} ${.ALLSRC} -L . -lBBInterp
+
+clean:
+	rm -f interp BlackBox

c/libBB.so

@@ -0,0 +1 @@
+../BlackBox/libBB.so

c/libBBInterp.so

@@ -0,0 +1 @@
+../BlackBox/libBBInterp.so

c/openbsd.c

@@ -0,0 +1,37 @@
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#include <setjmp.h>
+#include <stdio.h>
+
+#include <errno.h>
+
+/*
+int __sigsetjmp(sigjmp_buf env, int savemask)
+{
+	printf("__sigsetjmp ...\n");
+	return sigsetjmp(env, savemask);
+}
+*/
+
+int __xstat (int version, const char *path, struct stat *sb)
+{
+	if (version != 3) {
+		printf("WARNING: __xstat: %d %s\n", version, path);
+	}
+	return stat(path, sb); /* XXX */
+}
+
+int * __errno_location () {
+	return __errno();
+}
+
+#undef stdin
+void * stdin = (&__sF[0]);
+
+#undef stdout
+void * stdout = (&__sF[1]);
+
+#undef stderr
+void * stderr = (&__sF[2]);

c/run-interp

@@ -0,0 +1,4 @@
+#!/bin/sh
+
+# env LD_LIBRARY_PATH=. env LD_DEBUG=1 ./interp
+env LD_LIBRARY_PATH=. ./interp