keXa/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests 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.
@ -20,27 +20,27 @@
MODULE Icons;
IMPORT
Graph, File, SYSTEM, KOSAPI;
Graph, File, SYSTEM, KOSAPI;
CONST
fileName = "/sys/Icons16.png";
SIZE* = 18;
fileName = "/sys/Icons16.png";
SIZE* = 18;
VAR
source: INTEGER;
source: INTEGER;
(*
PROCEDURE copy (src, dst: INTEGER);
VAR
src_width, src_height,
dst_width, dst_height,
src_data, dst_data: INTEGER;
src_width, src_height,
dst_width, dst_height,
src_data, dst_data: INTEGER;
BEGIN
LibImg.GetInf(src, src_width, src_height, src_data);
LibImg.GetInf(dst, dst_width, dst_height, dst_data);
ASSERT(src_width = dst_width);
ASSERT(src_height = dst_height);
SYSTEM.MOVE(src_data, dst_data, src_width*src_height*4)
LibImg.GetInf(src, src_width, src_height, src_data);
LibImg.GetInf(dst, dst_width, dst_height, dst_data);
ASSERT(src_width = dst_width);
ASSERT(src_height = dst_height);
SYSTEM.MOVE(src_data, dst_data, src_width*src_height*4)
END copy;
*)
@ -50,93 +50,93 @@ PROCEDURE [stdcall, "Libimg.obj", ""] img_destroy (img: INTEGER); END;
PROCEDURE GetInf (img: INTEGER; VAR width, height, data: INTEGER);
BEGIN
SYSTEM.GET(img + 4, width);
SYSTEM.GET(img + 8, height);
SYSTEM.GET(img + 24, data);
SYSTEM.GET(img + 4, width);
SYSTEM.GET(img + 8, height);
SYSTEM.GET(img + 24, data);
END GetInf;
PROCEDURE GetImg (ptr, size: INTEGER): INTEGER;
VAR
image_data, dst, x, type: INTEGER;
image_data, dst, x, Type: INTEGER;
BEGIN
image_data := img_decode(ptr, size, 0);
IF image_data # 0 THEN
SYSTEM.GET(image_data + 4, x);
ASSERT(x = SIZE);
SYSTEM.GET(image_data + 20, type);
IF type # 3 THEN
dst := img_convert(image_data, 0, 3, 0, 0);
img_destroy(image_data);
image_data := dst
END
END
RETURN image_data
image_data := img_decode(ptr, size, 0);
IF image_data # 0 THEN
SYSTEM.GET(image_data + 4, x);
ASSERT(x = SIZE);
SYSTEM.GET(image_data + 20, Type);
IF Type # 3 THEN
dst := img_convert(image_data, 0, 3, 0, 0);
img_destroy(image_data);
image_data := dst
END
END
RETURN image_data
END GetImg;
PROCEDURE load (): INTEGER;
VAR
size, res, ptr: INTEGER;
size, res, ptr: INTEGER;
BEGIN
res := 0;
ptr := File.Load(fileName, size);
IF ptr # 0 THEN
res := GetImg(ptr, size);
ptr := KOSAPI.free(ptr)
END
RETURN res
res := 0;
ptr := File.Load(fileName, size);
IF ptr # 0 THEN
res := GetImg(ptr, size);
ptr := KOSAPI.free(ptr)
END
RETURN res
END load;
PROCEDURE draw* (icons, n, x, y: INTEGER);
VAR
width, height, data: INTEGER;
width, height, data: INTEGER;
BEGIN
GetInf(icons, width, height, data);
KOSAPI.sysfunc7(65, data + SIZE*SIZE*4*n, SIZE*65536 + SIZE, x*65536 + y, 32, 0, 0)
GetInf(icons, width, height, data);
KOSAPI.sysfunc7(65, data + SIZE*SIZE*4*n, SIZE*65536 + SIZE, x*65536 + y, 32, 0, 0)
END draw;
PROCEDURE iconsBackColor (icons: INTEGER; BackColor: INTEGER);
VAR
width, height, data, x, y, pix: INTEGER;
b, g, r, gr: BYTE;
width, height, data, x, y, pix: INTEGER;
b, g, r, gr: BYTE;
BEGIN
GetInf(icons, width, height, data);
FOR y := 0 TO height - 1 DO
FOR x := 0 TO width - 1 DO
SYSTEM.GET32(data, pix);
Graph.getRGB(pix, r, g, b);
gr := (r + g + b) DIV 3;
IF BackColor = -1 THEN
pix := gr + 256*gr + 65536*gr
ELSIF gr = 255 THEN
pix := BackColor
END;
SYSTEM.PUT32(data, pix);
INC(data, 4)
END
END
GetInf(icons, width, height, data);
FOR y := 0 TO height - 1 DO
FOR x := 0 TO width - 1 DO
SYSTEM.GET32(data, pix);
Graph.getRGB(pix, r, g, b);
gr := (r + g + b) DIV 3;
IF BackColor = -1 THEN
pix := gr + 256*gr + 65536*gr
ELSIF gr = 255 THEN
pix := BackColor
END;
SYSTEM.PUT32(data, pix);
INC(data, 4)
END
END
END iconsBackColor;
PROCEDURE get* (VAR icons, grayIcons: INTEGER; BackColor: INTEGER);
BEGIN
IF source = 0 THEN
source := load();
icons := load();
grayIcons := load();
iconsBackColor(grayIcons, -1);
iconsBackColor(grayIcons, BackColor);
iconsBackColor(icons, BackColor)
(*ELSE
copy(source, icons);
copy(source, grayIcons)*)
END
IF source = 0 THEN
source := load();
icons := load();
grayIcons := load();
iconsBackColor(grayIcons, -1);
iconsBackColor(grayIcons, BackColor);
iconsBackColor(icons, BackColor)
(*ELSE
copy(source, icons);
copy(source, grayIcons)*)
END
END get;
BEGIN
source := 0
source := 0
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
Copyright (c) 2018-2022, Anton Krotov
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
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} ")"
<...>
{$ELSIF "(" ident {"|" ident} ")"}
<...>
[$ELSE]
<...>
$END
где ident:
- одно из возможных значений параметра <target> в командной строке
- пользовательский идентификатор, переданный с ключом -def при компиляции
- один из возможных предопределенных идентификаторов:
WINDOWS - приложение Windows
LINUX - приложение Linux
KOLIBRIOS - приложение KolibriOS
CPU_X86 - приложение для процессора x86 (32-бит)
CPU_X8664 - приложение для процессора x86_64
примеры:
$IF (win64con | win64gui | win64dll)
OS := "WIN64";
$ELSIF (win32con | win32gui | win32dll)
OS := "WIN32";
$ELSIF (linux64exe | linux64so)
OS := "LINUX64";
$ELSIF (linux32exe | linux32so)
OS := "LINUX32";
$ELSE
OS := "UNKNOWN";
$END
$IF (debug) (* -def debug *)
print("debug");
$END
$IF (WINDOWS)
$IF (CPU_X86)
(*windows 32*)
$ELSIF (CPU_X8664)
(*windows 64*)
$END
$ELSIF (LINUX)
$IF (CPU_X86)
(*linux 32*)
$ELSIF (CPU_X8664)
(*linux 64*)
$END
Условная компиляция
синтаксис:
$IF "(" ident {"|" ident} ")"
<...>
{$ELSIF "(" ident {"|" ident} ")"}
<...>
[$ELSE]
<...>
$END
где ident:
- одно из возможных значений параметра <target> в командной строке
- пользовательский идентификатор, переданный с ключом -def при компиляции
- один из возможных предопределенных идентификаторов:
WINDOWS - приложение Windows
LINUX - приложение Linux
KOLIBRIOS - приложение KolibriOS
CPU_X86 - приложение для процессора x86 (32-бит)
CPU_X8664 - приложение для процессора x86_64
примеры:
$IF (win64con | win64gui | win64dll)
OS := "WIN64";
$ELSIF (win32con | win32gui | win32dll)
OS := "WIN32";
$ELSIF (linux64exe | linux64so)
OS := "LINUX64";
$ELSIF (linux32exe | linux32so)
OS := "LINUX32";
$ELSE
OS := "UNKNOWN";
$END
$IF (debug) (* -def debug *)
print("debug");
$END
$IF (WINDOWS)
$IF (CPU_X86)
(*windows 32*)
$ELSIF (CPU_X8664)
(*windows 64*)
$END
$ELSIF (LINUX)
$IF (CPU_X86)
(*linux 32*)
$ELSIF (CPU_X8664)
(*linux 64*)
$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) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
допустимо от 1 до 32 Мб)
-tab <width> размер табуляции (используется для вычисления координат в
исходном коде), по умолчанию - 4
исходном коде), по умолчанию - 4
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
нижнем регистре (по умолчанию)
-upper только верхний регистр для ключевых слов и встроенных
идентификаторов
-def <имя> задать символ условной компиляции
-ver <major.minor> версия программы (только для kosdll)
-uses вывести список импортированных модулей
@ -81,6 +83,7 @@ UTF-8 с BOM-сигнатурой.
13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно
16. Разрешено использовать нижний регистр для ключевых слов
------------------------------------------------------------------------------
Особенности реализации
@ -137,6 +140,10 @@ UTF-8 с BOM-сигнатурой.
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE VAL(v: любой тип; T): T
v - переменная;
интерпретирует v, как переменную типа T
PROCEDURE SIZE(T): INTEGER
возвращает размер типа 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
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
Copyright (c) 2013-2014, 2018-2022 Anton Krotov
All rights reserved.
*)
@ -271,8 +271,7 @@ BEGIN
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
x := 1.0 - 2.0 / (exp(2.0 * x) + 1.0)
END
RETURN x

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
*)
@ -48,6 +48,7 @@ VAR
BEGIN
options.lower := TRUE;
out := "";
checking := options.checking;
_end := FALSE;
@ -133,6 +134,9 @@ BEGIN
ELSIF param = "-lower" THEN
options.lower := TRUE
ELSIF param = "-upper" THEN
options.lower := FALSE
ELSIF param = "-pic" THEN
options.pic := TRUE
@ -215,7 +219,7 @@ BEGIN
C.Ln;
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.StringLn("Copyright (c) 2018-2022, Anton Krotov");
C.StringLn("Copyright (c) 2018-2023, Anton Krotov");
IF inname = "" THEN
C.Ln;
@ -243,7 +247,8 @@ BEGIN
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(" 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(" -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;

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

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

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
*)
@ -24,7 +24,7 @@ CONST
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; opDIV* = 10; opMOD* = 11;
opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; opUMINUS* = 16;
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;
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;
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;
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opSYSVALIGN16* = 192;
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;
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;
@ -265,12 +265,22 @@ BEGIN
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;
VAR
i, n, res: INTEGER;
BEGIN
IF TARGETS.WinLin THEN
AlignData(16)
END;
res := CHL.Length(codes.data);
i := 0;
n := LENGTH(s);
WHILE i < n DO
@ -290,6 +300,9 @@ VAR
BEGIN
IF codes.charoffs[c] = -1 THEN
IF TARGETS.WinLin THEN
AlignData(16)
END;
res := CHL.Length(codes.data);
PutByte(c);
PutByte(0);
@ -307,12 +320,12 @@ VAR
i, n, res: INTEGER;
BEGIN
res := CHL.Length(codes.data);
IF ODD(res) THEN
PutByte(0);
INC(res)
IF TARGETS.WinLin THEN
AlignData(16)
ELSE
AlignData(2)
END;
res := CHL.Length(codes.data);
n := STRINGS.Utf8To16(s, codes.wstr);
@ -341,12 +354,12 @@ VAR
BEGIN
IF codes.wcharoffs[c] = -1 THEN
res := CHL.Length(codes.data);
IF ODD(res) THEN
PutByte(0);
INC(res)
IF TARGETS.WinLin THEN
AlignData(16)
ELSE
AlignData(2)
END;
res := CHL.Length(codes.data);
IF TARGETS.LittleEndian THEN
PutByte(c MOD 256);

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
Copyright (c) 2019-2022, Anton Krotov
All rights reserved.
*)
@ -984,11 +984,6 @@ BEGIN
drop;
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:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
@ -1412,10 +1407,6 @@ BEGIN
Test(ACC);
jcc(jne, param1)
|IL.opCHR:
UnOp(reg1);
Op2(opAND, imm(255), reg1)
|IL.opABS:
UnOp(reg1);
Test(reg1);

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
*)
@ -41,6 +41,7 @@ CONST
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46;
sysVAL* = 47;
default32* = 2; _default32* = default32 + 1;
stdcall* = 4; _stdcall* = stdcall + 1;
@ -239,13 +240,18 @@ END NewIdent;
PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
VAR
size: INTEGER;
size, glob_align: INTEGER;
BEGIN
IF varIdent.offset = -1 THEN
size := varIdent._type.size;
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
varIdent.offset := program.bss;
INC(program.bss, size)
@ -1109,6 +1115,7 @@ BEGIN
EnterProc(unit, "put8", idSYSPROC, sysPUT8);
EnterProc(unit, "code", idSYSPROC, sysCODE);
EnterProc(unit, "move", idSYSPROC, sysMOVE);
EnterProc(unit, "val", idSYSPROC, sysVAL);
(*
IF program.target.sys = mConst.Target_iMSP430 THEN
EnterProc(unit, "nop", idSYSPROC, sysNOP);
@ -1256,7 +1263,11 @@ BEGIN
IF TARGETS.RealSize # 0 THEN
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;
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
Copyright (c) 2020-2021, Anton Krotov
Copyright (c) 2020-2022, Anton Krotov
All rights reserved.
*)
@ -790,14 +790,6 @@ BEGIN
UnOp(r1);
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:
UnOp(r1);
Emit(opCMPC, r1, 0);
@ -958,11 +950,6 @@ BEGIN
END;
drop
|IL.opCHKBYTE:
BinOp(r1, r2);
Emit(opCMPC, r1, 256);
Emit(opJBT, param1, 0)
|IL.opCHKIDX:
UnOp(r1);
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))
END
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)
END
END
@ -1062,7 +1056,7 @@ BEGIN
IF chkCHR IN Options.checking THEN
CheckRange(256, pos.line, errCHR)
ELSE
IL.AddCmd0(IL.opCHR)
IL.AddCmd(IL.opMODR, 256)
END
END
@ -1077,7 +1071,7 @@ BEGIN
IF chkWCHR IN Options.checking THEN
CheckRange(65536, pos.line, errWCHR)
ELSE
IL.AddCmd0(IL.opWCHR)
IL.AddCmd(IL.opMODR, 65536)
END
END
@ -1392,6 +1386,8 @@ VAR
field: PROG.FIELD;
pos: PARS.POSITION;
t, idx: PARS.EXPR;
sysVal: BOOLEAN;
n: INTEGER;
PROCEDURE LoadAdr (e: PARS.EXPR);
@ -1444,7 +1440,6 @@ VAR
_type: PROG._TYPE;
BEGIN
IF chkIDX IN Options.checking THEN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX2, label, 0);
@ -1477,12 +1472,35 @@ VAR
BEGIN
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
PROG.UseProc(parser.unit, e.ident.proc)
END;
IF isVar(e) THEN
IF isVar(e) & ~sysVal THEN
LoadAdr(e)
END;
@ -2599,6 +2617,9 @@ BEGIN
NextPos(parser, pos);
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));

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
Copyright (c) 2019-2021, 2023, Anton Krotov
All rights reserved.
*)
@ -67,7 +67,7 @@ VAR
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER;
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);
@ -110,6 +110,7 @@ BEGIN
Dispose := ~(target IN noDISPOSE);
RTL := ~(target IN noRTL);
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WinLin := OS IN {osWIN32, osLINUX32, osWIN64, osLINUX64};
WordSize := BitDepth DIV 8;
AdrSize := WordSize
END

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

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
Copyright (c) 2019-2022, Anton Krotov
All rights reserved.
*)
@ -91,6 +91,10 @@ TYPE
RELOCCODE = ARRAY 7 OF INTEGER;
MEM = RECORD
start, size, startReserve, endReserve: INTEGER
END;
VAR
@ -105,11 +109,9 @@ VAR
StkCount: INTEGER;
Target: RECORD
FlashAdr,
SRAMAdr,
flash, sram: MEM;
IVTLen,
MinStack,
Reserved: INTEGER;
MinStkSize: INTEGER;
InstrSet: SET;
isNXP: BOOLEAN
END;
@ -1151,14 +1153,13 @@ BEGIN
PushAll(0)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
IF param2 = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
ASSERT(R.top + 1 <= param2);
PushAll(param2)
END
|IL.opCLEANUP:
@ -1587,14 +1588,6 @@ BEGIN
Tst(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:
BinOp(r1, r2);
Shift(opcode, r1, r2);
@ -1620,11 +1613,6 @@ BEGIN
END
END
|IL.opCHKBYTE:
BinOp(r1, r2);
CmpConst(r1, 256);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(r1);
CmpConst(r1, param2);
@ -2344,33 +2332,36 @@ BEGIN
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
Target.FlashAdr := FlashStart;
Target.SRAMAdr := SRAMStart;
Target.flash.start := FlashStart;
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.isNXP := isNXP;
Target.IVTLen := 256; (* >= 192 *)
Target.Reserved := 0;
Target.MinStack := 512;
Target.IVTLen := 256; (* >= 192 *)
Target.MinStkSize := 256;
END SetTarget;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
opt: PROG.OPTIONS;
ram, rom, i, j: INTEGER;
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
i, j, DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
BEGIN
ram := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
rom := MIN(MAX(options.rom, minROM), maxROM) * 1024;
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;
tcount := CHL.Length(IL.codes.types);
@ -2384,33 +2375,33 @@ BEGIN
StkCount := 0;
DataAdr := Target.SRAMAdr + Target.Reserved;
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.Reserved;
DataAdr := Target.sram.start + Target.sram.startReserve;
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.sram.startReserve;
WHILE DataSize MOD 4 # 0 DO
CHL.PushByte(IL.codes.data, 0);
INC(DataSize)
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)));
BssSize := IL.codes.bss;
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);
epilog;
fixup(Target.FlashAdr, DataAdr, BssAdr);
fixup(Target.flash.start, DataAdr, BssAdr);
INC(DataSize, BssSize);
CodeSize := CHL.Length(program.code);
IF CodeSize > rom THEN
IF CodeSize > Target.flash.size - Target.flash.endReserve THEN
ERRORS.Error(203)
END;
IF DataSize > ram - Target.MinStack THEN
IF DataSize > Target.sram.size - Target.MinStkSize - Target.sram.endReserve THEN
ERRORS.Error(204)
END;
@ -2426,15 +2417,17 @@ BEGIN
WR.Create(outname);
HEX.Data2(program.code, 0, CodeSize, high(Target.FlashAdr));
HEX.Data2(program.code, 0, CodeSize, high(Target.flash.start));
HEX.End;
WR.Close;
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.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;

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

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

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

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