XenOn/kolibrios-fun
1
1
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Wiki Activity

oberon07: lower case by default

Browse Source 
git-svn-id: svn://kolibrios.org@9893 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Anton Krotov 2023-01-21 14:34:25 +00:00
parent bd24d8a01e
commit a1909c89a2
27 changed files with 1530 additions and 2226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
programs/develop/cedit/SRC/Icons.ob07
View File

@ -1,5 +1,5 @@
(* (*
Copyright 2021, 2022 Anton Krotov Copyright 2021-2023 Anton Krotov
This file is part of CEdit. This file is part of CEdit.
@ -20,27 +20,27 @@
MODULE Icons; MODULE Icons;
IMPORT IMPORT
Graph, File, SYSTEM, KOSAPI; Graph, File, SYSTEM, KOSAPI;
CONST CONST
fileName = "/sys/Icons16.png"; fileName = "/sys/Icons16.png";
SIZE* = 18; SIZE* = 18;
VAR VAR
source: INTEGER; source: INTEGER;
(* (*
PROCEDURE copy (src, dst: INTEGER); PROCEDURE copy (src, dst: INTEGER);
VAR VAR
src_width, src_height, src_width, src_height,
dst_width, dst_height, dst_width, dst_height,
src_data, dst_data: INTEGER; src_data, dst_data: INTEGER;
BEGIN BEGIN
LibImg.GetInf(src, src_width, src_height, src_data); LibImg.GetInf(src, src_width, src_height, src_data);
LibImg.GetInf(dst, dst_width, dst_height, dst_data); LibImg.GetInf(dst, dst_width, dst_height, dst_data);
ASSERT(src_width = dst_width); ASSERT(src_width = dst_width);
ASSERT(src_height = dst_height); ASSERT(src_height = dst_height);
SYSTEM.MOVE(src_data, dst_data, src_width*src_height*4) SYSTEM.MOVE(src_data, dst_data, src_width*src_height*4)
END copy; END copy;
*) *)
@ -50,93 +50,93 @@ PROCEDURE [stdcall, "Libimg.obj", ""] img_destroy (img: INTEGER); END;
PROCEDURE GetInf (img: INTEGER; VAR width, height, data: INTEGER); PROCEDURE GetInf (img: INTEGER; VAR width, height, data: INTEGER);
BEGIN BEGIN
SYSTEM.GET(img + 4, width); SYSTEM.GET(img + 4, width);
SYSTEM.GET(img + 8, height); SYSTEM.GET(img + 8, height);
SYSTEM.GET(img + 24, data); SYSTEM.GET(img + 24, data);
END GetInf; END GetInf;
PROCEDURE GetImg (ptr, size: INTEGER): INTEGER; PROCEDURE GetImg (ptr, size: INTEGER): INTEGER;
VAR VAR
image_data, dst, x, type: INTEGER; image_data, dst, x, Type: INTEGER;
BEGIN BEGIN
image_data := img_decode(ptr, size, 0); image_data := img_decode(ptr, size, 0);
IF image_data # 0 THEN IF image_data # 0 THEN
SYSTEM.GET(image_data + 4, x); SYSTEM.GET(image_data + 4, x);
ASSERT(x = SIZE); ASSERT(x = SIZE);
SYSTEM.GET(image_data + 20, type); SYSTEM.GET(image_data + 20, Type);
IF type # 3 THEN IF Type # 3 THEN
dst := img_convert(image_data, 0, 3, 0, 0); dst := img_convert(image_data, 0, 3, 0, 0);
img_destroy(image_data); img_destroy(image_data);
image_data := dst image_data := dst
END END
END END
RETURN image_data RETURN image_data
END GetImg; END GetImg;
PROCEDURE load (): INTEGER; PROCEDURE load (): INTEGER;
VAR VAR
size, res, ptr: INTEGER; size, res, ptr: INTEGER;
BEGIN BEGIN
res := 0; res := 0;
ptr := File.Load(fileName, size); ptr := File.Load(fileName, size);
IF ptr # 0 THEN IF ptr # 0 THEN
res := GetImg(ptr, size); res := GetImg(ptr, size);
ptr := KOSAPI.free(ptr) ptr := KOSAPI.free(ptr)
END END
RETURN res RETURN res
END load; END load;
PROCEDURE draw* (icons, n, x, y: INTEGER); PROCEDURE draw* (icons, n, x, y: INTEGER);
VAR VAR
width, height, data: INTEGER; width, height, data: INTEGER;
BEGIN BEGIN
GetInf(icons, width, height, data); GetInf(icons, width, height, data);
KOSAPI.sysfunc7(65, data + SIZE*SIZE*4*n, SIZE*65536 + SIZE, x*65536 + y, 32, 0, 0) KOSAPI.sysfunc7(65, data + SIZE*SIZE*4*n, SIZE*65536 + SIZE, x*65536 + y, 32, 0, 0)
END draw; END draw;
PROCEDURE iconsBackColor (icons: INTEGER; BackColor: INTEGER); PROCEDURE iconsBackColor (icons: INTEGER; BackColor: INTEGER);
VAR VAR
width, height, data, x, y, pix: INTEGER; width, height, data, x, y, pix: INTEGER;
b, g, r, gr: BYTE; b, g, r, gr: BYTE;
BEGIN BEGIN
GetInf(icons, width, height, data); GetInf(icons, width, height, data);
FOR y := 0 TO height - 1 DO FOR y := 0 TO height - 1 DO
FOR x := 0 TO width - 1 DO FOR x := 0 TO width - 1 DO
SYSTEM.GET32(data, pix); SYSTEM.GET32(data, pix);
Graph.getRGB(pix, r, g, b); Graph.getRGB(pix, r, g, b);
gr := (r + g + b) DIV 3; gr := (r + g + b) DIV 3;
IF BackColor = -1 THEN IF BackColor = -1 THEN
pix := gr + 256*gr + 65536*gr pix := gr + 256*gr + 65536*gr
ELSIF gr = 255 THEN ELSIF gr = 255 THEN
pix := BackColor pix := BackColor
END; END;
SYSTEM.PUT32(data, pix); SYSTEM.PUT32(data, pix);
INC(data, 4) INC(data, 4)
END END
END END
END iconsBackColor; END iconsBackColor;
PROCEDURE get* (VAR icons, grayIcons: INTEGER; BackColor: INTEGER); PROCEDURE get* (VAR icons, grayIcons: INTEGER; BackColor: INTEGER);
BEGIN BEGIN
IF source = 0 THEN IF source = 0 THEN
source := load(); source := load();
icons := load(); icons := load();
grayIcons := load(); grayIcons := load();
iconsBackColor(grayIcons, -1); iconsBackColor(grayIcons, -1);
iconsBackColor(grayIcons, BackColor); iconsBackColor(grayIcons, BackColor);
iconsBackColor(icons, BackColor) iconsBackColor(icons, BackColor)
(*ELSE (*ELSE
copy(source, icons); copy(source, icons);
copy(source, grayIcons)*) copy(source, grayIcons)*)
END END
END get; END get;
BEGIN BEGIN
source := 0 source := 0
END Icons. END Icons.

BIN
programs/develop/oberon07/Compiler.kex
View File

Binary file not shown.

2
programs/develop/oberon07/LICENSE
View File

@ -1,6 +1,6 @@
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
Redistribution and use in source and binary forms, with or without Redistribution and use in source and binary forms, with or without

120
programs/develop/oberon07/doc/CC.txt
View File

@ -1,61 +1,61 @@
Условная компиляция Условная компиляция
синтаксис: синтаксис:
$IF "(" ident {"|" ident} ")" $IF "(" ident {"|" ident} ")"
<...> <...>
{$ELSIF "(" ident {"|" ident} ")"} {$ELSIF "(" ident {"|" ident} ")"}
<...> <...>
[$ELSE] [$ELSE]
<...> <...>
$END $END
где ident: где ident:
- одно из возможных значений параметра <target> в командной строке - одно из возможных значений параметра <target> в командной строке
- пользовательский идентификатор, переданный с ключом -def при компиляции - пользовательский идентификатор, переданный с ключом -def при компиляции
- один из возможных предопределенных идентификаторов: - один из возможных предопределенных идентификаторов:
WINDOWS - приложение Windows WINDOWS - приложение Windows
LINUX - приложение Linux LINUX - приложение Linux
KOLIBRIOS - приложение KolibriOS KOLIBRIOS - приложение KolibriOS
CPU_X86 - приложение для процессора x86 (32-бит) CPU_X86 - приложение для процессора x86 (32-бит)
CPU_X8664 - приложение для процессора x86_64 CPU_X8664 - приложение для процессора x86_64
примеры: примеры:
$IF (win64con | win64gui | win64dll) $IF (win64con | win64gui | win64dll)
OS := "WIN64"; OS := "WIN64";
$ELSIF (win32con | win32gui | win32dll) $ELSIF (win32con | win32gui | win32dll)
OS := "WIN32"; OS := "WIN32";
$ELSIF (linux64exe | linux64so) $ELSIF (linux64exe | linux64so)
OS := "LINUX64"; OS := "LINUX64";
$ELSIF (linux32exe | linux32so) $ELSIF (linux32exe | linux32so)
OS := "LINUX32"; OS := "LINUX32";
$ELSE $ELSE
OS := "UNKNOWN"; OS := "UNKNOWN";
$END $END
$IF (debug) (* -def debug *) $IF (debug) (* -def debug *)
print("debug"); print("debug");
$END $END
$IF (WINDOWS) $IF (WINDOWS)
$IF (CPU_X86) $IF (CPU_X86)
(*windows 32*) (*windows 32*)
$ELSIF (CPU_X8664) $ELSIF (CPU_X8664)
(*windows 64*) (*windows 64*)
$END $END
$ELSIF (LINUX) $ELSIF (LINUX)
$IF (CPU_X86) $IF (CPU_X86)
(*linux 32*) (*linux 32*)
$ELSIF (CPU_X8664) $ELSIF (CPU_X8664)
(*linux 64*) (*linux 64*)
$END $END
$END $END

312
programs/develop/oberon07/doc/WinLib.txt
View File

@ -1,312 +0,0 @@
==============================================================================
Библиотека (Windows)
------------------------------------------------------------------------------
MODULE Out - консольный вывод
PROCEDURE Open
открывает консольный вывод
PROCEDURE Int(x, width: INTEGER)
вывод целого числа x;
width - количество знакомест, используемых для вывода
PROCEDURE Real(x: REAL; width: INTEGER)
вывод вещественного числа x в плавающем формате;
width - количество знакомест, используемых для вывода
PROCEDURE Char(x: CHAR)
вывод символа x
PROCEDURE FixReal(x: REAL; width, p: INTEGER)
вывод вещественного числа x в фиксированном формате;
width - количество знакомест, используемых для вывода;
p - количество знаков после десятичной точки
PROCEDURE Ln
переход на следующую строку
PROCEDURE String(s: ARRAY OF CHAR)
вывод строки s (ASCII)
PROCEDURE StringW(s: ARRAY OF WCHAR)
вывод строки s (UTF-16)
------------------------------------------------------------------------------
MODULE In - консольный ввод
VAR Done: BOOLEAN
принимает значение TRUE в случае успешного выполнения
операции ввода и FALSE в противном случае
PROCEDURE Open
открывает консольный ввод,
также присваивает переменной Done значение TRUE
PROCEDURE Int(VAR x: INTEGER)
ввод числа типа INTEGER
PROCEDURE Char(VAR x: CHAR)
ввод символа
PROCEDURE Real(VAR x: REAL)
ввод числа типа REAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
ввод строки
PROCEDURE Ln
ожидание нажатия ENTER
------------------------------------------------------------------------------
MODULE Console - дополнительные процедуры консольного вывода
CONST
Следующие константы определяют цвет консольного вывода
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
PROCEDURE Cls
очистка окна консоли
PROCEDURE SetColor(FColor, BColor: INTEGER)
установка цвета консольного вывода: FColor - цвет текста,
BColor - цвет фона, возможные значения - вышеперечисленные
константы
PROCEDURE SetCursor(x, y: INTEGER)
установка курсора консоли в позицию (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
записывает в параметры текущие координаты курсора консоли
PROCEDURE GetCursorX(): INTEGER
возвращает текущую x-координату курсора консоли
PROCEDURE GetCursorY(): INTEGER
возвращает текущую y-координату курсора консоли
------------------------------------------------------------------------------
MODULE Math - математические функции
CONST
pi = 3.141592653589793E+00
e = 2.718281828459045E+00
PROCEDURE IsNan(x: REAL): BOOLEAN
возвращает TRUE, если x - не число
PROCEDURE IsInf(x: REAL): BOOLEAN
возвращает TRUE, если x - бесконечность
PROCEDURE sqrt(x: REAL): REAL
квадратный корень x
PROCEDURE exp(x: REAL): REAL
экспонента x
PROCEDURE ln(x: REAL): REAL
натуральный логарифм x
PROCEDURE sin(x: REAL): REAL
синус x
PROCEDURE cos(x: REAL): REAL
косинус x
PROCEDURE tan(x: REAL): REAL
тангенс x
PROCEDURE arcsin(x: REAL): REAL
арксинус x
PROCEDURE arccos(x: REAL): REAL
арккосинус x
PROCEDURE arctan(x: REAL): REAL
арктангенс x
PROCEDURE arctan2(y, x: REAL): REAL
арктангенс y/x
PROCEDURE power(base, exponent: REAL): REAL
возведение числа base в степень exponent
PROCEDURE log(base, x: REAL): REAL
логарифм x по основанию base
PROCEDURE sinh(x: REAL): REAL
гиперболический синус x
PROCEDURE cosh(x: REAL): REAL
гиперболический косинус x
PROCEDURE tanh(x: REAL): REAL
гиперболический тангенс x
PROCEDURE arsinh(x: REAL): REAL
обратный гиперболический синус x
PROCEDURE arcosh(x: REAL): REAL
обратный гиперболический косинус x
PROCEDURE artanh(x: REAL): REAL
обратный гиперболический тангенс x
PROCEDURE round(x: REAL): REAL
округление x до ближайшего целого
PROCEDURE frac(x: REAL): REAL;
дробная часть числа x
PROCEDURE floor(x: REAL): REAL
наибольшее целое число (представление как REAL),
не больше x: floor(1.2) = 1.0
PROCEDURE ceil(x: REAL): REAL
наименьшее целое число (представление как REAL),
не меньше x: ceil(1.2) = 2.0
PROCEDURE sgn(x: REAL): INTEGER
если x > 0 возвращает 1
если x < 0 возвращает -1
если x = 0 возвращает 0
PROCEDURE fact(n: INTEGER): REAL
факториал n
------------------------------------------------------------------------------
MODULE File - работа с файловой системой
CONST
OPEN_R = 0
OPEN_W = 1
OPEN_RW = 2
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Create(FName: ARRAY OF CHAR): INTEGER
создает новый файл с именем FName (полное имя с путем),
открывет файл для записи и возвращает идентификатор файла
(целое число), в случае ошибки, возвращает -1
PROCEDURE Open(FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER
открывает существующий файл с именем FName (полное имя с
путем) в режиме Mode = (OPEN_R (только чтение), OPEN_W
(только запись), OPEN_RW (чтение и запись)), возвращает
идентификатор файла (целое число), в случае ошибки,
возвращает -1
PROCEDURE Read(F, Buffer, Count: INTEGER): INTEGER
Читает данные из файла в память. F - числовой идентификатор
файла, Buffer - адрес области памяти, Count - количество байт,
которое требуется прочитать из файла; возвращает количество
байт, которое было прочитано из файла
PROCEDURE Write(F, Buffer, Count: INTEGER): INTEGER
Записывает данные из памяти в файл. F - числовой идентификатор
файла, Buffer - адрес области памяти, Count - количество байт,
которое требуется записать в файл; возвращает количество байт,
которое было записано в файл
PROCEDURE Seek(F, Offset, Origin: INTEGER): INTEGER
устанавливает позицию чтения-записи файла с идентификатором F
на Offset, относительно Origin = (SEEK_BEG - начало файла,
SEEK_CUR - текущая позиция, SEEK_END - конец файла),
возвращает позицию относительно начала файла, например:
Seek(F, 0, 2) - устанавливает позицию на конец файла и
возвращает длину файла; при ошибке возвращает -1
PROCEDURE Close(F: INTEGER)
закрывает ранее открытый файл с идентификатором F
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
удаляет файл с именем FName (полное имя с путем),
возвращает TRUE, если файл успешно удален
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если файл с именем FName (полное имя)
существует
PROCEDURE Load(FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER
загружает в память существующий файл с именем FName (полное имя с
путем), возвращает адрес памяти, куда был загружен файл,
записывает размер файла в параметр Size;
при ошибке возвращает 0
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
создает папку с именем DirName, все промежуточные папки
должны существовать. В случае ошибки, возвращает FALSE
PROCEDURE RemoveDir(DirName: ARRAY OF CHAR): BOOLEAN
удаляет пустую папку с именем DirName. В случае ошибки,
возвращает FALSE
PROCEDURE ExistsDir(DirName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если папка с именем DirName существует
------------------------------------------------------------------------------
MODULE DateTime - дата, время
CONST ERR = -7.0E5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER)
возвращает в параметрах компоненты текущей системной даты и
времени
PROCEDURE NowEncode(): REAL;
возвращает текущую системную дату и
время (представление REAL)
PROCEDURE Encode(Year, Month, Day,
Hour, Min, Sec, MSec: INTEGER): REAL
возвращает дату, полученную из компонентов
Year, Month, Day, Hour, Min, Sec, MSec;
при ошибке возвращает константу ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec, MSec: INTEGER): BOOLEAN
извлекает компоненты
Year, Month, Day, Hour, Min, Sec, MSec из даты Date;
при ошибке возвращает FALSE
------------------------------------------------------------------------------
MODULE Args - параметры программы
VAR argc: INTEGER
количество параметров программы, включая имя
исполняемого файла
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
записывает в строку s n-й параметр программы,
нумерация параметров от 0 до argc - 1,
нулевой параметр -- имя исполняемого файла
------------------------------------------------------------------------------
MODULE Utils - разное
PROCEDURE Utf8To16(source: ARRAY OF CHAR;
VAR dest: ARRAY OF CHAR): INTEGER;
преобразует символы строки source из кодировки UTF-8 в
кодировку UTF-16, результат записывает в строку dest,
возвращает количество 16-битных символов, записанных в dest
PROCEDURE PutSeed(seed: INTEGER)
Инициализация генератора случайных чисел целым числом seed
PROCEDURE Rnd(range: INTEGER): INTEGER
Целые случайные числа в диапазоне 0 <= x < range
------------------------------------------------------------------------------
MODULE WINAPI - привязки к некоторым API-функциям Windows

17
programs/develop/oberon07/doc/x86.txt
View File

@ -20,15 +20,17 @@ UTF-8 с BOM-сигнатурой.
3) необязательные параметры-ключи 3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию, -out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла) (соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб, -stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб) допустимо от 1 до 32 Мб)
-tab <width> размер табуляции (используется для вычисления координат в -tab <width> размер табуляции (используется для вычисления координат в
исходном коде), по умолчанию - 4 исходном коде), по умолчанию - 4
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже) -nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-lower разрешить ключевые слова и встроенные идентификаторы в -lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре нижнем регистре (по умолчанию)
-upper только верхний регистр для ключевых слов и встроенных
идентификаторов
-def <имя> задать символ условной компиляции -def <имя> задать символ условной компиляции
-ver <major.minor> версия программы (только для kosdll) -ver <major.minor> версия программы (только для kosdll)
-uses вывести список импортированных модулей -uses вывести список импортированных модулей
@ -81,6 +83,7 @@ UTF-8 с BOM-сигнатурой.
13. Возможен импорт модулей с указанием пути и имени файла 13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt) 14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно 15. Имя процедуры в конце объявления (после END) необязательно
16. Разрешено использовать нижний регистр для ключевых слов
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Особенности реализации Особенности реализации
@ -137,6 +140,10 @@ UTF-8 с BOM-сигнатурой.
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x возвращает адрес x
PROCEDURE VAL(v: любой тип; T): T
v - переменная;
интерпретирует v, как переменную типа T
PROCEDURE SIZE(T): INTEGER PROCEDURE SIZE(T): INTEGER
возвращает размер типа T возвращает размер типа T

397
programs/develop/oberon07/doc/x86_64.txt
View File

@ -1,397 +0,0 @@
 Компилятор языка программирования Oberon-07/16 для x86_64
Windows/Linux
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32+ или ELF64.
Параметры:
1) имя главного модуля
2) тип приложения
"win64con" - Windows64 console
"win64gui" - Windows64 GUI
"win64dll" - Windows64 DLL
"linux64exe" - Linux ELF64-EXEC
"linux64so" - Linux ELF64-SO
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-tab <width> размер табуляции (используется для вычисления координат в
исходном коде), по умолчанию - 4
-nochk <"ptibcwra"> отключить проверки при выполнении
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
-uses вывести список импортированных модулей
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" win64con -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" win64dll -out "C:\example.dll" -nochk pti
Compiler "source/Compiler.ob07" linux64exe -out "source/Compiler" -nochk a
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Добавлены системные флаги
4. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
5. Расширен набор стандартных процедур
6. Семантика охраны/проверки типа уточнена для нулевого указателя
7. Добавлены однострочные комментарии (начинаются с пары символов "//")
8. Разрешено наследование от типа-указателя
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
12. Добавлена операция конкатенации строковых и символьных констант
13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -9223372036854775808 .. 9223372036854775807 8
REAL 4.94E-324 .. 1.70E+308 8
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 63} 8
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 255 символов
3. Максимальная длина строковых констант - 511 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
10 WCHR(x), если (x < 0) OR (x > 65535)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 64 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : BYTE)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(048H,08BH,045H,010H) (* mov rax,qword[rbp+16] *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове:
[win64], [systemv], [windows], [linux], [oberon], [ccall].
Например:
PROCEDURE [win64] MyProc (x, y, z: INTEGER): INTEGER;
Флаг [windows] - синоним для [win64], [linux] - синоним для [systemv].
Флаг [ccall] - синоним для [win64] или [systemv] (зависит от целевой ОС).
Знак "-" после имени флага ([win64-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове. [win64] и [systemv] используются для связи с
операционной системой и внешними приложениями.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Case {"|" Case}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 с BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
DISPOSE (VAR v: любой_указатель)
Освобождает память, выделенную процедурой NEW для
динамической переменной v^, и присваивает переменной v
значение NIL.
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импорт модулей с указанием пути и имени файла
Примеры:
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *)
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *)
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""] GetTickCount (): INTEGER;
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
Для Linux, импортированные процедуры не реализованы.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
Скрытые параметры необходимо учитывать при связи с внешними приложениями.
------------------------------------------------------------------------------
Модуль RTL
Все программы неявно используют модуль RTL. Компилятор транслирует
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не
следует вызывать эти процедуры явно.
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах
(Windows), в терминал (Linux).
------------------------------------------------------------------------------
Модуль API
Существуют несколько реализаций модуля API (для различных ОС).
Как и модуль RTL, модуль API не предназначен для прямого использования.
Он обеспечивает связь RTL с ОС.
------------------------------------------------------------------------------
Генерация исполняемых файлов DLL
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, ее имя должно быть отмечено символом
экспорта ("*") и должно быть указано соглашение о вызове. Нельзя
экспортировать процедуры, которые импортированы из других dll-библиотек.

5
programs/develop/oberon07/lib/KolibriOS/Math.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2013-2014, 2018-2020 Anton Krotov Copyright (c) 2013-2014, 2018-2022 Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -271,8 +271,7 @@ BEGIN
ELSIF x < -15.0 THEN ELSIF x < -15.0 THEN
x := -1.0 x := -1.0
ELSE ELSE
x := exp(2.0 * x); x := 1.0 - 2.0 / (exp(2.0 * x) + 1.0)
x := (x - 1.0) / (x + 1.0)
END END
RETURN x RETURN x

924
programs/develop/oberon07/lib/Math/CMath.ob07
View File

@ -1,462 +1,462 @@
(* *********************************************** (* ***********************************************
Модуль работы с комплексными числами. Модуль работы с комплексными числами.
Вадим Исаев, 2020 Вадим Исаев, 2020
Module for complex numbers. Module for complex numbers.
Vadim Isaev, 2020 Vadim Isaev, 2020
*************************************************** *) *************************************************** *)
MODULE CMath; MODULE CMath;
IMPORT Math, Out; IMPORT Math, Out;
TYPE TYPE
complex* = POINTER TO RECORD complex* = POINTER TO RECORD
re*: REAL; re*: REAL;
im*: REAL im*: REAL
END; END;
VAR VAR
result: complex; result: complex;
i* : complex; i* : complex;
_0*: complex; _0*: complex;
(* Инициализация комплексного числа. (* Инициализация комплексного числа.
Init complex number. *) Init complex number. *)
PROCEDURE CInit* (re : REAL; im: REAL): complex; PROCEDURE CInit* (re : REAL; im: REAL): complex;
VAR VAR
temp: complex; temp: complex;
BEGIN BEGIN
NEW(temp); NEW(temp);
temp.re:=re; temp.re:=re;
temp.im:=im; temp.im:=im;
RETURN temp RETURN temp
END CInit; END CInit;
(* Четыре основных арифметических операций. (* Четыре основных арифметических операций.
Four base operations +, -, * , / *) Four base operations +, -, * , / *)
(* Сложение (* Сложение
addition : z := z1 + z2 *) addition : z := z1 + z2 *)
PROCEDURE CAdd* (z1, z2: complex): complex; PROCEDURE CAdd* (z1, z2: complex): complex;
BEGIN BEGIN
result.re := z1.re + z2.re; result.re := z1.re + z2.re;
result.im := z1.im + z2.im; result.im := z1.im + z2.im;
RETURN result RETURN result
END CAdd; END CAdd;
(* Сложение с REAL. (* Сложение с REAL.
addition : z := z1 + r1 *) addition : z := z1 + r1 *)
PROCEDURE CAdd_r* (z1: complex; r1: REAL): complex; PROCEDURE CAdd_r* (z1: complex; r1: REAL): complex;
BEGIN BEGIN
result.re := z1.re + r1; result.re := z1.re + r1;
result.im := z1.im; result.im := z1.im;
RETURN result RETURN result
END CAdd_r; END CAdd_r;
(* Сложение с INTEGER. (* Сложение с INTEGER.
addition : z := z1 + i1 *) addition : z := z1 + i1 *)
PROCEDURE CAdd_i* (z1: complex; i1: INTEGER): complex; PROCEDURE CAdd_i* (z1: complex; i1: INTEGER): complex;
BEGIN BEGIN
result.re := z1.re + FLT(i1); result.re := z1.re + FLT(i1);
result.im := z1.im; result.im := z1.im;
RETURN result RETURN result
END CAdd_i; END CAdd_i;
(* Смена знака. (* Смена знака.
substraction : z := - z1 *) substraction : z := - z1 *)
PROCEDURE CNeg (z1 : complex): complex; PROCEDURE CNeg (z1 : complex): complex;
BEGIN BEGIN
result.re := -z1.re; result.re := -z1.re;
result.im := -z1.im; result.im := -z1.im;
RETURN result RETURN result
END CNeg; END CNeg;
(* Вычитание. (* Вычитание.
substraction : z := z1 - z2 *) substraction : z := z1 - z2 *)
PROCEDURE CSub* (z1, z2 : complex): complex; PROCEDURE CSub* (z1, z2 : complex): complex;
BEGIN BEGIN
result.re := z1.re - z2.re; result.re := z1.re - z2.re;
result.im := z1.im - z2.im; result.im := z1.im - z2.im;
RETURN result RETURN result
END CSub; END CSub;
(* Вычитание REAL. (* Вычитание REAL.
substraction : z := z1 - r1 *) substraction : z := z1 - r1 *)
PROCEDURE CSub_r1* (z1 : complex; r1 : REAL): complex; PROCEDURE CSub_r1* (z1 : complex; r1 : REAL): complex;
BEGIN BEGIN
result.re := z1.re - r1; result.re := z1.re - r1;
result.im := z1.im; result.im := z1.im;
RETURN result RETURN result
END CSub_r1; END CSub_r1;
(* Вычитание из REAL. (* Вычитание из REAL.
substraction : z := r1 - z1 *) substraction : z := r1 - z1 *)
PROCEDURE CSub_r2* (r1 : REAL; z1 : complex): complex; PROCEDURE CSub_r2* (r1 : REAL; z1 : complex): complex;
BEGIN BEGIN
result.re := r1 - z1.re; result.re := r1 - z1.re;
result.im := - z1.im; result.im := - z1.im;
RETURN result RETURN result
END CSub_r2; END CSub_r2;
(* Вычитание INTEGER. (* Вычитание INTEGER.
substraction : z := z1 - i1 *) substraction : z := z1 - i1 *)
PROCEDURE CSub_i* (z1 : complex; i1 : INTEGER): complex; PROCEDURE CSub_i* (z1 : complex; i1 : INTEGER): complex;
BEGIN BEGIN
result.re := z1.re - FLT(i1); result.re := z1.re - FLT(i1);
result.im := z1.im; result.im := z1.im;
RETURN result RETURN result
END CSub_i; END CSub_i;
(* Умножение. (* Умножение.
multiplication : z := z1 * z2 *) multiplication : z := z1 * z2 *)
PROCEDURE CMul (z1, z2 : complex): complex; PROCEDURE CMul (z1, z2 : complex): complex;
BEGIN BEGIN
result.re := (z1.re * z2.re) - (z1.im * z2.im); result.re := (z1.re * z2.re) - (z1.im * z2.im);
result.im := (z1.re * z2.im) + (z1.im * z2.re); result.im := (z1.re * z2.im) + (z1.im * z2.re);
RETURN result RETURN result
END CMul; END CMul;
(* Умножение с REAL. (* Умножение с REAL.
multiplication : z := z1 * r1 *) multiplication : z := z1 * r1 *)
PROCEDURE CMul_r (z1 : complex; r1 : REAL): complex; PROCEDURE CMul_r (z1 : complex; r1 : REAL): complex;
BEGIN BEGIN
result.re := z1.re * r1; result.re := z1.re * r1;
result.im := z1.im * r1; result.im := z1.im * r1;
RETURN result RETURN result
END CMul_r; END CMul_r;
(* Умножение с INTEGER. (* Умножение с INTEGER.
multiplication : z := z1 * i1 *) multiplication : z := z1 * i1 *)
PROCEDURE CMul_i (z1 : complex; i1 : INTEGER): complex; PROCEDURE CMul_i (z1 : complex; i1 : INTEGER): complex;
BEGIN BEGIN
result.re := z1.re * FLT(i1); result.re := z1.re * FLT(i1);
result.im := z1.im * FLT(i1); result.im := z1.im * FLT(i1);
RETURN result RETURN result
END CMul_i; END CMul_i;
(* Деление. (* Деление.
division : z := znum / zden *) division : z := znum / zden *)
PROCEDURE CDiv (z1, z2 : complex): complex; PROCEDURE CDiv (z1, z2 : complex): complex;
(* The following algorithm is used to properly handle (* The following algorithm is used to properly handle
denominator overflow: denominator overflow:
| a + b(d/c) c - a(d/c) | a + b(d/c) c - a(d/c)
| ---------- + ---------- I if |d| < |c| | ---------- + ---------- I if |d| < |c|
a + b I | c + d(d/c) a + d(d/c) a + b I | c + d(d/c) a + d(d/c)
------- = | ------- = |
c + d I | b + a(c/d) -a+ b(c/d) c + d I | b + a(c/d) -a+ b(c/d)
| ---------- + ---------- I if |d| >= |c| | ---------- + ---------- I if |d| >= |c|
| d + c(c/d) d + c(c/d) | d + c(c/d) d + c(c/d)
*) *)
VAR VAR
tmp, denom : REAL; tmp, denom : REAL;
BEGIN BEGIN
IF ( ABS(z2.re) > ABS(z2.im) ) THEN IF ( ABS(z2.re) > ABS(z2.im) ) THEN
tmp := z2.im / z2.re; tmp := z2.im / z2.re;
denom := z2.re + z2.im * tmp; denom := z2.re + z2.im * tmp;
result.re := (z1.re + z1.im * tmp) / denom; result.re := (z1.re + z1.im * tmp) / denom;
result.im := (z1.im - z1.re * tmp) / denom; result.im := (z1.im - z1.re * tmp) / denom;
ELSE ELSE
tmp := z2.re / z2.im; tmp := z2.re / z2.im;
denom := z2.im + z2.re * tmp; denom := z2.im + z2.re * tmp;
result.re := (z1.im + z1.re * tmp) / denom; result.re := (z1.im + z1.re * tmp) / denom;
result.im := (-z1.re + z1.im * tmp) / denom; result.im := (-z1.re + z1.im * tmp) / denom;
END; END;
RETURN result RETURN result
END CDiv; END CDiv;
(* Деление на REAL. (* Деление на REAL.
division : z := znum / r1 *) division : z := znum / r1 *)
PROCEDURE CDiv_r* (z1 : complex; r1 : REAL): complex; PROCEDURE CDiv_r* (z1 : complex; r1 : REAL): complex;
BEGIN BEGIN
result.re := z1.re / r1; result.re := z1.re / r1;
result.im := z1.im / r1; result.im := z1.im / r1;
RETURN result RETURN result
END CDiv_r; END CDiv_r;
(* Деление на INTEGER. (* Деление на INTEGER.
division : z := znum / i1 *) division : z := znum / i1 *)
PROCEDURE CDiv_i* (z1 : complex; i1 : INTEGER): complex; PROCEDURE CDiv_i* (z1 : complex; i1 : INTEGER): complex;
BEGIN BEGIN
result.re := z1.re / FLT(i1); result.re := z1.re / FLT(i1);
result.im := z1.im / FLT(i1); result.im := z1.im / FLT(i1);
RETURN result RETURN result
END CDiv_i; END CDiv_i;
(* fonctions elementaires *) (* fonctions elementaires *)
(* Вывод на экран. (* Вывод на экран.
out complex number *) out complex number *)
PROCEDURE CPrint* (z: complex; width: INTEGER); PROCEDURE CPrint* (z: complex; width: INTEGER);
BEGIN BEGIN
Out.Real(z.re, width); Out.Real(z.re, width);
IF z.im>=0.0 THEN IF z.im>=0.0 THEN
Out.String("+"); Out.String("+");
END; END;
Out.Real(z.im, width); Out.Real(z.im, width);
Out.String("i"); Out.String("i");
END CPrint; END CPrint;
PROCEDURE CPrintLn* (z: complex; width: INTEGER); PROCEDURE CPrintLn* (z: complex; width: INTEGER);
BEGIN BEGIN
CPrint(z, width); CPrint(z, width);
Out.Ln; Out.Ln;
END CPrintLn; END CPrintLn;
(* Вывод на экран с фиксированным кол-вом знаков (* Вывод на экран с фиксированным кол-вом знаков
после запятой (p) *) после запятой (p) *)
PROCEDURE CPrintFix* (z: complex; width, p: INTEGER); PROCEDURE CPrintFix* (z: complex; width, p: INTEGER);
BEGIN BEGIN
Out.FixReal(z.re, width, p); Out.FixReal(z.re, width, p);
IF z.im>=0.0 THEN IF z.im>=0.0 THEN
Out.String("+"); Out.String("+");
END; END;
Out.FixReal(z.im, width, p); Out.FixReal(z.im, width, p);
Out.String("i"); Out.String("i");
END CPrintFix; END CPrintFix;
PROCEDURE CPrintFixLn* (z: complex; width, p: INTEGER); PROCEDURE CPrintFixLn* (z: complex; width, p: INTEGER);
BEGIN BEGIN
CPrintFix(z, width, p); CPrintFix(z, width, p);
Out.Ln; Out.Ln;
END CPrintFixLn; END CPrintFixLn;
(* Модуль числа. (* Модуль числа.
module : r = |z| *) module : r = |z| *)
PROCEDURE CMod* (z1 : complex): REAL; PROCEDURE CMod* (z1 : complex): REAL;
BEGIN BEGIN
RETURN Math.sqrt((z1.re * z1.re) + (z1.im * z1.im)) RETURN Math.sqrt((z1.re * z1.re) + (z1.im * z1.im))
END CMod; END CMod;
(* Квадрат числа. (* Квадрат числа.
square : r := z*z *) square : r := z*z *)
PROCEDURE CSqr* (z1: complex): complex; PROCEDURE CSqr* (z1: complex): complex;
BEGIN BEGIN
result.re := z1.re * z1.re - z1.im * z1.im; result.re := z1.re * z1.re - z1.im * z1.im;
result.im := 2.0 * z1.re * z1.im; result.im := 2.0 * z1.re * z1.im;
RETURN result RETURN result
END CSqr; END CSqr;
(* Квадратный корень числа. (* Квадратный корень числа.
square root : r := sqrt(z) *) square root : r := sqrt(z) *)
PROCEDURE CSqrt* (z1: complex): complex; PROCEDURE CSqrt* (z1: complex): complex;
VAR VAR
root, q: REAL; root, q: REAL;
BEGIN BEGIN
IF (z1.re#0.0) OR (z1.im#0.0) THEN IF (z1.re#0.0) OR (z1.im#0.0) THEN
root := Math.sqrt(0.5 * (ABS(z1.re) + CMod(z1))); root := Math.sqrt(0.5 * (ABS(z1.re) + CMod(z1)));
q := z1.im / (2.0 * root); q := z1.im / (2.0 * root);
IF z1.re >= 0.0 THEN IF z1.re >= 0.0 THEN
result.re := root; result.re := root;
result.im := q; result.im := q;
ELSE ELSE
IF z1.im < 0.0 THEN IF z1.im < 0.0 THEN
result.re := - q; result.re := - q;
result.im := - root result.im := - root
ELSE ELSE
result.re := q; result.re := q;
result.im := root result.im := root
END END
END END
ELSE ELSE
result := z1; result := z1;
END; END;
RETURN result RETURN result
END CSqrt; END CSqrt;
(* Экспонента. (* Экспонента.
exponantial : r := exp(z) *) exponantial : r := exp(z) *)
(* exp(x + iy) = exp(x).exp(iy) = exp(x).[cos(y) + i sin(y)] *) (* exp(x + iy) = exp(x).exp(iy) = exp(x).[cos(y) + i sin(y)] *)
PROCEDURE CExp* (z: complex): complex; PROCEDURE CExp* (z: complex): complex;
VAR VAR
expz : REAL; expz : REAL;
BEGIN BEGIN
expz := Math.exp(z.re); expz := Math.exp(z.re);
result.re := expz * Math.cos(z.im); result.re := expz * Math.cos(z.im);
result.im := expz * Math.sin(z.im); result.im := expz * Math.sin(z.im);
RETURN result RETURN result
END CExp; END CExp;
(* Натуральный логарифм. (* Натуральный логарифм.
natural logarithm : r := ln(z) *) natural logarithm : r := ln(z) *)
(* ln( p exp(i0)) = ln(p) + i0 + 2kpi *) (* ln( p exp(i0)) = ln(p) + i0 + 2kpi *)
PROCEDURE CLn* (z: complex): complex; PROCEDURE CLn* (z: complex): complex;
BEGIN BEGIN
result.re := Math.ln(CMod(z)); result.re := Math.ln(CMod(z));
result.im := Math.arctan2(z.im, z.re); result.im := Math.arctan2(z.im, z.re);
RETURN result RETURN result
END CLn; END CLn;
(* Число в степени. (* Число в степени.
exp : z := z1^z2 *) exp : z := z1^z2 *)
PROCEDURE CPower* (z1, z2 : complex): complex; PROCEDURE CPower* (z1, z2 : complex): complex;
VAR VAR
a: complex; a: complex;
BEGIN BEGIN
a:=CLn(z1); a:=CLn(z1);
a:=CMul(z2, a); a:=CMul(z2, a);
result:=CExp(a); result:=CExp(a);
RETURN result RETURN result
END CPower; END CPower;
(* Число в степени REAL. (* Число в степени REAL.
multiplication : z := z1^r *) multiplication : z := z1^r *)
PROCEDURE CPower_r* (z1: complex; r: REAL): complex; PROCEDURE CPower_r* (z1: complex; r: REAL): complex;
VAR VAR
a: complex; a: complex;
BEGIN BEGIN
a:=CLn(z1); a:=CLn(z1);
a:=CMul_r(a, r); a:=CMul_r(a, r);
result:=CExp(a); result:=CExp(a);
RETURN result RETURN result
END CPower_r; END CPower_r;
(* Обратное число. (* Обратное число.
inverse : r := 1 / z *) inverse : r := 1 / z *)
PROCEDURE CInv* (z: complex): complex; PROCEDURE CInv* (z: complex): complex;
VAR VAR
denom : REAL; denom : REAL;
BEGIN BEGIN
denom := (z.re * z.re) + (z.im * z.im); denom := (z.re * z.re) + (z.im * z.im);
(* generates a fpu exception if denom=0 as for reals *) (* generates a fpu exception if denom=0 as for reals *)
result.re:=z.re/denom; result.re:=z.re/denom;
result.im:=-z.im/denom; result.im:=-z.im/denom;
RETURN result RETURN result
END CInv; END CInv;
(* direct trigonometric functions *) (* direct trigonometric functions *)
(* Косинус. (* Косинус.
complex cosinus *) complex cosinus *)
(* cos(x+iy) = cos(x).cos(iy) - sin(x).sin(iy) *) (* cos(x+iy) = cos(x).cos(iy) - sin(x).sin(iy) *)
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *) (* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *)
PROCEDURE CCos* (z: complex): complex; PROCEDURE CCos* (z: complex): complex;
BEGIN BEGIN
result.re := Math.cos(z.re) * Math.cosh(z.im); result.re := Math.cos(z.re) * Math.cosh(z.im);
result.im := - Math.sin(z.re) * Math.sinh(z.im); result.im := - Math.sin(z.re) * Math.sinh(z.im);
RETURN result RETURN result
END CCos; END CCos;
(* Синус. (* Синус.
sinus complex *) sinus complex *)
(* sin(x+iy) = sin(x).cos(iy) + cos(x).sin(iy) *) (* sin(x+iy) = sin(x).cos(iy) + cos(x).sin(iy) *)
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *) (* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *)
PROCEDURE CSin (z: complex): complex; PROCEDURE CSin (z: complex): complex;
BEGIN BEGIN
result.re := Math.sin(z.re) * Math.cosh(z.im); result.re := Math.sin(z.re) * Math.cosh(z.im);
result.im := Math.cos(z.re) * Math.sinh(z.im); result.im := Math.cos(z.re) * Math.sinh(z.im);
RETURN result RETURN result
END CSin; END CSin;
(* Тангенс. (* Тангенс.
tangente *) tangente *)
PROCEDURE CTg* (z: complex): complex; PROCEDURE CTg* (z: complex): complex;
VAR VAR
temp1, temp2: complex; temp1, temp2: complex;
BEGIN BEGIN
temp1:=CSin(z); temp1:=CSin(z);
temp2:=CCos(z); temp2:=CCos(z);
result:=CDiv(temp1, temp2); result:=CDiv(temp1, temp2);
RETURN result RETURN result
END CTg; END CTg;
(* inverse complex hyperbolic functions *) (* inverse complex hyperbolic functions *)
(* Гиперболический арккосинус. (* Гиперболический арккосинус.
hyberbolic arg cosinus *) hyberbolic arg cosinus *)
(* _________ *) (* _________ *)
(* argch(z) = -/+ ln(z + i.V 1 - z.z) *) (* argch(z) = -/+ ln(z + i.V 1 - z.z) *)
PROCEDURE CArcCosh* (z : complex): complex; PROCEDURE CArcCosh* (z : complex): complex;
BEGIN BEGIN
result:=CNeg(CLn(CAdd(z, CMul(i, CSqrt(CSub_r2(1.0, CMul(z, z))))))); result:=CNeg(CLn(CAdd(z, CMul(i, CSqrt(CSub_r2(1.0, CMul(z, z)))))));
RETURN result RETURN result
END CArcCosh; END CArcCosh;
(* Гиперболический арксинус. (* Гиперболический арксинус.
hyperbolic arc sinus *) hyperbolic arc sinus *)
(* ________ *) (* ________ *)
(* argsh(z) = ln(z + V 1 + z.z) *) (* argsh(z) = ln(z + V 1 + z.z) *)
PROCEDURE CArcSinh* (z : complex): complex; PROCEDURE CArcSinh* (z : complex): complex;
BEGIN BEGIN
result:=CLn(CAdd(z, CSqrt(CAdd_r(CMul(z, z), 1.0)))); result:=CLn(CAdd(z, CSqrt(CAdd_r(CMul(z, z), 1.0))));
RETURN result RETURN result
END CArcSinh; END CArcSinh;
(* Гиперболический арктангенс. (* Гиперболический арктангенс.
hyperbolic arc tangent *) hyperbolic arc tangent *)
(* argth(z) = 1/2 ln((z + 1) / (1 - z)) *) (* argth(z) = 1/2 ln((z + 1) / (1 - z)) *)
PROCEDURE CArcTgh (z : complex): complex; PROCEDURE CArcTgh (z : complex): complex;
BEGIN BEGIN
result:=CDiv_r(CLn(CDiv(CAdd_r(z, 1.0), CSub_r2(1.0, z))), 2.0); result:=CDiv_r(CLn(CDiv(CAdd_r(z, 1.0), CSub_r2(1.0, z))), 2.0);
RETURN result RETURN result
END CArcTgh; END CArcTgh;
(* trigonometriques inverses *) (* trigonometriques inverses *)
(* Арккосинус. (* Арккосинус.
arc cosinus complex *) arc cosinus complex *)
(* arccos(z) = -i.argch(z) *) (* arccos(z) = -i.argch(z) *)
PROCEDURE CArcCos* (z: complex): complex; PROCEDURE CArcCos* (z: complex): complex;
BEGIN BEGIN
result := CNeg(CMul(i, CArcCosh(z))); result := CNeg(CMul(i, CArcCosh(z)));
RETURN result RETURN result
END CArcCos; END CArcCos;
(* Арксинус. (* Арксинус.
arc sinus complex *) arc sinus complex *)
(* arcsin(z) = -i.argsh(i.z) *) (* arcsin(z) = -i.argsh(i.z) *)
PROCEDURE CArcSin* (z : complex): complex; PROCEDURE CArcSin* (z : complex): complex;
BEGIN BEGIN
result := CNeg(CMul(i, CArcSinh(z))); result := CNeg(CMul(i, CArcSinh(z)));
RETURN result RETURN result
END CArcSin; END CArcSin;
(* Арктангенс. (* Арктангенс.
arc tangente complex *) arc tangente complex *)
(* arctg(z) = -i.argth(i.z) *) (* arctg(z) = -i.argth(i.z) *)
PROCEDURE CArcTg* (z : complex): complex; PROCEDURE CArcTg* (z : complex): complex;
BEGIN BEGIN
result := CNeg(CMul(i, CArcTgh(CMul(i, z)))); result := CNeg(CMul(i, CArcTgh(CMul(i, z))));
RETURN result RETURN result
END CArcTg; END CArcTg;
BEGIN BEGIN
result:=CInit(0.0, 0.0); result:=CInit(0.0, 0.0);
i :=CInit(0.0, 1.0); i :=CInit(0.0, 1.0);
_0:=CInit(0.0, 0.0); _0:=CInit(0.0, 0.0);
END CMath. END CMath.

66
programs/develop/oberon07/lib/Math/MathBits.ob07
View File

@ -1,33 +1,33 @@
(* **************************************** (* ****************************************
Дополнение к модулю Math. Дополнение к модулю Math.
Побитовые операции над целыми числами. Побитовые операции над целыми числами.
Вадим Исаев, 2020 Вадим Исаев, 2020
Additional functions to the module Math. Additional functions to the module Math.
Bitwise operations on integers. Bitwise operations on integers.
Vadim Isaev, 2020 Vadim Isaev, 2020
******************************************* *) ******************************************* *)
MODULE MathBits; MODULE MathBits;
PROCEDURE iand* (x, y: INTEGER): INTEGER; PROCEDURE iand* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) * BITS(y)) RETURN ORD(BITS(x) * BITS(y))
END iand; END iand;
PROCEDURE ior* (x, y: INTEGER): INTEGER; PROCEDURE ior* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) + BITS(y)) RETURN ORD(BITS(x) + BITS(y))
END ior; END ior;
PROCEDURE ixor* (x, y: INTEGER): INTEGER; PROCEDURE ixor* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) / BITS(y)) RETURN ORD(BITS(x) / BITS(y))
END ixor; END ixor;
PROCEDURE inot* (x: INTEGER): INTEGER; PROCEDURE inot* (x: INTEGER): INTEGER;
RETURN ORD(-BITS(x)) RETURN ORD(-BITS(x))
END inot; END inot;
END MathBits. END MathBits.

196
programs/develop/oberon07/lib/Math/MathRound.ob07
View File

@ -1,99 +1,99 @@
(* ****************************************** (* ******************************************
Дополнительные функции к модулю Math. Дополнительные функции к модулю Math.
Функции округления. Функции округления.
Вадим Исаев, 2020 Вадим Исаев, 2020
------------------------------------- -------------------------------------
Additional functions to the module Math. Additional functions to the module Math.
Rounding functions. Rounding functions.
Vadim Isaev, 2020 Vadim Isaev, 2020
********************************************* *) ********************************************* *)
MODULE MathRound; MODULE MathRound;
IMPORT Math; IMPORT Math;
(* Возвращается целая часть числа x. (* Возвращается целая часть числа x.
Returns the integer part of a argument x.*) Returns the integer part of a argument x.*)
PROCEDURE trunc* (x: REAL): REAL; PROCEDURE trunc* (x: REAL): REAL;
VAR VAR
a: REAL; a: REAL;
BEGIN BEGIN
a := FLT(FLOOR(x)); a := FLT(FLOOR(x));
IF (x < 0.0) & (x # a) THEN IF (x < 0.0) & (x # a) THEN
a := a + 1.0 a := a + 1.0
END END
RETURN a RETURN a
END trunc; END trunc;
(* Возвращается дробная часть числа x. (* Возвращается дробная часть числа x.
Returns the fractional part of the argument x *) Returns the fractional part of the argument x *)
PROCEDURE frac* (x: REAL): REAL; PROCEDURE frac* (x: REAL): REAL;
RETURN x - trunc(x) RETURN x - trunc(x)
END frac; END frac;
(* Округление к ближайшему целому. (* Округление к ближайшему целому.
Rounding to the nearest integer. *) Rounding to the nearest integer. *)
PROCEDURE round* (x: REAL): REAL; PROCEDURE round* (x: REAL): REAL;
VAR VAR
a: REAL; a: REAL;
BEGIN BEGIN
a := trunc(x); a := trunc(x);
IF ABS(frac(x)) >= 0.5 THEN IF ABS(frac(x)) >= 0.5 THEN
a := a + FLT(Math.sgn(x)) a := a + FLT(Math.sgn(x))
END END
RETURN a RETURN a
END round; END round;
(* Округление к бОльшему целому. (* Округление к бОльшему целому.
Rounding to a largest integer *) Rounding to a largest integer *)
PROCEDURE ceil* (x: REAL): REAL; PROCEDURE ceil* (x: REAL): REAL;
VAR VAR
a: REAL; a: REAL;
BEGIN BEGIN
a := FLT(FLOOR(x)); a := FLT(FLOOR(x));
IF x # a THEN IF x # a THEN
a := a + 1.0 a := a + 1.0
END END
RETURN a RETURN a
END ceil; END ceil;
(* Округление к меньшему целому. (* Округление к меньшему целому.
Rounding to a smallest integer *) Rounding to a smallest integer *)
PROCEDURE floor* (x: REAL): REAL; PROCEDURE floor* (x: REAL): REAL;
RETURN FLT(FLOOR(x)) RETURN FLT(FLOOR(x))
END floor; END floor;
(* Округление до определённого количества знаков: (* Округление до определённого количества знаков:
- если Digits отрицательное, то округление - если Digits отрицательное, то округление
в знаках после десятичной запятой; в знаках после десятичной запятой;
- если Digits положительное, то округление - если Digits положительное, то округление
в знаках до запятой *) в знаках до запятой *)
PROCEDURE SimpleRoundTo* (AValue: REAL; Digits: INTEGER): REAL; PROCEDURE SimpleRoundTo* (AValue: REAL; Digits: INTEGER): REAL;
VAR VAR
RV, a : REAL; RV, a : REAL;
BEGIN BEGIN
RV := Math.ipower(10.0, -Digits); RV := Math.ipower(10.0, -Digits);
IF AValue < 0.0 THEN IF AValue < 0.0 THEN
a := trunc((AValue * RV) - 0.5) a := trunc((AValue * RV) - 0.5)
ELSE ELSE
a := trunc((AValue * RV) + 0.5) a := trunc((AValue * RV) + 0.5)
END END
RETURN a / RV RETURN a / RV
END SimpleRoundTo; END SimpleRoundTo;
END MathRound. END MathRound.

474
programs/develop/oberon07/lib/Math/MathStat.ob07
View File

@ -1,238 +1,238 @@
(* ******************************************** (* ********************************************
Дополнение к модулю Math. Дополнение к модулю Math.
Статистические процедуры. Статистические процедуры.
------------------------------------- -------------------------------------
Additional functions to the module Math. Additional functions to the module Math.
Statistical functions Statistical functions
*********************************************** *) *********************************************** *)
MODULE MathStat; MODULE MathStat;
IMPORT Math; IMPORT Math;
(*Минимальное значение. Нецелое *) (*Минимальное значение. Нецелое *)
PROCEDURE MinValue* (data: ARRAY OF REAL; N: INTEGER): REAL; PROCEDURE MinValue* (data: ARRAY OF REAL; N: INTEGER): REAL;
VAR VAR
i: INTEGER; i: INTEGER;
a: REAL; a: REAL;
BEGIN BEGIN
a := data[0]; a := data[0];
FOR i := 1 TO N - 1 DO FOR i := 1 TO N - 1 DO
IF data[i] < a THEN IF data[i] < a THEN
a := data[i] a := data[i]
END END
END END
RETURN a RETURN a
END MinValue; END MinValue;
(*Минимальное значение. Целое *) (*Минимальное значение. Целое *)
PROCEDURE MinIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER; PROCEDURE MinIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER;
VAR VAR
i: INTEGER; i: INTEGER;
a: INTEGER; a: INTEGER;
BEGIN BEGIN
a := data[0]; a := data[0];
FOR i := 1 TO N - 1 DO FOR i := 1 TO N - 1 DO
IF data[i] < a THEN IF data[i] < a THEN
a := data[i] a := data[i]
END END
END END
RETURN a RETURN a
END MinIntValue; END MinIntValue;
(*Максимальное значение. Нецелое *) (*Максимальное значение. Нецелое *)
PROCEDURE MaxValue* (data: ARRAY OF REAL; N: INTEGER): REAL; PROCEDURE MaxValue* (data: ARRAY OF REAL; N: INTEGER): REAL;
VAR VAR
i: INTEGER; i: INTEGER;
a: REAL; a: REAL;
BEGIN BEGIN
a := data[0]; a := data[0];
FOR i := 1 TO N - 1 DO FOR i := 1 TO N - 1 DO
IF data[i] > a THEN IF data[i] > a THEN
a := data[i] a := data[i]
END END
END END
RETURN a RETURN a
END MaxValue; END MaxValue;
(*Максимальное значение. Целое *) (*Максимальное значение. Целое *)
PROCEDURE MaxIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER; PROCEDURE MaxIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER;
VAR VAR
i: INTEGER; i: INTEGER;
a: INTEGER; a: INTEGER;
BEGIN BEGIN
a := data[0]; a := data[0];
FOR i := 1 TO N - 1 DO FOR i := 1 TO N - 1 DO
IF data[i] > a THEN IF data[i] > a THEN
a := data[i] a := data[i]
END END
END END
RETURN a RETURN a
END MaxIntValue; END MaxIntValue;
(* Сумма значений массива *) (* Сумма значений массива *)
PROCEDURE Sum* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE Sum* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR VAR
a: REAL; a: REAL;
i: INTEGER; i: INTEGER;
BEGIN BEGIN
a := 0.0; a := 0.0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
a := a + data[i] a := a + data[i]
END END
RETURN a RETURN a
END Sum; END Sum;
(* Сумма целых значений массива *) (* Сумма целых значений массива *)
PROCEDURE SumInt* (data: ARRAY OF INTEGER; Count: INTEGER): INTEGER; PROCEDURE SumInt* (data: ARRAY OF INTEGER; Count: INTEGER): INTEGER;
VAR VAR
a: INTEGER; a: INTEGER;
i: INTEGER; i: INTEGER;
BEGIN BEGIN
a := 0; a := 0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
a := a + data[i] a := a + data[i]
END END
RETURN a RETURN a
END SumInt; END SumInt;
(* Сумма квадратов значений массива *) (* Сумма квадратов значений массива *)
PROCEDURE SumOfSquares* (data : ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE SumOfSquares* (data : ARRAY OF REAL; Count: INTEGER): REAL;
VAR VAR
a: REAL; a: REAL;
i: INTEGER; i: INTEGER;
BEGIN BEGIN
a := 0.0; a := 0.0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
a := a + Math.sqrr(data[i]) a := a + Math.sqrr(data[i])
END END
RETURN a RETURN a
END SumOfSquares; END SumOfSquares;
(* Сумма значений и сумма квадратов значений массмва *) (* Сумма значений и сумма квадратов значений массмва *)
PROCEDURE SumsAndSquares* (data: ARRAY OF REAL; Count : INTEGER; PROCEDURE SumsAndSquares* (data: ARRAY OF REAL; Count : INTEGER;
VAR sum, sumofsquares : REAL); VAR sum, sumofsquares : REAL);
VAR VAR
i: INTEGER; i: INTEGER;
temp: REAL; temp: REAL;
BEGIN BEGIN
sumofsquares := 0.0; sumofsquares := 0.0;
sum := 0.0; sum := 0.0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
temp := data[i]; temp := data[i];
sumofsquares := sumofsquares + Math.sqrr(temp); sumofsquares := sumofsquares + Math.sqrr(temp);
sum := sum + temp sum := sum + temp
END END
END SumsAndSquares; END SumsAndSquares;
(* Средниее значений массива *) (* Средниее значений массива *)
PROCEDURE Mean* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE Mean* (data: ARRAY OF REAL; Count: INTEGER): REAL;
RETURN Sum(data, Count) / FLT(Count) RETURN Sum(data, Count) / FLT(Count)
END Mean; END Mean;
PROCEDURE MeanAndTotalVariance* (data: ARRAY OF REAL; Count: INTEGER; PROCEDURE MeanAndTotalVariance* (data: ARRAY OF REAL; Count: INTEGER;
VAR mu: REAL; VAR variance: REAL); VAR mu: REAL; VAR variance: REAL);
VAR VAR
i: INTEGER; i: INTEGER;
BEGIN BEGIN
mu := Mean(data, Count); mu := Mean(data, Count);
variance := 0.0; variance := 0.0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
variance := variance + Math.sqrr(data[i] - mu) variance := variance + Math.sqrr(data[i] - mu)
END END
END MeanAndTotalVariance; END MeanAndTotalVariance;
(* Вычисление статистической дисперсии равной сумме квадратов разницы (* Вычисление статистической дисперсии равной сумме квадратов разницы
между каждым конкретным значением массива Data и средним значением *) между каждым конкретным значением массива Data и средним значением *)
PROCEDURE TotalVariance* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE TotalVariance* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR VAR
mu, tv: REAL; mu, tv: REAL;
BEGIN BEGIN
MeanAndTotalVariance(data, Count, mu, tv) MeanAndTotalVariance(data, Count, mu, tv)
RETURN tv RETURN tv
END TotalVariance; END TotalVariance;
(* Типовая дисперсия всех значений массива *) (* Типовая дисперсия всех значений массива *)
PROCEDURE Variance* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE Variance* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR VAR
a: REAL; a: REAL;
BEGIN BEGIN
IF Count = 1 THEN IF Count = 1 THEN
a := 0.0 a := 0.0
ELSE ELSE
a := TotalVariance(data, Count) / FLT(Count - 1) a := TotalVariance(data, Count) / FLT(Count - 1)
END END
RETURN a RETURN a
END Variance; END Variance;
(* Стандартное среднеквадратичное отклонение *) (* Стандартное среднеквадратичное отклонение *)
PROCEDURE StdDev* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE StdDev* (data: ARRAY OF REAL; Count: INTEGER): REAL;
RETURN Math.sqrt(Variance(data, Count)) RETURN Math.sqrt(Variance(data, Count))
END StdDev; END StdDev;
(* Среднее арифметическое всех значений массива, и среднее отклонение *) (* Среднее арифметическое всех значений массива, и среднее отклонение *)
PROCEDURE MeanAndStdDev* (data: ARRAY OF REAL; Count: INTEGER; PROCEDURE MeanAndStdDev* (data: ARRAY OF REAL; Count: INTEGER;
VAR mean: REAL; VAR stdDev: REAL); VAR mean: REAL; VAR stdDev: REAL);
VAR VAR
totalVariance: REAL; totalVariance: REAL;
BEGIN BEGIN
MeanAndTotalVariance(data, Count, mean, totalVariance); MeanAndTotalVariance(data, Count, mean, totalVariance);
IF Count < 2 THEN IF Count < 2 THEN
stdDev := 0.0 stdDev := 0.0
ELSE ELSE
stdDev := Math.sqrt(totalVariance / FLT(Count - 1)) stdDev := Math.sqrt(totalVariance / FLT(Count - 1))
END END
END MeanAndStdDev; END MeanAndStdDev;
(* Евклидова норма для всех значений массива *) (* Евклидова норма для всех значений массива *)
PROCEDURE Norm* (data: ARRAY OF REAL; Count: INTEGER): REAL; PROCEDURE Norm* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR VAR
a: REAL; a: REAL;
i: INTEGER; i: INTEGER;
BEGIN BEGIN
a := 0.0; a := 0.0;
FOR i := 0 TO Count - 1 DO FOR i := 0 TO Count - 1 DO
a := a + Math.sqrr(data[i]) a := a + Math.sqrr(data[i])
END END
RETURN Math.sqrt(a) RETURN Math.sqrt(a)
END Norm; END Norm;
END MathStat. END MathStat.

160
programs/develop/oberon07/lib/Math/Rand.ob07
View File

@ -1,81 +1,81 @@
(* ************************************ (* ************************************
Генератор какбыслучайных чисел, Генератор какбыслучайных чисел,
Линейный конгруэнтный метод, Линейный конгруэнтный метод,
алгоритм Лемера. алгоритм Лемера.
Вадим Исаев, 2020 Вадим Исаев, 2020
------------------------------- -------------------------------
Generator pseudorandom numbers, Generator pseudorandom numbers,
Linear congruential generator, Linear congruential generator,
Algorithm by D. H. Lehmer. Algorithm by D. H. Lehmer.
Vadim Isaev, 2020 Vadim Isaev, 2020
*************************************** *) *************************************** *)
MODULE Rand; MODULE Rand;
IMPORT HOST, Math; IMPORT HOST, Math;
CONST CONST
RAND_MAX = 2147483647; RAND_MAX = 2147483647;
VAR VAR
seed: INTEGER; seed: INTEGER;
PROCEDURE Randomize*; PROCEDURE Randomize*;
BEGIN BEGIN
seed := HOST.GetTickCount() seed := HOST.GetTickCount()
END Randomize; END Randomize;
(* Целые какбыслучайные числа до RAND_MAX *) (* Целые какбыслучайные числа до RAND_MAX *)
PROCEDURE RandomI* (): INTEGER; PROCEDURE RandomI* (): INTEGER;
CONST CONST
a = 630360016; a = 630360016;
BEGIN BEGIN
seed := (a * seed) MOD RAND_MAX seed := (a * seed) MOD RAND_MAX
RETURN seed RETURN seed
END RandomI; END RandomI;
(* Какбыслучайные числа с плавающей запятой от 0 до 1 *) (* Какбыслучайные числа с плавающей запятой от 0 до 1 *)
PROCEDURE RandomR* (): REAL; PROCEDURE RandomR* (): REAL;
RETURN FLT(RandomI()) / FLT(RAND_MAX) RETURN FLT(RandomI()) / FLT(RAND_MAX)
END RandomR; END RandomR;
(* Какбыслучайное число в диапазоне от 0 до l. (* Какбыслучайное число в диапазоне от 0 до l.
Return a random number in a range 0 ... l *) Return a random number in a range 0 ... l *)
PROCEDURE RandomITo* (aTo: INTEGER): INTEGER; PROCEDURE RandomITo* (aTo: INTEGER): INTEGER;
RETURN FLOOR(RandomR() * FLT(aTo)) RETURN FLOOR(RandomR() * FLT(aTo))
END RandomITo; END RandomITo;
(* Какбыслучайное число в диапазоне. (* Какбыслучайное число в диапазоне.
Return a random number in a range *) Return a random number in a range *)
PROCEDURE RandomIRange* (aFrom, aTo: INTEGER): INTEGER; PROCEDURE RandomIRange* (aFrom, aTo: INTEGER): INTEGER;
RETURN FLOOR(RandomR() * FLT(aTo - aFrom)) + aFrom RETURN FLOOR(RandomR() * FLT(aTo - aFrom)) + aFrom
END RandomIRange; END RandomIRange;
(* Какбыслучайное число. Распределение Гаусса *) (* Какбыслучайное число. Распределение Гаусса *)
PROCEDURE RandG* (mean, stddev: REAL): REAL; PROCEDURE RandG* (mean, stddev: REAL): REAL;
VAR VAR
U, S: REAL; U, S: REAL;
BEGIN BEGIN
REPEAT REPEAT
U := 2.0 * RandomR() - 1.0; U := 2.0 * RandomR() - 1.0;
S := Math.sqrr(U) + Math.sqrr(2.0 * RandomR() - 1.0) S := Math.sqrr(U) + Math.sqrr(2.0 * RandomR() - 1.0)
UNTIL (1.0E-20 < S) & (S <= 1.0) UNTIL (1.0E-20 < S) & (S <= 1.0)
RETURN Math.sqrt(-2.0 * Math.ln(S) / S) * U * stddev + mean RETURN Math.sqrt(-2.0 * Math.ln(S) / S) * U * stddev + mean
END RandG; END RandG;
BEGIN BEGIN
seed := 654321 seed := 654321
END Rand. END Rand.

596
programs/develop/oberon07/lib/Math/RandExt.ob07
View File

@ -1,298 +1,298 @@
(* ************************************************************ (* ************************************************************
Дополнительные алгоритмы генераторов какбыслучайных чисел. Дополнительные алгоритмы генераторов какбыслучайных чисел.
Вадим Исаев, 2020 Вадим Исаев, 2020
Additional generators of pseudorandom numbers. Additional generators of pseudorandom numbers.
Vadim Isaev, 2020 Vadim Isaev, 2020
************************************************************ *) ************************************************************ *)
MODULE RandExt; MODULE RandExt;
IMPORT HOST, MathRound, MathBits; IMPORT HOST, MathRound, MathBits;
CONST CONST
(* Для алгоритма Мерсена-Твистера *) (* Для алгоритма Мерсена-Твистера *)
N = 624; N = 624;
M = 397; M = 397;
MATRIX_A = 9908B0DFH; (* constant vector a *) MATRIX_A = 9908B0DFH; (* constant vector a *)
UPPER_MASK = 80000000H; (* most significant w-r bits *) UPPER_MASK = 80000000H; (* most significant w-r bits *)
LOWER_MASK = 7FFFFFFFH; (* least significant r bits *) LOWER_MASK = 7FFFFFFFH; (* least significant r bits *)
INT_MAX = 4294967295; INT_MAX = 4294967295;
TYPE TYPE
(* структура служебных данных, для алгоритма mrg32k3a *) (* структура служебных данных, для алгоритма mrg32k3a *)
random_t = RECORD random_t = RECORD
mrg32k3a_seed : REAL; mrg32k3a_seed : REAL;
mrg32k3a_x : ARRAY 3 OF REAL; mrg32k3a_x : ARRAY 3 OF REAL;
mrg32k3a_y : ARRAY 3 OF REAL mrg32k3a_y : ARRAY 3 OF REAL
END; END;
(* Для алгоритма Мерсена-Твистера *) (* Для алгоритма Мерсена-Твистера *)
MTKeyArray = ARRAY N OF INTEGER; MTKeyArray = ARRAY N OF INTEGER;
VAR VAR
(* Для алгоритма mrg32k3a *) (* Для алгоритма mrg32k3a *)
prndl: random_t; prndl: random_t;
(* Для алгоритма Мерсена-Твистера *) (* Для алгоритма Мерсена-Твистера *)
mt : MTKeyArray; (* the array for the state vector *) mt : MTKeyArray; (* the array for the state vector *)
mti : INTEGER; (* mti == N+1 means mt[N] is not initialized *) mti : INTEGER; (* mti == N+1 means mt[N] is not initialized *)
(* --------------------------------------------------------------------------- (* ---------------------------------------------------------------------------
Генератор какбыслучайных чисел в диапазоне [a,b]. Генератор какбыслучайных чисел в диапазоне [a,b].
Алгоритм 133б из книги "Агеев и др. - Бибилотека алгоритмов 101б-150б", Алгоритм 133б из книги "Агеев и др. - Бибилотека алгоритмов 101б-150б",
стр. 53. стр. 53.
Переделка из Algol на Oberon и доработка, Вадим Исаев, 2020 Переделка из Algol на Oberon и доработка, Вадим Исаев, 2020
Generator pseudorandom numbers, algorithm 133b from Generator pseudorandom numbers, algorithm 133b from
Comm ACM 5,10 (Oct 1962) 553. Comm ACM 5,10 (Oct 1962) 553.
Convert from Algol to Oberon Vadim Isaev, 2020. Convert from Algol to Oberon Vadim Isaev, 2020.
Входные параметры: Входные параметры:
a - начальное вычисляемое значение, тип REAL; a - начальное вычисляемое значение, тип REAL;
b - конечное вычисляемое значение, тип REAL; b - конечное вычисляемое значение, тип REAL;
seed - начальное значение для генерации случайного числа. seed - начальное значение для генерации случайного числа.
Должно быть в диапазоне от 10 000 000 000 до 34 359 738 368 (2^35), Должно быть в диапазоне от 10 000 000 000 до 34 359 738 368 (2^35),
нечётное. нечётное.
--------------------------------------------------------------------------- *) --------------------------------------------------------------------------- *)
PROCEDURE alg133b* (a, b: REAL; VAR seed: INTEGER): REAL; PROCEDURE alg133b* (a, b: REAL; VAR seed: INTEGER): REAL;
CONST CONST
m35 = 34359738368; m35 = 34359738368;
m36 = 68719476736; m36 = 68719476736;
m37 = 137438953472; m37 = 137438953472;
VAR VAR
x: INTEGER; x: INTEGER;
BEGIN BEGIN
IF seed # 0 THEN IF seed # 0 THEN
IF (seed MOD 2 = 0) THEN IF (seed MOD 2 = 0) THEN
seed := seed + 1 seed := seed + 1
END; END;
x:=seed; x:=seed;
seed:=0; seed:=0;
END; END;
x:=5*x; x:=5*x;
IF x>=m37 THEN IF x>=m37 THEN
x:=x-m37 x:=x-m37
END; END;
IF x>=m36 THEN IF x>=m36 THEN
x:=x-m36 x:=x-m36
END; END;
IF x>=m35 THEN IF x>=m35 THEN
x:=x-m35 x:=x-m35
END; END;
RETURN FLT(x) / FLT(m35) * (b - a) + a RETURN FLT(x) / FLT(m35) * (b - a) + a
END alg133b; END alg133b;
(* ---------------------------------------------------------- (* ----------------------------------------------------------
Генератор почти равномерно распределённых Генератор почти равномерно распределённых
какбыслучайных чисел mrg32k3a какбыслучайных чисел mrg32k3a
(Combined Multiple Recursive Generator) от 0 до 1. (Combined Multiple Recursive Generator) от 0 до 1.
Период повторения последовательности = 2^127 Период повторения последовательности = 2^127
Generator pseudorandom numbers, Generator pseudorandom numbers,
algorithm mrg32k3a. algorithm mrg32k3a.
Переделка из FreePascal на Oberon, Вадим Исаев, 2020 Переделка из FreePascal на Oberon, Вадим Исаев, 2020
Convert from FreePascal to Oberon, Vadim Isaev, 2020 Convert from FreePascal to Oberon, Vadim Isaev, 2020
---------------------------------------------------------- *) ---------------------------------------------------------- *)
(* Инициализация генератора. (* Инициализация генератора.
Входные параметры: Входные параметры:
seed - значение для инициализации. Любое. Если передать seed - значение для инициализации. Любое. Если передать
ноль, то вместо ноля будет подставлено кол-во ноль, то вместо ноля будет подставлено кол-во
процессорных тиков. *) процессорных тиков. *)
PROCEDURE mrg32k3a_init* (seed: REAL); PROCEDURE mrg32k3a_init* (seed: REAL);
BEGIN BEGIN
prndl.mrg32k3a_x[0] := 1.0; prndl.mrg32k3a_x[0] := 1.0;
prndl.mrg32k3a_x[1] := 1.0; prndl.mrg32k3a_x[1] := 1.0;
prndl.mrg32k3a_y[0] := 1.0; prndl.mrg32k3a_y[0] := 1.0;
prndl.mrg32k3a_y[1] := 1.0; prndl.mrg32k3a_y[1] := 1.0;
prndl.mrg32k3a_y[2] := 1.0; prndl.mrg32k3a_y[2] := 1.0;
IF seed # 0.0 THEN IF seed # 0.0 THEN
prndl.mrg32k3a_x[2] := seed; prndl.mrg32k3a_x[2] := seed;
ELSE ELSE
prndl.mrg32k3a_x[2] := FLT(HOST.GetTickCount()); prndl.mrg32k3a_x[2] := FLT(HOST.GetTickCount());
END; END;
END mrg32k3a_init; END mrg32k3a_init;
(* Генератор какбыслучайных чисел от 0.0 до 1.0. *) (* Генератор какбыслучайных чисел от 0.0 до 1.0. *)
PROCEDURE mrg32k3a* (): REAL; PROCEDURE mrg32k3a* (): REAL;
CONST CONST
(* random MRG32K3A algorithm constants *) (* random MRG32K3A algorithm constants *)
MRG32K3A_NORM = 2.328306549295728E-10; MRG32K3A_NORM = 2.328306549295728E-10;
MRG32K3A_M1 = 4294967087.0; MRG32K3A_M1 = 4294967087.0;
MRG32K3A_M2 = 4294944443.0; MRG32K3A_M2 = 4294944443.0;
MRG32K3A_A12 = 1403580.0; MRG32K3A_A12 = 1403580.0;
MRG32K3A_A13 = 810728.0; MRG32K3A_A13 = 810728.0;
MRG32K3A_A21 = 527612.0; MRG32K3A_A21 = 527612.0;
MRG32K3A_A23 = 1370589.0; MRG32K3A_A23 = 1370589.0;
RAND_BUFSIZE = 512; RAND_BUFSIZE = 512;
VAR VAR
xn, yn, result: REAL; xn, yn, result: REAL;
BEGIN BEGIN
(* Часть 1 *) (* Часть 1 *)
xn := MRG32K3A_A12 * prndl.mrg32k3a_x[1] - MRG32K3A_A13 * prndl.mrg32k3a_x[2]; xn := MRG32K3A_A12 * prndl.mrg32k3a_x[1] - MRG32K3A_A13 * prndl.mrg32k3a_x[2];
xn := xn - MathRound.trunc(xn / MRG32K3A_M1) * MRG32K3A_M1; xn := xn - MathRound.trunc(xn / MRG32K3A_M1) * MRG32K3A_M1;
IF xn < 0.0 THEN IF xn < 0.0 THEN
xn := xn + MRG32K3A_M1; xn := xn + MRG32K3A_M1;
END; END;
prndl.mrg32k3a_x[2] := prndl.mrg32k3a_x[1]; prndl.mrg32k3a_x[2] := prndl.mrg32k3a_x[1];
prndl.mrg32k3a_x[1] := prndl.mrg32k3a_x[0]; prndl.mrg32k3a_x[1] := prndl.mrg32k3a_x[0];
prndl.mrg32k3a_x[0] := xn; prndl.mrg32k3a_x[0] := xn;
(* Часть 2 *) (* Часть 2 *)
yn := MRG32K3A_A21 * prndl.mrg32k3a_y[0] - MRG32K3A_A23 * prndl.mrg32k3a_y[2]; yn := MRG32K3A_A21 * prndl.mrg32k3a_y[0] - MRG32K3A_A23 * prndl.mrg32k3a_y[2];
yn := yn - MathRound.trunc(yn / MRG32K3A_M2) * MRG32K3A_M2; yn := yn - MathRound.trunc(yn / MRG32K3A_M2) * MRG32K3A_M2;
IF yn < 0.0 THEN IF yn < 0.0 THEN
yn := yn + MRG32K3A_M2; yn := yn + MRG32K3A_M2;
END; END;
prndl.mrg32k3a_y[2] := prndl.mrg32k3a_y[1]; prndl.mrg32k3a_y[2] := prndl.mrg32k3a_y[1];
prndl.mrg32k3a_y[1] := prndl.mrg32k3a_y[0]; prndl.mrg32k3a_y[1] := prndl.mrg32k3a_y[0];
prndl.mrg32k3a_y[0] := yn; prndl.mrg32k3a_y[0] := yn;
(* Смешение частей *) (* Смешение частей *)
IF xn <= yn THEN IF xn <= yn THEN
result := ((xn - yn + MRG32K3A_M1) * MRG32K3A_NORM) result := ((xn - yn + MRG32K3A_M1) * MRG32K3A_NORM)
ELSE ELSE
result := (xn - yn) * MRG32K3A_NORM; result := (xn - yn) * MRG32K3A_NORM;
END; END;
RETURN result RETURN result
END mrg32k3a; END mrg32k3a;
(* ------------------------------------------------------------------- (* -------------------------------------------------------------------
Генератор какбыслучайных чисел, алгоритм Мерсена-Твистера (MT19937). Генератор какбыслучайных чисел, алгоритм Мерсена-Твистера (MT19937).
Переделка из Delphi в Oberon Вадим Исаев, 2020. Переделка из Delphi в Oberon Вадим Исаев, 2020.
Mersenne Twister Random Number Generator. Mersenne Twister Random Number Generator.
A C-program for MT19937, with initialization improved 2002/1/26. A C-program for MT19937, with initialization improved 2002/1/26.
Coded by Takuji Nishimura and Makoto Matsumoto. Coded by Takuji Nishimura and Makoto Matsumoto.
Adapted for DMath by Jean Debord - Feb. 2007 Adapted for DMath by Jean Debord - Feb. 2007
Adapted for Oberon-07 by Vadim Isaev - May 2020 Adapted for Oberon-07 by Vadim Isaev - May 2020
------------------------------------------------------------ *) ------------------------------------------------------------ *)
(* Initializes MT generator with a seed *) (* Initializes MT generator with a seed *)
PROCEDURE InitMT(Seed : INTEGER); PROCEDURE InitMT(Seed : INTEGER);
VAR VAR
i : INTEGER; i : INTEGER;
BEGIN BEGIN
mt[0] := MathBits.iand(Seed, INT_MAX); mt[0] := MathBits.iand(Seed, INT_MAX);
FOR i := 1 TO N-1 DO FOR i := 1 TO N-1 DO
mt[i] := (1812433253 * MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) + i); mt[i] := (1812433253 * MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) + i);
(* See Knuth TAOCP Vol2. 3rd Ed. P.106 For multiplier. (* See Knuth TAOCP Vol2. 3rd Ed. P.106 For multiplier.
In the previous versions, MSBs of the seed affect In the previous versions, MSBs of the seed affect
only MSBs of the array mt[]. only MSBs of the array mt[].
2002/01/09 modified by Makoto Matsumoto *) 2002/01/09 modified by Makoto Matsumoto *)
mt[i] := MathBits.iand(mt[i], INT_MAX); mt[i] := MathBits.iand(mt[i], INT_MAX);
(* For >32 Bit machines *) (* For >32 Bit machines *)
END; END;
mti := N; mti := N;
END InitMT; END InitMT;
(* Initialize MT generator with an array InitKey[0..(KeyLength - 1)] *) (* Initialize MT generator with an array InitKey[0..(KeyLength - 1)] *)
PROCEDURE InitMTbyArray(InitKey : MTKeyArray; KeyLength : INTEGER); PROCEDURE InitMTbyArray(InitKey : MTKeyArray; KeyLength : INTEGER);
VAR VAR
i, j, k, k1 : INTEGER; i, j, k, k1 : INTEGER;
BEGIN BEGIN
InitMT(19650218); InitMT(19650218);
i := 1; i := 1;
j := 0; j := 0;
IF N > KeyLength THEN IF N > KeyLength THEN
k1 := N k1 := N
ELSE ELSE
k1 := KeyLength; k1 := KeyLength;
END; END;
FOR k := k1 TO 1 BY -1 DO FOR k := k1 TO 1 BY -1 DO
(* non linear *) (* non linear *)
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1664525)) + InitKey[j] + j; mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1664525)) + InitKey[j] + j;
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *) mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *)
INC(i); INC(i);
INC(j); INC(j);
IF i >= N THEN IF i >= N THEN
mt[0] := mt[N-1]; mt[0] := mt[N-1];
i := 1; i := 1;
END; END;
IF j >= KeyLength THEN IF j >= KeyLength THEN
j := 0; j := 0;
END; END;
END; END;
FOR k := N-1 TO 1 BY -1 DO FOR k := N-1 TO 1 BY -1 DO
(* non linear *) (* non linear *)
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1566083941)) - i; mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1566083941)) - i;
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *) mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *)
INC(i); INC(i);
IF i >= N THEN IF i >= N THEN
mt[0] := mt[N-1]; mt[0] := mt[N-1];
i := 1; i := 1;
END; END;
END; END;
mt[0] := UPPER_MASK; (* MSB is 1; assuring non-zero initial array *) mt[0] := UPPER_MASK; (* MSB is 1; assuring non-zero initial array *)
END InitMTbyArray; END InitMTbyArray;
(* Generates a integer Random number on [-2^31 .. 2^31 - 1] interval *) (* Generates a integer Random number on [-2^31 .. 2^31 - 1] interval *)
PROCEDURE IRanMT(): INTEGER; PROCEDURE IRanMT(): INTEGER;
VAR VAR
mag01 : ARRAY 2 OF INTEGER; mag01 : ARRAY 2 OF INTEGER;
y,k : INTEGER; y,k : INTEGER;
BEGIN BEGIN
IF mti >= N THEN (* generate N words at one Time *) IF mti >= N THEN (* generate N words at one Time *)
(* If IRanMT() has not been called, a default initial seed is used *) (* If IRanMT() has not been called, a default initial seed is used *)
IF mti = N + 1 THEN IF mti = N + 1 THEN
InitMT(5489); InitMT(5489);
END; END;
FOR k := 0 TO (N-M)-1 DO FOR k := 0 TO (N-M)-1 DO
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK)); y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK));
mt[k] := MathBits.ixor(MathBits.ixor(mt[k+M], LSR(y, 1)), mag01[MathBits.iand(y, 1H)]); mt[k] := MathBits.ixor(MathBits.ixor(mt[k+M], LSR(y, 1)), mag01[MathBits.iand(y, 1H)]);
END; END;
FOR k := (N-M) TO (N-2) DO FOR k := (N-M) TO (N-2) DO
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK)); y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK));
mt[k] := MathBits.ixor(mt[k - (N - M)], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)])); mt[k] := MathBits.ixor(mt[k - (N - M)], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)]));
END; END;
y := MathBits.ior(MathBits.iand(mt[N-1], UPPER_MASK), MathBits.iand(mt[0], LOWER_MASK)); y := MathBits.ior(MathBits.iand(mt[N-1], UPPER_MASK), MathBits.iand(mt[0], LOWER_MASK));
mt[N-1] := MathBits.ixor(mt[M-1], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)])); mt[N-1] := MathBits.ixor(mt[M-1], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)]));
mti := 0; mti := 0;
END; END;
y := mt[mti]; y := mt[mti];
INC(mti); INC(mti);
(* Tempering *) (* Tempering *)
y := MathBits.ixor(y, LSR(y, 11)); y := MathBits.ixor(y, LSR(y, 11));
y := MathBits.ixor(y, MathBits.iand(LSL(y, 7), 9D2C5680H)); y := MathBits.ixor(y, MathBits.iand(LSL(y, 7), 9D2C5680H));
y := MathBits.ixor(y, MathBits.iand(LSL(y, 15), 4022730752)); y := MathBits.ixor(y, MathBits.iand(LSL(y, 15), 4022730752));
y := MathBits.ixor(y, LSR(y, 18)); y := MathBits.ixor(y, LSR(y, 18));
RETURN y RETURN y
END IRanMT; END IRanMT;
(* Generates a real Random number on [0..1] interval *) (* Generates a real Random number on [0..1] interval *)
PROCEDURE RRanMT(): REAL; PROCEDURE RRanMT(): REAL;
BEGIN BEGIN
RETURN FLT(IRanMT())/FLT(INT_MAX) RETURN FLT(IRanMT())/FLT(INT_MAX)
END RRanMT; END RRanMT;
END RandExt. END RandExt.

27
programs/develop/oberon07/source/AMD64.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -1152,14 +1152,13 @@ BEGIN
movrm(reg1, reg1, 0) movrm(reg1, reg1, 0)
|IL.opPARAM: |IL.opPARAM:
n := param2; IF param2 = 1 THEN
IF n = 1 THEN
UnOp(reg1); UnOp(reg1);
push(reg1); push(reg1);
drop drop
ELSE ELSE
ASSERT(R.top + 1 <= n); ASSERT(R.top + 1 <= param2);
PushAll(n) PushAll(param2)
END END
|IL.opJNZ1: |IL.opJNZ1:
@ -1344,8 +1343,8 @@ BEGIN
|IL.opNEW: |IL.opNEW:
PushAll(1); PushAll(1);
n := param2 + 8; n := param2 + 16;
ASSERT(UTILS.Align(n, 8)); ASSERT(UTILS.Align(n, 16));
pushc(n); pushc(n);
pushc(param1); pushc(param1);
CallRTL(IL._new) CallRTL(IL._new)
@ -1787,11 +1786,6 @@ BEGIN
X86._movrm(reg1, reg1, 0, param2 * 8, FALSE); X86._movrm(reg1, reg1, 0, param2 * 8, FALSE);
X86._movrm(reg1, reg2, 0, param2 * 8, TRUE) X86._movrm(reg1, reg2, 0, param2 * 8, TRUE)
|IL.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|IL.opCHKIDX: |IL.opCHKIDX:
UnOp(reg1); UnOp(reg1);
cmprc(reg1, param2); cmprc(reg1, param2);
@ -1832,14 +1826,6 @@ BEGIN
INCL(R.regs, reg1); INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1)) ASSERT(REG.GetReg(R, reg1))
|IL.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|IL.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP: |IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP:
UnOp(reg1); UnOp(reg1);
reg2 := GetAnyReg(); reg2 := GetAnyReg();
@ -2385,6 +2371,7 @@ VAR
BEGIN BEGIN
Xmm[0] := 0; Xmm[0] := 0;
X86.align16(TRUE);
tcount := CHL.Length(IL.codes.types); tcount := CHL.Length(IL.codes.types);
Win64RegPar[0] := rcx; Win64RegPar[0] := rcx;

31
programs/develop/oberon07/source/ARITH.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov Copyright (c) 2018-2022, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -217,7 +217,6 @@ END opFloat2;
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR VAR
value: REAL; value: REAL;
frac: REAL;
exp10: REAL; exp10: REAL;
i, n, d: INTEGER; i, n, d: INTEGER;
minus: BOOLEAN; minus: BOOLEAN;
@ -225,32 +224,24 @@ VAR
BEGIN BEGIN
error := 0; error := 0;
value := 0.0; value := 0.0;
frac := 0.0;
exp10 := 1.0;
minus := FALSE; minus := FALSE;
n := 0; n := 0;
i := 0; exp10 := 0.0;
WHILE (error = 0) & STRINGS.digit(s[i]) DO WHILE (error = 0) & (STRINGS.digit(s[i]) OR (s[i] = ".")) DO
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN IF s[i] = "." THEN
exp10 := 1.0;
INC(i) INC(i)
ELSE ELSE
error := 4 IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") & opFloat2(exp10, 10.0, "*") THEN
INC(i)
ELSE
error := 4
END
END END
END; END;
INC(i); IF ~opFloat2(value, exp10, "/") THEN
WHILE (error = 0) & STRINGS.digit(s[i]) DO
IF opFloat2(frac, 10.0, "*") & opFloat2(frac, FLT(digit[ORD(s[i])]), "+") THEN
exp10 := exp10 * 10.0;
INC(i)
ELSE
error := 4
END
END;
IF ~opFloat2(value, frac / exp10, "+") THEN
error := 4 error := 4
END; END;

11
programs/develop/oberon07/source/Compiler.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -48,6 +48,7 @@ VAR
BEGIN BEGIN
options.lower := TRUE;
out := ""; out := "";
checking := options.checking; checking := options.checking;
_end := FALSE; _end := FALSE;
@ -133,6 +134,9 @@ BEGIN
ELSIF param = "-lower" THEN ELSIF param = "-lower" THEN
options.lower := TRUE options.lower := TRUE
ELSIF param = "-upper" THEN
options.lower := FALSE
ELSIF param = "-pic" THEN ELSIF param = "-pic" THEN
options.pic := TRUE options.pic := TRUE
@ -215,7 +219,7 @@ BEGIN
C.Ln; C.Ln;
C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor); C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit) " + UTILS.Date); C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit) " + UTILS.Date);
C.StringLn("Copyright (c) 2018-2022, Anton Krotov"); C.StringLn("Copyright (c) 2018-2023, Anton Krotov");
IF inname = "" THEN IF inname = "" THEN
C.Ln; C.Ln;
@ -243,7 +247,8 @@ BEGIN
C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln; C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln;
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,"); C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,");
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln; C.StringLn(" BYTE, CHR, WCHR)"); C.Ln;
C.StringLn(" -lower allow lower case for keywords"); C.Ln; C.StringLn(" -lower allow lower case for keywords (default)"); C.Ln;
C.StringLn(" -upper only upper case for keywords"); C.Ln;
C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln; C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln;
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln; C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln; C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;

4
programs/develop/oberon07/source/FILES.ob07
View File

@ -1,13 +1,13 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov Copyright (c) 2018-2022, Anton Krotov
All rights reserved. All rights reserved.
*) *)
MODULE FILES; MODULE FILES;
IMPORT UTILS, C := COLLECTIONS, CONSOLE; IMPORT UTILS, C := COLLECTIONS;
TYPE TYPE

43
programs/develop/oberon07/source/IL.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -24,7 +24,7 @@ CONST
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; opDIV* = 10; opMOD* = 11; opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; opDIV* = 10; opMOD* = 11;
opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; opUMINUS* = 16; opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; opUMINUS* = 16;
opADD* = 17; opSUB* = 18; opONERR* = 19; opSUBL* = 20; opADDC* = 21; opSUBR* = 22; opADD* = 17; opSUB* = 18; opONERR* = 19; opSUBL* = 20; opADDC* = 21; opSUBR* = 22;
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28; opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; (*opCHKBYTE* = 27;*) opDROP* = 28;
opNOT* = 29; opNOT* = 29;
opEQ* = 30; opNE* = opEQ + 1; opLT* = opEQ + 2; opLE* = opEQ + 3; opGT* = opEQ + 4; opGE* = opEQ + 5 (* 35 *); opEQ* = 30; opNE* = opEQ + 1; opLT* = opEQ + 2; opLE* = opEQ + 3; opGT* = opEQ + 4; opGE* = opEQ + 5 (* 35 *);
@ -72,7 +72,7 @@ CONST
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173; opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opLENGTHW* = 179; opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opLENGTHW* = 179;
opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184; (*opCHR* = 180;*) opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184;
opLSR* = 185; opLSR1* = 186; opLSR2* = 187; opLSR* = 185; opLSR1* = 186; opLSR2* = 187;
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opSYSVALIGN16* = 192; opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opSYSVALIGN16* = 192;
opEQB* = 193; opNEB* = 194; opINF* = 195; opWIN64ALIGN16* = 196; opVLOAD8* = 197; opGLOAD8* = 198; opEQB* = 193; opNEB* = 194; opINF* = 195; opWIN64ALIGN16* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
@ -80,7 +80,7 @@ CONST
opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206; opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206;
opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212; opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212;
opSAVE16C* = 213; opWCHR* = 214; opHANDLER* = 215; opSAVE16C* = 213; (*opWCHR* = 214;*) opHANDLER* = 215;
opSYSVCALL* = 216; opSYSVCALLI* = 217; opSYSVCALLP* = 218; opFNAME* = 219; opFASTCALL* = 220; opSYSVCALL* = 216; opSYSVCALLI* = 217; opSYSVCALLP* = 218; opFNAME* = 219; opFASTCALL* = 220;
@ -265,12 +265,22 @@ BEGIN
END PutByte; END PutByte;
PROCEDURE AlignData (n: INTEGER);
BEGIN
WHILE CHL.Length(codes.data) MOD n # 0 DO
PutByte(0)
END
END AlignData;
PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER; PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER;
VAR VAR
i, n, res: INTEGER; i, n, res: INTEGER;
BEGIN BEGIN
IF TARGETS.WinLin THEN
AlignData(16)
END;
res := CHL.Length(codes.data); res := CHL.Length(codes.data);
i := 0; i := 0;
n := LENGTH(s); n := LENGTH(s);
WHILE i < n DO WHILE i < n DO
@ -290,6 +300,9 @@ VAR
BEGIN BEGIN
IF codes.charoffs[c] = -1 THEN IF codes.charoffs[c] = -1 THEN
IF TARGETS.WinLin THEN
AlignData(16)
END;
res := CHL.Length(codes.data); res := CHL.Length(codes.data);
PutByte(c); PutByte(c);
PutByte(0); PutByte(0);
@ -307,12 +320,12 @@ VAR
i, n, res: INTEGER; i, n, res: INTEGER;
BEGIN BEGIN
res := CHL.Length(codes.data); IF TARGETS.WinLin THEN
AlignData(16)
IF ODD(res) THEN ELSE
PutByte(0); AlignData(2)
INC(res)
END; END;
res := CHL.Length(codes.data);
n := STRINGS.Utf8To16(s, codes.wstr); n := STRINGS.Utf8To16(s, codes.wstr);
@ -341,12 +354,12 @@ VAR
BEGIN BEGIN
IF codes.wcharoffs[c] = -1 THEN IF codes.wcharoffs[c] = -1 THEN
res := CHL.Length(codes.data); IF TARGETS.WinLin THEN
AlignData(16)
IF ODD(res) THEN ELSE
PutByte(0); AlignData(2)
INC(res)
END; END;
res := CHL.Length(codes.data);
IF TARGETS.LittleEndian THEN IF TARGETS.LittleEndian THEN
PutByte(c MOD 256); PutByte(c MOD 256);

11
programs/develop/oberon07/source/MSP430.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov Copyright (c) 2019-2022, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -984,11 +984,6 @@ BEGIN
drop; drop;
Op2(opMOV + bw(param2 = 1), src_x(param1, SR), dst_x(0, reg2)) Op2(opMOV + bw(param2 = 1), src_x(param1, SR), dst_x(0, reg2))
|IL.opCHKBYTE:
BinOp(reg1, reg2);
Op2(opCMP, imm(256), reg1);
jcc(jb, param1)
|IL.opCHKIDX: |IL.opCHKIDX:
UnOp(reg1); UnOp(reg1);
Op2(opCMP, imm(param2), reg1); Op2(opCMP, imm(param2), reg1);
@ -1412,10 +1407,6 @@ BEGIN
Test(ACC); Test(ACC);
jcc(jne, param1) jcc(jne, param1)
|IL.opCHR:
UnOp(reg1);
Op2(opAND, imm(255), reg1)
|IL.opABS: |IL.opABS:
UnOp(reg1); UnOp(reg1);
Test(reg1); Test(reg1);

19
programs/develop/oberon07/source/PROG.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -41,6 +41,7 @@ CONST
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38; sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42; sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46; sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46;
sysVAL* = 47;
default32* = 2; _default32* = default32 + 1; default32* = 2; _default32* = default32 + 1;
stdcall* = 4; _stdcall* = stdcall + 1; stdcall* = 4; _stdcall* = stdcall + 1;
@ -239,13 +240,18 @@ END NewIdent;
PROCEDURE getOffset* (varIdent: IDENT): INTEGER; PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
VAR VAR
size: INTEGER; size, glob_align: INTEGER;
BEGIN BEGIN
IF varIdent.offset = -1 THEN IF varIdent.offset = -1 THEN
size := varIdent._type.size; size := varIdent._type.size;
IF varIdent.global THEN IF varIdent.global THEN
IF UTILS.Align(program.bss, varIdent._type.align) THEN IF TARGETS.WinLin THEN
glob_align := 16
ELSE
glob_align := varIdent._type.align
END;
IF UTILS.Align(program.bss, glob_align) THEN
IF UTILS.maxint - program.bss >= size THEN IF UTILS.maxint - program.bss >= size THEN
varIdent.offset := program.bss; varIdent.offset := program.bss;
INC(program.bss, size) INC(program.bss, size)
@ -1109,6 +1115,7 @@ BEGIN
EnterProc(unit, "put8", idSYSPROC, sysPUT8); EnterProc(unit, "put8", idSYSPROC, sysPUT8);
EnterProc(unit, "code", idSYSPROC, sysCODE); EnterProc(unit, "code", idSYSPROC, sysCODE);
EnterProc(unit, "move", idSYSPROC, sysMOVE); EnterProc(unit, "move", idSYSPROC, sysMOVE);
EnterProc(unit, "val", idSYSPROC, sysVAL);
(* (*
IF program.target.sys = mConst.Target_iMSP430 THEN IF program.target.sys = mConst.Target_iMSP430 THEN
EnterProc(unit, "nop", idSYSPROC, sysNOP); EnterProc(unit, "nop", idSYSPROC, sysNOP);
@ -1256,7 +1263,11 @@ BEGIN
IF TARGETS.RealSize # 0 THEN IF TARGETS.RealSize # 0 THEN
program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL); program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL.align := TARGETS.RealSize IF TARGETS.OS = TARGETS.osLINUX32 THEN
program.stTypes.tREAL.align := 4
ELSE
program.stTypes.tREAL.align := TARGETS.RealSize
END
END; END;
program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL); program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);

15
programs/develop/oberon07/source/RVMxI.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov Copyright (c) 2020-2022, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -790,14 +790,6 @@ BEGIN
UnOp(r1); UnOp(r1);
Emit(opLSRC, r1, param2 MOD (szWord * 8)) Emit(opLSRC, r1, param2 MOD (szWord * 8))
|IL.opCHR:
UnOp(r1);
Emit(opANDC, r1, 255)
|IL.opWCHR:
UnOp(r1);
Emit(opANDC, r1, 65535)
|IL.opABS: |IL.opABS:
UnOp(r1); UnOp(r1);
Emit(opCMPC, r1, 0); Emit(opCMPC, r1, 0);
@ -958,11 +950,6 @@ BEGIN
END; END;
drop drop
|IL.opCHKBYTE:
BinOp(r1, r2);
Emit(opCMPC, r1, 256);
Emit(opJBT, param1, 0)
|IL.opCHKIDX: |IL.opCHKIDX:
UnOp(r1); UnOp(r1);
Emit(opCMPC, r1, param2); Emit(opCMPC, r1, param2);

41
programs/develop/oberon07/source/STATEMENTS.ob07
View File

@ -402,12 +402,6 @@ BEGIN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value)) IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
END END
ELSE ELSE
IF chkBYTE IN Options.checking THEN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKBYTE, label, 0);
IL.OnError(line, errBYTE);
IL.SetLabel(label)
END;
IL.AddCmd0(IL.opSAVE8) IL.AddCmd0(IL.opSAVE8)
END END
END END
@ -1062,7 +1056,7 @@ BEGIN
IF chkCHR IN Options.checking THEN IF chkCHR IN Options.checking THEN
CheckRange(256, pos.line, errCHR) CheckRange(256, pos.line, errCHR)
ELSE ELSE
IL.AddCmd0(IL.opCHR) IL.AddCmd(IL.opMODR, 256)
END END
END END
@ -1077,7 +1071,7 @@ BEGIN
IF chkWCHR IN Options.checking THEN IF chkWCHR IN Options.checking THEN
CheckRange(65536, pos.line, errWCHR) CheckRange(65536, pos.line, errWCHR)
ELSE ELSE
IL.AddCmd0(IL.opWCHR) IL.AddCmd(IL.opMODR, 65536)
END END
END END
@ -1392,6 +1386,8 @@ VAR
field: PROG.FIELD; field: PROG.FIELD;
pos: PARS.POSITION; pos: PARS.POSITION;
t, idx: PARS.EXPR; t, idx: PARS.EXPR;
sysVal: BOOLEAN;
n: INTEGER;
PROCEDURE LoadAdr (e: PARS.EXPR); PROCEDURE LoadAdr (e: PARS.EXPR);
@ -1444,7 +1440,6 @@ VAR
_type: PROG._TYPE; _type: PROG._TYPE;
BEGIN BEGIN
IF chkIDX IN Options.checking THEN IF chkIDX IN Options.checking THEN
label := IL.NewLabel(); label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX2, label, 0); IL.AddCmd2(IL.opCHKIDX2, label, 0);
@ -1477,12 +1472,35 @@ VAR
BEGIN BEGIN
qualident(parser, e); qualident(parser, e);
sysVal := (e.obj = eSYSPROC) & (e.stproc = PROG.sysVAL);
IF sysVal THEN
PARS.checklex(parser, SCAN.lxLROUND);
PARS.Next(parser);
getpos(parser, pos);
designator(parser, e);
PARS.check(isVar(e), pos, 93);
IF PROG.isOpenArray(e._type) THEN
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END
END;
PARS.checklex(parser, SCAN.lxCOMMA);
PARS.Next(parser);
getpos(parser, pos);
qualident(parser, t);
PARS.check(t.obj = eTYPE, pos, 79);
e._type := t._type;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END;
IF e.obj IN {ePROC, eIMP} THEN IF e.obj IN {ePROC, eIMP} THEN
PROG.UseProc(parser.unit, e.ident.proc) PROG.UseProc(parser.unit, e.ident.proc)
END; END;
IF isVar(e) THEN IF isVar(e) & ~sysVal THEN
LoadAdr(e) LoadAdr(e)
END; END;
@ -2599,6 +2617,9 @@ BEGIN
NextPos(parser, pos); NextPos(parser, pos);
expression(parser, e1); expression(parser, e1);
IF (e._type.typ = PROG.tBYTE) & (e1.obj # eCONST) & (e1._type.typ = PROG.tINTEGER) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
IL.setlast(endcall.prev(IL.COMMAND)); IL.setlast(endcall.prev(IL.COMMAND));

5
programs/develop/oberon07/source/TARGETS.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov Copyright (c) 2019-2021, 2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -67,7 +67,7 @@ VAR
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER; target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER;
ComLinePar*, LibDir*, FileExt*: STRING; ComLinePar*, LibDir*, FileExt*: STRING;
Import*, Dispose*, RTL*, Dll*, LittleEndian*: BOOLEAN; Import*, Dispose*, RTL*, Dll*, LittleEndian*, WinLin*: BOOLEAN;
PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING); PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
@ -110,6 +110,7 @@ BEGIN
Dispose := ~(target IN noDISPOSE); Dispose := ~(target IN noDISPOSE);
RTL := ~(target IN noRTL); RTL := ~(target IN noRTL);
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL}; Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WinLin := OS IN {osWIN32, osLINUX32, osWIN64, osLINUX64};
WordSize := BitDepth DIV 8; WordSize := BitDepth DIV 8;
AdrSize := WordSize AdrSize := WordSize
END END

85
programs/develop/oberon07/source/THUMB.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov Copyright (c) 2019-2022, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -91,6 +91,10 @@ TYPE
RELOCCODE = ARRAY 7 OF INTEGER; RELOCCODE = ARRAY 7 OF INTEGER;
MEM = RECORD
start, size, startReserve, endReserve: INTEGER
END;
VAR VAR
@ -105,11 +109,9 @@ VAR
StkCount: INTEGER; StkCount: INTEGER;
Target: RECORD Target: RECORD
FlashAdr, flash, sram: MEM;
SRAMAdr,
IVTLen, IVTLen,
MinStack, MinStkSize: INTEGER;
Reserved: INTEGER;
InstrSet: SET; InstrSet: SET;
isNXP: BOOLEAN isNXP: BOOLEAN
END; END;
@ -1151,14 +1153,13 @@ BEGIN
PushAll(0) PushAll(0)
|IL.opPARAM: |IL.opPARAM:
n := param2; IF param2 = 1 THEN
IF n = 1 THEN
UnOp(r1); UnOp(r1);
push(r1); push(r1);
drop drop
ELSE ELSE
ASSERT(R.top + 1 <= n); ASSERT(R.top + 1 <= param2);
PushAll(n) PushAll(param2)
END END
|IL.opCLEANUP: |IL.opCLEANUP:
@ -1587,14 +1588,6 @@ BEGIN
Tst(r1); Tst(r1);
SetCC(jne, r1) SetCC(jne, r1)
|IL.opCHR:
UnOp(r1);
Code(0B2C0H + r1 * 9) (* uxtb r1, r1 *)
|IL.opWCHR:
UnOp(r1);
Code(0B280H + r1 * 9) (* uxth r1, r1 *)
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR: |IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
BinOp(r1, r2); BinOp(r1, r2);
Shift(opcode, r1, r2); Shift(opcode, r1, r2);
@ -1620,11 +1613,6 @@ BEGIN
END END
END END
|IL.opCHKBYTE:
BinOp(r1, r2);
CmpConst(r1, 256);
jcc(jb, param1)
|IL.opCHKIDX: |IL.opCHKIDX:
UnOp(r1); UnOp(r1);
CmpConst(r1, param2); CmpConst(r1, param2);
@ -2344,33 +2332,36 @@ BEGIN
END epilog; END epilog;
PROCEDURE SetTarget (FlashStart, SRAMStart: INTEGER; InstrSet: SET; isNXP: BOOLEAN); PROCEDURE SetTarget (FlashStart, FlashSize, FlashReserve, SRAMStart, SRAMSize, SRAMReserve: INTEGER; InstrSet: SET; isNXP: BOOLEAN);
BEGIN BEGIN
Target.FlashAdr := FlashStart; Target.flash.start := FlashStart;
Target.SRAMAdr := SRAMStart; Target.flash.size := FlashSize;
(*Target.flash.startReserve := 0;*)
Target.flash.endReserve := FlashReserve;
Target.sram.start := SRAMStart;
Target.sram.size := SRAMSize;
Target.sram.startReserve := 0;
Target.sram.endReserve := SRAMReserve;
Target.InstrSet := InstrSet; Target.InstrSet := InstrSet;
Target.isNXP := isNXP; Target.isNXP := isNXP;
Target.IVTLen := 256; (* >= 192 *) Target.IVTLen := 256; (* >= 192 *)
Target.Reserved := 0; Target.MinStkSize := 256;
Target.MinStack := 512;
END SetTarget; END SetTarget;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR VAR
opt: PROG.OPTIONS; opt: PROG.OPTIONS;
i, j, DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
ram, rom, i, j: INTEGER;
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
BEGIN BEGIN
ram := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
rom := MIN(MAX(options.rom, minROM), maxROM) * 1024;
IF target = TARGETS.STM32CM3 THEN IF target = TARGETS.STM32CM3 THEN
SetTarget(08000000H, 20000000H, CortexM3, FALSE) SetTarget(08000000H, MIN(MAX(options.rom, minROM), maxROM) * 1024, 0,
20000000H, MIN(MAX(options.ram, minRAM), maxRAM) * 1024, 0,
CortexM3, FALSE)
END; END;
tcount := CHL.Length(IL.codes.types); tcount := CHL.Length(IL.codes.types);
@ -2384,33 +2375,33 @@ BEGIN
StkCount := 0; StkCount := 0;
DataAdr := Target.SRAMAdr + Target.Reserved; DataAdr := Target.sram.start + Target.sram.startReserve;
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.Reserved; DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.sram.startReserve;
WHILE DataSize MOD 4 # 0 DO WHILE DataSize MOD 4 # 0 DO
CHL.PushByte(IL.codes.data, 0); CHL.PushByte(IL.codes.data, 0);
INC(DataSize) INC(DataSize)
END; END;
BssAdr := DataAdr + DataSize - Target.Reserved; BssAdr := DataAdr + DataSize - Target.sram.startReserve;
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4))); IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4)));
BssSize := IL.codes.bss; BssSize := IL.codes.bss;
ASSERT(UTILS.Align(BssSize, 4)); ASSERT(UTILS.Align(BssSize, 4));
prolog(BssSize, tcount, ORD(opt.pic), Target.SRAMAdr + ram, Target.IVTLen); prolog(BssSize, tcount, ORD(opt.pic), Target.sram.start + Target.sram.size - Target.sram.endReserve, Target.IVTLen);
translate(ORD(opt.pic), tcount * 4); translate(ORD(opt.pic), tcount * 4);
epilog; epilog;
fixup(Target.FlashAdr, DataAdr, BssAdr); fixup(Target.flash.start, DataAdr, BssAdr);
INC(DataSize, BssSize); INC(DataSize, BssSize);
CodeSize := CHL.Length(program.code); CodeSize := CHL.Length(program.code);
IF CodeSize > rom THEN IF CodeSize > Target.flash.size - Target.flash.endReserve THEN
ERRORS.Error(203) ERRORS.Error(203)
END; END;
IF DataSize > ram - Target.MinStack THEN IF DataSize > Target.sram.size - Target.MinStkSize - Target.sram.endReserve THEN
ERRORS.Error(204) ERRORS.Error(204)
END; END;
@ -2426,15 +2417,17 @@ BEGIN
WR.Create(outname); WR.Create(outname);
HEX.Data2(program.code, 0, CodeSize, high(Target.FlashAdr)); HEX.Data2(program.code, 0, CodeSize, high(Target.flash.start));
HEX.End; HEX.End;
WR.Close; WR.Close;
C.Dashes; C.Dashes;
C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(CodeSize * 100 DIV rom); C.StringLn("%)"); C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(Target.flash.size - Target.flash.endReserve);
C.String(" ("); C.Int(CodeSize * 100 DIV (Target.flash.size - Target.flash.endReserve)); C.StringLn("%)");
C.Ln; C.Ln;
C.String( " ram: "); C.Int(DataSize); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(DataSize * 100 DIV ram); C.StringLn("%)") C.String( " ram: "); C.Int(DataSize); C.String(" of "); C.Int(Target.sram.size - Target.sram.endReserve);
C.String(" ("); C.Int(DataSize * 100 DIV (Target.sram.size - Target.sram.endReserve)); C.StringLn("%)")
END CodeGen; END CodeGen;

6
programs/develop/oberon07/source/UTILS.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -23,8 +23,8 @@ CONST
max32* = 2147483647; max32* = 2147483647;
vMajor* = 1; vMajor* = 1;
vMinor* = 57; vMinor* = 63;
Date* = "31-aug-2022"; Date* = "21-jan-2023";
FILE_EXT* = ".ob07"; FILE_EXT* = ".ob07";
RTL_NAME* = "RTL"; RTL_NAME* = "RTL";

51
programs/develop/oberon07/source/X86.ob07
View File

@ -1,7 +1,7 @@
(* (*
BSD 2-Clause License BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov Copyright (c) 2018-2023, Anton Krotov
All rights reserved. All rights reserved.
*) *)
@ -954,14 +954,13 @@ BEGIN
jmp(param1) jmp(param1)
|IL.opPARAM: |IL.opPARAM:
n := param2; IF param2 = 1 THEN
IF n = 1 THEN
UnOp(reg1); UnOp(reg1);
push(reg1); push(reg1);
drop drop
ELSE ELSE
ASSERT(R.top + 1 <= n); ASSERT(R.top + 1 <= param2);
PushAll(n) PushAll(param2)
END END
|IL.opCLEANUP: |IL.opCLEANUP:
@ -1438,11 +1437,6 @@ BEGIN
pushc(param1); pushc(param1);
CallRTL(pic, IL._move) CallRTL(pic, IL._move)
|IL.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|IL.opCHKIDX: |IL.opCHKIDX:
UnOp(reg1); UnOp(reg1);
cmprc(reg1, param2); cmprc(reg1, param2);
@ -1557,14 +1551,6 @@ BEGIN
CallRTL(pic, IL._lengthw); CallRTL(pic, IL._lengthw);
GetRegA GetRegA
|IL.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|IL.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR: |IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
UnOp(reg1); UnOp(reg1);
IF reg1 # ecx THEN IF reg1 # ecx THEN
@ -1828,8 +1814,17 @@ BEGIN
|IL.opNEW: |IL.opNEW:
PushAll(1); PushAll(1);
n := param2 + 8; CASE TARGETS.OS OF
ASSERT(UTILS.Align(n, 32)); |TARGETS.osWIN32:
n := param2 + 4;
ASSERT(UTILS.Align(n, 4))
|TARGETS.osLINUX32:
n := param2 + 16;
ASSERT(UTILS.Align(n, 16))
|TARGETS.osKOS:
n := param2 + 8;
ASSERT(UTILS.Align(n, 32))
END;
pushc(n); pushc(n);
pushc(param1); pushc(param1);
CallRTL(pic, IL._new) CallRTL(pic, IL._new)
@ -2444,6 +2439,19 @@ BEGIN
END epilog; END epilog;
PROCEDURE align16* (bit64: BOOLEAN);
BEGIN
IF TARGETS.WinLin THEN
WHILE CHL.Length(IL.codes.data) MOD 16 # 0 DO
CHL.PushByte(IL.codes.data, 0)
END;
WHILE CHL.Length(IL.codes.types) MOD (4 - 2*ORD(bit64)) # 0 DO
CHL.PushInt(IL.codes.types, 0)
END
END
END align16;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR VAR
dllret, dllinit, sofinit: INTEGER; dllret, dllinit, sofinit: INTEGER;
@ -2451,6 +2459,7 @@ VAR
BEGIN BEGIN
FR[0] := 0; FR[0] := 0;
align16(FALSE);
tcount := CHL.Length(IL.codes.types); tcount := CHL.Length(IL.codes.types);
opt := options; opt := options;
@ -2476,7 +2485,6 @@ BEGIN
epilog(opt.pic, outname, target, opt.stack, opt.version, dllinit, dllret, sofinit); epilog(opt.pic, outname, target, opt.stack, opt.version, dllinit, dllret, sofinit);
BIN.fixup(program); BIN.fixup(program);
IF TARGETS.OS = TARGETS.osWIN32 THEN IF TARGETS.OS = TARGETS.osWIN32 THEN
PE32.write(program, outname, target = TARGETS.Win32C, target = TARGETS.Win32DLL, FALSE) PE32.write(program, outname, target = TARGETS.Win32C, target = TARGETS.Win32DLL, FALSE)
ELSIF target = TARGETS.KolibriOS THEN ELSIF target = TARGETS.KolibriOS THEN
@ -2486,7 +2494,6 @@ BEGIN
ELSIF TARGETS.OS = TARGETS.osLINUX32 THEN ELSIF TARGETS.OS = TARGETS.osLINUX32 THEN
ELF.write(program, outname, sofinit, target = TARGETS.Linux32SO, FALSE) ELF.write(program, outname, sofinit, target = TARGETS.Linux32SO, FALSE)
END END
END CodeGen; END CodeGen;