diff --git a/programs/develop/cedit/SRC/Icons.ob07 b/programs/develop/cedit/SRC/Icons.ob07 index a53a1e42ce..ef4bce32c2 100644 --- a/programs/develop/cedit/SRC/Icons.ob07 +++ b/programs/develop/cedit/SRC/Icons.ob07 @@ -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. \ No newline at end of file diff --git a/programs/develop/oberon07/Compiler.kex b/programs/develop/oberon07/Compiler.kex index 186e32a542..3f52139e20 100644 Binary files a/programs/develop/oberon07/Compiler.kex and b/programs/develop/oberon07/Compiler.kex differ diff --git a/programs/develop/oberon07/LICENSE b/programs/develop/oberon07/LICENSE index 947fea54c0..3abe18a443 100644 --- a/programs/develop/oberon07/LICENSE +++ b/programs/develop/oberon07/LICENSE @@ -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 diff --git a/programs/develop/oberon07/doc/CC.txt b/programs/develop/oberon07/doc/CC.txt index 0df944219f..278b0616bc 100644 --- a/programs/develop/oberon07/doc/CC.txt +++ b/programs/develop/oberon07/doc/CC.txt @@ -1,61 +1,61 @@ -Условная компиляция - -синтаксис: - - $IF "(" ident {"|" ident} ")" - <...> - {$ELSIF "(" ident {"|" ident} ")"} - <...> - [$ELSE] - <...> - $END - - где ident: - - одно из возможных значений параметра в командной строке - - пользовательский идентификатор, переданный с ключом -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: + - одно из возможных значений параметра в командной строке + - пользовательский идентификатор, переданный с ключом -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 \ No newline at end of file diff --git a/programs/develop/oberon07/doc/WinLib.txt b/programs/develop/oberon07/doc/WinLib.txt deleted file mode 100644 index be342ad92b..0000000000 --- a/programs/develop/oberon07/doc/WinLib.txt +++ /dev/null @@ -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 \ No newline at end of file diff --git a/programs/develop/oberon07/doc/x86.txt b/programs/develop/oberon07/doc/x86.txt index 7f67425c45..c1d4535151 100644 --- a/programs/develop/oberon07/doc/x86.txt +++ b/programs/develop/oberon07/doc/x86.txt @@ -20,15 +20,17 @@ UTF-8 с BOM-сигнатурой. 3) необязательные параметры-ключи -out имя результирующего файла; по умолчанию, - совпадает с именем главного модуля, но с другим расширением - (соответствует типу исполняемого файла) + совпадает с именем главного модуля, но с другим расширением + (соответствует типу исполняемого файла) -stk размер стэка в мегабайтах (по умолчанию 2 Мб, - допустимо от 1 до 32 Мб) + допустимо от 1 до 32 Мб) -tab размер табуляции (используется для вычисления координат в - исходном коде), по умолчанию - 4 + исходном коде), по умолчанию - 4 -nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже) -lower разрешить ключевые слова и встроенные идентификаторы в - нижнем регистре + нижнем регистре (по умолчанию) + -upper только верхний регистр для ключевых слов и встроенных + идентификаторов -def <имя> задать символ условной компиляции -ver версия программы (только для 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 diff --git a/programs/develop/oberon07/doc/x86_64.txt b/programs/develop/oberon07/doc/x86_64.txt deleted file mode 100644 index 092fbce6fd..0000000000 --- a/programs/develop/oberon07/doc/x86_64.txt +++ /dev/null @@ -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 имя результирующего файла; по умолчанию, - совпадает с именем главного модуля, но с другим расширением - (соответствует типу исполняемого файла) - -stk размер стэка в мегабайтах (по умолчанию 2 Мб, - допустимо от 1 до 32 Мб) - -tab размер табуляции (используется для вычисления координат в - исходном коде), по умолчанию - 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-библиотек. \ No newline at end of file diff --git a/programs/develop/oberon07/lib/KolibriOS/Math.ob07 b/programs/develop/oberon07/lib/KolibriOS/Math.ob07 index d6056af747..03302f6426 100644 --- a/programs/develop/oberon07/lib/KolibriOS/Math.ob07 +++ b/programs/develop/oberon07/lib/KolibriOS/Math.ob07 @@ -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 diff --git a/programs/develop/oberon07/lib/Math/CMath.ob07 b/programs/develop/oberon07/lib/Math/CMath.ob07 index e1d48b0b50..adc7fb178e 100644 --- a/programs/develop/oberon07/lib/Math/CMath.ob07 +++ b/programs/develop/oberon07/lib/Math/CMath.ob07 @@ -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. diff --git a/programs/develop/oberon07/lib/Math/MathBits.ob07 b/programs/develop/oberon07/lib/Math/MathBits.ob07 index 3d102c226a..b339c06bd8 100644 --- a/programs/develop/oberon07/lib/Math/MathBits.ob07 +++ b/programs/develop/oberon07/lib/Math/MathBits.ob07 @@ -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. diff --git a/programs/develop/oberon07/lib/Math/MathRound.ob07 b/programs/develop/oberon07/lib/Math/MathRound.ob07 index ac2548a022..3952e88b3e 100644 --- a/programs/develop/oberon07/lib/Math/MathRound.ob07 +++ b/programs/develop/oberon07/lib/Math/MathRound.ob07 @@ -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. \ No newline at end of file diff --git a/programs/develop/oberon07/lib/Math/MathStat.ob07 b/programs/develop/oberon07/lib/Math/MathStat.ob07 index a05d14476f..9e56d93a2a 100644 --- a/programs/develop/oberon07/lib/Math/MathStat.ob07 +++ b/programs/develop/oberon07/lib/Math/MathStat.ob07 @@ -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. \ No newline at end of file diff --git a/programs/develop/oberon07/lib/Math/Rand.ob07 b/programs/develop/oberon07/lib/Math/Rand.ob07 index c13deb6f38..a8372eb080 100644 --- a/programs/develop/oberon07/lib/Math/Rand.ob07 +++ b/programs/develop/oberon07/lib/Math/Rand.ob07 @@ -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. \ No newline at end of file diff --git a/programs/develop/oberon07/lib/Math/RandExt.ob07 b/programs/develop/oberon07/lib/Math/RandExt.ob07 index 1d35795b2b..4990a4f4c8 100644 --- a/programs/develop/oberon07/lib/Math/RandExt.ob07 +++ b/programs/develop/oberon07/lib/Math/RandExt.ob07 @@ -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. diff --git a/programs/develop/oberon07/source/AMD64.ob07 b/programs/develop/oberon07/source/AMD64.ob07 index 5c0dfab521..9242cb1937 100644 --- a/programs/develop/oberon07/source/AMD64.ob07 +++ b/programs/develop/oberon07/source/AMD64.ob07 @@ -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; diff --git a/programs/develop/oberon07/source/ARITH.ob07 b/programs/develop/oberon07/source/ARITH.ob07 index d572d8b830..c0fc195645 100644 --- a/programs/develop/oberon07/source/ARITH.ob07 +++ b/programs/develop/oberon07/source/ARITH.ob07 @@ -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; diff --git a/programs/develop/oberon07/source/Compiler.ob07 b/programs/develop/oberon07/source/Compiler.ob07 index b849c52d20..7ea35d6e8c 100644 --- a/programs/develop/oberon07/source/Compiler.ob07 +++ b/programs/develop/oberon07/source/Compiler.ob07 @@ -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 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 define conditional compilation symbol"); C.Ln; C.StringLn(" -ver set version of program (KolibriOS DLL)"); C.Ln; C.StringLn(" -ram set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln; diff --git a/programs/develop/oberon07/source/FILES.ob07 b/programs/develop/oberon07/source/FILES.ob07 index d1bbde9cbf..646def3e3d 100644 --- a/programs/develop/oberon07/source/FILES.ob07 +++ b/programs/develop/oberon07/source/FILES.ob07 @@ -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 diff --git a/programs/develop/oberon07/source/IL.ob07 b/programs/develop/oberon07/source/IL.ob07 index ba668813ed..f07160c454 100644 --- a/programs/develop/oberon07/source/IL.ob07 +++ b/programs/develop/oberon07/source/IL.ob07 @@ -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); diff --git a/programs/develop/oberon07/source/MSP430.ob07 b/programs/develop/oberon07/source/MSP430.ob07 index abba309e77..acec51fe49 100644 --- a/programs/develop/oberon07/source/MSP430.ob07 +++ b/programs/develop/oberon07/source/MSP430.ob07 @@ -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); diff --git a/programs/develop/oberon07/source/PROG.ob07 b/programs/develop/oberon07/source/PROG.ob07 index 5147c1a783..c1bfd45775 100644 --- a/programs/develop/oberon07/source/PROG.ob07 +++ b/programs/develop/oberon07/source/PROG.ob07 @@ -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); diff --git a/programs/develop/oberon07/source/RVMxI.ob07 b/programs/develop/oberon07/source/RVMxI.ob07 index e2d0139910..53bb5a86bb 100644 --- a/programs/develop/oberon07/source/RVMxI.ob07 +++ b/programs/develop/oberon07/source/RVMxI.ob07 @@ -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); diff --git a/programs/develop/oberon07/source/STATEMENTS.ob07 b/programs/develop/oberon07/source/STATEMENTS.ob07 index d3d940e281..de418d581e 100644 --- a/programs/develop/oberon07/source/STATEMENTS.ob07 +++ b/programs/develop/oberon07/source/STATEMENTS.ob07 @@ -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)); diff --git a/programs/develop/oberon07/source/TARGETS.ob07 b/programs/develop/oberon07/source/TARGETS.ob07 index a9006e944d..d33aed7ca3 100644 --- a/programs/develop/oberon07/source/TARGETS.ob07 +++ b/programs/develop/oberon07/source/TARGETS.ob07 @@ -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 diff --git a/programs/develop/oberon07/source/THUMB.ob07 b/programs/develop/oberon07/source/THUMB.ob07 index 90bbf086de..55c230dcf3 100644 --- a/programs/develop/oberon07/source/THUMB.ob07 +++ b/programs/develop/oberon07/source/THUMB.ob07 @@ -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; diff --git a/programs/develop/oberon07/source/UTILS.ob07 b/programs/develop/oberon07/source/UTILS.ob07 index 20b75a396a..f12a8addc9 100644 --- a/programs/develop/oberon07/source/UTILS.ob07 +++ b/programs/develop/oberon07/source/UTILS.ob07 @@ -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"; diff --git a/programs/develop/oberon07/source/X86.ob07 b/programs/develop/oberon07/source/X86.ob07 index 5a28ba5918..45a40589af 100644 --- a/programs/develop/oberon07/source/X86.ob07 +++ b/programs/develop/oberon07/source/X86.ob07 @@ -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;