BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → /programs/ @ 7982

  → /programs/ @ 7983

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

No changes between revisions

Regard whitespace Rev 7982 → Rev 7983

/programs/develop/oberon07/Compiler
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/programs/develop/oberon07/Compiler.exe
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/programs/develop/oberon07/Compiler.kex
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream

/programs/develop/oberon07/Docs/About866.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/About1251.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/KOSLib1251.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/KOSLib866.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/KOSLib.txt
0,0 → 1,566
==============================================================================
Библиотека (KolibriOS)
------------------------------------------------------------------------------
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
------------------------------------------------------------------------------
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 ConsoleLib - обертка библиотеки console.obj
------------------------------------------------------------------------------
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 Debug - вывод на доску отладки
Интерфейс как модуль Out
PROCEDURE Open
открывает доску отладки
------------------------------------------------------------------------------
MODULE File - работа с файловой системой
TYPE
FNAME = ARRAY 520 OF CHAR
FS = POINTER TO rFS
rFS = RECORD (* информационная структура файла *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
FD = POINTER TO rFD
rFD = RECORD (* структура блока данных входа каталога *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
CONST
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
Загружает в память файл с именем FName, записывает в параметр
size размер файла, возвращает адрес загруженного файла
или 0 (ошибка). При необходимости, распаковывает
файл (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
Записывает структуру блока данных входа каталога для файла
или папки с именем FName в параметр Info.
При ошибке возвращает FALSE.
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если файл с именем FName существует
PROCEDURE Close(VAR F: FS)
освобождает память, выделенную для информационной структуры
файла F и присваивает F значение NIL
PROCEDURE Open(FName: ARRAY OF CHAR): FS
возвращает указатель на информационную структуру файла с
именем FName, при ошибке возвращает NIL
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
удаляет файл с именем FName, при ошибке возвращает FALSE
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
устанавливает позицию чтения-записи файла F на Offset,
относительно Origin = (SEEK_BEG - начало файла,
SEEK_CUR - текущая позиция, SEEK_END - конец файла),
возвращает позицию относительно начала файла, например:
Seek(F, 0, SEEK_END)
устанавливает позицию на конец файла и возвращает длину
файла; при ошибке возвращает -1
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
Читает данные из файла в память. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется прочитать
из файла; возвращает количество байт, которое было прочитано
и соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
Записывает данные из памяти в файл. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется записать
в файл; возвращает количество байт, которое было записано и
соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Create(FName: ARRAY OF CHAR): FS
создает новый файл с именем FName (полное имя), возвращает
указатель на информационную структуру файла,
при ошибке возвращает NIL
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
создает папку с именем DirName, все промежуточные папки
должны существовать, при ошибке возвращает FALSE
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
удаляет пустую папку с именем DirName,
при ошибке возвращает FALSE
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если папка с именем DirName существует
------------------------------------------------------------------------------
MODULE Read - чтение основных типов данных из файла F
Процедуры возвращают TRUE в случае успешной операции чтения и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
PROCEDURE WChar(F: File.FS; VAR x: WCHAR): BOOLEAN
------------------------------------------------------------------------------
MODULE Write - запись основных типов данных в файл F
Процедуры возвращают TRUE в случае успешной операции записи и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
PROCEDURE WChar(F: File.FS; x: WCHAR): BOOLEAN
------------------------------------------------------------------------------
MODULE DateTime - дата, время
CONST ERR = -7.0E5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
записывает в параметры компоненты текущей системной даты и
времени
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL
возвращает дату, полученную из компонентов
Year, Month, Day, Hour, Min, Sec;
при ошибке возвращает константу ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
извлекает компоненты
Year, Month, Day, Hour, Min, Sec из даты Date;
при ошибке возвращает FALSE
------------------------------------------------------------------------------
MODULE Args - параметры программы
VAR argc: INTEGER
количество параметров программы, включая имя
исполняемого файла
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
записывает в строку s n-й параметр программы,
нумерация параметров от 0 до argc - 1,
нулевой параметр -- имя исполняемого файла
------------------------------------------------------------------------------
MODULE KOSAPI
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Обертки для функций API ядра KolibriOS.
arg1 .. arg7 соответствуют регистрам
eax, ebx, ecx, edx, esi, edi, ebp;
возвращают значение регистра eax после системного вызова.
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Обертка для функций API ядра KolibriOS.
arg1 - регистр eax, arg2 - регистр ebx,
res2 - значение регистра ebx после системного вызова;
возвращает значение регистра eax после системного вызова.
PROCEDURE malloc(size: INTEGER): INTEGER
Выделяет блок памяти.
size - размер блока в байтах,
возвращает адрес выделенного блока
PROCEDURE free(ptr: INTEGER): INTEGER
Освобождает ранее выделенный блок памяти с адресом ptr,
возвращает 0
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
Перераспределяет блок памяти,
ptr - адрес ранее выделенного блока,
size - новый размер,
возвращает указатель на перераспределенный блок,
0 при ошибке
PROCEDURE GetCommandLine(): INTEGER
Возвращает адрес строки параметров
PROCEDURE GetName(): INTEGER
Возвращает адрес строки с именем программы
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
Загружает DLL с полным именем name. Возвращает адрес таблицы
экспорта. При ошибке возвращает 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - имя процедуры
lib - адрес таблицы экспорта DLL
Возвращает адрес процедуры. При ошибке возвращает 0.
------------------------------------------------------------------------------
MODULE ColorDlg - работа с диалогом "Color Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
color: INTEGER (* выбранный цвет *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE);
процедура возвращает указатель на структуру диалога
PROCEDURE Show(cd: Dialog)
показать диалог
cd - указатель на структуру диалога, который был создан ранее
процедурой Create
PROCEDURE Destroy(VAR cd: Dialog)
уничтожить диалог
cd - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE OpenDlg - работа с диалогом "Open Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
FileName: ARRAY 4096 OF CHAR (* имя выбранного файла *)
FilePath: ARRAY 4096 OF CHAR (* полное имя выбранного
файла *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE)
type - тип диалога
0 - открыть
1 - сохранить
2 - выбрать папку
def_path - путь по умолчанию, папка def_path будет открыта
при первом запуске диалога
filter - в строке записано перечисление расширений файлов,
которые будут показаны в диалоговом окне, расширения
разделяются символом "|", например: "ASM|TXT|INI"
процедура возвращает указатель на структуру диалога
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
показать диалог
od - указатель на структуру диалога, который был создан ранее
процедурой Create
Width и Height - ширина и высота диалогового окна
PROCEDURE Destroy(VAR od: Dialog)
уничтожить диалог
od - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE kfonts - работа с kf-шрифтами
CONST
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
TYPE
TFont = POINTER TO TFont_desc (* указатель на шрифт *)
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
загрузить шрифт из файла
file_name имя kf-файла
рез-т: указатель на шрифт/NIL (ошибка)
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
установить размер шрифта
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (ошибка)
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
проверить, есть ли шрифт, заданного размера
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (шрифта нет)
PROCEDURE Destroy(VAR Font: TFont)
выгрузить шрифт, освободить динамическую память
Font указатель на шрифт
Присваивает переменной Font значение NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
получить высоту строки текста
Font указатель на шрифт
рез-т: высота строки текста в пикселях
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
получить ширину строки текста
Font указатель на шрифт
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
params параметры-флаги см. ниже
рез-т: ширина строки текста в пикселях
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
вывести текст в буфер
для вывода буфера в окно, использовать ф.65 или
ф.7 (если буфер 24-битный)
Font указатель на шрифт
canvas адрес графического буфера
структура буфера:
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 бита)
или Xsize * Ysize * 3 (24 бита)
x, y координаты текста относительно левого верхнего
угла буфера
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
color цвет текста 0x00RRGGBB
params параметры-флаги:
1 жирный
2 курсив
4 подчеркнутый
8 перечеркнутый
16 применить сглаживание
32 вывод в 32-битный буфер
возможно использование флагов в любых сочетаниях
------------------------------------------------------------------------------
MODULE RasterWorks - обертка библиотеки Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - обертка библиотеки libimg.obj
------------------------------------------------------------------------------

/programs/develop/oberon07/Docs/WinLib.txt
0,0 → 1,312
==============================================================================
Библиотека (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

/programs/develop/oberon07/Docs/x86.txt
0,0 → 1,358
 Компилятор языка программирования Oberon-07/16 для i486
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32, ELF или MENUET01/MSCOFF.
Параметры:
1) имя главного модуля
2) тип приложения
"win32con" - Windows console
"win32gui" - Windows GUI
"win32dll" - Windows DLL
"linux32exe" - Linux ELF-EXEC
"linux32so" - Linux ELF-SO
"kosexe" - KolibriOS
"kosdll" - KolibriOS DLL
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-ver <major.minor> версия программы (только для kosdll)
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" win32dll -out "C:\example.dll"
Compiler.exe "C:\example.ob07" win32gui -out "C:\example.exe" -stk 4
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -nochk pti
Compiler.kex "/tmp0/1/example.ob07" kosexe -out "/tmp0/1/example.kex" -stk 4
Compiler.kex "/tmp0/1/example.ob07" kosdll -out "/tmp0/1/mydll.obj" -ver 2.7
Compiler.exe "C:\example.ob07" linux32exe -out "C:\example" -stk 1 -nochk a
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
При работе компилятора в KolibriOS, код завершения не передается.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Добавлены системные флаги
4. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
5. Расширен набор стандартных процедур
6. Семантика охраны/проверки типа уточнена для нулевого указателя
7. Добавлены однострочные комментарии (начинаются с пары символов "//")
8. Разрешено наследование от типа-указателя
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -2147483648 .. 2147483647 4
REAL 4.94E-324 .. 1.70E+308 8
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (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 GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 16 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : INTEGER)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall],
[ccall], [ccall16], [windows], [linux]. Например:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
Если указан флаг [ccall16], то принимается соглашение ccall, но перед
вызовом указатель стэка будет выравнен по границе 16 байт.
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall16].
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[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 c BOM.
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны 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
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- "library" -- имя файла динамической библиотеки
- "function" -- имя импортируемой процедуры
например:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
В KolibriOS импортировать процедуры можно только из библиотек, размещенных
в /rd/1/lib. Импортировать и вызывать функции инициализации библиотек
(lib_init, START) при этом не нужно.
Для 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), на доску отладки (KolibriOS).
------------------------------------------------------------------------------
Модуль API
Существуют несколько реализаций модуля API (для различных ОС).
Как и модуль RTL, модуль API не предназначен для прямого использования.
Он обеспечивает связь RTL с ОС.
------------------------------------------------------------------------------
Генерация исполняемых файлов DLL
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, и ее имя должно быть отмечено символом
экспорта ("*"). KolibriOS DLL всегда экспортируют идентификаторы "version"
(версия программы) и "lib_init" - адрес процедуры инициализации DLL:
PROCEDURE [stdcall] lib_init (): INTEGER
Эта процедура должна быть вызвана перед использованием DLL.
Процедура всегда возвращает 1.

/programs/develop/oberon07/Docs/x86_64.txt
0,0 → 1,346
 Компилятор языка программирования Oberon-07/16 для x86_64
Windows/Linux
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32+ или ELF64.
Параметры:
1) имя главного модуля
2) тип приложения
"win64con" - Windows64 console
"win64gui" - Windows64 GUI
"win64dll" - Windows64 DLL
"linux64exe" - Linux ELF64-EXEC
"linux64so" - Linux ELF64-SO
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении
параметр -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
------------------------------------------------------------------------------
Особенности реализации
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. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (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 GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
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)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 32 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
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].
Например:
PROCEDURE [win64] MyProc (x, y, z: INTEGER): INTEGER;
Флаг [windows] - синоним для [win64], [linux] - синоним для [systemv].
Знак "-" после имени флага ([win64-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан, то принимается внутреннее соглашение о вызове.
[win64] и [systemv] используются для связи с операционной системой и внешними
приложениями.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[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 c BOM.
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны 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
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- "library" -- имя файла динамической библиотеки
- "function" -- имя импортируемой процедуры
например:
PROCEDURE [win64, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [win64] (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
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, ее имя должно быть отмечено символом
экспорта ("*") и должно быть указано соглашение о вызове.

/programs/develop/oberon07/GitHub.url
0,0 → 1,2
[InternetShortcut]
URL=https://github.com/AntKrotov/oberon-07-compiler

/programs/develop/oberon07/LICENSE
0,0 → 1,25
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2020, Anton Krotov
All rights reserved.
*)
318,4 → 318,13
END GetTickCount;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
END sofinit;
END API.

/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/File.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
57,7 → 57,9
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
PROCEDURE [stdcall, "Console.obj", "con_init"] con_init (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] con_exit (bCloseWindow: BOOLEAN);
453,6 → 455,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a);
463,9 → 501,11
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
Console := API.import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END HOST.
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/In.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
1,4 → 1,4
(*
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07
1,4 → 1,4
(*
(*
Copyright 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
16,36 → 16,16
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
name: INTEGER;
types: INTEGER;
bits: ARRAY MAX_SET + 1 OF INTEGER;
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
97,7 → 77,6
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
106,7 → 85,6
INC(i)
END;
A[k] := n
END _rot;
128,14 → 106,16
END _set;
PROCEDURE [stdcall] _set1* (a: INTEGER): INTEGER;
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
IF ASR(a, 5) = 0 THEN
SYSTEM.GET(SYSTEM.ADR(bits[0]) + a * WORD, a)
ELSE
a := 0
END
RETURN a
SYSTEM.CODE(
031H, 0C0H, (* xor eax, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
077H, 003H, (* ja L *)
00FH, 0ABH, 0C8H (* bts eax, ecx *)
(* L: *)
)
END _set1;
315,7 → 295,6
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
349,7 → 328,6
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
398,7 → 376,6
c: CHAR;
BEGIN
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
422,6 → 399,7
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
437,7 → 415,6
END;
s1[j] := 0X
END append;
446,20 → 423,18
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
513,36 → 488,16
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
API.sofinit
END _sofinit;
RETURN res
END _dllentry;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
571,42 → 526,8
END
END;
j := 1;
FOR i := 0 TO MAX_SET DO
bits[i] := j;
j := LSL(j, 1)
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
name := modname
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.
END RTL.

/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/UnixTime.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Lib/KolibriOS/Vector.ob07
1,4 → 1,4
(*
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/Linux32/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
13,11 → 13,13
CONST
RTLD_LAZY* = 1;
BIT_DEPTH* = 32;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
46,7 → 48,9
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
103,6 → 107,7
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
142,4 → 147,23
END exit_thread;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

/programs/develop/oberon07/Lib/Linux32/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
26,7 → 26,9
eol*: ARRAY 2 OF CHAR;
maxreal*: REAL;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
148,6 → 150,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
164,5 → 202,7
BEGIN
eol := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
END HOST.
END HOST.

/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
13,6 → 13,7
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
VAR
69,12 → 70,17
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);

/programs/develop/oberon07/Lib/Linux32/Libdl.ob07
0,0 → 1,65
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Libdl;
IMPORT SYSTEM, API;
CONST
LAZY* = 1;
NOW* = 2;
BINDING_MASK* = 3;
NOLOAD* = 4;
LOCAL* = 0;
GLOBAL* = 256;
NODELETE* = 4096;
VAR
_close: PROCEDURE [linux] (handle: INTEGER): INTEGER;
_error: PROCEDURE [linux] (): INTEGER;
PROCEDURE open* (file: ARRAY OF CHAR; mode: INTEGER): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(file[0]), mode)
END open;
PROCEDURE sym* (handle: INTEGER; name: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(name[0]))
END sym;
PROCEDURE close* (handle: INTEGER): INTEGER;
RETURN _close(handle)
END close;
PROCEDURE error* (): INTEGER;
RETURN _error()
END error;
PROCEDURE init;
VAR
lib: INTEGER;
BEGIN
lib := open("libdl.so.2", LAZY);
SYSTEM.PUT(SYSTEM.ADR(_close), sym(lib, "dlclose"));
ASSERT(_close # NIL);
SYSTEM.PUT(SYSTEM.ADR(_error), sym(lib, "dlerror"));
ASSERT(_error # NIL)
END init;
BEGIN
init
END Libdl.

/programs/develop/oberon07/Lib/Linux32/Math.ob07
0,0 → 1,384
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
res := (b - a) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
res := exp(exponent * ln(base))
END
RETURN res
END power;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
END Math.

/programs/develop/oberon07/Lib/Linux32/Out.ob07
0,0 → 1,277
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(x: CHAR);
BEGIN
API.putc(x)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/Lib/Linux32/RTL.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
16,36 → 16,16
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
name: INTEGER;
types: INTEGER;
bits: ARRAY MAX_SET + 1 OF INTEGER;
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
97,7 → 77,6
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
106,7 → 85,6
INC(i)
END;
A[k] := n
END _rot;
128,14 → 106,16
END _set;
PROCEDURE [stdcall] _set1* (a: INTEGER): INTEGER;
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
IF ASR(a, 5) = 0 THEN
SYSTEM.GET(SYSTEM.ADR(bits[0]) + a * WORD, a)
ELSE
a := 0
END
RETURN a
SYSTEM.CODE(
031H, 0C0H, (* xor eax, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
077H, 003H, (* ja L *)
00FH, 0ABH, 0C8H (* bts eax, ecx *)
(* L: *)
)
END _set1;
315,7 → 295,6
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
349,7 → 328,6
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
398,7 → 376,6
c: CHAR;
BEGIN
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
422,6 → 399,7
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
437,7 → 415,6
END;
s1[j] := 0X
END append;
446,20 → 423,18
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
513,36 → 488,16
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
API.sofinit
END _sofinit;
RETURN res
END _dllentry;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
571,42 → 526,8
END
END;
j := 1;
FOR i := 0 TO MAX_SET DO
bits[i] := j;
j := LSL(j, 1)
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
name := modname
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.
END RTL.

/programs/develop/oberon07/Lib/Linux64/API.ob07
0,0 → 1,169
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
RTLD_LAZY* = 1;
BIT_DEPTH* = 64;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
eol*: ARRAY 2 OF CHAR;
MainParam*: INTEGER;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
res := malloc(size);
IF res # 0 THEN
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
RETURN res
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(p)
RETURN 0
END _DISPOSE;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
eol := 0AX;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
librt := dlopen(SYSTEM.SADR("librt.so.1"), RTLD_LAZY);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
_exit(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

/programs/develop/oberon07/Lib/Linux64/HOST.ob07
0,0 → 1,208
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
OS* = "LINUX";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
VAR
argc: INTEGER;
eol*: ARRAY 2 OF CHAR;
maxreal*: REAL;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
File := API.fclose(File)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
BEGIN
API.putc(c)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
res: INTEGER;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
END
RETURN res
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
END HOST.

/programs/develop/oberon07/Lib/Linux64/LINAPI.ob07
0,0 → 1,138
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API;
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
VAR
argc*, envc*: INTEGER;
libc*, librt*: INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END;
libc := API.libc;
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
librt := API.librt;
clock_gettime := API.clock_gettime
END init;
PROCEDURE [stdcall64-] syscall* (rax, rdi, rsi, rdx, r10, r8, r9: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 055H, 028H, (* mov rdx, qword [rbp + 40] *)
04CH, 08BH, 055H, 030H, (* mov r10, qword [rbp + 48] *)
04CH, 08BH, 045H, 038H, (* mov r8, qword [rbp + 56] *)
04CH, 08BH, 04DH, 040H, (* mov r9, qword [rbp + 64] *)
00FH, 005H, (* syscall *)
0C9H, (* leave *)
0C2H, 038H, 000H (* ret 56 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

/programs/develop/oberon07/Lib/Linux64/Libdl.ob07
0,0 → 1,65
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Libdl;
IMPORT SYSTEM, API;
CONST
LAZY* = 1;
NOW* = 2;
BINDING_MASK* = 3;
NOLOAD* = 4;
LOCAL* = 0;
GLOBAL* = 256;
NODELETE* = 4096;
VAR
_close: PROCEDURE [linux] (handle: INTEGER): INTEGER;
_error: PROCEDURE [linux] (): INTEGER;
PROCEDURE open* (file: ARRAY OF CHAR; mode: INTEGER): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(file[0]), mode)
END open;
PROCEDURE sym* (handle: INTEGER; name: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(name[0]))
END sym;
PROCEDURE close* (handle: INTEGER): INTEGER;
RETURN _close(handle)
END close;
PROCEDURE error* (): INTEGER;
RETURN _error()
END error;
PROCEDURE init;
VAR
lib: INTEGER;
BEGIN
lib := open("libdl.so.2", LAZY);
SYSTEM.PUT(SYSTEM.ADR(_close), sym(lib, "dlclose"));
ASSERT(_close # NIL);
SYSTEM.PUT(SYSTEM.ADR(_error), sym(lib, "dlerror"));
ASSERT(_error # NIL)
END init;
BEGIN
init
END Libdl.

/programs/develop/oberon07/Lib/Linux64/Math.ob07
0,0 → 1,311
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
VAR
Exp: ARRAY 710 OF REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
VAR
a, s, res: REAL;
neg: BOOLEAN;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
ELSE
res := SYSTEM.INF();
x := 0.0
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
END
RETURN res
END exp;
PROCEDURE ln* (x: REAL): REAL;
VAR
a, x2, res: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
UNPK(x, n);
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
RETURN res * 2.0
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
RETURN exp(exponent * ln(base))
END power;
PROCEDURE log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
VAR
a, res: REAL;
n: INTEGER;
BEGIN
x := ABS(x);
ASSERT(x <= MaxCosArg);
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
RETURN res
END cos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
END
RETURN x
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
END
END init;
BEGIN
init
END Math.

/programs/develop/oberon07/Lib/Linux64/Out.ob07
0,0 → 1,276
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(x: CHAR);
BEGIN
API.putc(x)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 24 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/Lib/Linux64/RTL.ob07
0,0 → 1,516
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 64;
maxint* = 7FFFFFFFFFFFFFFFH;
minint* = 8000000000000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
sets: ARRAY (MAX_SET + 1) * (MAX_SET + 1) OF INTEGER;
PROCEDURE [stdcall64] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 085H, 0C0H, (* test rax, rax *)
07EH, 020H, (* jle L *)
0FCH, (* cld *)
057H, (* push rdi *)
056H, (* push rsi *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 0C1H, 0E9H, 003H, (* shr rcx, 3 *)
0F3H, 048H, 0A5H, (* rep movsd *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 083H, 0E1H, 007H, (* and rcx, 7 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop rsi *)
05FH (* pop rdi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall64] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall64] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall64] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall64] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
SYSTEM.GET((MIN(b, MAX_SET) * (MAX_SET + 1) + MAX(a, 0)) * WORD + SYSTEM.ADR(sets[0]), a)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE [stdcall64] _set1* (a: INTEGER); (* {a} -> rax *)
BEGIN
SYSTEM.CODE(
048H, 031H, 0C0H, (* xor rax, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- a *)
048H, 083H, 0F9H, 03FH, (* cmp rcx, 63 *)
077H, 004H, (* ja L *)
048H, 00FH, 0ABH, 0C8H (* bts rax, rcx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall64] _divmod* (y, x: INTEGER); (* (x div y) -> rax; (x mod y) -> rdx *)
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *) (* rax <- x *)
048H, 031H, 0D2H, (* xor rdx, rdx *)
048H, 085H, 0C0H, (* test rax, rax *)
074H, 022H, (* je L2 *)
07FH, 003H, (* jg L1 *)
048H, 0F7H, 0D2H, (* not rdx *)
(* L1: *)
049H, 089H, 0C0H, (* mov r8, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- y *)
048H, 0F7H, 0F9H, (* idiv rcx *)
048H, 085H, 0D2H, (* test rdx, rdx *)
074H, 00EH, (* je L2 *)
049H, 031H, 0C8H, (* xor r8, rcx *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07DH, 006H, (* jge L2 *)
048H, 0FFH, 0C8H, (* dec rax *)
048H, 001H, 0CAH (* add rdx, rcx *)
(* L2: *)
)
END _divmod;
PROCEDURE [stdcall64] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall64] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall64] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 0FFH, 0C8H, (* dec rax *)
(* L1: *)
048H, 0FFH, 0C0H, (* inc rax *)
080H, 038H, 000H, (* cmp byte [rax], 0 *)
074H, 005H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
048H, 0FFH, 0C0H, (* inc rax *)
(* L2: *)
048H, 02BH, 045H, 018H (* sub rax, qword [rbp + 24] *)
)
END _length;
PROCEDURE [stdcall64] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 083H, 0E8H, 002H, (* sub rax, 2 *)
(* L1: *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
066H, 083H, 038H, 000H, (* cmp word [rax], 0 *)
074H, 006H, (* jz L2 *)
0E2H, 0F4H, (* loop L1 *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
(* L2: *)
048H, 02BH, 045H, 018H, (* sub rax, qword [rbp + 24] *)
048H, 0D1H, 0E8H (* shr rax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall64] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 024H, (* jle L3 *)
044H, 08AH, 009H, (* mov r9b, byte[rcx] *)
044H, 08AH, 012H, (* mov r10b, byte[rdx] *)
048H, 0FFH, 0C1H, (* inc rcx *)
048H, 0FFH, 0C2H, (* inc rdx *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0DAH, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall64] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 028H, (* jle L3 *)
066H, 044H, 08BH, 009H, (* mov r9w, word[rcx] *)
066H, 044H, 08BH, 012H, (* mov r10w, word[rdx] *)
048H, 083H, 0C1H, 002H, (* add rcx, 2 *)
048H, 083H, 0C2H, 002H, (* add rdx, 2 *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0D6H, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall64] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall64] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall64] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall64] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall64] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall64] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall64] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall64] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall64] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall64] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
FOR i := 0 TO MAX_SET DO
FOR j := 0 TO i DO
sets[i * (MAX_SET + 1) + j] := LSR(ASR(minint, i - j), MAX_SET - i)
END
END;
name := modname
END _init;
END RTL.

/programs/develop/oberon07/Lib/Windows32/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
14,7 → 14,17
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
eol*: ARRAY 3 OF CHAR;
21,7 → 31,11
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
51,6 → 65,9
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
69,4 → 86,45
END exit_thread;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

/programs/develop/oberon07/Lib/Windows32/Args.ob07
0,0 → 1,101
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Args;
IMPORT SYSTEM, WINAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR): INTEGER;
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
RETURN cond
END ChangeCond;
BEGIN
p := WINAPI.GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: IF ChangeCond(0, 4, 1, cond, c) = 1 THEN Params[count, 0] := p END
|1: IF ChangeCond(0, 3, 1, cond, c) IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: IF ChangeCond(3, 1, 3, cond, c) = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: IF ChangeCond(5, 0, 5, cond, c) = 5 THEN Params[count, 0] := p END
|5: IF ChangeCond(5, 1, 5, cond, c) = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
i := Params[n, 0];
len := LEN(s) - 1;
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # '"' THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
BEGIN
ParamParse
END Args.

/programs/develop/oberon07/Lib/Windows32/Console.ob07
0,0 → 1,100
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
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;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

/programs/develop/oberon07/Lib/Windows32/DateTime.ob07
0,0 → 1,174
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
CONST
ERR* = -7.0E5;
VAR
DateTable: ARRAY 120000, 3 OF INTEGER;
MonthsTable: ARRAY 13, 4 OF INTEGER;
PROCEDURE Encode* (Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): REAL;
VAR
d, bis: INTEGER;
res: REAL;
BEGIN
res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) &
(MSec >= 0) & (MSec <= 999) THEN
bis := ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
IF Day <= MonthsTable[Month][2 + bis] THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) +
MonthsTable[Month][bis] + Day - 693594;
res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / 86400000.0
END
END
RETURN res
END Encode;
PROCEDURE Decode* (Date: REAL; VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
d, t: INTEGER;
L, R, M: INTEGER;
BEGIN
res := (Date >= -693593.0) & (Date < 2958466.0);
IF res THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
INC(d, 693593);
L := 0;
R := LEN(DateTable) - 1;
M := (L + R) DIV 2;
WHILE R - L > 1 DO
IF d > DateTable[M][0] THEN
L := M;
M := (L + R) DIV 2
ELSIF d < DateTable[M][0] THEN
R := M;
M := (L + R) DIV 2
ELSE
L := M;
R := M
END
END;
Year := DateTable[L][1];
Month := DateTable[L][2];
Day := d - DateTable[L][0] + 1;
Hour := t DIV 3600000; t := t MOD 3600000;
Min := t DIV 60000; t := t MOD 60000;
Sec := t DIV 1000;
MSec := t MOD 1000
END
RETURN res
END Decode;
PROCEDURE Now* (VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER);
VAR
T: WINAPI.TSystemTime;
BEGIN
WINAPI.GetLocalTime(T);
Year := ORD(T.Year);
Month := ORD(T.Month);
Day := ORD(T.Day);
Hour := ORD(T.Hour);
Min := ORD(T.Min);
Sec := ORD(T.Sec);
MSec := ORD(T.MSec)
END Now;
PROCEDURE NowEncode* (): REAL;
VAR
Year, Month, Day, Hour, Min, Sec, MSec: INTEGER;
BEGIN
Now(Year, Month, Day, Hour, Min, Sec, MSec)
RETURN Encode(Year, Month, Day, Hour, Min, Sec, MSec)
END NowEncode;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;
Months: ARRAY 13 OF INTEGER;
BEGIN
Months[1] := 31; Months[2] := 28; Months[3] := 31; Months[4] := 30;
Months[5] := 31; Months[6] := 30; Months[7] := 31; Months[8] := 31;
Months[9] := 30; Months[10] := 31; Months[11] := 30; Months[12] := 31;
day := 0;
year := 1;
month := 1;
i := 0;
WHILE year <= 10000 DO
DateTable[i][0] := day;
DateTable[i][1] := year;
DateTable[i][2] := month;
INC(day, Months[month]);
IF (month = 2) & ((year MOD 4 = 0) & (year MOD 100 # 0) OR (year MOD 400 = 0)) THEN
INC(day)
END;
INC(month);
IF month > 12 THEN
month := 1;
INC(year)
END;
INC(i)
END;
MonthsTable[1][0] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][0] := MonthsTable[i - 1][0] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][2] := Months[i]
END;
Months[2] := 29;
MonthsTable[1][1] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][1] := MonthsTable[i - 1][1] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][3] := Months[i]
END
END init;
BEGIN
init
END DateTime.

/programs/develop/oberon07/Lib/Windows32/File.ob07
0,0 → 1,142
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, WINAPI;
CONST
OPEN_R* = 0; OPEN_W* = 1; OPEN_RW* = 2;
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
FindData: WINAPI.TWin32FindData;
Handle: INTEGER;
BEGIN
Handle := WINAPI.FindFirstFile(SYSTEM.ADR(FName[0]), FindData);
IF Handle # -1 THEN
WINAPI.FindClose(Handle);
IF 4 IN FindData.dwFileAttributes THEN
Handle := -1
END
END
RETURN Handle # -1
END Exists;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.DeleteFile(SYSTEM.ADR(FName[0])) # 0
END Delete;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN WINAPI.CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END Create;
PROCEDURE Close* (F: INTEGER);
BEGIN
WINAPI.CloseHandle(F)
END Close;
PROCEDURE Open* (FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER;
VAR
ofstr: WINAPI.OFSTRUCT;
BEGIN
RETURN WINAPI.OpenFile(SYSTEM.ADR(FName[0]), ofstr, Mode)
END Open;
PROCEDURE Seek* (F, Offset, Origin: INTEGER): INTEGER;
RETURN WINAPI.SetFilePointer(F, Offset, 0, Origin)
END Seek;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF WINAPI.ReadFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END Read;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF WINAPI.WriteFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END Write;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER;
VAR
res, n, F: INTEGER;
BEGIN
res := 0;
F := Open(FName, OPEN_R);
IF F # -1 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := WINAPI.GlobalAlloc(64, Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
WINAPI.GlobalFree(Size);
res := 0;
Size := 0
END
END;
Close(F)
END
RETURN res
END Load;
PROCEDURE RemoveDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.RemoveDirectory(SYSTEM.ADR(DirName[0])) # 0
END RemoveDir;
PROCEDURE ExistsDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
Code: SET;
BEGIN
Code := WINAPI.GetFileAttributes(SYSTEM.ADR(DirName[0]))
RETURN (Code # {0..31}) & (4 IN Code)
END ExistsDir;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.CreateDirectory(SYSTEM.ADR(DirName[0]), NIL) # 0
END CreateDir;
END File.

/programs/develop/oberon07/Lib/Windows32/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
82,7 → 82,9
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
310,6 → 312,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
326,6 → 364,8
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.
END HOST.

/programs/develop/oberon07/Lib/Windows32/In.ob07
0,0 → 1,289
(*
Copyright 2013, 2017, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE In;
IMPORT sys := SYSTEM, WINAPI;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
WINAPI.ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
hConsoleInput := WINAPI.GetStdHandle(-10);
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/Windows32/Math.ob07
0,0 → 1,384
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
res := (b - a) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
res := exp(exponent * ln(base))
END
RETURN res
END power;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
END Math.

/programs/develop/oberon07/Lib/Windows32/Out.ob07
0,0 → 1,280
(*
Copyright 2013, 2014, 2017, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, WINAPI;
CONST
d = 1.0 - 5.0E-12;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE String*(s: ARRAY OF CHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), NIL)
END String;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
END StringW;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
END Char;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := WINAPI.GetStdHandle(-11)
END Open;
END Out.

/programs/develop/oberon07/Lib/Windows32/RTL.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
16,36 → 16,16
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
name: INTEGER;
types: INTEGER;
bits: ARRAY MAX_SET + 1 OF INTEGER;
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
97,7 → 77,6
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
106,7 → 85,6
INC(i)
END;
A[k] := n
END _rot;
128,14 → 106,16
END _set;
PROCEDURE [stdcall] _set1* (a: INTEGER): INTEGER;
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
IF ASR(a, 5) = 0 THEN
SYSTEM.GET(SYSTEM.ADR(bits[0]) + a * WORD, a)
ELSE
a := 0
END
RETURN a
SYSTEM.CODE(
031H, 0C0H, (* xor eax, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
077H, 003H, (* ja L *)
00FH, 0ABH, 0C8H (* bts eax, ecx *)
(* L: *)
)
END _set1;
315,7 → 295,6
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
349,7 → 328,6
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
398,7 → 376,6
c: CHAR;
BEGIN
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
422,6 → 399,7
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
437,7 → 415,6
END;
s1[j] := 0X
END append;
446,20 → 423,18
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
513,36 → 488,16
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
API.sofinit
END _sofinit;
RETURN res
END _dllentry;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
571,42 → 526,8
END
END;
j := 1;
FOR i := 0 TO MAX_SET DO
bits[i] := j;
j := LSL(j, 1)
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
name := modname
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.
END RTL.

/programs/develop/oberon07/Lib/Windows32/UnixTime.ob07
0,0 → 1,64
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE UnixTime;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END time;
BEGIN
init
END UnixTime.

/programs/develop/oberon07/Lib/Windows32/Utils.ob07
0,0 → 1,76
(*
Copyright 2013, 2017, 2018, 2020 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Utils;
IMPORT WINAPI;
PROCEDURE PutSeed*(seed: INTEGER);
BEGIN
WINAPI.srand(seed)
END PutSeed;
PROCEDURE Rnd*(range : INTEGER): INTEGER;
RETURN WINAPI.rand() MOD range
END Rnd;
PROCEDURE Utf8To16*(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR): INTEGER;
VAR i, j, L, u, N: INTEGER;
BEGIN
L := LEN(source);
N := LEN(dest);
N := N - N MOD 2 - 1;
i := 0;
j := 0;
WHILE (i < L) & (j < N) & (source[i] # 0X) DO
CASE source[i] OF
|00X..7FX: u := ORD(source[i]);
|0C1X..0DFX:
u := LSL(ORD(source[i]) - 0C0H, 6);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
|0E1X..0EFX:
u := LSL(ORD(source[i]) - 0E0H, 12);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 20);
INC(i)
END;
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
(* |0F1X..0F7X:
|0F9X..0FBX:
|0FDX:*)
ELSE
END;
INC(i);
dest[j] := CHR(u MOD 256);
INC(j);
dest[j] := CHR(u DIV 256);
INC(j);
END;
IF j < N THEN
dest[j] := 0X;
dest[j + 1] := 0X
END
RETURN j DIV 2
END Utf8To16;
END Utils.

/programs/develop/oberon07/Lib/Windows32/WINAPI.ob07
0,0 → 1,241
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
END;
TWin32FindData* = RECORD
dwFileAttributes*: SET;
ftCreationTime*: TFileTime;
ftLastAccessTime*: TFileTime;
ftLastWriteTime*: TFileTime;
nFileSizeHigh*: INTEGER;
nFileSizeLow*: INTEGER;
dwReserved0*: INTEGER;
dwReserved1*: INTEGER;
cFileName*: STRING;
cAlternateFileName*: ARRAY 14 OF CHAR
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "RemoveDirectoryA"]
RemoveDirectory* (lpPathName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetFileAttributesA"]
GetFileAttributes* (lpPathName: INTEGER): SET;
PROCEDURE [windows-, "kernel32.dll", "CreateDirectoryA"]
CreateDirectory* (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindFirstFileA"]
FindFirstFile* (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "DeleteFileA"]
DeleteFile* (lpFileName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindClose"]
FindClose* (hFindFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
CreateFile* (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
OpenFile* (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetFilePointer"]
SetFilePointer* (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleA"]
WriteConsole* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "rand"]
rand* (): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "srand"]
srand* (seed: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"]
MessageBoxA* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxW"]
MessageBox* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "CreateWindowExA"]
CreateWindowEx* (
dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y,
nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.

/programs/develop/oberon07/Lib/Windows64/API.ob07
0,0 → 1,130
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN HeapAlloc(heap, 8, size)
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
HeapFree(heap, 0, p)
RETURN 0
END _DISPOSE;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

/programs/develop/oberon07/Lib/Windows64/Console.ob07
0,0 → 1,100
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
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;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

/programs/develop/oberon07/Lib/Windows64/DateTime.ob07
0,0 → 1,174
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
CONST
ERR* = -7.0E5;
VAR
DateTable: ARRAY 120000, 3 OF INTEGER;
MonthsTable: ARRAY 13, 4 OF INTEGER;
PROCEDURE Encode* (Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): REAL;
VAR
d, bis: INTEGER;
res: REAL;
BEGIN
res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) &
(MSec >= 0) & (MSec <= 999) THEN
bis := ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
IF Day <= MonthsTable[Month][2 + bis] THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) +
MonthsTable[Month][bis] + Day - 693594;
res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / 86400000.0
END
END
RETURN res
END Encode;
PROCEDURE Decode* (Date: REAL; VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
d, t: INTEGER;
L, R, M: INTEGER;
BEGIN
res := (Date >= -693593.0) & (Date < 2958466.0);
IF res THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
INC(d, 693593);
L := 0;
R := LEN(DateTable) - 1;
M := (L + R) DIV 2;
WHILE R - L > 1 DO
IF d > DateTable[M][0] THEN
L := M;
M := (L + R) DIV 2
ELSIF d < DateTable[M][0] THEN
R := M;
M := (L + R) DIV 2
ELSE
L := M;
R := M
END
END;
Year := DateTable[L][1];
Month := DateTable[L][2];
Day := d - DateTable[L][0] + 1;
Hour := t DIV 3600000; t := t MOD 3600000;
Min := t DIV 60000; t := t MOD 60000;
Sec := t DIV 1000;
MSec := t MOD 1000
END
RETURN res
END Decode;
PROCEDURE Now* (VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER);
VAR
T: WINAPI.TSystemTime;
BEGIN
WINAPI.GetLocalTime(T);
Year := ORD(T.Year);
Month := ORD(T.Month);
Day := ORD(T.Day);
Hour := ORD(T.Hour);
Min := ORD(T.Min);
Sec := ORD(T.Sec);
MSec := ORD(T.MSec)
END Now;
PROCEDURE NowEncode* (): REAL;
VAR
Year, Month, Day, Hour, Min, Sec, MSec: INTEGER;
BEGIN
Now(Year, Month, Day, Hour, Min, Sec, MSec)
RETURN Encode(Year, Month, Day, Hour, Min, Sec, MSec)
END NowEncode;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;
Months: ARRAY 13 OF INTEGER;
BEGIN
Months[1] := 31; Months[2] := 28; Months[3] := 31; Months[4] := 30;
Months[5] := 31; Months[6] := 30; Months[7] := 31; Months[8] := 31;
Months[9] := 30; Months[10] := 31; Months[11] := 30; Months[12] := 31;
day := 0;
year := 1;
month := 1;
i := 0;
WHILE year <= 10000 DO
DateTable[i][0] := day;
DateTable[i][1] := year;
DateTable[i][2] := month;
INC(day, Months[month]);
IF (month = 2) & ((year MOD 4 = 0) & (year MOD 100 # 0) OR (year MOD 400 = 0)) THEN
INC(day)
END;
INC(month);
IF month > 12 THEN
month := 1;
INC(year)
END;
INC(i)
END;
MonthsTable[1][0] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][0] := MonthsTable[i - 1][0] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][2] := Months[i]
END;
Months[2] := 29;
MonthsTable[1][1] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][1] := MonthsTable[i - 1][1] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][3] := Months[i]
END
END init;
BEGIN
init
END DateTime.

/programs/develop/oberon07/Lib/Windows64/HOST.ob07
0,0 → 1,371
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, RTL;
CONST
slash* = "\";
OS* = "WINDOWS";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
TYPE
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: WCHAR;
Reserved1: WCHAR;
Reserved2: WCHAR;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
TSystemTime = RECORD
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
END;
VAR
hConsoleOutput: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
_CloseHandle(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
T: TSystemTime;
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

/programs/develop/oberon07/Lib/Windows64/In.ob07
0,0 → 1,295
(*
Copyright 2013, 2017, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE In;
IMPORT sys := SYSTEM;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
hConsoleInput := GetStdHandle(-10);
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/Windows64/Math.ob07
0,0 → 1,311
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
VAR
Exp: ARRAY 710 OF REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
VAR
a, s, res: REAL;
neg: BOOLEAN;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
ELSE
res := SYSTEM.INF();
x := 0.0
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
END
RETURN res
END exp;
PROCEDURE ln* (x: REAL): REAL;
VAR
a, x2, res: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
UNPK(x, n);
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
RETURN res * 2.0
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
RETURN exp(exponent * ln(base))
END power;
PROCEDURE log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
VAR
a, res: REAL;
n: INTEGER;
BEGIN
x := ABS(x);
ASSERT(x <= MaxCosArg);
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
RETURN res
END cos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
END
RETURN x
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
END
END init;
BEGIN
init
END Math.

/programs/develop/oberon07/Lib/Windows64/Out.ob07
0,0 → 1,308
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
TYPE
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
BEGIN
WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
END Char;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
BEGIN
WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
END StringW;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR len, i: INTEGER;
BEGIN
len := LENGTH(s);
FOR i := 0 TO len - 1 DO
Char(s[i])
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 32 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i, minInt: INTEGER;
BEGIN
minInt := 1;
minInt := ROR(minInt, 1);
IF x # minInt THEN
WriteInt(x, width)
ELSE
FOR i := 21 TO width DO
Char(20X)
END;
String("-9223372036854775808")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

/programs/develop/oberon07/Lib/Windows64/RTL.ob07
0,0 → 1,516
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 64;
maxint* = 7FFFFFFFFFFFFFFFH;
minint* = 8000000000000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
sets: ARRAY (MAX_SET + 1) * (MAX_SET + 1) OF INTEGER;
PROCEDURE [stdcall64] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 085H, 0C0H, (* test rax, rax *)
07EH, 020H, (* jle L *)
0FCH, (* cld *)
057H, (* push rdi *)
056H, (* push rsi *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 0C1H, 0E9H, 003H, (* shr rcx, 3 *)
0F3H, 048H, 0A5H, (* rep movsd *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 083H, 0E1H, 007H, (* and rcx, 7 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop rsi *)
05FH (* pop rdi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall64] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall64] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall64] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall64] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
SYSTEM.GET((MIN(b, MAX_SET) * (MAX_SET + 1) + MAX(a, 0)) * WORD + SYSTEM.ADR(sets[0]), a)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE [stdcall64] _set1* (a: INTEGER); (* {a} -> rax *)
BEGIN
SYSTEM.CODE(
048H, 031H, 0C0H, (* xor rax, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- a *)
048H, 083H, 0F9H, 03FH, (* cmp rcx, 63 *)
077H, 004H, (* ja L *)
048H, 00FH, 0ABH, 0C8H (* bts rax, rcx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall64] _divmod* (y, x: INTEGER); (* (x div y) -> rax; (x mod y) -> rdx *)
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *) (* rax <- x *)
048H, 031H, 0D2H, (* xor rdx, rdx *)
048H, 085H, 0C0H, (* test rax, rax *)
074H, 022H, (* je L2 *)
07FH, 003H, (* jg L1 *)
048H, 0F7H, 0D2H, (* not rdx *)
(* L1: *)
049H, 089H, 0C0H, (* mov r8, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- y *)
048H, 0F7H, 0F9H, (* idiv rcx *)
048H, 085H, 0D2H, (* test rdx, rdx *)
074H, 00EH, (* je L2 *)
049H, 031H, 0C8H, (* xor r8, rcx *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07DH, 006H, (* jge L2 *)
048H, 0FFH, 0C8H, (* dec rax *)
048H, 001H, 0CAH (* add rdx, rcx *)
(* L2: *)
)
END _divmod;
PROCEDURE [stdcall64] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall64] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall64] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 0FFH, 0C8H, (* dec rax *)
(* L1: *)
048H, 0FFH, 0C0H, (* inc rax *)
080H, 038H, 000H, (* cmp byte [rax], 0 *)
074H, 005H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
048H, 0FFH, 0C0H, (* inc rax *)
(* L2: *)
048H, 02BH, 045H, 018H (* sub rax, qword [rbp + 24] *)
)
END _length;
PROCEDURE [stdcall64] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 083H, 0E8H, 002H, (* sub rax, 2 *)
(* L1: *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
066H, 083H, 038H, 000H, (* cmp word [rax], 0 *)
074H, 006H, (* jz L2 *)
0E2H, 0F4H, (* loop L1 *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
(* L2: *)
048H, 02BH, 045H, 018H, (* sub rax, qword [rbp + 24] *)
048H, 0D1H, 0E8H (* shr rax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall64] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 024H, (* jle L3 *)
044H, 08AH, 009H, (* mov r9b, byte[rcx] *)
044H, 08AH, 012H, (* mov r10b, byte[rdx] *)
048H, 0FFH, 0C1H, (* inc rcx *)
048H, 0FFH, 0C2H, (* inc rdx *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0DAH, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall64] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 028H, (* jle L3 *)
066H, 044H, 08BH, 009H, (* mov r9w, word[rcx] *)
066H, 044H, 08BH, 012H, (* mov r10w, word[rdx] *)
048H, 083H, 0C1H, 002H, (* add rcx, 2 *)
048H, 083H, 0C2H, 002H, (* add rdx, 2 *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0D6H, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall64] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall64] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall64] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall64] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall64] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall64] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall64] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall64] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall64] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall64] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
FOR i := 0 TO MAX_SET DO
FOR j := 0 TO i DO
sets[i * (MAX_SET + 1) + j] := LSR(ASR(minint, i - j), MAX_SET - i)
END
END;
name := modname
END _init;
END RTL.

/programs/develop/oberon07/Lib/Windows64/UnixTime.ob07
0,0 → 1,64
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE UnixTime;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END time;
BEGIN
init
END UnixTime.

/programs/develop/oberon07/Lib/Windows64/WINAPI.ob07
0,0 → 1,170
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.

/programs/develop/oberon07/Samples/Dialogs.ob07
1,4 → 1,4
MODULE Dialogs;
MODULE Dialogs;
IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg;

/programs/develop/oberon07/Samples/HW.ob07
1,4 → 1,4
MODULE HW;
MODULE HW;
IMPORT sys := SYSTEM, KOSAPI;

/programs/develop/oberon07/Samples/HW_con.ob07
1,4 → 1,4
MODULE HW_con;
MODULE HW_con;
IMPORT Out, In, Console, DateTime;

/programs/develop/oberon07/Source/CONSTANTS.ob07
File deleted

/programs/develop/oberon07/Source/AMD64.ob07
1,14 → 1,14
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE AMD64;
IMPORT IL, BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PATHS, PROG,
REG, C := CONSOLE, UTILS, mConst := CONSTANTS, S := STRINGS, PE32, ELF, X86;
IMPORT IL, BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PATHS, PROG, TARGETS,
REG, C := CONSOLE, UTILS, S := STRINGS, PE32, ELF, X86;
CONST
74,25 → 74,25
PROCEDURE OutByte2 (a, b: BYTE);
BEGIN
OutByte(a);
OutByte(b)
X86.OutByte(a);
X86.OutByte(b)
END OutByte2;
PROCEDURE OutByte3 (a, b, c: BYTE);
BEGIN
OutByte(a);
OutByte(b);
OutByte(c)
X86.OutByte(a);
X86.OutByte(b);
X86.OutByte(c)
END OutByte3;
PROCEDURE OutInt (n: INTEGER);
BEGIN
OutByte(UTILS.Byte(n, 0));
OutByte(UTILS.Byte(n, 1));
OutByte(UTILS.Byte(n, 2));
OutByte(UTILS.Byte(n, 3))
X86.OutByte(n MOD 256);
X86.OutByte(UTILS.Byte(n, 1));
X86.OutByte(UTILS.Byte(n, 2));
X86.OutByte(UTILS.Byte(n, 3))
END OutInt;
114,7 → 114,7
PROCEDURE OutIntByte (n: INTEGER);
BEGIN
IF isByte(n) THEN
OutByte(UTILS.Byte(n, 0))
OutByte(n MOD 256)
ELSE
OutInt(n)
END
154,12 → 154,12
PROCEDURE lea (reg, offset, section: INTEGER);
BEGIN
Rex(0, reg);
OutByte2(8DH, 05H + 8 * (reg MOD 8)); // lea reg, [rip + offset]
OutByte2(8DH, 05H + 8 * (reg MOD 8)); (* lea reg, [rip + offset] *)
X86.Reloc(section, offset)
END lea;
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); // op reg1, reg2
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
Rex(reg1, reg2);
OutByte2(op, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8)
166,7 → 166,7
END oprr;
PROCEDURE oprr2 (op1, op2: BYTE; reg1, reg2: INTEGER); // op reg1, reg2
PROCEDURE oprr2 (op1, op2: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
Rex(reg1, reg2);
OutByte3(op1, op2, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8)
173,55 → 173,55
END oprr2;
PROCEDURE mov (reg1, reg2: INTEGER); // mov reg1, reg2
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *)
BEGIN
oprr(89H, reg1, reg2)
END mov;
PROCEDURE xor (reg1, reg2: INTEGER); // xor reg1, reg2
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *)
BEGIN
oprr(31H, reg1, reg2)
END xor;
PROCEDURE and (reg1, reg2: INTEGER); // and reg1, reg2
PROCEDURE and (reg1, reg2: INTEGER); (* and reg1, reg2 *)
BEGIN
oprr(21H, reg1, reg2)
END and;
PROCEDURE or (reg1, reg2: INTEGER); // and reg1, reg2
PROCEDURE or (reg1, reg2: INTEGER); (* or reg1, reg2 *)
BEGIN
oprr(09H, reg1, reg2)
END or;
PROCEDURE add (reg1, reg2: INTEGER); // add reg1, reg2
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *)
BEGIN
oprr(01H, reg1, reg2)
END add;
PROCEDURE sub (reg1, reg2: INTEGER); // sub reg1, reg2
PROCEDURE sub (reg1, reg2: INTEGER); (* sub reg1, reg2 *)
BEGIN
oprr(29H, reg1, reg2)
END sub;
PROCEDURE xchg (reg1, reg2: INTEGER); // xchg reg1, reg2
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *)
BEGIN
oprr(87H, reg1, reg2)
END xchg;
PROCEDURE cmprr (reg1, reg2: INTEGER); // cmp reg1, reg2
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *)
BEGIN
oprr(39H, reg1, reg2)
END cmprr;
PROCEDURE pop (reg: INTEGER); // pop reg
PROCEDURE pop (reg: INTEGER); (* pop reg *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
230,7 → 230,7
END pop;
PROCEDURE push (reg: INTEGER); // push reg
PROCEDURE push (reg: INTEGER); (* push reg *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
242,7 → 242,7
PROCEDURE decr (reg: INTEGER);
BEGIN
Rex(reg, 0);
OutByte2(0FFH, 0C8H + reg MOD 8) // dec reg1
OutByte2(0FFH, 0C8H + reg MOD 8) (* dec reg1 *)
END decr;
249,7 → 249,7
PROCEDURE incr (reg: INTEGER);
BEGIN
Rex(reg, 0);
OutByte2(0FFH, 0C0H + reg MOD 8) // inc reg1
OutByte2(0FFH, 0C0H + reg MOD 8) (* inc reg1 *)
END incr;
276,7 → 276,7
BEGIN
reg := GetAnyReg();
lea(reg, label, sIMP);
IF reg >= 8 THEN // call qword[reg]
IF reg >= 8 THEN (* call qword[reg] *)
OutByte(41H)
END;
OutByte2(0FFH, 10H + reg MOD 8);
337,7 → 337,7
BEGIN
Rex(reg, 0);
OutByte(0B8H + reg MOD 8); // movabs reg, n
OutByte(0B8H + reg MOD 8); (* movabs reg, n *)
FOR i := 0 TO 7 DO
OutByte(UTILS.Byte(n, i))
END
344,7 → 344,7
END movabs;
PROCEDURE movrc (reg, n: INTEGER); // mov reg, n
PROCEDURE movrc (reg, n: INTEGER); (* mov reg, n *)
BEGIN
IF isLong(n) THEN
movabs(reg, n)
358,7 → 358,7
END movrc;
PROCEDURE test (reg: INTEGER); // test reg, reg
PROCEDURE test (reg: INTEGER); (* test reg, reg *)
BEGIN
oprr(85H, reg, reg)
END test;
370,6 → 370,7
BEGIN
reg2 := GetAnyReg();
ASSERT(reg2 # reg);
movabs(reg2, n);
oprr(reg, reg2);
drop
388,30 → 389,46
END oprc;
PROCEDURE cmprc (reg, n: INTEGER); // cmp reg, n
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *)
BEGIN
IF n = 0 THEN
test(reg)
ELSE
oprc(0F8H, reg, n, cmprr)
END
END cmprc;
PROCEDURE addrc (reg, n: INTEGER); // add reg, n
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *)
BEGIN
oprc(0C0H, reg, n, add)
END addrc;
PROCEDURE subrc (reg, n: INTEGER); // sub reg, n
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *)
BEGIN
oprc(0E8H, reg, n, sub)
END subrc;
PROCEDURE andrc (reg, n: INTEGER); // and reg, n
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *)
BEGIN
oprc(0E0H, reg, n, and)
END andrc;
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *)
BEGIN
oprc(0C8H, reg, n, or)
END orrc;
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *)
BEGIN
oprc(0F0H, reg, n, xor)
END xorrc;
PROCEDURE pushc (n: INTEGER);
VAR
reg2: INTEGER;
423,12 → 440,12
push(reg2);
drop
ELSE
OutByte(68H + short(n)); OutIntByte(n) // push n
OutByte(68H + short(n)); OutIntByte(n) (* push n *)
END
END pushc;
PROCEDURE not (reg: INTEGER); // not reg
PROCEDURE not (reg: INTEGER); (* not reg *)
BEGIN
Rex(reg, 0);
OutByte2(0F7H, 0D0H + reg MOD 8)
435,7 → 452,7
END not;
PROCEDURE neg (reg: INTEGER); // neg reg
PROCEDURE neg (reg: INTEGER); (* neg reg *)
BEGIN
Rex(reg, 0);
OutByte2(0F7H, 0D8H + reg MOD 8)
442,129 → 459,39
END neg;
PROCEDURE movzx (reg1, reg2, offs: INTEGER; word: BOOLEAN); // movzx reg1, byte/word[reg2 + offs]
VAR
b: BYTE;
PROCEDURE movzx (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *)
BEGIN
Rex(reg2, reg1);
OutByte2(0FH, 0B6H + ORD(word));
IF (offs = 0) & (reg2 # rbp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = rsp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
X86.movzx(reg1, reg2, offs, word)
END movzx;
PROCEDURE _movrm (reg1, reg2, offs, size: INTEGER; mr: BOOLEAN);
VAR
b: BYTE;
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_32 *)
BEGIN
IF size = 16 THEN
OutByte(66H)
END;
IF (reg1 >= 8) OR (reg2 >= 8) OR (size = 64) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8) + 8 * ORD(size = 64))
END;
OutByte(8BH - 2 * ORD(mr) - ORD(size = 8));
IF (offs = 0) & (reg2 # rbp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = rsp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END _movrm;
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); // mov dword[reg1+offs], reg2_32
BEGIN
_movrm(reg2, reg1, offs, 32, TRUE)
X86._movrm(reg2, reg1, offs, 32, TRUE)
END movmr32;
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); // mov reg1_32, dword[reg2+offs]
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); (* mov reg1_32, dword[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 32, FALSE)
X86._movrm(reg1, reg2, offs, 32, FALSE)
END movrm32;
PROCEDURE movmr8 (reg1, offs, reg2: INTEGER); // mov byte[reg1+offs], reg2_8
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov qword[reg1+offs], reg2 *)
BEGIN
_movrm(reg2, reg1, offs, 8, TRUE)
END movmr8;
PROCEDURE movrm8 (reg1, reg2, offs: INTEGER); // mov reg1_8, byte[reg2+offs]
BEGIN
_movrm(reg1, reg2, offs, 8, FALSE)
END movrm8;
PROCEDURE movmr16 (reg1, offs, reg2: INTEGER); // mov word[reg1+offs], reg2_16
BEGIN
_movrm(reg2, reg1, offs, 16, TRUE)
END movmr16;
PROCEDURE movrm16 (reg1, reg2, offs: INTEGER); // mov reg1_16, word[reg2+offs]
BEGIN
_movrm(reg1, reg2, offs, 16, FALSE)
END movrm16;
PROCEDURE movmr (reg1, offs, reg2: INTEGER); // mov qword[reg1+offs], reg2
BEGIN
_movrm(reg2, reg1, offs, 64, TRUE)
X86._movrm(reg2, reg1, offs, 64, TRUE)
END movmr;
PROCEDURE movrm (reg1, reg2, offs: INTEGER); // mov reg1, qword[reg2+offs]
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, qword[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 64, FALSE)
X86._movrm(reg1, reg2, offs, 64, FALSE)
END movrm;
PROCEDURE pushm (reg, offs: INTEGER); // push qword[reg+offs]
VAR
b: BYTE;
PROCEDURE comisd (xmm1, xmm2: INTEGER); (* comisd xmm1, xmm2 *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte(0FFH);
IF (offs = 0) & (reg # rbp) THEN
b := 30H
ELSE
b := 70H + long(offs)
END;
OutByte(b + reg MOD 8);
IF reg = rsp THEN
OutByte(24H)
END;
IF b # 30H THEN
OutIntByte(offs)
END
END pushm;
PROCEDURE comisd (xmm1, xmm2: INTEGER); // comisd xmm1, xmm2
BEGIN
OutByte(66H);
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8)
598,13 → 525,13
END _movsdrm;
PROCEDURE movsdrm (xmm, reg, offs: INTEGER); // movsd xmm, qword[reg+offs]
PROCEDURE movsdrm (xmm, reg, offs: INTEGER); (* movsd xmm, qword[reg+offs] *)
BEGIN
_movsdrm(xmm, reg, offs, FALSE)
END movsdrm;
PROCEDURE movsdmr (reg, offs, xmm: INTEGER); // movsd qword[reg+offs], xmm
PROCEDURE movsdmr (reg, offs, xmm: INTEGER); (* movsd qword[reg+offs], xmm *)
BEGIN
_movsdrm(xmm, reg, offs, TRUE)
END movsdmr;
620,19 → 547,19
END opxx;
PROCEDURE jcc (cc, label: INTEGER); // jcc label
PROCEDURE jcc (cc, label: INTEGER); (* jcc label *)
BEGIN
X86.jcc(cc, label)
END jcc;
PROCEDURE jmp (label: INTEGER); // jmp label
PROCEDURE jmp (label: INTEGER); (* jmp label *)
BEGIN
X86.jmp(label)
END jmp;
PROCEDURE setcc (cc, reg: INTEGER); //setcc reg8
PROCEDURE setcc (cc, reg: INTEGER); (* setcc reg8 *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
680,7 → 607,6
reg: INTEGER;
max: INTEGER;
loop: INTEGER;
param2: INTEGER;
BEGIN
loop := 1;
756,17 → 682,7
leaf := FALSE
|IL.opDIVR, IL.opMODR:
param2 := cur.param2;
IF param2 >= 1 THEN
param2 := UTILS.Log2(param2)
ELSIF param2 <= -1 THEN
param2 := UTILS.Log2(-param2)
ELSE
param2 := -1
END;
IF param2 < 0 THEN
leaf := FALSE
END
leaf := UTILS.Log2(cur.param2) >= 0
ELSE
912,9 → 828,9
comisd(xmm - 1, xmm);
cc := setnc
END;
OutByte2(7AH, 3 + reg DIV 8); // jp L
OutByte2(7AH, 3 + reg DIV 8); (* jp L *)
setcc(cc, reg);
//L:
(* L: *)
END fcmp;
969,7 → 885,7
|IL.opWIN64CALLP: Win64Passing(param2)
|IL.opSYSVCALLP: SysVPassing(param2)
END;
OutByte2(0FFH, 0D0H); // call rax
OutByte2(0FFH, 0D0H); (* call rax *)
REG.Restore(R);
ASSERT(R.top = -1)
989,6 → 905,10
|IL.opERR:
CallRTL(IL._error)
|IL.opONERR:
pushc(param2);
jmp(param1)
|IL.opPUSHC:
pushc(param2)
1117,9 → 1037,9
n := param2;
IF n > 4 THEN
movrc(rcx, n);
// L:
(* L: *)
pushc(0);
OutByte2(0E2H, 0FCH) // loop L
OutByte2(0E2H, 0FCH) (* loop L *)
ELSE
WHILE n > 0 DO
pushc(0);
1156,9 → 1076,9
pop(rbp);
IF param2 > 0 THEN
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) // ret param2
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) (* ret param2 *)
ELSE
OutByte(0C3H) // ret
X86.ret
END;
REG.Reset(R)
1265,7 → 1185,7
|IL.opLADR:
n := param2 * 8;
next := cmd.next(COMMAND);
IF next.opcode = IL.opSAVEF THEN
IF (next.opcode = IL.opSAVEF) OR (next.opcode = IL.opSAVEFI) THEN
movsdmr(rbp, n, xmm);
DEC(xmm);
cmd := next
1276,7 → 1196,7
ELSE
reg1 := GetAnyReg();
Rex(0, reg1);
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); // lea reg1, qword[rbp+n]
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); (* lea reg1, qword[rbp+n] *)
OutIntByte(n)
END
1291,7 → 1211,7
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, param2); // mov byte[reg1], param2
OutByte3(0C6H, reg1 MOD 8, param2); (* mov byte[reg1], param2 *)
drop
|IL.opSAVE16C:
1301,7 → 1221,7
OutByte(41H)
END;
OutByte2(0C7H, reg1 MOD 8);
OutByte2(param2 MOD 256, param2 DIV 256); // mov word[reg1], param2
OutByte2(param2 MOD 256, param2 DIV 256); (* mov word[reg1], param2 *)
drop
|IL.opSAVEC:
1313,7 → 1233,7
drop
ELSE
Rex(reg1, 0);
OutByte2(0C7H, reg1 MOD 8); // mov qword[reg1], param2
OutByte2(0C7H, reg1 MOD 8); (* mov qword[reg1], param2 *)
OutInt(param2)
END;
drop
1346,10 → 1266,10
|IL.opINCL, IL.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 64);
OutByte2(73H, 04H); // jnb L
OutByte2(73H, 04H); (* jnb L *)
Rex(reg2, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); // bts/btr qword[reg2], reg1
// L:
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); (* bts/btr qword[reg2], reg1 *)
(* L: *)
drop;
drop
1356,7 → 1276,7
|IL.opINCLC, IL.opEXCLC:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); // bts/btr qword[reg1], param2
OutByte2(0FH, 0BAH); (* bts/btr qword[reg1], param2 *)
OutByte2(28H + 8 * ORD(opcode = IL.opEXCLC) + reg1 MOD 8, param2);
drop
1384,26 → 1304,19
drop
ELSE
UnOp(reg1);
IF param2 = 0 THEN
test(reg1)
ELSE
cmprc(reg1, param2)
END
END;
drop;
cc := X86.cond(opcode);
IF cmd.next(COMMAND).opcode = IL.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = IL.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(X86.inv0(cc), label);
cmd := cmd.next(COMMAND)
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
jcc(X86.inv0(cc), next.param1);
cmd := next
ELSE
reg1 := GetAnyReg();
setcc(cc + 16, reg1);
1447,6 → 1360,11
test(reg1);
jcc(je, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJE:
UnOp(reg1);
test(reg1);
1459,7 → 1377,11
jcc(je, param1);
drop
|IL.opIN:
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
reg2 := GetAnyReg();
movrc(reg2, param2)
END;
label := NewLabel();
L := NewLabel();
BinOp(reg1, reg2);
1469,34 → 1391,16
jmp(label);
X86.SetLabel(L);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); (* bt reg2, reg1 *)
setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
|IL.opINR:
label := NewLabel();
L := NewLabel();
UnOp(reg1);
reg2 := GetAnyReg();
cmprc(reg1, 64);
jcc(jb, L);
xor(reg1, reg1);
jmp(label);
X86.SetLabel(L);
movrc(reg2, param2);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
|IL.opINL:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); // bt reg1, param2
OutByte2(0FH, 0BAH); (* bt reg1, param2 *)
OutByte2(0E0H + reg1 MOD 8, param2);
setcc(setc, reg1);
andrc(reg1, 1)
1516,9 → 1420,9
|IL.opABS:
UnOp(reg1);
test(reg1);
OutByte2(7DH, 03H); // jge L
OutByte2(7DH, 03H); (* jge L *)
neg(reg1)
// L:
(* L: *)
|IL.opEQB, IL.opNEB:
BinOp(reg1, reg2);
1545,12 → 1449,14
UnOp(reg1);
andrc(reg1, param2)
|IL.opDIVSC, IL.opADDSL, IL.opADDSR:
|IL.opDIVSC:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(81H + short(param2), 0C8H + 28H * ORD(opcode = IL.opDIVSC) + reg1 MOD 8); // or/xor reg1, param2
OutIntByte(param2)
xorrc(reg1, param2)
|IL.opADDSL, IL.opADDSR:
UnOp(reg1);
orrc(reg1, param2)
|IL.opSUBSL:
UnOp(reg1);
not(reg1);
1646,7 → 1552,7
|IL.opTYPEGD:
UnOp(reg1);
PushAll(0);
pushm(reg1, -8);
X86.pushm(reg1, -8);
pushc(param2 * tcount);
CallRTL(IL._guardrec);
GetRegA
1673,7 → 1579,7
|IL.opINC, IL.opDEC:
BinOp(reg1, reg2);
// add/sub qword[reg2], reg1
(* add/sub qword[reg2], reg1 *)
Rex(reg2, reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg2 MOD 8 + (reg1 MOD 8) * 8);
drop;
1684,15 → 1590,15
IF isLong(param2) THEN
reg2 := GetAnyReg();
movrc(reg2, param2);
// add qword[reg1], reg2
(* add qword[reg1], reg2 *)
Rex(reg1, reg2);
OutByte2(01H, reg1 MOD 8 + (reg2 MOD 8) * 8);
drop
ELSIF ABS(param2) = 1 THEN
Rex(reg1, 0);
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(param2 = -1)) // inc/dec qword[reg1]
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(param2 = -1)) (* inc/dec qword[reg1] *)
ELSE
// add qword[reg1], param2
(* add qword[reg1], param2 *)
Rex(reg1, 0);
OutByte2(81H + short(param2), reg1 MOD 8);
OutIntByte(param2)
1711,13 → 1617,13
|IL.opSAVE8:
BinOp(reg2, reg1);
movmr8(reg1, 0, reg2);
X86.movmr8(reg1, 0, reg2);
drop;
drop
|IL.opSAVE16:
BinOp(reg2, reg1);
movmr16(reg1, 0, reg2);
X86.movmr16(reg1, 0, reg2);
drop;
drop
1727,38 → 1633,27
drop;
drop
|IL.opMIN:
|IL.opMAX, IL.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(7EH, 3); // jle L
OutByte2(7DH + ORD(opcode = IL.opMIN), 3); (* jge/jle L *)
mov(reg1, reg2);
// L:
(* L: *)
drop
|IL.opMAX:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(7DH, 3); // jge L
mov(reg1, reg2);
// L:
drop
|IL.opMINC:
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
jcc(jle, label);
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, label);
movrc(reg1, param2);
X86.SetLabel(label)
|IL.opMAXC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
jcc(jge, label);
movrc(reg1, param2);
X86.SetLabel(label)
|IL.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
1765,7 → 1660,7
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, 95H, reg1 MOD 8); // setne byte[reg1]
OutByte3(0FH, 95H, reg1 MOD 8); (* setne byte[reg1] *)
drop;
drop
1774,13 → 1669,9
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0)); // mov byte[reg1], 0/1
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *)
drop
|IL.opODD:
UnOp(reg1);
andrc(reg1, 1)
|IL.opUMINUS:
UnOp(reg1);
neg(reg1)
1810,8 → 1701,29
END
|IL.opADDL, IL.opADDR:
IF param2 # 0 THEN
IF (param2 # 0) & ~isLong(param2) THEN
UnOp(reg1);
next := cmd.next(COMMAND);
CASE next.opcode OF
|IL.opLOAD64:
movrm(reg1, reg1, param2);
cmd := next
|IL.opLOAD32:
movrm32(reg1, reg1, param2);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
cmd := next
|IL.opLOAD16:
movzx(reg1, reg1, param2, TRUE);
cmd := next
|IL.opLOAD8:
movzx(reg1, reg1, param2, FALSE);
cmd := next
|IL.opLOAD64_PARAM:
X86.pushm(reg1, param2);
drop;
cmd := next
ELSE
IF param2 = 1 THEN
incr(reg1)
ELSIF param2 = -1 THEN
1820,6 → 1732,9
addrc(reg1, param2)
END
END
ELSIF isLong(param2) THEN
addrc(reg1, param2)
END
|IL.opDIV:
PushAll(2);
1827,41 → 1742,16
GetRegA
|IL.opDIVR:
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
UnOp(reg1);
neg(reg1)
ELSE
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
IF a < 0 THEN
reg2 := GetAnyReg();
mov(reg2, reg1);
shiftrc(sar, reg1, n);
sub(reg1, reg2);
drop
ELSE
shiftrc(sar, reg1, n)
END
ELSE
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(IL._divmod);
GetRegA
END
END
|IL.opDIVL:
UnOp(reg1);
1879,39 → 1769,20
GetRegA
|IL.opMODR:
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF ABS(a) = 1 THEN
UnOp(reg1);
xor(reg1, reg1)
ELSE
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, ABS(a) - 1);
IF a < 0 THEN
test(reg1);
label := NewLabel();
jcc(je, label);
addrc(reg1, a);
X86.SetLabel(label)
END
ELSE
andrc(reg1, param2 - 1);
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(IL._divmod);
mov(rax, rdx);
GetRegA
ELSE
UnOp(reg1);
xor(reg1, reg1)
END
END
|IL.opMODL:
UnOp(reg1);
1925,10 → 1796,19
|IL.opMUL:
BinOp(reg1, reg2);
oprr2(0FH, 0AFH, reg2, reg1); // imul reg1, reg2
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *)
drop
|IL.opMULC:
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN
BinOp(reg1, reg2);
OutByte2(48H + 5 * (reg1 DIV 8) + 2 * (reg2 DIV 8), 8DH); (* lea reg1, [reg1 + reg2 * param2] *)
reg1 := reg1 MOD 8;
reg2 := reg2 MOD 8;
OutByte2(04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2));
drop;
cmd := cmd.next(COMMAND)
ELSE
UnOp(reg1);
a := param2;
1953,12 → 1833,21
END;
shiftrc(shl, reg1, n)
ELSE
// imul reg1, a
IF isLong(a) THEN
reg2 := GetAnyReg();
movabs(reg2, a);
ASSERT(reg1 # reg2);
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *)
drop
ELSE
(* imul reg1, a *)
Rex(reg1, reg1);
OutByte2(69H + short(a), 0C0H + (reg1 MOD 8) * 9);
OutIntByte(a)
END
END
END
END
|IL.opADDS:
BinOp(reg1, reg2);
1990,17 → 1879,23
|IL.opENDSW:
|IL.opCASEL:
GetRegA;
cmprc(rax, param1);
jcc(jl, param2)
jcc(jl, param2);
drop
|IL.opCASER:
GetRegA;
cmprc(rax, param1);
jcc(jg, param2)
jcc(jg, param2);
drop
|IL.opCASELR:
GetRegA;
cmprc(rax, param1);
jcc(jl, param2);
jcc(jg, cmd.param3)
jcc(jg, cmd.param3);
drop
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
BinOp(reg1, reg2);
2007,7 → 1902,7
xchg(reg2, rcx);
Rex(reg1, 0);
OutByte(0D3H);
X86.shift(opcode, reg1 MOD 8); // shift reg1, cl
X86.shift(opcode, reg1 MOD 8); (* shift reg1, cl *)
xchg(reg2, rcx);
drop
2018,7 → 1913,7
xchg(reg1, rcx);
Rex(reg2, 0);
OutByte(0D3H);
X86.shift(opcode, reg2 MOD 8); // shift reg2, cl
X86.shift(opcode, reg2 MOD 8); (* shift reg2, cl *)
xchg(reg1, rcx);
drop;
drop;
2038,8 → 1933,8
END;
drop;
drop;
_movrm(reg1, reg1, 0, param2 * 8, FALSE);
_movrm(reg1, reg2, 0, param2 * 8, TRUE)
X86._movrm(reg1, reg1, 0, param2 * 8, FALSE);
X86._movrm(reg1, reg2, 0, param2 * 8, TRUE)
|IL.opCHKBYTE:
BinOp(reg1, reg2);
2055,14 → 1950,11
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
mov(reg1, reg2);
drop;
jcc(jb, param1)
ELSE
jcc(jb, param1);
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
|IL.opLENGTH:
PushAll(2);
2127,7 → 2019,7
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1 MOD 8, param2 MOD 256); // add/sub byte[reg1], param2 MOD 256
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1 MOD 8, param2 MOD 256); (* add/sub byte[reg1], param2 MOD 256 *)
drop
|IL.opINCB, IL.opDECB:
2135,7 → 2027,7
IF (reg1 >= 8) OR (reg2 >= 8) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8))
END;
OutByte2(28H * ORD(opcode = IL.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); // add/sub byte[reg2], reg1_8
OutByte2(28H * ORD(opcode = IL.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); (* add/sub byte[reg2], reg1_8 *)
drop;
drop
2149,7 → 2041,7
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte2(8FH, reg1 MOD 8); // pop qword[reg1]
OutByte2(8FH, reg1 MOD 8); (* pop qword[reg1] *)
drop
|IL.opCLEANUP:
2181,7 → 2073,7
drop;
NewNumber(UTILS.splitf(float, a, b))
|IL.opSAVEF:
|IL.opSAVEF, IL.opSAVEFI:
UnOp(reg1);
movsdmr(reg1, 0, xmm);
DEC(xmm);
2216,7 → 2108,7
|IL.opUMINF:
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // xorpd xmm, xmmword[reg1]
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); (* xorpd xmm, xmmword[reg1] *)
OutByte2(57H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
2223,7 → 2115,7
|IL.opFABS:
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs + 16, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // andpd xmm, xmmword[reg1]
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); (* andpd xmm, xmmword[reg1] *)
OutByte2(54H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
2230,7 → 2122,7
|IL.opFLT:
UnOp(reg1);
INC(xmm);
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); // cvtsi2sd xmm, reg1
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); (* cvtsi2sd xmm, reg1 *)
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8);
drop
2237,14 → 2129,14
|IL.opFLOOR:
reg1 := GetAnyReg();
subrc(rsp, 8);
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); // stmxcsr dword[rsp+4];
OutByte2(00FH, 0AEH); OutByte2(01CH, 024H); // stmxcsr dword[rsp];
OutByte3(081H, 024H, 024H); OutByte2(0FFH, 09FH); OutByte2(0FFH, 0FFH); // and dword[rsp],11111111111111111001111111111111b;
OutByte3(081H, 00CH, 024H); OutByte2(000H, 020H); OutByte2(000H, 000H); // or dword[rsp],00000000000000000010000000000000b;
OutByte2(00FH, 0AEH); OutByte2(014H, 024H); // ldmxcsr dword[rsp];
OutByte(0F2H); Rex(xmm, reg1); OutByte(0FH); // cvtsd2si reg1, xmm
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); (* stmxcsr dword[rsp+4]; *)
OutByte2(00FH, 0AEH); OutByte2(01CH, 024H); (* stmxcsr dword[rsp]; *)
OutByte3(081H, 024H, 024H); OutByte2(0FFH, 09FH); OutByte2(0FFH, 0FFH); (* and dword[rsp],11111111111111111001111111111111b; *)
OutByte3(081H, 00CH, 024H); OutByte2(000H, 020H); OutByte2(000H, 000H); (* or dword[rsp],00000000000000000010000000000000b; *)
OutByte2(00FH, 0AEH); OutByte2(014H, 024H); (* ldmxcsr dword[rsp]; *)
OutByte(0F2H); Rex(xmm, reg1); OutByte(0FH); (* cvtsd2si reg1, xmm *)
OutByte2(2DH, 0C0H + xmm MOD 8 + (reg1 MOD 8) * 8);
OutByte3(00FH, 0AEH, 054H); OutByte2(024H, 004H); // ldmxcsr dword[rsp+4];
OutByte3(00FH, 0AEH, 054H); OutByte2(024H, 004H); (* ldmxcsr dword[rsp+4]; *)
addrc(rsp, 8);
DEC(xmm)
2278,7 → 2170,7
movrm(reg2, reg2, 0);
push(reg1);
lea(reg1, Numbers_Offs + 40, sDATA); // {0..51, 63}
lea(reg1, Numbers_Offs + 40, sDATA); (* {0..51, 63} *)
movrm(reg1, reg1, 0);
and(reg2, reg1);
pop(reg1);
2299,7 → 2191,7
IF ~regVar THEN
reg2 := GetAnyReg();
Rex(0, reg2);
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); // lea reg2, qword[rbp+n]
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); (* lea reg2, qword[rbp+n] *)
OutIntByte(n)
END
ELSE
2324,7 → 2216,7
movrm(reg1, reg2, 0);
push(reg2);
lea(reg2, Numbers_Offs + 48, sDATA); // {52..61}
lea(reg2, Numbers_Offs + 48, sDATA); (* {52..61} *)
movrm(reg2, reg2, 0);
or(reg1, reg2);
pop(reg2);
2331,7 → 2223,7
Rex(reg1, 0);
OutByte2(0FH, 0BAH);
OutByte2(0F0H + reg1 MOD 8, 3EH); // btr reg1, 62
OutByte2(0F0H + reg1 MOD 8, 3EH); (* btr reg1, 62 *)
movmr(reg2, 0, reg1);
drop;
drop
2340,11 → 2232,11
pushDA(stroffs + param2)
|IL.opVADR_PARAM:
pushm(rbp, param2 * 8)
X86.pushm(rbp, param2 * 8)
|IL.opLOAD64_PARAM:
UnOp(reg1);
pushm(reg1, 0);
X86.pushm(reg1, 0);
drop
|IL.opLLOAD64_PARAM:
2352,7 → 2244,7
IF reg1 # -1 THEN
push(reg1)
ELSE
pushm(rbp, param2 * 8)
X86.pushm(rbp, param2 * 8)
END
|IL.opGLOAD64_PARAM:
2405,7 → 2297,7
movmr(rbp, n, reg2);
drop
ELSE
OutByte3(48H, 0C7H, 45H + long(n)); // mov qword[rbp+n],param2
OutByte3(48H, 0C7H, 45H + long(n)); (* mov qword[rbp+n], param2 *)
OutIntByte(n);
OutInt(param2)
END
2424,7 → 2316,7
reg2 := GetAnyReg();
lea(reg2, param1, sBSS);
Rex(reg2, 0);
OutByte2(0C7H, reg2 MOD 8); // mov qword[reg2], param2
OutByte2(0C7H, reg2 MOD 8); (* mov qword[reg2], param2 *)
OutInt(param2);
drop
END
2450,7 → 2342,7
n := param1 * 8;
Rex(0, reg2);
OutByte2(01H, 45H + long(n) + (reg2 MOD 8) * 8);
OutIntByte(n) // add qword[rbp+n],reg2
OutIntByte(n) (* add qword[rbp+n], reg2 *)
END;
drop
ELSIF ABS(param2) = 1 THEN
2462,7 → 2354,7
END
ELSE
n := param1 * 8;
OutByte3(48H, 0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); // inc/dec qword[rbp+n]
OutByte3(48H, 0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec qword[rbp+n] *)
OutIntByte(n)
END
ELSE
2472,7 → 2364,7
n := param1 * 8;
OutByte3(48H, 81H + short(param2), 45H + long(n));
OutIntByte(n);
OutIntByte(param2) // add qword[rbp+n],param2
OutIntByte(param2) (* add qword[rbp+n], param2 *)
END
END
2490,7 → 2382,7
n := param1 * 8;
OutByte2(80H, 45H + long(n) + 28H * ORD(opcode = IL.opLADR_DECCB));
OutIntByte(n);
OutByte(param2) // add/sub byte[rbp+n],param2
OutByte(param2) (* add/sub byte[rbp+n], param2 *)
END
|IL.opLADR_INC, IL.opLADR_DEC:
2506,7 → 2398,7
n := param2 * 8;
Rex(0, reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + (reg1 MOD 8) * 8);
OutIntByte(n) // add/sub qword[rbp+n],reg1
OutIntByte(n) (* add/sub qword[rbp+n], reg1 *)
END;
drop
2526,7 → 2418,7
OutByte(44H)
END;
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n) // add/sub byte[rbp+n], reg1_8
OutIntByte(n) (* add/sub byte[rbp+n], reg1_8 *)
END;
drop
2535,16 → 2427,16
cmprc(reg1, 64);
reg2 := GetVarReg(param2);
IF reg2 # -1 THEN
OutByte2(73H, 4); // jnb L
oprr2(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), reg2, reg1) // bts/btr reg2, reg1
OutByte2(73H, 4); (* jnb L *)
oprr2(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), reg2, reg1) (* bts/btr reg2, reg1 *)
ELSE
n := param2 * 8;
OutByte2(73H, 5 + 3 * ORD(~isByte(n))); // jnb L
OutByte2(73H, 5 + 3 * ORD(~isByte(n))); (* jnb L *)
Rex(0, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n) // bts/btr qword[rbp+n], reg1
OutIntByte(n) (* bts/btr qword[rbp+n], reg1 *)
END;
// L:
(* L: *)
drop
|IL.opLADR_INCLC, IL.opLADR_EXCLC:
2551,11 → 2443,11
reg1 := GetVarReg(param1);
IF reg1 # -1 THEN
Rex(reg1, 0);
OutByte3(0FH, 0BAH, 0E8H); // bts/btr reg1, param2
OutByte3(0FH, 0BAH, 0E8H); (* bts/btr reg1, param2 *)
OutByte2(reg1 MOD 8 + 8 * ORD(opcode = IL.opLADR_EXCLC), param2)
ELSE
n := param1 * 8;
OutByte3(48H, 0FH, 0BAH); // bts/btr qword[rbp+n], param2
OutByte3(48H, 0FH, 0BAH); (* bts/btr qword[rbp+n], param2 *)
OutByte(6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC));
OutIntByte(n);
OutByte(param2)
2586,7 → 2478,7
entry := NewLabel();
X86.SetLabel(entry);
IF target = mConst.Target_iDLL64 THEN
IF target = TARGETS.Win64DLL THEN
dllret := NewLabel();
push(r8);
push(rdx);
2596,7 → 2488,7
jcc(je, dllret)
END;
IF target = mConst.Target_iELF64 THEN
IF target = TARGETS.Linux64 THEN
push(rsp)
ELSE
pushc(0)
2604,12 → 2496,12
lea(rax, entry, sCODE);
push(rax);
pushDA(0); //TYPES
pushDA(0); (* TYPES *)
pushc(tcount);
pushDA(ModName_Offs); //MODNAME
pushDA(ModName_Offs); (* MODNAME *)
CallRTL(IL._init);
IF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iELF64} THEN
IF target IN {TARGETS.Win64C, TARGETS.Win64GUI, TARGETS.Linux64} THEN
L := NewLabel();
pushc(0);
push(rsp);
2619,7 → 2511,9
pop(rax);
test(rax);
jcc(je, L);
GetRegA;
addrc(rax, 1024 * 1024 * stack_size - 8);
drop;
mov(rsp, rax);
X86.SetLabel(L)
END
2655,15 → 2549,15
BEGIN
IF target = mConst.Target_iDLL64 THEN
IF target = TARGETS.Win64DLL THEN
X86.SetLabel(dllret);
OutByte(0C3H) // ret
ELSIF target = mConst.Target_iELFSO64 THEN
X86.ret
ELSIF target = TARGETS.Linux64SO THEN
sofinit := NewLabel();
OutByte(0C3H); // ret
X86.ret;
X86.SetLabel(sofinit);
CallRTL(IL._sofinit);
OutByte(0C3H) // ret
X86.ret
ELSE
pushc(0);
CallRTL(IL._exit)
2724,8 → 2618,8
BEGIN
offs := offs * 8;
CASE size OF
|1: movmr8(rbp, offs, reg)
|2: movmr16(rbp, offs, reg)
|1: X86.movmr8(rbp, offs, reg)
|2: X86.movmr16(rbp, offs, reg)
|4: movmr32(rbp, offs, reg)
|8: movmr(rbp, offs, reg)
END
2778,12 → 2672,12
epilog(modname, target);
BIN.fixup(prog);
IF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
PE32.write(prog, outname, target = mConst.Target_iConsole64, target = mConst.Target_iDLL64, TRUE)
ELSIF target IN {mConst.Target_iELF64, mConst.Target_iELFSO64} THEN
ELF.write(prog, outname, sofinit, target = mConst.Target_iELFSO64, TRUE)
IF TARGETS.OS = TARGETS.osWIN64 THEN
PE32.write(prog, outname, target = TARGETS.Win64C, target = TARGETS.Win64DLL, TRUE)
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
ELF.write(prog, outname, sofinit, target = TARGETS.Linux64SO, TRUE)
END
END CodeGen;
END AMD64.
END AMD64.

/programs/develop/oberon07/Source/ARITH.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
75,6 → 75,11
END Float;
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN;
RETURN (a <= i.int) & (i.int <= b)
END range;
PROCEDURE check* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
81,9 → 86,9
BEGIN
CASE v.typ OF
|tINTEGER: res := (UTILS.target.minInt <= v.int) & (v.int <= UTILS.target.maxInt)
|tCHAR: res := (0 <= v.int) & (v.int <= 255)
|tWCHAR: res := (0 <= v.int) & (v.int <= 65535)
|tINTEGER: res := range(v, UTILS.target.minInt, UTILS.target.maxInt)
|tCHAR: res := range(v, 0, 255)
|tWCHAR: res := range(v, 0, 65535)
|tREAL: res := (-UTILS.target.maxReal <= v.float) & (v.float <= UTILS.target.maxReal)
END
196,61 → 201,15
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN;
VAR
max: REAL;
res: BOOLEAN;
BEGIN
max := UTILS.maxreal;
CASE op OF
|"+":
IF (a < 0.0) & (b < 0.0) THEN
res := a > -max - b
ELSIF (a > 0.0) & (b > 0.0) THEN
res := a < max - b
ELSE
res := TRUE
END;
IF res THEN
a := a + b
|"+": a := a + b
|"-": a := a - b
|"*": a := a * b
|"/": a := a / b
END
|"-":
IF (a < 0.0) & (b > 0.0) THEN
res := a > b - max
ELSIF (a > 0.0) & (b < 0.0) THEN
res := a < b + max
ELSE
res := TRUE
END;
IF res THEN
a := a - b
END
|"*":
IF (ABS(a) > 1.0) & (ABS(b) > 1.0) THEN
res := ABS(a) < max / ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a * b
END
|"/":
IF ABS(b) < 1.0 THEN
res := ABS(a) < max * ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a / b
END
END
RETURN res
RETURN (-UTILS.maxreal <= a) & (a <= UTILS.maxreal) (* +inf > UTILS.maxreal *)
END opFloat2;
407,13 → 366,8
BEGIN
ASSERT(x > 0);
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 1 THEN
n := UTILS.Log2(x);
IF n = -1 THEN
n := 255
END
521,7 → 475,7
|"-": success := subInt(a.int, b.int)
|"*": success := mulInt(a.int, b.int)
|"/": success := FALSE
|"D": IF (b.int # -1) OR (a.int # UTILS.minint) THEN a.int := a.int DIV b.int ELSE success := FALSE END
|"D": a.int := a.int DIV b.int
|"M": a.int := a.int MOD b.int
|"L": a.int := _LSL(a.int, b.int)
|"A": a.int := _ASR(a.int, b.int)
670,11 → 624,6
END opBoolean;
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN;
RETURN (a <= i.int) & (i.int <= b)
END range;
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;

/programs/develop/oberon07/Source/AVLTREES.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/BIN.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
12,19 → 12,14
CONST
RCODE* = 1;
RDATA* = 2;
RBSS* = 3;
RIMP* = 4;
RCODE* = 0; PICCODE* = RCODE + 1;
RDATA* = 2; PICDATA* = RDATA + 1;
RBSS* = 4; PICBSS* = RBSS + 1;
RIMP* = 6; PICIMP* = RIMP + 1;
PICCODE* = 5;
PICDATA* = 6;
PICBSS* = 7;
PICIMP* = 8;
IMPTAB* = 8;
IMPTAB* = 9;
TYPE
RELOC* = POINTER TO RECORD (LISTS.ITEM)
211,6 → 206,13
END PutCode32LE;
PROCEDURE PutCode16LE* (program: PROGRAM; x: INTEGER);
BEGIN
CHL.PushByte(program.code, UTILS.Byte(x, 0));
CHL.PushByte(program.code, UTILS.Byte(x, 1))
END PutCode16LE;
PROCEDURE SetLabel* (program: PROGRAM; label, offset: INTEGER);
BEGIN
CHL.SetInt(program.labels, label, offset)

/programs/develop/oberon07/Source/CHUNKLISTS.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
12,8 → 12,8
CONST
LENOFBYTECHUNK = 64000;
LENOFINTCHUNK = 16000;
LENOFBYTECHUNK = 65536;
LENOFINTCHUNK = 16384;
TYPE

/programs/develop/oberon07/Source/COLLECTIONS.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/CONSOLE.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/Compiler.ob07
1,54 → 1,16
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE Compiler;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER, MSP430;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE,
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS;
PROCEDURE Target (s: ARRAY OF CHAR): INTEGER;
VAR
res: INTEGER;
BEGIN
IF s = mConst.Target_sConsole THEN
res := mConst.Target_iConsole
ELSIF s = mConst.Target_sGUI THEN
res := mConst.Target_iGUI
ELSIF s = mConst.Target_sDLL THEN
res := mConst.Target_iDLL
ELSIF s = mConst.Target_sKolibri THEN
res := mConst.Target_iKolibri
ELSIF s = mConst.Target_sObject THEN
res := mConst.Target_iObject
ELSIF s = mConst.Target_sConsole64 THEN
res := mConst.Target_iConsole64
ELSIF s = mConst.Target_sGUI64 THEN
res := mConst.Target_iGUI64
ELSIF s = mConst.Target_sDLL64 THEN
res := mConst.Target_iDLL64
ELSIF s = mConst.Target_sELF32 THEN
res := mConst.Target_iELF32
ELSIF s = mConst.Target_sELFSO32 THEN
res := mConst.Target_iELFSO32
ELSIF s = mConst.Target_sELF64 THEN
res := mConst.Target_iELF64
ELSIF s = mConst.Target_sELFSO64 THEN
res := mConst.Target_iELFSO64
ELSIF s = mConst.Target_sMSP430 THEN
res := mConst.Target_iMSP430
ELSE
res := 0
END
RETURN res
END Target;
PROCEDURE keys (VAR options: PROG.OPTIONS; VAR out: PARS.PATH);
VAR
param: PARS.PATH;
168,6 → 130,22
END keys;
PROCEDURE OutTargetItem (target: INTEGER; text: ARRAY OF CHAR);
VAR
width: INTEGER;
BEGIN
width := 15;
width := width - LENGTH(TARGETS.Targets[target].ComLinePar) - 4;
C.String(" '"); C.String(TARGETS.Targets[target].ComLinePar); C.String("'");
WHILE width > 0 DO
C.String(20X);
DEC(width)
END;
C.StringLn(text)
END OutTargetItem;
PROCEDURE main;
VAR
path: PARS.PATH;
180,7 → 158,6
param: PARS.PATH;
temp: PARS.PATH;
target: INTEGER;
bit_depth: INTEGER;
time: INTEGER;
options: PROG.OPTIONS;
196,32 → 173,46
UTILS.GetArg(1, inname);
C.Ln;
C.String("Akron Oberon Compiler v"); C.Int(mConst.vMajor); C.String("."); C.Int2(mConst.vMinor);
C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit)");
C.StringLn("Copyright (c) 2018-2019, Anton Krotov");
C.StringLn("Copyright (c) 2018-2020, Anton Krotov");
IF inname = "" THEN
C.Ln;
C.StringLn("Usage: Compiler <main module> <target> [optional settings]"); C.Ln;
C.StringLn("target =");
IF UTILS.bit_depth = 64 THEN
C.StringLn('target = console | gui | dll | console64 | gui64 | dll64 | kos | obj | elfexe | elfso | elfexe64 | elfso64 | msp430'); C.Ln;
ELSIF UTILS.bit_depth = 32 THEN
C.StringLn('target = console | gui | dll | kos | obj | elfexe | elfso | msp430'); C.Ln;
OutTargetItem(TARGETS.Win64C, "Windows64 Console");
OutTargetItem(TARGETS.Win64GUI, "Windows64 GUI");
OutTargetItem(TARGETS.Win64DLL, "Windows64 DLL");
OutTargetItem(TARGETS.Linux64, "Linux64 Exec");
OutTargetItem(TARGETS.Linux64SO, "Linux64 SO")
END;
OutTargetItem(TARGETS.Win32C, "Windows32 Console");
OutTargetItem(TARGETS.Win32GUI, "Windows32 GUI");
OutTargetItem(TARGETS.Win32DLL, "Windows32 DLL");
OutTargetItem(TARGETS.Linux32, "Linux32 Exec");
OutTargetItem(TARGETS.Linux32SO, "Linux32 SO");
OutTargetItem(TARGETS.KolibriOS, "KolibriOS Exec");
OutTargetItem(TARGETS.KolibriOSDLL, "KolibriOS DLL");
OutTargetItem(TARGETS.MSP430, "MSP430x{1,2}xx microcontrollers");
OutTargetItem(TARGETS.STM32CM3, "STM32 Cortex-M3 microcontrollers");
C.Ln;
C.StringLn("optional settings:"); C.Ln;
C.StringLn(" -out <file name> output"); C.Ln;
C.StringLn(" -stk <size> set size of stack in megabytes"); C.Ln;
C.StringLn(' -nochk <"ptibcwra"> disable runtime checking (pointers, types, indexes,');
C.StringLn(' BYTE, CHR, WCHR)'); C.Ln;
C.StringLn(" -ver <major.minor> set version of program ('obj' target)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes ('msp430' target)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes ('msp430' target)"); C.Ln;
C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln;
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,");
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln;
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
UTILS.Exit(0)
END;
C.StringLn("--------------------------------------------");
PATHS.split(inname, path, modname, ext);
IF ext # mConst.FILE_EXT THEN
IF ext # UTILS.FILE_EXT THEN
ERRORS.Error(207)
END;
235,52 → 226,29
ERRORS.Error(205)
END;
target := Target(param);
IF target = 0 THEN
IF TARGETS.Select(param) THEN
target := TARGETS.target
ELSE
ERRORS.Error(206)
END;
CASE target OF
|mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64, mConst.Target_iELFSO64:
bit_depth := 64
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL,
mConst.Target_iKolibri, mConst.Target_iObject, mConst.Target_iELF32, mConst.Target_iELFSO32:
bit_depth := 32
|mConst.Target_iMSP430:
bit_depth := 16;
IF target = TARGETS.MSP430 THEN
options.ram := MSP430.minRAM;
options.rom := MSP430.minROM
END;
IF UTILS.bit_depth < bit_depth THEN
IF target = TARGETS.STM32CM3 THEN
options.ram := THUMB.STM32_minRAM;
options.rom := THUMB.STM32_minROM
END;
IF UTILS.bit_depth < TARGETS.BitDepth THEN
ERRORS.Error(206)
END;
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
CASE target OF
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL:
STRINGS.append(lib_path, "Windows32")
|mConst.Target_iKolibri, mConst.Target_iObject:
STRINGS.append(lib_path, "KolibriOS")
|mConst.Target_iELF32, mConst.Target_iELFSO32:
STRINGS.append(lib_path, "Linux32")
|mConst.Target_iELF64, mConst.Target_iELFSO64:
STRINGS.append(lib_path, "Linux64")
|mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64:
STRINGS.append(lib_path, "Windows64")
|mConst.Target_iMSP430:
STRINGS.append(lib_path, "MSP430")
END;
STRINGS.append(lib_path, TARGETS.LibDir);
STRINGS.append(lib_path, UTILS.slash);
keys(options, outname);
287,24 → 255,7
IF outname = "" THEN
outname := path;
STRINGS.append(outname, modname);
CASE target OF
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iConsole64, mConst.Target_iGUI64:
STRINGS.append(outname, ".exe")
|mConst.Target_iObject:
STRINGS.append(outname, ".obj")
|mConst.Target_iKolibri, mConst.Target_iELF32, mConst.Target_iELF64:
|mConst.Target_iELFSO32, mConst.Target_iELFSO64:
STRINGS.append(outname, ".so")
|mConst.Target_iDLL, mConst.Target_iDLL64:
STRINGS.append(outname, ".dll")
|mConst.Target_iMSP430:
STRINGS.append(outname, ".hex")
END
STRINGS.append(outname, TARGETS.FileExt)
ELSE
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
312,15 → 263,12
END
END;
PARS.init(bit_depth, target, options);
PARS.init(options);
PARS.program.dll := target IN {mConst.Target_iELFSO32, mConst.Target_iELFSO64, mConst.Target_iDLL, mConst.Target_iDLL64, mConst.Target_iObject};
PARS.program.obj := target = mConst.Target_iObject;
ST.compile(path, lib_path, modname, outname, target, options);
time := UTILS.GetTickCount() - UTILS.time;
C.StringLn("--------------------------------------------");
C.Int(PARS.lines); C.String(" lines, ");
C.Int(time DIV 100); C.String("."); C.Int2(time MOD 100); C.String(" sec, ");
C.Int(WRITER.counter); C.StringLn(" bytes");

/programs/develop/oberon07/Source/ELF.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
142,23 → 142,27
PROCEDURE fixup (program: BIN.PROGRAM; text, data, bss: INTEGER; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
L, delta: INTEGER;
code: CHL.BYTELIST;
L, delta, delta0: INTEGER;
BEGIN
code := program.code;
delta0 := 3 - 7 * ORD(amd64);
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - text - 7 * ORD(amd64);
L := BIN.get32le(code, reloc.offset);
delta := delta0 - reloc.offset - text;
CASE reloc.opcode OF
|BIN.PICDATA: BIN.put32le(program.code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(program.code, reloc.offset, L + bss + delta)
|BIN.PICDATA: BIN.put32le(code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(code, reloc.offset, L + bss + delta)
END;
reloc := reloc.next(BIN.RELOC)
END;
END
END fixup;

/programs/develop/oberon07/Source/ERRORS.ob07
1,13 → 1,13
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE ERRORS;
IMPORT C := CONSOLE, UTILS, mConst := CONSTANTS;
IMPORT C := CONSOLE, UTILS;
PROCEDURE HintMsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
73,7 → 73,7
| 43: str := "expression is not an integer"
| 44: str := "out of range 0..MAXSET"
| 45: str := "division by zero"
| 46: str := "integer division by zero"
| 46: str := "IV out of range"
| 47: str := "'OF' or ',' expected"
| 48: str := "undeclared identifier"
| 49: str := "type expected"
137,7 → 137,7
|107: str := "too large parameter of CHR"
|108: str := "a variable or a procedure expected"
|109: str := "expression should be constant"
|110: str := "out of range 0..65535"
|111: str := "record [noalign] cannot have a base type"
|112: str := "record [noalign] cannot be a base type"
|113: str := "result type of procedure should not be REAL"
146,8 → 146,8
|116: str := "procedure too deep nested"
|120: str := "too many formal parameters"
|122: str := "negative divisor"
|121: str := "multiply defined handler"
|122: str := "bad divisor"
|123: str := "illegal flag"
|124: str := "unknown flag"
|125: str := "flag not supported"
184,7 → 184,7
PROCEDURE WrongRTL* (ProcName: ARRAY OF CHAR);
BEGIN
Error5("procedure ", mConst.RTL_NAME, ".", ProcName, " not found")
Error5("procedure ", UTILS.RTL_NAME, ".", ProcName, " not found")
END WrongRTL;
209,9 → 209,9
|204: Error1("size of variables is too large")
|205: Error1("not enough parameters")
|206: Error1("bad parameter <target>")
|207: Error3('inputfile name extension must be "', mConst.FILE_EXT, '"')
|207: Error3('inputfile name extension must be "', UTILS.FILE_EXT, '"')
END
END Error;
END ERRORS.
END ERRORS.

/programs/develop/oberon07/Source/FILES.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
17,8 → 17,10
ptr: INTEGER;
buffer: ARRAY 64*1024 OF BYTE;
count: INTEGER
count: INTEGER;
chksum*: INTEGER
END;
VAR
83,7 → 85,8
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := 0
file.count := 0;
file.chksum := 0
ELSE
file := NIL
END
190,30 → 193,14
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN;
VAR
res: BOOLEAN;
arr: ARRAY 1 OF BYTE;
BEGIN
res := TRUE;
IF (file # NIL) & (file.count >= 0) THEN
IF file.count = LEN(file.buffer) THEN
IF flush(file) # LEN(file.buffer) THEN
res := FALSE
ELSE
file.buffer[0] := byte;
file.count := 1
END
ELSE
file.buffer[file.count] := byte;
INC(file.count)
END
ELSE
res := FALSE
END
RETURN res
arr[0] := byte
RETURN write(file, arr, 1) = 1
END WriteByte;
BEGIN
files := C.create()
END FILES.
END FILES.

/programs/develop/oberon07/Source/HEX.ob07
0,0 → 1,127
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE HEX;
IMPORT FILES, WRITER, CHL := CHUNKLISTS;
PROCEDURE hexdgt (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
n := n + ORD("0")
ELSE
n := n - 10 + ORD("A")
END
RETURN n
END hexdgt;
PROCEDURE Byte (file: FILES.FILE; byte: BYTE);
BEGIN
WRITER.WriteByte(file, hexdgt(byte DIV 16));
WRITER.WriteByte(file, hexdgt(byte MOD 16));
INC(file.chksum, byte);
END Byte;
PROCEDURE NewLine (file: FILES.FILE);
BEGIN
Byte(file, (-file.chksum) MOD 256);
file.chksum := 0;
WRITER.WriteByte(file, 0DH);
WRITER.WriteByte(file, 0AH)
END NewLine;
PROCEDURE StartCode (file: FILES.FILE);
BEGIN
WRITER.WriteByte(file, ORD(":"));
file.chksum := 0
END StartCode;
PROCEDURE Data* (file: FILES.FILE; mem: ARRAY OF BYTE; idx, cnt: INTEGER);
VAR
i, len: INTEGER;
BEGIN
WHILE cnt > 0 DO
len := MIN(cnt, 16);
StartCode(file);
Byte(file, len);
Byte(file, idx DIV 256);
Byte(file, idx MOD 256);
Byte(file, 0);
FOR i := 1 TO len DO
Byte(file, mem[idx]);
INC(idx)
END;
DEC(cnt, len);
NewLine(file)
END
END Data;
PROCEDURE ExtLA* (file: FILES.FILE; LA: INTEGER);
BEGIN
ASSERT((0 <= LA) & (LA <= 0FFFFH));
StartCode(file);
Byte(file, 2);
Byte(file, 0);
Byte(file, 0);
Byte(file, 4);
Byte(file, LA DIV 256);
Byte(file, LA MOD 256);
NewLine(file)
END ExtLA;
PROCEDURE Data2* (file: FILES.FILE; mem: CHL.BYTELIST; idx, cnt, LA: INTEGER);
VAR
i, len, offset: INTEGER;
BEGIN
ExtLA(file, LA);
offset := 0;
WHILE cnt > 0 DO
ASSERT(offset <= 65536);
IF offset = 65536 THEN
INC(LA);
ExtLA(file, LA);
offset := 0
END;
len := MIN(cnt, 16);
StartCode(file);
Byte(file, len);
Byte(file, offset DIV 256);
Byte(file, offset MOD 256);
Byte(file, 0);
FOR i := 1 TO len DO
Byte(file, CHL.GetByte(mem, idx));
INC(idx);
INC(offset)
END;
DEC(cnt, len);
NewLine(file)
END
END Data2;
PROCEDURE End* (file: FILES.FILE);
BEGIN
StartCode(file);
Byte(file, 0);
Byte(file, 0);
Byte(file, 0);
Byte(file, 1);
NewLine(file)
END End;
END HEX.

/programs/develop/oberon07/Source/IL.ob07
1,13 → 1,13
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE IL;
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS;
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS, TARGETS;
CONST
65,7 → 65,7
opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139;
opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145;
opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151;
opODD* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162;
opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168;
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
83,7 → 83,9
opSYSVCALL* = 217; opSYSVCALLI* = 218; opSYSVCALLP* = 219; opSYSVALIGN16* = 220; opWIN64ALIGN16* = 221;
opONERR* = 222; opSAVEFI* = 223; opHANDLER* = 224;
opSADR_PARAM* = -1; opLOAD64_PARAM* = -2; opLLOAD64_PARAM* = -3; opGLOAD64_PARAM* = -4;
opVADR_PARAM* = -5; opCONST_PARAM* = -6; opGLOAD32_PARAM* = -7; opLLOAD32_PARAM* = -8;
opLOAD32_PARAM* = -9;
119,7 → 121,19
_guard *= 20;
_guardrec *= 21;
_fmul *= 22;
_fdiv *= 23;
_fdivi *= 24;
_fadd *= 25;
_fsub *= 26;
_fsubi *= 27;
_fcmp *= 28;
_floor *= 29;
_flt *= 30;
_pack *= 31;
_unpk *= 32;
TYPE
LOCALVAR* = POINTER TO RECORD (LISTS.ITEM)
184,7 → 198,7
dmin*: INTEGER;
lcount*: INTEGER;
bss*: INTEGER;
rtl*: ARRAY 22 OF INTEGER;
rtl*: ARRAY 33 OF INTEGER;
errlabels*: ARRAY 12 OF INTEGER;
charoffs: ARRAY 256 OF INTEGER;
198,8 → 212,7
VAR
codes*: CODES;
endianness: INTEGER;
numRegsFloat: INTEGER;
endianness, numRegsFloat, CPU: INTEGER;
commands, variables: C.COLLECTION;
433,6 → 446,8
BEGIN
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64, TARGETS.cpuMSP430} THEN
old_opcode := cur.opcode;
param2 := nov.param2;
481,6 → 496,9
ELSE
old_opcode := -1
END
ELSE
old_opcode := -1
END;
IF old_opcode = -1 THEN
633,8 → 651,7
PROCEDURE OnError* (line, error: INTEGER);
BEGIN
AddCmd(opPUSHC, line);
AddJmpCmd(opJMP, codes.errlabels[error])
AddCmd2(opONERR, codes.errlabels[error], line)
END OnError;
877,9 → 894,13
END SysPut;
PROCEDURE savef*;
PROCEDURE savef* (inv: BOOLEAN);
BEGIN
AddCmd0(opSAVEF);
IF inv THEN
AddCmd0(opSAVEFI)
ELSE
AddCmd0(opSAVEF)
END;
DEC(codes.fregs);
ASSERT(codes.fregs >= 0)
END savef;
1138,7 → 1159,7
END DelImport;
PROCEDURE init* (pNumRegsFloat, pEndianness: INTEGER);
PROCEDURE init* (pCPU: INTEGER);
VAR
cmd: COMMAND;
i: INTEGER;
1146,9 → 1167,16
BEGIN
commands := C.create();
variables := C.create();
numRegsFloat := pNumRegsFloat;
endianness := pEndianness;
CPU := pCPU;
endianness := little_endian;
CASE CPU OF
|TARGETS.cpuAMD64: numRegsFloat := 6
|TARGETS.cpuX86: numRegsFloat := 8
|TARGETS.cpuMSP430: numRegsFloat := 0
|TARGETS.cpuTHUMB: numRegsFloat := 256
END;
NEW(codes.begcall);
codes.begcall.top := -1;
NEW(codes.endcall);

/programs/develop/oberon07/Source/KOS.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
116,6 → 116,7
icount, dcount, ccount: INTEGER;
code: CHL.BYTELIST;
BEGIN
base := 0;
141,11 → 142,11
header.param := header.sp;
header.path := header.param + PARAM_SIZE;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
L := BIN.get32le(code, reloc.offset);
delta := 3 - reloc.offset - text;
CASE reloc.opcode OF
152,32 → 153,32
|BIN.RIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, idata + iproc.label)
BIN.put32le(code, reloc.offset, idata + iproc.label)
|BIN.RBSS:
BIN.put32le(program.code, reloc.offset, L + bss)
BIN.put32le(code, reloc.offset, L + bss)
|BIN.RDATA:
BIN.put32le(program.code, reloc.offset, L + data)
BIN.put32le(code, reloc.offset, L + data)
|BIN.RCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text)
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text)
|BIN.PICDATA:
BIN.put32le(program.code, reloc.offset, L + data + delta)
BIN.put32le(code, reloc.offset, L + data + delta)
|BIN.PICCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS:
BIN.put32le(program.code, reloc.offset, L + bss + delta)
BIN.put32le(code, reloc.offset, L + bss + delta)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, idata + iproc.label + delta)
BIN.put32le(code, reloc.offset, idata + iproc.label + delta)
|BIN.IMPTAB:
BIN.put32le(program.code, reloc.offset, idata + delta)
BIN.put32le(code, reloc.offset, idata + delta)
END;
198,7 → 199,7
WR.Write32LE(File, header.param);
WR.Write32LE(File, header.path);
CHL.WriteToFile(File, program.code);
CHL.WriteToFile(File, code);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(File, program.data);

/programs/develop/oberon07/Source/LISTS.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/MSCOFF.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
45,19 → 45,11
WHILE reloc # NIL DO
CASE reloc.opcode OF
|BIN.RIMP, BIN.IMPTAB:
WriteReloc(File, reloc.offset, 4, 6)
|BIN.RBSS:
WriteReloc(File, reloc.offset, 5, 6)
|BIN.RDATA:
WriteReloc(File, reloc.offset, 2, 6)
|BIN.RCODE:
WriteReloc(File, reloc.offset, 1, 6)
|BIN.RIMP,
BIN.IMPTAB: WriteReloc(File, reloc.offset, 4, 6)
|BIN.RBSS: WriteReloc(File, reloc.offset, 5, 6)
|BIN.RDATA: WriteReloc(File, reloc.offset, 2, 6)
|BIN.RCODE: WriteReloc(File, reloc.offset, 1, 6)
END;
reloc := reloc.next(BIN.RELOC)
70,9 → 62,11
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
res, L: INTEGER;
code: CHL.BYTELIST;
BEGIN
res := 0;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
79,14 → 73,14
INC(res);
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(program.code, reloc.offset);
L := BIN.get32le(code, reloc.offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.label)
BIN.put32le(code, reloc.offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(program.code, reloc.offset);
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L))
L := BIN.get32le(code, reloc.offset);
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L))
END;
reloc := reloc.next(BIN.RELOC)
159,7 → 153,7
FileHeader.Machine := 014CX;
FileHeader.NumberOfSections := 5X;
FileHeader.TimeDateStamp := UTILS.UnixTime();
//FileHeader.PointerToSymbolTable := 0;
(* FileHeader.PointerToSymbolTable := 0; *)
FileHeader.NumberOfSymbols := 6;
FileHeader.SizeOfOptionalHeader := 0X;
FileHeader.Characteristics := 0184X;
169,7 → 163,7
flat.VirtualAddress := 0;
flat.SizeOfRawData := ccount;
flat.PointerToRawData := ORD(FileHeader.NumberOfSections) * PE32.SIZE_OF_IMAGE_SECTION_HEADER + PE32.SIZE_OF_IMAGE_FILE_HEADER;
//flat.PointerToRelocations := 0;
(* flat.PointerToRelocations := 0; *)
flat.PointerToLinenumbers := 0;
SetNumberOfRelocations(flat, RelocCount(program));
flat.NumberOfLinenumbers := 0X;
191,7 → 185,7
edata.VirtualAddress := 0;
edata.SizeOfRawData := ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD + LENGTH(szversion) + 1 + ecount;
edata.PointerToRawData := data.PointerToRawData + data.SizeOfRawData;
//edata.PointerToRelocations := 0;
(* edata.PointerToRelocations := 0; *)
edata.PointerToLinenumbers := 0;
SetNumberOfRelocations(edata, ExpCount * 2 + 1);
edata.NumberOfLinenumbers := 0X;
202,7 → 196,7
idata.VirtualAddress := 0;
idata.SizeOfRawData := isize;
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData;
//idata.PointerToRelocations := 0;
(* idata.PointerToRelocations := 0; *)
idata.PointerToLinenumbers := 0;
SetNumberOfRelocations(idata, ICount(ImportTable, ILen));
idata.NumberOfLinenumbers := 0X;

/programs/develop/oberon07/Source/MSP430.ob07
1,20 → 1,20
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE MSP430;
IMPORT IL, LISTS, REG, CHL := CHUNKLISTS, ERRORS, FILES, WRITER,
IMPORT IL, LISTS, REG, CHL := CHUNKLISTS, ERRORS, WR := WRITER, HEX,
UTILS, C := CONSOLE, PROG, RTL := MSP430RTL;
CONST
minRAM* = 128; maxRAM* = 10240;
minROM* = 2048; maxROM* = 49152;
minRAM* = 128; maxRAM* = 2048;
minROM* = 2048; maxROM* = 24576;
minStackSize = 64;
24,7 → 24,7
R4 = 4; R5 = 5; R6 = 6; R7 = 7;
IR = 13; HP = 14; BP = 15;
HP = 14; IR = 15;
ACC = R4;
108,7 → 108,9
IdxWords: RECORD src, dst: INTEGER END;
StkCnt: INTEGER;
PROCEDURE EmitLabel (L: INTEGER);
VAR
label: LABEL;
167,9 → 169,18
PROCEDURE src_x (x, Rn: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IdxWords.src := x
RETURN Rn * 256 + sIDX
IF (x = 0) & ~(Rn IN {PC, SR, CG}) THEN
res := Rn * 256 + sINDIR
ELSE
IdxWords.src := x;
res := Rn * 256 + sIDX
END
RETURN res
END src_x;
197,7 → 208,7
BEGIN
CASE x OF
| 0: res := CG * 256
| 1: res := src_x(0, CG); IdxWords.src := NOWORD
| 1: res := CG * 256 + sIDX
| 2: res := indir(CG)
| 4: res := indir(SR)
| 8: res := incr(SR)
213,9 → 224,9
PROCEDURE Op2 (op, src, dst: INTEGER);
BEGIN
ASSERT(BITS(op) + {6, 12..15} = {6, 12..15});
ASSERT(BITS(src) + {4, 5, 8..11} = {4, 5, 8..11});
ASSERT(BITS(dst) + {0..3, 7} = {0..3, 7});
ASSERT(BITS(op) - {6, 12..15} = {});
ASSERT(BITS(src) - {4, 5, 8..11} = {});
ASSERT(BITS(dst) - {0..3, 7} = {});
EmitWord(op + src + dst);
254,7 → 265,8
ELSE
Op1(opPUSH, PC, sINCR);
EmitWord(imm)
END
END;
INC(StkCnt)
END PushImm;
376,13 → 388,15
PROCEDURE Push (reg: INTEGER);
BEGIN
Op1(opPUSH, reg, sREG)
Op1(opPUSH, reg, sREG);
INC(StkCnt)
END Push;
PROCEDURE Pop (reg: INTEGER);
BEGIN
Op2(opMOV, incr(SP), reg)
Op2(opMOV, incr(SP), reg);
DEC(StkCnt)
END Pop;
430,7 → 444,8
EmitCall(RTL.rtl[proc].label);
RTL.Used(proc);
IF params > 0 THEN
Op2(opADD, imm(params * 2), SP)
Op2(opADD, imm(params * 2), SP);
DEC(StkCnt, params)
END
END CallRTL;
582,11 → 597,26
END Neg;
PROCEDURE LocalOffset (offset: INTEGER): INTEGER;
RETURN (offset + StkCnt - ORD(offset > 0)) * 2
END LocalOffset;
PROCEDURE LocalDst (offset: INTEGER): INTEGER;
RETURN dst_x(LocalOffset(offset), SP)
END LocalDst;
PROCEDURE LocalSrc (offset: INTEGER): INTEGER;
RETURN src_x(LocalOffset(offset), SP)
END LocalSrc;
PROCEDURE translate;
VAR
cmd, next: COMMAND;
opcode, param1, param2, label, L, a, n, c1, c2: INTEGER;
opcode, param1, param2, L, a, n, c1, c2: INTEGER;
reg1, reg2: INTEGER;
623,6 → 653,7
|IL.opSADR_PARAM:
Op1(opPUSH, PC, sINCR);
INC(StkCnt);
EmitWord(param2);
Reloc(RDATA)
632,17 → 663,18
|IL.opPUSHC:
PushImm(param2)
|IL.opONERR:
PushImm(param2);
DEC(StkCnt);
EmitJmp(opJMP, param1)
|IL.opLEAVEC:
Pop(PC)
|IL.opENTER:
ASSERT(R.top = -1);
StkCnt := 0;
EmitLabel(param1);
Push(BP);
MovRR(SP, BP);
IF param2 > 8 THEN
Op2(opMOV, imm(param2), R4);
L := NewLabel();
668,14 → 700,11
END;
drop
END;
ASSERT(R.top = -1);
ASSERT(StkCnt = param1);
IF param1 > 0 THEN
MovRR(BP, SP)
Op2(opADD, imm(param1 * 2), SP)
END;
Pop(BP);
Pop(PC)
|IL.opRES:
684,7 → 713,8
|IL.opCLEANUP:
IF param2 # 0 THEN
Op2(opADD, imm(param2 * 2), SP)
Op2(opADD, imm(param2 * 2), SP);
DEC(StkCnt, param2)
END
|IL.opCONST:
720,14 → 750,17
|IL.opLADR:
reg1 := GetAnyReg();
MovRR(BP, reg1);
Op2(opADD, imm(param2 * 2), reg1)
n := LocalOffset(param2);
Op2(opMOV, SP * 256, reg1);
IF n # 0 THEN
Op2(opADD, imm(n), reg1)
END
|IL.opLLOAD8:
Op2(opMOV + BW, src_x(param2 * 2, BP), GetAnyReg())
Op2(opMOV + BW, LocalSrc(param2), GetAnyReg())
|IL.opLLOAD16, IL.opVADR:
Op2(opMOV, src_x(param2 * 2, BP), GetAnyReg())
Op2(opMOV, LocalSrc(param2), GetAnyReg())
|IL.opGLOAD8:
Op2(opMOV + BW, src_x(param2, SR), GetAnyReg());
747,12 → 780,12
|IL.opVLOAD8:
reg1 := GetAnyReg();
Op2(opMOV, src_x(param2 * 2, BP), reg1);
Op2(opMOV, LocalSrc(param2), reg1);
Op2(opMOV + BW, indir(reg1), reg1)
|IL.opVLOAD16:
reg1 := GetAnyReg();
Op2(opMOV, src_x(param2 * 2, BP), reg1);
Op2(opMOV, LocalSrc(param2), reg1);
Op2(opMOV, indir(reg1), reg1)
|IL.opSAVE, IL.opSAVE16:
803,20 → 836,15
Op2(opSUB, imm(param2), reg1)
END;
IF opcode = IL.opSUBL THEN
reg2 := GetAnyReg();
Clear(reg2);
Op2(opSUB, reg1 * 256, reg2);
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
Neg(reg1)
END
|IL.opLADR_SAVEC:
Op2(opMOV, imm(param2), dst_x(param1 * 2, BP))
Op2(opMOV, imm(param2), LocalDst(param1))
|IL.opLADR_SAVE:
UnOp(reg1);
Op2(opMOV, reg1 * 256, dst_x(param2 * 2, BP));
Op2(opMOV, reg1 * 256, LocalDst(param2));
drop
|IL.opGADR_SAVEC:
850,17 → 878,14
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF cmd.next(COMMAND).opcode = IL.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = IL.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(ORD(BITS(cc) / {0}), label);
cmd := cmd.next(COMMAND)
IF next.opcode = IL.opJE THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
jcc(ORD(BITS(cc) / {0}), next.param1);
cmd := next
ELSE
setcc(cc, GetAnyReg())
END
942,14 → 967,11
BinOp(reg1, reg2);
IF param2 # -1 THEN
Op2(opCMP, reg1 * 256, reg2);
MovRR(reg2, reg1);
drop;
jcc(jb, param1)
ELSE
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
|IL.opINCC, IL.opINCCB:
UnOp(reg1);
974,19 → 996,19
drop
|IL.opLADR_INCC, IL.opLADR_INCCB:
Op2(opADD + bw(opcode = IL.opLADR_INCCB), imm(param2), dst_x(param1 * 2, BP))
Op2(opADD + bw(opcode = IL.opLADR_INCCB), imm(param2), LocalDst(param1))
|IL.opLADR_DECCB:
Op2(opSUB + BW, imm(param2), dst_x(param1 * 2, BP))
Op2(opSUB + BW, imm(param2), LocalDst(param1))
|IL.opLADR_INC, IL.opLADR_INCB:
UnOp(reg1);
Op2(opADD + bw(opcode = IL.opLADR_INCB), reg1 * 256, dst_x(param2 * 2, BP));
Op2(opADD + bw(opcode = IL.opLADR_INCB), reg1 * 256, LocalDst(param2));
drop
|IL.opLADR_DEC, IL.opLADR_DECB:
UnOp(reg1);
Op2(opSUB + bw(opcode = IL.opLADR_DECB), reg1 * 256, dst_x(param2 * 2, BP));
Op2(opSUB + bw(opcode = IL.opLADR_DECB), reg1 * 256, LocalDst(param2));
drop
|IL.opPUSHT:
1023,6 → 1045,7
UnOp(reg1);
PushAll(0);
Op1(opPUSH, reg1, sIDX);
INC(StkCnt);
EmitWord(-2);
PushImm(param2);
CallRTL(RTL._guardrec, 2);
1078,39 → 1101,32
CallRTL(RTL._length, 2);
GetRegA
|IL.opMIN:
|IL.opMAX,IL.opMIN:
BinOp(reg1, reg2);
Op2(opCMP, reg2 * 256, reg1);
EmitWord(opJL + 1); (* jl L *)
IF opcode = IL.opMIN THEN
cc := opJL + 1
ELSE
cc := opJGE + 1
END;
EmitWord(cc); (* jge/jl L *)
MovRR(reg2, reg1);
(* L: *)
drop
|IL.opMAX:
BinOp(reg1, reg2);
Op2(opCMP, reg2 * 256, reg1);
EmitWord(opJGE + 1); (* jge L *)
MovRR(reg2, reg1);
(* L: *)
drop
|IL.opMINC:
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
L := NewLabel();
jcc(jl, L);
IF opcode = IL.opMINC THEN
cc := jl
ELSE
cc := jge
END;
jcc(cc, L);
Op2(opMOV, imm(param2), reg1);
EmitLabel(L)
|IL.opMAXC:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
L := NewLabel();
jcc(jge, L);
Op2(opMOV, imm(param2), reg1);
EmitLabel(L)
|IL.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
1153,10 → 1169,6
Op2(opMOV + BW, imm(param2), dst_x(0, reg1));
drop
|IL.opODD:
UnOp(reg1);
Op2(opAND, imm(1), reg1)
|IL.opEQS .. IL.opGES:
PushAll(4);
PushImm((opcode - IL.opEQS) * 12);
1353,6 → 1365,7
UnOp(reg1);
PushAll_1;
Op1(opPUSH, PC, sINCR);
INC(StkCnt);
EmitWord(param2);
Reloc(RDATA);
Push(reg1);
1432,8 → 1445,10
END
|IL.opVADR_PARAM:
Op1(opPUSH, BP, sIDX);
EmitWord(param2 * 2)
reg1 := GetAnyReg();
Op2(opMOV, LocalSrc(param2), reg1);
Push(reg1);
drop
|IL.opNEW:
PushAll(1);
1505,8 → 1520,11
|IL.opLADR_INCL, IL.opLADR_EXCL:
PushAll(1);
MovRR(BP, ACC);
Op2(opADD, imm(param2 * 2), ACC);
MovRR(SP, ACC);
n := LocalOffset(param2);
IF n # 0 THEN
Op2(opADD, imm(n), ACC)
END;
Push(ACC);
IF opcode = IL.opLADR_INCL THEN
CallRTL(RTL._incl, 2)
1515,10 → 1533,10
END
|IL.opLADR_INCLC:
Op2(opBIS, imm(ORD({param2})), dst_x(param1 * 2, BP))
Op2(opBIS, imm(ORD({param2})), LocalDst(param1))
|IL.opLADR_EXCLC:
Op2(opBIC, imm(ORD({param2})), dst_x(param1 * 2, BP))
Op2(opBIC, imm(ORD({param2})), LocalDst(param1))
END;
1598,51 → 1616,6
END epilog;
PROCEDURE hexdgt (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
n := n + ORD("0")
ELSE
n := n - 10 + ORD("A")
END
RETURN n
END hexdgt;
PROCEDURE WriteHexByte (file: FILES.FILE; byte: BYTE);
BEGIN
WRITER.WriteByte(file, hexdgt(byte DIV 16));
WRITER.WriteByte(file, hexdgt(byte MOD 16));
END WriteHexByte;
PROCEDURE WriteHex (file: FILES.FILE; mem: ARRAY OF BYTE; idx, cnt: INTEGER);
VAR
i, len, chksum: INTEGER;
BEGIN
WHILE cnt > 0 DO
len := MIN(cnt, 16);
chksum := len + idx DIV 256 + idx MOD 256;
WRITER.WriteByte(file, ORD(":"));
WriteHexByte(file, len);
WriteHexByte(file, idx DIV 256);
WriteHexByte(file, idx MOD 256);
WriteHexByte(file, 0);
FOR i := 1 TO len DO
WriteHexByte(file, mem[idx]);
INC(chksum, mem[idx]);
INC(idx)
END;
WriteHexByte(file, (-chksum) MOD 256);
DEC(cnt, len);
WRITER.WriteByte(file, 0DH);
WRITER.WriteByte(file, 0AH)
END
END WriteHex;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
i, adr, heap, stack, TextSize, TypesSize, bits, n: INTEGER;
1653,7 → 1626,7
reloc: RELOC;
file: FILES.FILE;
file: WR.FILE;
BEGIN
IdxWords.src := NOWORD;
1694,7 → 1667,7
Code.size := Fixup(Code.address, IntVectorSize + TypesSize);
Data.address := Code.address + Code.size;
Data.size := CHL.Length(IL.codes.data);
Data.size := Data.size + ORD(ODD(Data.size));
Data.size := Data.size + Data.size MOD 2;
TextSize := Code.size + Data.size;
IF Code.address + TextSize + MAX(IL.codes.dmin - Data.size, IntVectorSize + TypesSize) > 10000H THEN
1702,7 → 1675,7
END;
Bss.address := RTL.ram + RTL.VarSize;
Bss.size := IL.codes.bss + ORD(ODD(IL.codes.bss));
Bss.size := IL.codes.bss + IL.codes.bss MOD 2;
heap := Bss.address + Bss.size;
stack := RTL.ram + ram;
ASSERT(stack - heap >= minStackSize);
1754,25 → 1727,19
PutWord(Free.size, adr);
PutWord(4130H, adr); (* RET *)
PutWord(stack, adr);
PutWord(0001H, adr); (* bsl signature (adr 0FFBEH) *)
FOR i := 0 TO LEN(IV) - 1 DO
PutWord(LabelOffs(IV[i]) * 2, adr)
END;
file := FILES.create(outname);
WriteHex(file, mem, Code.address, TextSize);
WriteHex(file, mem, 10000H - IntVectorSize - TypesSize, IntVectorSize + TypesSize);
file := WR.Create(outname);
WRITER.WriteByte(file, ORD(":"));
WriteHexByte(file, 0);
WriteHexByte(file, 0);
WriteHexByte(file, 0);
WriteHexByte(file, 1);
WriteHexByte(file, 255);
WRITER.WriteByte(file, 0DH);
WRITER.WriteByte(file, 0AH);
HEX.Data(file, mem, Code.address, TextSize);
HEX.Data(file, mem, 10000H - IntVectorSize - TypesSize, IntVectorSize + TypesSize);
HEX.End(file);
FILES.close(file);
WR.Close(file);
INC(TextSize, IntVectorSize + TypesSize);
INC(Bss.size, minStackSize + RTL.VarSize);
1784,10 → 1751,9
C.Hex(Free.address, 4); C.String("H..0"); C.Hex(Free.address + Free.size - 1, 4); C.StringLn("H)")
END;
C.Ln;
C.String( " ram: "); C.Int(Bss.size); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(Bss.size * 100 DIV ram); C.StringLn("%)");
C.StringLn("--------------------------------------------")
C.String( " ram: "); C.Int(Bss.size); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(Bss.size * 100 DIV ram); C.StringLn("%)")
END CodeGen;
END MSP430.
END MSP430.

/programs/develop/oberon07/Source/MSP430RTL.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
39,7 → 39,8
LenIV* = 32;
iv = 10000H - LenIV * 2;
sp = iv - 2;
bsl = iv - 2;
sp = bsl - 2;
empty_proc* = sp - 2;
free_size = empty_proc - 2;
free_adr = free_size - 2;
370,18 → 371,20
Word1(4130H) (* RET *)
END;
(* _error (module, err, line: INTEGER) *)
(* _error (modNum, modName, err, line: INTEGER) *)
IF rtl[_error].used THEN
Label(rtl[_error].label);
Word1(0C232H); (* BIC #8, SR; DINT *)
Word1(4303H); (* MOV R3, R3; NOP *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- module *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- err *)
Word2(4116H, 6); (* MOV 6(SP), R6; R6 <- line *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- modNum *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- modName *)
Word2(4116H, 6); (* MOV 6(SP), R6; R6 <- err *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- line *)
Word2(4211H, sp); (* MOV sp(SR), SP *)
Word1(1207H); (* PUSH R7 *)
Word1(1206H); (* PUSH R6 *)
Word1(1205H); (* PUSH R5 *)
Word1(1204H); (* PUSH R4 *)
Word1(1205H); (* PUSH R5 *)
Word2(4214H, trap); (* MOV trap(SR), R4 *)
Word1(9304H); (* TST R4 *)
Word1(2400H + 1); (* JZ L *)
663,15 → 666,10
Label := pLabel;
Word := pWord;
Call := pCall;
IF ramSize > 2048 THEN
ram := 1100H
ELSE
ram := 200H
END;
ram := 200H;
trap := ram;
int := trap + 2
END Init;
END MSP430RTL.
END MSP430RTL.

/programs/develop/oberon07/Source/PARS.ob07
1,13 → 1,14
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE PARS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS, C := COLLECTIONS, mConst := CONSTANTS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS,
C := COLLECTIONS, TARGETS, THUMB;
CONST
77,7 → 78,7
parsers: C.COLLECTION;
lines*: INTEGER;
lines*, modules: INTEGER;
PROCEDURE destroy* (VAR parser: PARSER);
132,7 → 133,7
BEGIN
SCAN.Next(parser.scanner, parser.lex);
errno := parser.lex.error;
IF (errno = 0) & (program.target.sys = mConst.Target_iMSP430) THEN
IF (errno = 0) & (TARGETS.CPU = TARGETS.cpuMSP430) THEN
IF parser.lex.sym = SCAN.lxFLOAT THEN
errno := -SCAN.lxERROR13
ELSIF (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
508,7 → 509,7
check1(FALSE, parser, 124)
END;
check1(sf IN program.target.sysflags, parser, 125);
check1(sf IN program.sysflags, parser, 125);
IF proc THEN
check1(sf IN PROG.proc_flags, parser, 123)
532,15 → 533,15
|PROG.sf_code:
res := PROG.code
|PROG.sf_windows:
IF program.target.sys IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
IF TARGETS.OS = TARGETS.osWIN32 THEN
res := PROG.stdcall
ELSIF program.target.sys IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
ELSIF TARGETS.OS = TARGETS.osWIN64 THEN
res := PROG.win64
END
|PROG.sf_linux:
IF program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELFSO32} THEN
IF TARGETS.OS = TARGETS.osLINUX32 THEN
res := PROG.ccall16
ELSIF program.target.sys IN {mConst.Target_iELF64, mConst.Target_iELFSO64} THEN
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
res := PROG.systemv
END
|PROG.sf_noalign:
577,6 → 578,7
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxSTRING);
dll := parser.lex.s;
STRINGS.UpCase(dll);
ExpectSym(parser, SCAN.lxCOMMA);
ExpectSym(parser, SCAN.lxSTRING);
proc := parser.lex.s;
586,16 → 588,19
checklex(parser, SCAN.lxRSQUARE);
Next(parser)
ELSE
CASE program.target.bit_depth OF
CASE TARGETS.BitDepth OF
|16: call := PROG.default16
|32: call := PROG.default32
|32: IF TARGETS.target = TARGETS.STM32CM3 THEN
call := PROG.ccall
ELSE
call := PROG.default32
END
|64: call := PROG.default64
END
END;
IF import # NIL THEN
check(~(program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELF64, mConst.Target_iELFSO32,
mConst.Target_iELFSO64, mConst.Target_iMSP430}), pos, 70)
check(TARGETS.Import, pos, 70)
END
RETURN call
751,8 → 756,8
ExpectSym(parser, SCAN.lxTO);
Next(parser);
t := PROG.enterType(program, PROG.tPOINTER, program.target.adr, 0, unit);
t.align := program.target.adr;
t := PROG.enterType(program, PROG.tPOINTER, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
getpos(parser, pos);
770,8 → 775,8
ELSIF parser.sym = SCAN.lxPROCEDURE THEN
NextPos(parser, pos);
t := PROG.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t.align := program.target.adr;
t := PROG.enterType(program, PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
t.call := procflag(parser, import, FALSE);
FormalParameters(parser, t)
ELSE
897,11 → 902,13
variables: LISTS.LIST;
int, flt: INTEGER;
comma: BOOLEAN;
code: ARITH.VALUE;
codeProc: BOOLEAN;
code, iv: ARITH.VALUE;
codeProc,
handler: BOOLEAN;
BEGIN
endmod := FALSE;
handler := FALSE;
unit := parser.unit;
921,13 → 928,27
check(PROG.openScope(unit, proc.proc), pos, 116);
proc.type := PROG.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
proc.type := PROG.enterType(program, PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t := proc.type;
t.align := program.target.adr;
t.align := TARGETS.AdrSize;
t.call := call;
FormalParameters(parser, t);
IF parser.sym = SCAN.lxLSQUARE THEN
getpos(parser, pos2);
check(TARGETS.target = TARGETS.STM32CM3, pos2, 24);
Next(parser);
getpos(parser, pos2);
ConstExpression(parser, iv);
check(iv.typ = ARITH.tINTEGER, pos2, 43);
check((0 <= ARITH.Int(iv)) & (ARITH.Int(iv) <= THUMB.maxIVT), pos2, 46);
check(THUMB.SetIV(ARITH.Int(iv)), pos2, 121);
checklex(parser, SCAN.lxRSQUARE);
Next(parser);
handler := TRUE
END;
codeProc := call IN {PROG.code, PROG._code};
IF call IN {PROG.systemv, PROG._systemv} THEN
948,7 → 969,11
IF import = NIL THEN
label := IL.NewLabel();
proc.proc.label := label
proc.proc.label := label;
proc.proc.used := handler;
IF handler THEN
IL.AddCmd2(IL.opHANDLER, label, ARITH.Int(iv))
END
END;
IF codeProc THEN
958,8 → 983,10
getpos(parser, pos2);
ConstExpression(parser, code);
check(code.typ = ARITH.tINTEGER, pos2, 43);
IF program.target.sys # mConst.Target_iMSP430 THEN
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
check(ARITH.range(code, 0, 255), pos2, 42)
ELSIF TARGETS.CPU = TARGETS.cpuTHUMB THEN
check(ARITH.range(code, 0, 65535), pos2, 110)
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
976,8 → 1003,8
IF import = NIL THEN
IF parser.main & proc.export & program.dll THEN
IF program.obj THEN
IF parser.main & proc.export & TARGETS.Dll THEN
IF TARGETS.target = TARGETS.KolibriOSDLL THEN
check((proc.name.s # "lib_init") & (proc.name.s # "version"), pos, 114)
END;
IL.AddExp(label, proc.name.s);
1023,8 → 1050,8
proc.proc.leave := IL.LeaveC()
END;
IF program.target.sys = mConst.Target_iMSP430 THEN
check((enter.param2 * ORD(~codeProc) + proc.type.parSize) * 2 + 16 < program.target.options.ram, pos1, 63)
IF TARGETS.CPU = TARGETS.cpuMSP430 THEN
check((enter.param2 * ORD(~codeProc) + proc.type.parSize) * 2 + 16 < program.options.ram, pos1, 63)
END
END;
1141,7 → 1168,13
ImportList(parser)
END;
CONSOLE.String("compiling "); CONSOLE.String(unit.name.s);
INC(modules);
CONSOLE.String("compiling ");
IF TARGETS.CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuMSP430} THEN
CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") ")
END;
CONSOLE.String(unit.name.s);
IF parser.unit.sysimport THEN
CONSOLE.String(" (SYSTEM)")
END;
1156,6 → 1189,9
IL.SetLabel(errlabel);
IL.StrAdr(name);
IL.Param1;
IF TARGETS.CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuMSP430} THEN
IL.AddCmd(IL.opPUSHC, modules)
END;
IL.AddCmd0(IL.opERR);
FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO
1227,7 → 1263,7
parser.path := path;
parser.lib_path := lib_path;
parser.ext := mConst.FILE_EXT;
parser.ext := UTILS.FILE_EXT;
parser.fname := path;
parser.modname := "";
parser.scanner := NIL;
1247,12 → 1283,13
END create;
PROCEDURE init* (bit_depth, target: INTEGER; options: PROG.OPTIONS);
PROCEDURE init* (options: PROG.OPTIONS);
BEGIN
program := PROG.create(bit_depth, target, options);
program := PROG.create(options);
parsers := C.create();
lines := 0
lines := 0;
modules := 0
END init;
END PARS.
END PARS.

/programs/develop/oberon07/Source/PATHS.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/PE32.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
7,7 → 7,7
MODULE PE32;
IMPORT BIN, LISTS, UTILS, WR := WRITER, mConst := CONSTANTS, CHL := CHUNKLISTS;
IMPORT BIN, LISTS, UTILS, WR := WRITER, CHL := CHUNKLISTS;
CONST
165,13 → 165,9
Relocations: LISTS.LIST;
bit64: BOOLEAN;
libcnt: INTEGER;
SizeOfWord: INTEGER;
PROCEDURE SIZE (): INTEGER;
RETURN SIZE_OF_DWORD * (ORD(bit64) + 1)
END SIZE;
PROCEDURE Export (program: BIN.PROGRAM; DataRVA: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
BEGIN
258,7 → 254,7
import := import.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SIZE()
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord
END GetImportSize;
266,33 → 262,34
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
AdrImp: INTEGER;
code: CHL.BYTELIST;
L, delta, delta0, AdrImp: INTEGER;
BEGIN
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
delta0 := 3 - 7 * ORD(bit64);
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - Address.Code - 7 * ORD(bit64);
L := BIN.get32le(code, reloc.offset);
delta := delta0 - reloc.offset - Address.Code;
CASE reloc.opcode OF
|BIN.PICDATA:
BIN.put32le(program.code, reloc.offset, L + Address.Data + delta)
BIN.put32le(code, reloc.offset, L + Address.Data + delta)
|BIN.PICCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
|BIN.PICBSS:
BIN.put32le(program.code, reloc.offset, L + Address.Bss + delta)
BIN.put32le(code, reloc.offset, L + Address.Bss + delta)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.FirstThunk * SIZE() + AdrImp + delta)
BIN.put32le(code, reloc.offset, iproc.FirstThunk * SizeOfWord + AdrImp + delta)
END;
418,7 → 415,6
i: INTEGER;
BEGIN
WriteWord(file, h.Magic);
WR.WriteByte(file, h.MajorLinkerVersion);
499,6 → 495,7
BEGIN
bit64 := amd64;
SizeOfWord := SIZE_OF_DWORD * (ORD(bit64) + 1);
Relocations := LISTS.create(NIL);
Size.Code := CHL.Length(program.code);
532,8 → 529,8
PEHeader.FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
PEHeader.OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
PEHeader.OptionalHeader.MajorLinkerVersion := mConst.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := mConst.vMinor;
PEHeader.OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
PEHeader.OptionalHeader.SizeOfCode := align(Size.Code, FileAlignment);
PEHeader.OptionalHeader.SizeOfInitializedData := 0;
PEHeader.OptionalHeader.SizeOfUninitializedData := 0;
658,7 → 655,7
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SIZE() + n - 1 DO
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SizeOfWord + n - 1 DO
CHL.PushInt(ImportTable, 0)
END;
666,11 → 663,11
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
i := i + 5
END;
import := import.next(BIN.IMPRT)

/programs/develop/oberon07/Source/PROG.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
7,7 → 7,7
MODULE PROG;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, mConst := CONSTANTS, IL, UTILS;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS;
CONST
199,25 → 199,15
locsize*: INTEGER;
procs*: LISTS.LIST;
dll*: BOOLEAN;
obj*: BOOLEAN;
sysflags*: SET;
options*: OPTIONS;
stTypes*: RECORD
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
tSTRING*, tNIL*, tCARD32*, tANYREC*: TYPE_
END;
target*: RECORD
bit_depth*: INTEGER;
word*: INTEGER;
adr*: INTEGER;
sys*: INTEGER;
sysflags*: SET;
options*: OPTIONS
END
END;
249,7 → 239,6
PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
VAR
word: INTEGER;
size: INTEGER;
BEGIN
263,9 → 252,8
END
END
ELSE
word := program.target.word;
IF UTILS.Align(size, word) THEN
size := size DIV word;
IF UTILS.Align(size, TARGETS.WordSize) THEN
size := size DIV TARGETS.WordSize;
IF UTILS.maxint - program.locsize >= size THEN
INC(program.locsize, size);
varIdent.offset := program.locsize
682,10 → 670,12
ident := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
ident.type := program.stTypes.tBOOLEAN;
IF program.target.sys # mConst.Target_iMSP430 THEN
IF TARGETS.RealSize # 0 THEN
ident := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
ident.type := program.stTypes.tREAL;
ident.type := program.stTypes.tREAL
END;
IF TARGETS.BitDepth >= 32 THEN
ident := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);
ident.type := program.stTypes.tWCHAR
END
737,14 → 727,19
EnterFunc(unit, "MIN", stMIN);
EnterFunc(unit, "MAX", stMAX);
IF unit.program.target.sys # mConst.Target_iMSP430 THEN
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "PACK", stPACK);
EnterProc(unit, "UNPK", stUNPK);
EnterProc(unit, "DISPOSE", stDISPOSE);
EnterFunc(unit, "WCHR", stWCHR);
EnterFunc(unit, "FLOOR", stFLOOR);
EnterFunc(unit, "FLT", stFLT)
END;
IF TARGETS.BitDepth >= 32 THEN
EnterFunc(unit, "WCHR", stWCHR)
END;
IF TARGETS.Dispose THEN
EnterProc(unit, "DISPOSE", stDISPOSE)
END
END enterStProcs;
782,7 → 777,7
unit.sysimport := FALSE;
IF unit.name.s = mConst.RTL_NAME THEN
IF unit.name.s = UTILS.RTL_NAME THEN
program.rtl := unit
END
1037,7 → 1032,7
t.unit := unit;
t.num := 0;
CASE program.target.bit_depth OF
CASE TARGETS.BitDepth OF
|16: t.call := default16
|32: t.call := default32
|64: t.call := default64
1119,12 → 1114,18
EnterProc(unit, "DINT", idSYSPROC, sysDINT)
END;
*)
IF program.target.sys # mConst.Target_iMSP430 THEN
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "INF", idSYSFUNC, sysINF);
END;
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
EnterProc(unit, "COPY", idSYSPROC, sysCOPY)
END;
IF TARGETS.BitDepth >= 32 THEN
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "COPY", idSYSPROC, sysCOPY);
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident.type := program.stTypes.tCARD32;
1191,7 → 1192,7
END DelUnused;
PROCEDURE create* (bit_depth, target: INTEGER; options: OPTIONS): PROGRAM;
PROCEDURE create* (options: OPTIONS): PROGRAM;
VAR
program: PROGRAM;
1198,34 → 1199,18
BEGIN
idents := C.create();
UTILS.SetBitDepth(bit_depth);
UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
NEW(program);
program.target.bit_depth := bit_depth;
program.target.word := bit_depth DIV 8;
program.target.adr := bit_depth DIV 8;
program.target.sys := target;
program.target.options := options;
program.options := options;
CASE target OF
|mConst.Target_iConsole,
mConst.Target_iGUI,
mConst.Target_iDLL: program.target.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iELF32,
mConst.Target_iELFSO32: program.target.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iKolibri,
mConst.Target_iObject: program.target.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iConsole64,
mConst.Target_iGUI64,
mConst.Target_iDLL64: program.target.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|mConst.Target_iELF64,
mConst.Target_iELFSO64: program.target.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|mConst.Target_iMSP430: program.target.sysflags := {sf_code}
CASE TARGETS.OS OF
|TARGETS.osWIN32: program.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osNONE: program.sysflags := {sf_code}
END;
program.recCount := -1;
1235,39 → 1220,36
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL);
program.stTypes.tINTEGER := enterType(program, tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
IF target # mConst.Target_iMSP430 THEN
program.stTypes.tINTEGER.align := TARGETS.WordSize;
program.stTypes.tBYTE.align := 1;
program.stTypes.tCHAR.align := 1;
program.stTypes.tSET.align := TARGETS.WordSize;
program.stTypes.tBOOLEAN.align := 1;
IF TARGETS.BitDepth >= 32 THEN
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL)
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR.align := 2;
program.stTypes.tCARD32.align := 4
END;
program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL);
IF TARGETS.RealSize # 0 THEN
program.stTypes.tREAL := enterType(program, tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL.align := TARGETS.RealSize
END;
program.stTypes.tSTRING := enterType(program, tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, TARGETS.WordSize, 0, NIL);
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
program.stTypes.tBYTE.align := 1;
program.stTypes.tCHAR.align := program.stTypes.tCHAR.size;
program.stTypes.tSET.align := program.stTypes.tSET.size;
program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
IF target # mConst.Target_iMSP430 THEN
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
program.stTypes.tREAL.align := program.stTypes.tREAL.size;
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size
END;
program.dll := FALSE;
program.obj := FALSE;
createSysUnit(program)
RETURN program

/programs/develop/oberon07/Source/REG.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/SCAN.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/STATEMENTS.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
9,8 → 9,8
IMPORT
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430,
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, mConst := CONSTANTS;
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB,
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, TARGETS;
CONST
29,9 → 29,7
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE};
cpuX86 = 1; cpuAMD64 = 2; cpuMSP430 = 3;
TYPE
isXXX = PROCEDURE (e: PARS.EXPR): BOOLEAN;
418,7 → 416,7
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value))
END;
IL.savef
IL.savef(e.obj = eCONST)
ELSIF isChar(e) & (VarType = tCHAR) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
500,6 → 498,7
PROCEDURE ArrLen (t: PROG.TYPE_; n: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
REPEAT
res := t.length;
513,8 → 512,8
PROCEDURE OpenArray (t, t2: PROG.TYPE_);
VAR
n: INTEGER;
d1, d2: INTEGER;
n, d1, d2: INTEGER;
BEGIN
IF t.length # 0 THEN
IL.Param1;
606,7 → 605,7
IF p.type.base = tCHAR THEN
stroffs := String(e);
IL.StrAdr(stroffs);
IF (CPU = cpuMSP430) & (p.type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
IF (CPU = TARGETS.cpuMSP430) & (p.type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
ERRORS.WarningMsg(pos.line, pos.col, 0)
END
ELSE (* WCHAR *)
648,17 → 647,16
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e2: PARS.EXPR;
e1, e2: PARS.EXPR;
pos: PARS.POSITION;
proc: INTEGER;
label: INTEGER;
proc,
label,
n, i: INTEGER;
code: ARITH.VALUE;
e1: PARS.EXPR;
wchar: BOOLEAN;
wchar,
comma: BOOLEAN;
cmd1,
cmd2: IL.COMMAND;
comma: BOOLEAN;
PROCEDURE varparam (parser: PARS.PARSER; pos: PARS.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR);
675,6 → 673,7
PROCEDURE shift_minmax (proc: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
CASE proc OF
|PROG.stASR: res := "A"
777,7 → 776,7
|PROG.stNEW:
varparam(parser, pos, isPtr, TRUE, e);
IF CPU = cpuMSP430 THEN
IF CPU = TARGETS.cpuMSP430 THEN
PARS.check(e.type.base.size + 16 < Options.ram, pos, 63)
END;
IL.New(e.type.base.size, e.type.base.num)
885,9 → 884,9
PARS.check(e2.type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
IF e2.obj = eCONST THEN
IF e2.type = tREAL THEN
IL.Float(ARITH.Float(e2.value));
IL.setlast(endcall.prev(IL.COMMAND));
IL.Float(ARITH.Float(e2.value));
IL.savef
IL.savef(FALSE)
ELSE
LoadConst(e2);
IL.setlast(endcall.prev(IL.COMMAND));
896,7 → 895,7
ELSE
IL.setlast(endcall.prev(IL.COMMAND));
IF e2.type = tREAL THEN
IL.savef
IL.savef(FALSE)
ELSIF e2.type = tBYTE THEN
IL.SysPut(tINTEGER.size)
ELSE
962,8 → 961,10
getpos(parser, pos);
PARS.ConstExpression(parser, code);
PARS.check(code.typ = ARITH.tINTEGER, pos, 43);
IF CPU # cpuMSP430 THEN
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
PARS.check(ARITH.range(code, 0, 255), pos, 42)
ELSIF CPU = TARGETS.cpuTHUMB THEN
PARS.check(ARITH.range(code, 0, 65535), pos, 110)
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
1113,7 → 1114,7
IF e.obj = eCONST THEN
ARITH.odd(e.value)
ELSE
IL.AddCmd0(IL.opODD)
IL.AddCmd(IL.opMODR, 2)
END
|PROG.stORD:
1409,9 → 1410,8
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR);
VAR
label: INTEGER;
label, offset, n, k: INTEGER;
type: PROG.TYPE_;
n, offset, k: INTEGER;
BEGIN
1571,11 → 1571,11
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG.TYPE_; isfloat: BOOLEAN; VAR fregs: INTEGER; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN);
VAR
cconv: INTEGER;
parSize: INTEGER;
callconv: INTEGER;
fparSize: INTEGER;
int, flt: INTEGER;
cconv,
parSize,
callconv,
fparSize,
int, flt,
stk_par: INTEGER;
BEGIN
1862,12 → 1862,9
PROCEDURE term (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: PARS.POSITION;
op: INTEGER;
e1: PARS.EXPR;
op, label, label1: INTEGER;
label: INTEGER;
label1: INTEGER;
BEGIN
factor(parser, e);
label := -1;
1972,10 → 1969,7
|SCAN.lxDIV, SCAN.lxMOD:
PARS.check(isInt(e) & isInt(e1), pos, 37);
IF e1.obj = eCONST THEN
PARS.check(~ARITH.isZero(e1.value), pos, 46);
IF CPU = cpuMSP430 THEN
PARS.check(ARITH.Int(e1.value) > 0, pos, 122)
END
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
1988,11 → 1982,7
ELSE
IF e1.obj # eCONST THEN
label1 := IL.NewLabel();
IF CPU = cpuMSP430 THEN
IL.AddJmpCmd(IL.opJG, label1)
ELSE
IL.AddJmpCmd(IL.opJNZ, label1)
END
END;
IF e.obj = eCONST THEN
IL.OnError(pos.line, errDIV);
2223,7 → 2213,6
res: BOOLEAN;
BEGIN
res := TRUE;
IF isString(e) & isCharArray(e1) THEN
3026,11 → 3015,11
ELSIF isRec(e) THEN
IL.drop;
IL.AddCmd(IL.opLADR, e.ident.offset - 1);
IL.load(PARS.program.target.word)
IL.load(TARGETS.WordSize)
ELSIF isPtr(e) THEN
deref(pos, e, FALSE, errPTR);
IL.AddCmd(IL.opSUBR, PARS.program.target.word);
IL.load(PARS.program.target.word)
IL.AddCmd(IL.opSUBR, TARGETS.WordSize);
IL.load(TARGETS.WordSize)
END;
PARS.checklex(parser, SCAN.lxOF);
3243,7 → 3232,6
rtl := PARS.program.rtl;
ASSERT(rtl # NIL);
IF CPU IN {cpuX86, cpuAMD64} THEN
getproc(rtl, "_strcmp", IL._strcmp);
getproc(rtl, "_length", IL._length);
getproc(rtl, "_arrcpy", IL._arrcpy);
3250,22 → 3238,36
getproc(rtl, "_is", IL._is);
getproc(rtl, "_guard", IL._guard);
getproc(rtl, "_guardrec", IL._guardrec);
getproc(rtl, "_error", IL._error);
getproc(rtl, "_new", IL._new);
getproc(rtl, "_rot", IL._rot);
getproc(rtl, "_strcpy", IL._strcpy);
getproc(rtl, "_move", IL._move);
getproc(rtl, "_divmod", IL._divmod);
getproc(rtl, "_set", IL._set);
getproc(rtl, "_set1", IL._set1);
getproc(rtl, "_isrec", IL._isrec);
getproc(rtl, "_lengthw", IL._lengthw);
getproc(rtl, "_strcmpw", IL._strcmpw);
getproc(rtl, "_init", IL._init);
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
getproc(rtl, "_error", IL._error);
getproc(rtl, "_divmod", IL._divmod);
getproc(rtl, "_exit", IL._exit);
getproc(rtl, "_dispose", IL._dispose);
getproc(rtl, "_isrec", IL._isrec);
getproc(rtl, "_dllentry", IL._dllentry);
getproc(rtl, "_dispose", IL._dispose);
getproc(rtl, "_exit", IL._exit);
getproc(rtl, "_init", IL._init);
getproc(rtl, "_sofinit", IL._sofinit)
ELSIF CPU = TARGETS.cpuTHUMB THEN
getproc(rtl, "_fmul", IL._fmul);
getproc(rtl, "_fdiv", IL._fdiv);
getproc(rtl, "_fdivi", IL._fdivi);
getproc(rtl, "_fadd", IL._fadd);
getproc(rtl, "_fsub", IL._fsub);
getproc(rtl, "_fsubi", IL._fsubi);
getproc(rtl, "_fcmp", IL._fcmp);
getproc(rtl, "_floor", IL._floor);
getproc(rtl, "_flt", IL._flt);
getproc(rtl, "_pack", IL._pack);
getproc(rtl, "_unpk", IL._unpk)
END
END setrtl;
3286,19 → 3288,9
tREAL := PARS.program.stTypes.tREAL;
Options := options;
CPU := TARGETS.CPU;
CASE target OF
|mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64, mConst.Target_iELFSO64:
CPU := cpuAMD64
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL,
mConst.Target_iKolibri, mConst.Target_iObject, mConst.Target_iELF32,
mConst.Target_iELFSO32:
CPU := cpuX86
|mConst.Target_iMSP430:
CPU := cpuMSP430
END;
ext := mConst.FILE_EXT;
ext := UTILS.FILE_EXT;
CaseLabels := C.create();
CaseVar := C.create();
3305,25 → 3297,21
CaseVariants := LISTS.create(NIL);
LISTS.push(CaseVariants, NewVariant(0, NIL));
CASE CPU OF
|cpuAMD64: IL.init(6, IL.little_endian)
|cpuX86: IL.init(8, IL.little_endian)
|cpuMSP430: IL.init(0, IL.little_endian)
END;
IL.init(CPU);
IF CPU # cpuMSP430 THEN
IF CPU # TARGETS.cpuMSP430 THEN
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, mConst.RTL_NAME) THEN
IF parser.open(parser, UTILS.RTL_NAME) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
PARS.destroy(parser);
parser := PARS.create(lib_path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, mConst.RTL_NAME) THEN
IF parser.open(parser, UTILS.RTL_NAME) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
ERRORS.FileNotFound(lib_path, mConst.RTL_NAME, mConst.FILE_EXT)
ERRORS.FileNotFound(lib_path, UTILS.RTL_NAME, UTILS.FILE_EXT)
END
END
END;
3334,16 → 3322,16
IF parser.open(parser, modname) THEN
parser.parse(parser)
ELSE
ERRORS.FileNotFound(path, modname, mConst.FILE_EXT)
ERRORS.FileNotFound(path, modname, UTILS.FILE_EXT)
END;
PARS.destroy(parser);
IF PARS.program.bss > mConst.MAX_GLOBAL_SIZE THEN
IF PARS.program.bss > UTILS.MAX_GLOBAL_SIZE THEN
ERRORS.Error(204)
END;
IF CPU # cpuMSP430 THEN
IF CPU # TARGETS.cpuMSP430 THEN
setrtl
END;
3352,12 → 3340,13
IL.set_bss(PARS.program.bss);
CASE CPU OF
| cpuAMD64: AMD64.CodeGen(outname, target, options)
| cpuX86: X86.CodeGen(outname, target, options)
|cpuMSP430: MSP430.CodeGen(outname, target, options)
|TARGETS.cpuAMD64: AMD64.CodeGen(outname, target, options)
|TARGETS.cpuX86: X86.CodeGen(outname, target, options)
|TARGETS.cpuMSP430: MSP430.CodeGen(outname, target, options)
|TARGETS.cpuTHUMB: THUMB.CodeGen(outname, target, options)
END
END compile;
END STATEMENTS.
END STATEMENTS.

/programs/develop/oberon07/Source/STRINGS.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
13,6 → 13,7
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
32,13 → 33,12
END append;
PROCEDURE reverse* (VAR s: ARRAY OF CHAR);
PROCEDURE reverse (VAR s: ARRAY OF CHAR);
VAR
i, j: INTEGER;
a, b: CHAR;
BEGIN
i := 0;
j := LENGTH(s) - 1;
172,6 → 172,27
END space;
PROCEDURE cap (VAR c: CHAR);
BEGIN
IF ("a" <= c) & (c <= "z") THEN
c := CHR(ORD(c) - 32)
END
END cap;
PROCEDURE UpCase* (VAR str: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(str)) & (str[i] # 0X) DO
cap(str[i]);
INC(i)
END
END UpCase;
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN;
VAR
i, k: INTEGER;
276,21 → 297,21
u := ORD(c)
|0C1X..0DFX:
u := LSL(ORD(c) - 0C0H, 6);
u := (ORD(c) - 0C0H) * 64;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(BITS(ORD(src[i])) * {0..5}))
INC(u, ORD(src[i]) MOD 64)
END
|0E1X..0EFX:
u := LSL(ORD(c) - 0E0H, 12);
u := (ORD(c) - 0E0H) * 4096;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(BITS(ORD(src[i])) * {0..5}) * 64)
INC(u, (ORD(src[i]) MOD 64) * 64)
END;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(BITS(ORD(src[i])) * {0..5}))
INC(u, ORD(src[i]) MOD 64)
END
(*
|0F1X..0F7X:

/programs/develop/oberon07/Source/TARGETS.ob07
0,0 → 1,116
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE TARGETS;
CONST
MSP430* = 0;
Win32C* = 1;
Win32GUI* = 2;
Win32DLL* = 3;
KolibriOS* = 4;
KolibriOSDLL* = 5;
Win64C* = 6;
Win64GUI* = 7;
Win64DLL* = 8;
Linux32* = 9;
Linux32SO* = 10;
Linux64* = 11;
Linux64SO* = 12;
STM32CM3* = 13;
cpuX86* = 0; cpuAMD64* = 1; cpuMSP430* = 2; cpuTHUMB* = 3;
osNONE* = 0; osWIN32* = 1; osWIN64* = 2;
osLINUX32* = 3; osLINUX64* = 4; osKOS* = 5;
TYPE
STRING = ARRAY 32 OF CHAR;
TARGET = RECORD
target, CPU, BitDepth, OS, RealSize: INTEGER;
ComLinePar*, LibDir, FileExt: STRING
END;
VAR
Targets*: ARRAY 14 OF TARGET;
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*: INTEGER;
ComLinePar*, LibDir*, FileExt*: STRING;
Import*, Dispose*, Dll*: BOOLEAN;
PROCEDURE Enter (idx, CPU, BitDepth, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
BEGIN
Targets[idx].target := idx;
Targets[idx].CPU := CPU;
Targets[idx].BitDepth := BitDepth;
Targets[idx].RealSize := RealSize;
Targets[idx].OS := OS;
Targets[idx].ComLinePar := ComLinePar;
Targets[idx].LibDir := LibDir;
Targets[idx].FileExt := FileExt;
END Enter;
PROCEDURE Select* (ComLineParam: ARRAY OF CHAR): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
i := 0;
WHILE (i < LEN(Targets)) & (Targets[i].ComLinePar # ComLineParam) DO
INC(i)
END;
res := i < LEN(Targets);
IF res THEN
target := Targets[i].target;
CPU := Targets[i].CPU;
BitDepth := Targets[i].BitDepth;
RealSize := Targets[i].RealSize;
OS := Targets[i].OS;
ComLinePar := Targets[i].ComLinePar;
LibDir := Targets[i].LibDir;
FileExt := Targets[i].FileExt;
Import := OS IN {osWIN32, osWIN64, osKOS};
Dispose := ~(target IN {MSP430, STM32CM3});
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WordSize := BitDepth DIV 8;
AdrSize := WordSize
END
RETURN res
END Select;
BEGIN
Enter( MSP430, cpuMSP430, 16, 0, osNONE, "msp430", "MSP430", ".hex");
Enter( Win32C, cpuX86, 32, 8, osWIN32, "win32con", "Windows32", ".exe");
Enter( Win32GUI, cpuX86, 32, 8, osWIN32, "win32gui", "Windows32", ".exe");
Enter( Win32DLL, cpuX86, 32, 8, osWIN32, "win32dll", "Windows32", ".dll");
Enter( KolibriOS, cpuX86, 32, 8, osKOS, "kosexe", "KolibriOS", "");
Enter( KolibriOSDLL, cpuX86, 32, 8, osKOS, "kosdll", "KolibriOS", ".obj");
Enter( Win64C, cpuAMD64, 64, 8, osWIN64, "win64con", "Windows64", ".exe");
Enter( Win64GUI, cpuAMD64, 64, 8, osWIN64, "win64gui", "Windows64", ".exe");
Enter( Win64DLL, cpuAMD64, 64, 8, osWIN64, "win64dll", "Windows64", ".dll");
Enter( Linux32, cpuX86, 32, 8, osLINUX32, "linux32exe", "Linux32", "");
Enter( Linux32SO, cpuX86, 32, 8, osLINUX32, "linux32so", "Linux32", ".so");
Enter( Linux64, cpuAMD64, 64, 8, osLINUX64, "linux64exe", "Linux64", "");
Enter( Linux64SO, cpuAMD64, 64, 8, osLINUX64, "linux64so", "Linux64", ".so");
Enter( STM32CM3, cpuTHUMB, 32, 4, osNONE, "stm32cm3", "STM32CM3", ".hex");
END TARGETS.

/programs/develop/oberon07/Source/TEXTDRV.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/THUMB.ob07
0,0 → 1,2430
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE THUMB;
IMPORT PROG, LISTS, CHL := CHUNKLISTS, BIN, REG, IL, C := CONSOLE,
UTILS, WR := WRITER, HEX, ERRORS, TARGETS;
CONST
R0 = 0; R1 = 1; R2 = 2; R3 = 3; R4 = 4;
SP = 13; LR = 14; PC = 15;
ACC = R0;
je = 0; jne = 1; jnb = 2; jb = 3; jge = 10; jl = 11; jg = 12; jle = 13;
inf = 7F800000H;
STM32_minROM* = 16; STM32_maxROM* = 65536;
STM32_minRAM* = 4; STM32_maxRAM* = 65536;
maxIVT* = 1023;
TYPE
COMMAND = IL.COMMAND;
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
offset: INTEGER
END;
CODE = POINTER TO RECORD (ANYCODE)
code: INTEGER
END;
LABEL = POINTER TO RECORD (ANYCODE)
label: INTEGER
END;
JUMP = POINTER TO RECORD (ANYCODE)
label, diff, len, cond: INTEGER;
short: BOOLEAN
END;
JMP = POINTER TO RECORD (JUMP)
END;
JCC = POINTER TO RECORD (JUMP)
END;
CBXZ = POINTER TO RECORD (JUMP)
reg: INTEGER
END;
CALL = POINTER TO RECORD (JUMP)
END;
RELOC = POINTER TO RECORD (ANYCODE)
reg, rel, value: INTEGER
END;
RELOCCODE = ARRAY 7 OF INTEGER;
VAR
R: REG.REGS;
tcount: INTEGER;
CodeList: LISTS.LIST;
program: BIN.PROGRAM;
StkCount: INTEGER;
Target: RECORD
FlashAdr,
SRAMAdr,
IVTLen,
MinStack,
Reserved: INTEGER;
InstrSet: RECORD thumb2, it, cbxz, sdiv: BOOLEAN END
END;
IVT: ARRAY maxIVT + 1 OF INTEGER;
sdivProc, trap, genTrap, entry, emptyProc, int0, genInt: INTEGER;
PROCEDURE Code (code: INTEGER);
VAR
c: CODE;
BEGIN
NEW(c);
c.code := code;
LISTS.push(CodeList, c)
END Code;
PROCEDURE Label (label: INTEGER);
VAR
L: LABEL;
BEGIN
NEW(L);
L.label := label;
LISTS.push(CodeList, L)
END Label;
PROCEDURE jcc (cond, label: INTEGER);
VAR
j: JCC;
BEGIN
NEW(j);
j.label := label;
j.cond := cond;
j.short := FALSE;
j.len := 3;
LISTS.push(CodeList, j)
END jcc;
PROCEDURE cbxz (cond, reg, label: INTEGER);
VAR
j: CBXZ;
BEGIN
NEW(j);
j.label := label;
j.cond := cond;
j.reg := reg;
j.short := FALSE;
j.len := 4;
LISTS.push(CodeList, j)
END cbxz;
PROCEDURE jmp (label: INTEGER);
VAR
j: JMP;
BEGIN
NEW(j);
j.label := label;
j.short := FALSE;
j.len := 2;
LISTS.push(CodeList, j)
END jmp;
PROCEDURE call (label: INTEGER);
VAR
c: CALL;
BEGIN
NEW(c);
c.label := label;
c.short := FALSE;
c.len := 2;
LISTS.push(CodeList, c)
END call;
PROCEDURE reloc (reg, rel, value: INTEGER);
VAR
r: RELOC;
BEGIN
NEW(r);
r.reg := reg;
r.rel := rel;
r.value := value;
LISTS.push(CodeList, r)
END reloc;
PROCEDURE NewLabel (): INTEGER;
BEGIN
BIN.NewLabel(program)
RETURN IL.NewLabel()
END NewLabel;
PROCEDURE range (x, n: INTEGER): BOOLEAN;
RETURN (0 <= x) & (x < LSL(1, n))
END range;
PROCEDURE srange (x, n: INTEGER): BOOLEAN;
RETURN (-LSL(1, n - 1) <= x) & (x < LSL(1, n - 1))
END srange;
PROCEDURE gen1 (op, imm, rs, rd: INTEGER);
BEGIN
ASSERT(op IN {0..2});
ASSERT(range(imm, 5));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(LSL(op, 11) + LSL(imm, 6) + LSL(rs, 3) + rd)
END gen1;
PROCEDURE gen2 (i, op: BOOLEAN; imm, rs, rd: INTEGER);
BEGIN
ASSERT(range(imm, 3));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(1800H + LSL(ORD(i), 10) + LSL(ORD(op), 9) + LSL(imm, 6) + LSL(rs, 3) + rd)
END gen2;
PROCEDURE gen3 (op, rd, imm: INTEGER);
BEGIN
ASSERT(range(op, 2));
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(2000H + LSL(op, 11) + LSL(rd, 8) + imm)
END gen3;
PROCEDURE gen4 (op, rs, rd: INTEGER);
BEGIN
ASSERT(range(op, 4));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(4000H + LSL(op, 6) + LSL(rs, 3) + rd)
END gen4;
PROCEDURE gen5 (op: INTEGER; h1, h2: BOOLEAN; rs, rd: INTEGER);
BEGIN
ASSERT(range(op, 2));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(4400H + LSL(op, 8) + LSL(ORD(h1), 7) + LSL(ORD(h2), 6) + LSL(rs, 3) + rd)
END gen5;
PROCEDURE gen7 (l, b: BOOLEAN; ro, rb, rd: INTEGER);
BEGIN
ASSERT(range(ro, 3));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(5000H + LSL(ORD(l), 11) + LSL(ORD(b), 10) + LSL(ro, 6) + LSL(rb, 3) + rd)
END gen7;
PROCEDURE gen8 (h, s: BOOLEAN; ro, rb, rd: INTEGER);
BEGIN
ASSERT(range(ro, 3));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(5200H + LSL(ORD(h), 11) + LSL(ORD(s), 10) + LSL(ro, 6) + LSL(rb, 3) + rd)
END gen8;
PROCEDURE gen9 (b, l: BOOLEAN; imm, rb, rd: INTEGER);
BEGIN
ASSERT(range(imm, 5));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(6000H + LSL(ORD(b), 12) + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd)
END gen9;
PROCEDURE gen10 (l: BOOLEAN; imm, rb, rd: INTEGER);
BEGIN
ASSERT(range(imm, 5));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(8000H + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd)
END gen10;
PROCEDURE gen11 (l: BOOLEAN; rd, imm: INTEGER);
BEGIN
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(9000H + LSL(ORD(l), 11) + LSL(rd, 8) + imm)
END gen11;
PROCEDURE gen12 (sp: BOOLEAN; rd, imm: INTEGER);
BEGIN
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(0A000H + LSL(ORD(sp), 11) + LSL(rd, 8) + imm)
END gen12;
PROCEDURE gen14 (l, r: BOOLEAN; rlist: SET);
VAR
i, n: INTEGER;
BEGIN
ASSERT(range(ORD(rlist), 8));
n := ORD(r);
FOR i := 0 TO 7 DO
IF i IN rlist THEN
INC(n)
END
END;
IF l THEN
n := -n
END;
INC(StkCount, n);
Code(0B400H + LSL(ORD(l), 11) + LSL(ORD(r), 8) + ORD(rlist))
END gen14;
PROCEDURE split16 (imm16: INTEGER; VAR imm4, imm1, imm3, imm8: INTEGER);
BEGIN
ASSERT(range(imm16, 16));
imm8 := imm16 MOD 256;
imm4 := LSR(imm16, 12);
imm3 := LSR(imm16, 8) MOD 8;
imm1 := LSR(imm16, 11) MOD 2;
END split16;
PROCEDURE LslImm (r, imm5: INTEGER);
BEGIN
gen1(0, imm5, r, r)
END LslImm;
PROCEDURE LsrImm (r, imm5: INTEGER);
BEGIN
gen1(1, imm5, r, r)
END LsrImm;
PROCEDURE AsrImm (r, imm5: INTEGER);
BEGIN
gen1(2, imm5, r, r)
END AsrImm;
PROCEDURE AddReg (rd, rs, rn: INTEGER);
BEGIN
gen2(FALSE, FALSE, rn, rs, rd)
END AddReg;
PROCEDURE SubReg (rd, rs, rn: INTEGER);
BEGIN
gen2(FALSE, TRUE, rn, rs, rd)
END SubReg;
PROCEDURE AddImm8 (rd, imm8: INTEGER);
BEGIN
IF imm8 # 0 THEN
gen3(2, rd, imm8)
END
END AddImm8;
PROCEDURE SubImm8 (rd, imm8: INTEGER);
BEGIN
IF imm8 # 0 THEN
gen3(3, rd, imm8)
END
END SubImm8;
PROCEDURE AddSubImm12 (r, imm12: INTEGER; sub: BOOLEAN);
VAR
imm4, imm1, imm3, imm8: INTEGER;
BEGIN
split16(imm12, imm4, imm1, imm3, imm8);
Code(0F200H + LSL(imm1, 10) + r + 0A0H * ORD(sub)); (* addw/subw r, r, imm12 *)
Code(LSL(imm3, 12) + LSL(r, 8) + imm8)
END AddSubImm12;
PROCEDURE MovImm8 (rd, imm8: INTEGER);
BEGIN
gen3(0, rd, imm8)
END MovImm8;
PROCEDURE CmpImm8 (rd, imm8: INTEGER);
BEGIN
gen3(1, rd, imm8)
END CmpImm8;
PROCEDURE Neg (r: INTEGER);
BEGIN
gen4(9, r, r)
END Neg;
PROCEDURE Mul (rd, rs: INTEGER);
BEGIN
gen4(13, rs, rd)
END Mul;
PROCEDURE Str32 (rs, rb: INTEGER);
BEGIN
gen9(FALSE, FALSE, 0, rb, rs)
END Str32;
PROCEDURE Ldr32 (rd, rb: INTEGER);
BEGIN
gen9(FALSE, TRUE, 0, rb, rd)
END Ldr32;
PROCEDURE Str16 (rs, rb: INTEGER);
BEGIN
gen10(FALSE, 0, rb, rs)
END Str16;
PROCEDURE Ldr16 (rd, rb: INTEGER);
BEGIN
gen10(TRUE, 0, rb, rd)
END Ldr16;
PROCEDURE Str8 (rs, rb: INTEGER);
BEGIN
gen9(TRUE, FALSE, 0, rb, rs)
END Str8;
PROCEDURE Ldr8 (rd, rb: INTEGER);
BEGIN
gen9(TRUE, TRUE, 0, rb, rd)
END Ldr8;
PROCEDURE Cmp (r1, r2: INTEGER);
BEGIN
gen4(10, r2, r1)
END Cmp;
PROCEDURE Tst (r: INTEGER);
BEGIN
gen3(1, r, 0) (* cmp r, #0 *)
END Tst;
PROCEDURE LdrSp (r, offset: INTEGER);
BEGIN
gen11(TRUE, r, offset)
END LdrSp;
PROCEDURE MovImm32 (r, imm32: INTEGER);
BEGIN
MovImm8(r, LSR(imm32, 24) MOD 256);
LslImm(r, 8);
AddImm8(r, LSR(imm32, 16) MOD 256);
LslImm(r, 8);
AddImm8(r, LSR(imm32, 8) MOD 256);
LslImm(r, 8);
AddImm8(r, imm32 MOD 256)
END MovImm32;
PROCEDURE low (x: INTEGER): INTEGER;
RETURN x MOD 65536
END low;
PROCEDURE high (x: INTEGER): INTEGER;
RETURN (x DIV 65536) MOD 65536
END high;
PROCEDURE movwt (r, imm16, t: INTEGER);
VAR
imm1, imm3, imm4, imm8: INTEGER;
BEGIN
ASSERT(range(r, 3));
ASSERT(range(imm16, 16));
ASSERT(range(t, 1));
split16(imm16, imm4, imm1, imm3, imm8);
Code(0F240H + imm1 * 1024 + t * 128 + imm4);
Code(imm3 * 4096 + r * 256 + imm8);
END movwt;
PROCEDURE inv0 (cond: INTEGER): INTEGER;
RETURN ORD(BITS(cond) / {0})
END inv0;
PROCEDURE fixup (CodeAdr, DataAdr, BssAdr: INTEGER);
VAR
code: ANYCODE;
count: INTEGER;
shorted: BOOLEAN;
jump: JUMP;
first, second: INTEGER;
reloc, i, diff, len: INTEGER;
RelocCode: RELOCCODE;
PROCEDURE genjcc (cond, offset: INTEGER): INTEGER;
BEGIN
ASSERT(range(cond, 4));
ASSERT(srange(offset, 8))
RETURN 0D000H + cond * 256 + offset MOD 256
END genjcc;
PROCEDURE genjmp (offset: INTEGER): INTEGER;
BEGIN
ASSERT(srange(offset, 11))
RETURN 0E000H + offset MOD 2048
END genjmp;
PROCEDURE genlongjmp (offset: INTEGER; VAR first, second: INTEGER);
BEGIN
ASSERT(srange(offset, 22));
first := 0F000H + ASR(offset, 11) MOD 2048;
second := 0F800H + offset MOD 2048
END genlongjmp;
PROCEDURE movwt (r, imm16, t: INTEGER; VAR code: RELOCCODE);
VAR
imm1, imm3, imm4, imm8: INTEGER;
BEGIN
split16(imm16, imm4, imm1, imm3, imm8);
code[t * 2] := 0F240H + imm1 * 1024 + t * 128 + imm4;
code[t * 2 + 1] := imm3 * 4096 + r * 256 + imm8
END movwt;
PROCEDURE genmovimm32 (r, value: INTEGER; VAR code: RELOCCODE);
BEGIN
IF Target.InstrSet.thumb2 THEN
movwt(r, low(value), 0, code);
movwt(r, high(value), 1, code)
ELSE
code[0] := 2000H + r * 256 + UTILS.Byte(value, 3); (* mov r, #imm8 *)
code[1] := 0200H + r * 9; (* lsl r, r, #8 *)
code[2] := 3000H + r * 256 + UTILS.Byte(value, 2); (* add r, #imm8 *)
code[3] := code[1]; (* lsl r, r, #8 *)
code[4] := 3000H + r * 256 + UTILS.Byte(value, 1); (* add r, #imm8 *)
code[5] := code[1]; (* lsl r, r, #8 *)
code[6] := 3000H + r * 256 + UTILS.Byte(value, 0) (* add r, #imm8 *)
END
END genmovimm32;
PROCEDURE PutCode (code: INTEGER);
BEGIN
BIN.PutCode16LE(program, code)
END PutCode;
PROCEDURE genbc (code: JUMP);
VAR
first, second: INTEGER;
BEGIN
CASE code.len OF
|1: PutCode(genjcc(code.cond, code.diff))
|2: PutCode(genjcc(inv0(code.cond), 0));
PutCode(genjmp(code.diff))
|3: PutCode(genjcc(inv0(code.cond), 1));
genlongjmp(code.diff, first, second);
PutCode(first);
PutCode(second)
END
END genbc;
PROCEDURE SetIV (idx, label, CodeAdr: INTEGER);
VAR
l, h: ANYCODE;
BEGIN
l := CodeList.first(ANYCODE);
h := l.next(ANYCODE);
WHILE idx > 0 DO
l := h.next(ANYCODE);
h := l.next(ANYCODE);
DEC(idx)
END;
label := BIN.GetLabel(program, label) * 2 + CodeAdr + 1;
l(CODE).code := low(label);
h(CODE).code := high(label)
END SetIV;
BEGIN
REPEAT
shorted := FALSE;
count := 0;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
code.offset := count;
CASE code OF
|CODE: INC(count)
|LABEL: BIN.SetLabel(program, code.label, count)
|JUMP: INC(count, code.len); code.offset := count + ORD(code.short)
|RELOC: INC(count, 7 - ORD(Target.InstrSet.thumb2) * 3 + code.rel MOD 2)
END;
code := code.next(ANYCODE)
END;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
IF code IS JUMP THEN
jump := code(JUMP);
jump.diff := BIN.GetLabel(program, jump.label) - jump.offset;
len := jump.len;
diff := jump.diff;
CASE jump OF
|JMP:
IF (len = 2) & srange(diff, 11) THEN
len := 1
END
|JCC:
CASE len OF
|1:
|2: IF srange(diff, 8) THEN DEC(len) END
|3: IF srange(diff, 11) THEN DEC(len) END
END
|CBXZ:
CASE len OF
|1:
|2: IF range(diff, 6) THEN DEC(len) END
|3: IF srange(diff, 8) THEN DEC(len) END
|4: IF srange(diff, 11) THEN DEC(len) END
END
|CALL:
END;
IF len # jump.len THEN
jump.len := len;
jump.short := TRUE;
shorted := TRUE
END
END;
code := code.next(ANYCODE)
END
UNTIL ~shorted;
FOR i := 1 TO Target.IVTLen - 1 DO
SetIV(i, IVT[i], CodeAdr)
END;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
CASE code OF
|CODE: BIN.PutCode16LE(program, code.code)
|LABEL:
|JMP:
IF code.len = 1 THEN
PutCode(genjmp(code.diff))
ELSE
genlongjmp(code.diff, first, second);
PutCode(first);
PutCode(second)
END
|JCC: genbc(code)
|CBXZ:
IF code.len > 1 THEN
PutCode(2800H + code.reg * 256); (* cmp code.reg, #0 *)
DEC(code.len);
genbc(code)
ELSE
(* cb(n)z code.reg, L *)
PutCode(0B100H + 800H * ORD(code.cond = jne) + 200H * ORD(code.diff >= 32) + (code.diff MOD 32) * 8 + code.reg)
END
|CALL:
genlongjmp(code.diff, first, second);
PutCode(first);
PutCode(second)
|RELOC:
CASE code.rel OF
|BIN.RCODE, BIN.PICCODE: reloc := BIN.GetLabel(program, code.value) * 2 + CodeAdr
|BIN.RDATA, BIN.PICDATA: reloc := code.value + DataAdr
|BIN.RBSS, BIN.PICBSS: reloc := code.value + BssAdr
END;
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN
DEC(reloc, CodeAdr + 2 * (code.offset - 3 * ORD(Target.InstrSet.thumb2) + 9))
END;
genmovimm32(code.reg, reloc, RelocCode);
FOR i := 0 TO 6 - 3 * ORD(Target.InstrSet.thumb2) DO
PutCode(RelocCode[i])
END;
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN
PutCode(4478H + code.reg) (* add code.reg, PC *)
END
END;
code := code.next(ANYCODE)
END
END fixup;
PROCEDURE push (r: INTEGER);
BEGIN
gen14(FALSE, FALSE, {r})
END push;
PROCEDURE pop (r: INTEGER);
BEGIN
gen14(TRUE, FALSE, {r})
END pop;
PROCEDURE mov (r1, r2: INTEGER);
BEGIN
IF (r1 < 8) & (r2 < 8) THEN
gen1(0, 0, r2, r1)
ELSE
gen5(2, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8)
END
END mov;
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
push(r1); push(r2);
pop(r1); pop(r2)
END xchg;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE UnOp (VAR r: INTEGER);
BEGIN
REG.UnOp(R, r)
END UnOp;
PROCEDURE BinOp (VAR r1, r2: INTEGER);
BEGIN
REG.BinOp(R, r1, r2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE cond (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|IL.opGT, IL.opGTC: res := jg
|IL.opGE, IL.opGEC: res := jge
|IL.opLT, IL.opLTC: res := jl
|IL.opLE, IL.opLEC: res := jle
|IL.opEQ, IL.opEQC: res := je
|IL.opNE, IL.opNEC: res := jne
END
RETURN res
END cond;
PROCEDURE GetRegA;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetRegA;
PROCEDURE MovConst (r, c: INTEGER);
BEGIN
IF (0 <= c) & (c <= 255) THEN
MovImm8(r, c)
ELSIF (-255 <= c) & (c < 0) THEN
MovImm8(r, -c);
Neg(r)
ELSIF UTILS.Log2(c) >= 0 THEN
MovImm8(r, 1);
LslImm(r, UTILS.Log2(c))
ELSIF c = UTILS.min32 THEN
MovImm8(r, 1);
LslImm(r, 31)
ELSE
IF Target.InstrSet.thumb2 THEN
movwt(r, low(c), 0);
IF (c < 0) OR (c > 65535) THEN
movwt(r, high(c), 1)
END
ELSE
MovImm32(r, c)
END
END
END MovConst;
PROCEDURE CmpConst (r, c: INTEGER);
VAR
r2: INTEGER;
BEGIN
IF (0 <= c) & (c <= 255) THEN
CmpImm8(r, c)
ELSE
r2 := GetAnyReg();
ASSERT(r2 # r);
MovConst(r2, c);
Cmp(r, r2);
drop
END
END CmpConst;
PROCEDURE LocalOffset (offset: INTEGER): INTEGER;
RETURN offset + StkCount - ORD(offset > 0)
END LocalOffset;
PROCEDURE SetCC (cc, r: INTEGER);
VAR
L1, L2: INTEGER;
BEGIN
IF Target.InstrSet.it THEN
Code(0BF00H + cc * 16 + ((cc + 1) MOD 2) * 8 + 4); (* ite cc *)
MovConst(r, 1);
MovConst(r, 0)
ELSE
L1 := NewLabel();
L2 := NewLabel();
jcc(cc, L1);
MovConst(r, 0);
jmp(L2);
Label(L1);
MovConst(r, 1);
Label(L2)
END
END SetCC;
PROCEDURE PushConst (n: INTEGER);
VAR
r: INTEGER;
BEGIN
r := GetAnyReg();
MovConst(r, n);
push(r);
drop
END PushConst;
PROCEDURE AddConst (r, n: INTEGER);
VAR
r2: INTEGER;
BEGIN
IF n # 0 THEN
IF (-255 <= n) & (n <= 255) THEN
IF n > 0 THEN
AddImm8(r, n)
ELSE
SubImm8(r, -n)
END
ELSIF Target.InstrSet.thumb2 & (-4095 <= n) & (n <= 4095) THEN
IF n > 0 THEN
AddSubImm12(r, n, FALSE)
ELSE
AddSubImm12(r, -n, TRUE)
END
ELSE
r2 := GetAnyReg();
ASSERT(r2 # r);
IF n > 0 THEN
MovConst(r2, n);
AddReg(r, r, r2)
ELSE
MovConst(r2, -n);
SubReg(r, r, r2)
END;
drop
END
END
END AddConst;
PROCEDURE AddHH (r1, r2: INTEGER);
BEGIN
ASSERT((r1 >= 8) OR (r2 >= 8));
gen5(0, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8)
END AddHH;
PROCEDURE AddSP (n: INTEGER);
BEGIN
IF n > 0 THEN
IF n < 127 THEN
Code(0B000H + n) (* add sp, n*4 *)
ELSE
ASSERT(R2 IN R.regs);
MovConst(R2, n * 4);
AddHH(SP, R2)
END;
DEC(StkCount, n)
END
END AddSP;
PROCEDURE cbz (r, label: INTEGER);
BEGIN
IF Target.InstrSet.cbxz THEN
cbxz(je, r, label)
ELSE
Tst(r);
jcc(je, label)
END
END cbz;
PROCEDURE cbnz (r, label: INTEGER);
BEGIN
IF Target.InstrSet.cbxz THEN
cbxz(jne, r, label)
ELSE
Tst(r);
jcc(jne, label)
END
END cbnz;
PROCEDURE Shift (op, r1, r2: INTEGER);
VAR
L: INTEGER;
BEGIN
LslImm(r2, 27);
LsrImm(r2, 27);
L := NewLabel();
cbz(r2, L);
CASE op OF
|IL.opLSL, IL.opLSL1: gen4(2, r2, r1)
|IL.opLSR, IL.opLSR1: gen4(3, r2, r1)
|IL.opASR, IL.opASR1: gen4(4, r2, r1)
|IL.opROR, IL.opROR1: gen4(7, r2, r1)
END;
Label(L)
END Shift;
PROCEDURE LocAdr (offs: INTEGER);
VAR
r1, n: INTEGER;
BEGIN
r1 := GetAnyReg();
n := LocalOffset(offs);
IF n <= 255 THEN
gen12(TRUE, r1, n)
ELSE
MovConst(r1, n * 4);
AddHH(r1, SP)
END
END LocAdr;
PROCEDURE CallRTL (proc, par: INTEGER);
BEGIN
call(IL.codes.rtl[proc]);
AddSP(par)
END CallRTL;
PROCEDURE divmod;
BEGIN
call(sdivProc);
AddSP(2)
END divmod;
PROCEDURE translate (pic, stroffs: INTEGER);
VAR
cmd, next: COMMAND;
opcode, param1, param2: INTEGER;
r1, r2, r3: INTEGER;
a, n, cc, L, L2: INTEGER;
BEGIN
cmd := IL.codes.commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
jmp(param1)
|IL.opLABEL:
Label(param1)
|IL.opHANDLER:
IF param2 = 0 THEN
int0 := param1
ELSIF param2 = 1 THEN
trap := param1
ELSE
IVT[param2] := param1
END
|IL.opCALL:
call(param1)
|IL.opCALLP:
UnOp(r1);
AddImm8(r1, 1);
gen5(3, TRUE, FALSE, r1, 0); (* blx r1 *)
drop;
ASSERT(R.top = -1)
|IL.opENTER:
ASSERT(R.top = -1);
Label(param1);
gen14(FALSE, TRUE, {}); (* push LR *)
n := param2;
IF n >= 5 THEN
MovConst(ACC, 0);
MovConst(R2, n);
L := NewLabel();
Label(L);
push(ACC);
SubImm8(R2, 1);
Tst(R2);
jcc(jne, L)
ELSIF n > 0 THEN
MovConst(ACC, 0);
WHILE n > 0 DO
push(ACC);
DEC(n)
END
END;
StkCount := param2
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode # IL.opLEAVE THEN
UnOp(r1);
IF r1 # ACC THEN
GetRegA;
ASSERT(REG.Exchange(R, r1, ACC));
drop
END;
drop
END;
ASSERT(R.top = -1);
ASSERT(StkCount = param1);
AddSP(param1);
gen14(TRUE, TRUE, {}) (* pop PC *)
|IL.opLEAVEC:
gen5(3, FALSE, TRUE, 6, 0) (* bx LR *)
|IL.opPRECALL:
PushAll(0)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
|IL.opCLEANUP:
AddSP(param2)
|IL.opRES, IL.opRESF:
ASSERT(R.top = -1);
GetRegA
|IL.opPUSHC:
PushConst(param2)
|IL.opONERR:
MovConst(R0, param2);
push(R0);
DEC(StkCount);
jmp(param1)
|IL.opERR:
call(genTrap)
|IL.opNOP:
|IL.opSADR:
reloc(GetAnyReg(), BIN.RDATA + pic, stroffs + param2)
|IL.opGADR:
reloc(GetAnyReg(), BIN.RBSS + pic, param2)
|IL.opLADR:
LocAdr(param2)
|IL.opGLOAD32:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr32(r1, r1)
|IL.opGLOAD16:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr16(r1, r1)
|IL.opGLOAD8:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr8(r1, r1)
|IL.opLLOAD32, IL.opVADR, IL.opVLOAD32:
r1 := GetAnyReg();
n := LocalOffset(param2);
IF n <= 255 THEN
LdrSp(r1, n)
ELSE
drop;
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1)
END;
IF opcode = IL.opVLOAD32 THEN
Ldr32(r1, r1)
END
|IL.opLLOAD16:
LocAdr(param2);
UnOp(r1);
Ldr16(r1, r1)
|IL.opLLOAD8:
LocAdr(param2);
UnOp(r1);
Ldr8(r1, r1)
|IL.opLOAD32, IL.opLOADF:
UnOp(r1);
Ldr32(r1, r1)
|IL.opLOAD16:
UnOp(r1);
Ldr16(r1, r1)
|IL.opLOAD8:
UnOp(r1);
Ldr8(r1, r1)
|IL.opVLOAD16:
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1);
Ldr16(r1, r1)
|IL.opVLOAD8:
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1);
Ldr8(r1, r1)
|IL.opSBOOL:
BinOp(r2, r1);
Tst(r2);
SetCC(jne, r2);
Str8(r2, r1);
drop;
drop
|IL.opSBOOLC:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, ORD(param2 # 0));
Str8(r2, r1);
drop;
drop
|IL.opSAVEC:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, param2);
Str32(r2, r1);
drop;
drop
|IL.opSAVE16C:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, low(param2));
Str16(r2, r1);
drop;
drop
|IL.opSAVE8C:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, param2 MOD 256);
Str8(r2, r1);
drop;
drop
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF:
BinOp(r2, r1);
Str32(r2, r1);
drop;
drop
|IL.opSAVEFI:
BinOp(r2, r1);
Str32(r1, r2);
drop;
drop
|IL.opSAVE16:
BinOp(r2, r1);
Str16(r2, r1);
drop;
drop
|IL.opSAVE8:
BinOp(r2, r1);
Str8(r2, r1);
drop;
drop
|IL.opSAVEP:
UnOp(r1);
r2 := GetAnyReg();
reloc(r2, BIN.RCODE + pic, param2);
Str32(r2, r1);
drop;
drop
|IL.opPUSHP:
reloc(GetAnyReg(), BIN.RCODE + pic, param2)
|IL.opEQB, IL.opNEB:
BinOp(r1, r2);
drop;
L := NewLabel();
cbz(r1, L);
MovConst(r1, 1);
Label(L);
L := NewLabel();
cbz(r2, L);
MovConst(r2, 1);
Label(L);
Cmp(r1, r2);
IF opcode = IL.opEQB THEN
SetCC(je, r1)
ELSE
SetCC(jne, r1)
END
|IL.opACC:
IF (R.top # 0) OR (R.stk[0] # ACC) THEN
PushAll(0);
GetRegA;
pop(ACC);
DEC(R.pushed)
END
|IL.opDROP:
UnOp(r1);
drop
|IL.opJNZ:
UnOp(r1);
cbnz(r1, param1)
|IL.opJZ:
UnOp(r1);
cbz(r1, param1)
|IL.opJG:
UnOp(r1);
Tst(r1);
jcc(jg, param1)
|IL.opJE:
UnOp(r1);
cbnz(r1, param1);
drop
|IL.opJNE:
UnOp(r1);
cbz(r1, param1);
drop
|IL.opSWITCH:
UnOp(r1);
IF param2 = 0 THEN
r2 := ACC
ELSE
r2 := R2
END;
IF r1 # r2 THEN
ASSERT(REG.GetReg(R, r2));
ASSERT(REG.Exchange(R, r1, r2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
GetRegA;
CmpConst(ACC, param1);
jcc(jl, param2);
drop
|IL.opCASER:
GetRegA;
CmpConst(ACC, param1);
jcc(jg, param2);
drop
|IL.opCASELR:
GetRegA;
CmpConst(ACC, param1);
jcc(jl, param2);
jcc(jg, cmd.param3);
drop
|IL.opCODE:
Code(param2)
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(r1, r2);
Cmp(r1, r2);
drop
ELSE
UnOp(r1);
CmpConst(r1, param2)
END;
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
SetCC(cc, GetAnyReg())
END
|IL.opINCC:
UnOp(r1);
r2 := GetAnyReg();
Ldr32(r2, r1);
AddConst(r2, param2);
Str32(r2, r1);
drop;
drop
|IL.opINCCB, IL.opDECCB:
IF opcode = IL.opDECCB THEN
param2 := -param2
END;
UnOp(r1);
r2 := GetAnyReg();
Ldr8(r2, r1);
AddConst(r2, param2);
Str8(r2, r1);
drop;
drop
|IL.opUMINUS:
UnOp(r1);
Neg(r1)
|IL.opADD:
BinOp(r1, r2);
CASE cmd.next(COMMAND).opcode OF
|IL.opLOAD32, IL.opLOADF:
gen7(TRUE, FALSE, r2, r1, r1); (* ldr r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
|IL.opLOAD8:
gen7(TRUE, TRUE, r2, r1, r1); (* ldrb r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
|IL.opLOAD16:
gen8(TRUE, FALSE, r2, r1, r1); (* ldrh r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
ELSE
AddReg(r1, r1, r2)
END;
drop
|IL.opADDL, IL.opADDR:
UnOp(r1);
AddConst(r1, param2)
|IL.opSUB:
BinOp(r1, r2);
SubReg(r1, r1, r2);
drop
|IL.opSUBL, IL.opSUBR:
UnOp(r1);
AddConst(r1, -param2);
IF opcode = IL.opSUBL THEN
Neg(r1)
END
|IL.opMUL:
BinOp(r1, r2);
Mul(r1, r2);
drop
|IL.opMULC:
UnOp(r1);
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
Neg(r1)
ELSIF a = 0 THEN
MovConst(r1, 0)
ELSE
IF n > 0 THEN
IF a < 0 THEN
Neg(r1)
END;
LslImm(r1, n)
ELSE
r2 := GetAnyReg();
MovConst(r2, a);
Mul(r1, r2);
drop
END
END
|IL.opABS:
UnOp(r1);
Tst(r1);
L := NewLabel();
jcc(jge, L);
Neg(r1);
Label(L)
|IL.opNOT:
UnOp(r1);
Tst(r1);
SetCC(je, r1)
|IL.opORD:
UnOp(r1);
Tst(r1);
SetCC(jne, r1)
|IL.opCHR:
UnOp(r1);
Code(0B2C0H + r1 * 9) (* uxtb r1 *)
|IL.opWCHR:
UnOp(r1);
Code(0B280H + r1 * 9) (* uxth r1 *)
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
BinOp(r1, r2);
Shift(opcode, r1, r2);
drop
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1:
MovConst(GetAnyReg(), param2);
BinOp(r2, r1);
Shift(opcode, r1, r2);
INCL(R.regs, r2);
DEC(R.top);
R.stk[R.top] := r1
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2:
n := param2 MOD 32;
IF n # 0 THEN
UnOp(r1);
CASE opcode OF
|IL.opASR2: AsrImm(r1, n)
|IL.opROR2: r2 := GetAnyReg(); MovConst(r2, n); Shift(IL.opROR, r1, r2); drop
|IL.opLSL2: LslImm(r1, n)
|IL.opLSR2: LsrImm(r1, n)
END
END
|IL.opCHKBYTE:
BinOp(r1, r2);
CmpConst(r1, 256);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(r1);
CmpConst(r1, param2);
jcc(jb, param1)
|IL.opCHKIDX2:
BinOp(r1, r2);
IF param2 # -1 THEN
Cmp(r2, r1);
jcc(jb, param1)
END;
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opLEN:
n := param2;
UnOp(r1);
drop;
EXCL(R.regs, r1);
WHILE n > 0 DO
UnOp(r2);
drop;
DEC(n)
END;
INCL(R.regs, r1);
ASSERT(REG.GetReg(R, r1))
|IL.opLOOP, IL.opENDLOOP:
|IL.opINF:
MovConst(GetAnyReg(), inf)
|IL.opPUSHF:
UnOp(r1);
push(r1);
drop
|IL.opCONST:
MovConst(GetAnyReg(), param2)
|IL.opEQP, IL.opNEP:
reloc(GetAnyReg(), BIN.RCODE + pic, param1);
BinOp(r1, r2);
Cmp(r1, r2);
drop;
IF opcode = IL.opEQP THEN
SetCC(je, r1)
ELSE
SetCC(jne, r1)
END
|IL.opPUSHT:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
SubImm8(r2, 4);
Ldr32(r2, r2)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(r1, r2)
ELSIF opcode = IL.opGETC THEN
UnOp(r2);
r1 := GetAnyReg();
MovConst(r1, param1)
END;
drop;
drop;
CASE param2 OF
|1: Ldr8(r1, r1); Str8(r1, r2)
|2: Ldr16(r1, r1); Str16(r1, r2)
|4: Ldr32(r1, r1); Str32(r1, r2)
END
|IL.opINC, IL.opDEC:
BinOp(r2, r1);
r3 := GetAnyReg();
Ldr32(r3, r1);
IF opcode = IL.opINC THEN
AddReg(r3, r3, r2)
ELSE
SubReg(r3, r3, r2)
END;
Str32(r3, r1);
drop;
drop;
drop
|IL.opINCB, IL.opDECB:
BinOp(r2, r1);
r3 := GetAnyReg();
Ldr8(r3, r1);
IF opcode = IL.opINCB THEN
AddReg(r3, r3, r2)
ELSE
SubReg(r3, r3, r2)
END;
Str8(r3, r1);
drop;
drop;
drop
|IL.opMIN, IL.opMAX:
BinOp(r1, r2);
Cmp(r1, r2);
L := NewLabel();
IF opcode = IL.opMIN THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, L);
mov(r1, r2);
Label(L);
drop
|IL.opMINC, IL.opMAXC:
UnOp(r1);
CmpConst(r1, param2);
L := NewLabel();
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, L);
MovConst(r1, param2);
Label(L)
|IL.opMULS:
BinOp(r1, r2);
gen4(0, r2, r1); (* and r1, r2 *)
drop
|IL.opMULSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(0, r2, r1); (* and r1, r2 *)
drop
|IL.opDIVS:
BinOp(r1, r2);
gen4(1, r2, r1); (* eor r1, r2 *)
drop
|IL.opDIVSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(1, r2, r1); (* eor r1, r2 *)
drop
|IL.opADDS:
BinOp(r1, r2);
gen4(12, r2, r1); (* orr r1, r2 *)
drop
|IL.opSUBS:
BinOp(r1, r2);
gen4(14, r2, r1); (* bic r1, r2 *)
drop
|IL.opADDSL, IL.opADDSR:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(12, r2, r1); (* orr r1, r2 *)
drop
|IL.opSUBSL:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(14, r1, r2); (* bic r2, r1 *)
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opSUBSR:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(14, r2, r1); (* bic r1, r2 *)
drop
|IL.opUMINS:
UnOp(r1);
gen4(15, r1, r1) (* mvn r1, r1 *)
|IL.opINCL, IL.opEXCL:
BinOp(r1, r2);
r3 := GetAnyReg();
MovConst(r3, 1);
CmpConst(r1, 32);
L := NewLabel();
jcc(jnb, L);
gen4(2, r1, r3); (* lsl r3, r1 *)
Ldr32(r1, r2);
IF opcode = IL.opINCL THEN
gen4(12, r3, r1) (* orr r1, r3 *)
ELSE
gen4(14, r3, r1) (* bic r1, r3 *)
END;
Str32(r1, r2);
Label(L);
drop;
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(r2);
r1 := GetAnyReg();
r3 := GetAnyReg();
MovConst(r3, 1);
LslImm(r3, param2);
Ldr32(r1, r2);
IF opcode = IL.opINCLC THEN
gen4(12, r3, r1) (* orr r1, r3 *)
ELSE
gen4(14, r3, r1) (* bic r1, r3 *)
END;
Str32(r1, r2);
drop;
drop;
drop
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length, 2);
GetRegA
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw, 2);
GetRegA
|IL.opSAVES:
UnOp(r2);
REG.PushAll_1(R);
r1 := GetAnyReg();
reloc(r1, BIN.RDATA + pic, stroffs + param2);
push(r1);
drop;
push(r2);
drop;
PushConst(param1);
CallRTL(IL._move, 3)
|IL.opEQS .. IL.opGES:
PushAll(4);
PushConst(opcode - IL.opEQS);
CallRTL(IL._strcmp, 5);
GetRegA
|IL.opEQSW .. IL.opGESW:
PushAll(4);
PushConst(opcode - IL.opEQSW);
CallRTL(IL._strcmpw, 5);
GetRegA
|IL.opCOPY:
PushAll(2);
PushConst(param2);
CallRTL(IL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move, 3)
|IL.opCOPYA:
PushAll(4);
PushConst(param2);
CallRTL(IL._arrcpy, 5);
GetRegA
|IL.opCOPYS:
PushAll(4);
PushConst(param2);
CallRTL(IL._strcpy, 5)
|IL.opDIV:
PushAll(2);
divmod;
GetRegA
|IL.opDIVL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
divmod;
GetRegA
|IL.opDIVR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(r1);
AsrImm(r1, n)
ELSIF n < 0 THEN
PushAll(1);
PushConst(param2);
divmod;
GetRegA
END
|IL.opMOD:
PushAll(2);
divmod;
mov(R0, R1);
GetRegA
|IL.opMODR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(r1);
IF n = 8 THEN
Code(0B2C0H + r1 * 9) (* uxtb r1 *)
ELSIF n = 16 THEN
Code(0B280H + r1 * 9) (* uxth r1 *)
ELSE
LslImm(r1, 32 - n);
LsrImm(r1, 32 - n)
END
ELSIF n < 0 THEN
PushAll(1);
PushConst(param2);
divmod;
mov(R0, R1);
GetRegA
ELSE
UnOp(r1);
MovConst(r1, 0)
END
|IL.opMODL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
divmod;
mov(R0, R1);
GetRegA
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
r2 := GetAnyReg();
MovConst(r2, param2)
END;
L := NewLabel();
L2 := NewLabel();
BinOp(r1, r2);
r3 := GetAnyReg();
CmpConst(r1, 32);
jcc(jb, L);
MovConst(r1, 0);
jmp(L2);
Label(L);
MovConst(r3, 1);
Shift(IL.opLSL, r3, r1);
gen4(0, r3, r2); (* and r2, r3 *)
SetCC(jne, r1);
Label(L2);
drop;
drop
|IL.opINL:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, LSL(1, param2));
gen4(0, r2, r1); (* and r1, r2 *)
SetCC(jne, r1);
drop
|IL.opRSET:
PushAll(2);
CallRTL(IL._set, 2);
GetRegA
|IL.opRSETR:
PushAll(1);
PushConst(param2);
CallRTL(IL._set, 2);
GetRegA
|IL.opRSETL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
CallRTL(IL._set, 2);
GetRegA
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1, 1);
GetRegA
|IL.opCONSTF:
MovConst(GetAnyReg(), UTILS.d2s(cmd.float))
|IL.opMULF:
PushAll(2);
CallRTL(IL._fmul, 2);
GetRegA
|IL.opDIVF:
PushAll(2);
CallRTL(IL._fdiv, 2);
GetRegA
|IL.opDIVFI:
PushAll(2);
CallRTL(IL._fdivi, 2);
GetRegA
|IL.opADDF, IL.opADDFI:
PushAll(2);
CallRTL(IL._fadd, 2);
GetRegA
|IL.opSUBFI:
PushAll(2);
CallRTL(IL._fsubi, 2);
GetRegA
|IL.opSUBF:
PushAll(2);
CallRTL(IL._fsub, 2);
GetRegA
|IL.opEQF..IL.opGEF:
PushAll(2);
PushConst(opcode - IL.opEQF);
CallRTL(IL._fcmp, 3);
GetRegA
|IL.opFLOOR:
PushAll(1);
CallRTL(IL._floor, 1);
GetRegA
|IL.opFLT:
PushAll(1);
CallRTL(IL._flt, 1);
GetRegA
|IL.opUMINF:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, 1);
LslImm(r2, 31);
gen4(1, r2, r1); (* eor r1, r2 *)
drop
|IL.opFABS:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, 1);
LslImm(r2, 31);
gen4(14, r2, r1); (* bic r1, r2 *)
drop
|IL.opNEW:
PushAll(1);
n := param2 + 8;
ASSERT(UTILS.Align(n, 32));
PushConst(n);
PushConst(param1);
CallRTL(IL._new, 3)
|IL.opTYPEGP:
UnOp(r1);
PushAll(0);
push(r1);
PushConst(param2);
CallRTL(IL._guard, 2);
GetRegA
|IL.opIS:
PushAll(1);
PushConst(param2);
CallRTL(IL._is, 2);
GetRegA
|IL.opISREC:
PushAll(2);
PushConst(param2);
CallRTL(IL._guardrec, 3);
GetRegA
|IL.opTYPEGR:
PushAll(1);
PushConst(param2);
CallRTL(IL._guardrec, 2);
GetRegA
|IL.opTYPEGD:
UnOp(r1);
PushAll(0);
SubImm8(r1, 4);
Ldr32(r1, r1);
push(r1);
PushConst(param2);
CallRTL(IL._guardrec, 2);
GetRegA
|IL.opCASET:
push(R2);
push(R2);
PushConst(param2);
CallRTL(IL._guardrec, 2);
pop(R2);
cbnz(ACC, param1)
|IL.opROT:
PushAll(0);
mov(R2, SP);
push(R2);
PushConst(param2);
CallRTL(IL._rot, 2)
|IL.opPACK:
PushAll(2);
CallRTL(IL._pack, 2)
|IL.opPACKC:
PushAll(1);
PushConst(param2);
CallRTL(IL._pack, 2)
|IL.opUNPK:
PushAll(2);
CallRTL(IL._unpk, 2)
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog (GlobSize, tcount, pic, FlashAdr, sp, ivt_len: INTEGER);
VAR
r1, r2, i, dcount: INTEGER;
BEGIN
entry := NewLabel();
emptyProc := NewLabel();
genInt := NewLabel();
genTrap := NewLabel();
sdivProc := NewLabel();
trap := emptyProc;
int0 := emptyProc;
IVT[0] := sp;
IVT[1] := entry;
FOR i := 2 TO ivt_len - 1 DO
IVT[i] := genInt
END;
FOR i := 0 TO ivt_len - 1 DO
Code(low(IVT[i]));
Code(high(IVT[i]))
END;
Label(entry);
r1 := GetAnyReg();
r2 := GetAnyReg();
reloc(r1, BIN.RDATA + pic, 0);
FOR i := 0 TO tcount - 1 DO
MovConst(r2, CHL.GetInt(IL.codes.types, i));
Str32(r2, r1);
AddImm8(r1, 4)
END;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO dcount - 1 BY 4 DO
MovConst(r2, BIN.get32le(IL.codes.data, i));
Str32(r2, r1);
AddImm8(r1, 4)
END;
drop;
drop;
r1 := GetAnyReg();
MovConst(r1, sp);
mov(SP, r1);
reloc(r1, BIN.RDATA + pic, 0);
push(r1);
reloc(r1, BIN.RBSS + pic, 0);
r2 := GetAnyReg();
MovConst(r2, GlobSize);
AddReg(r1, r1, r2);
drop;
push(r1);
drop;
PushConst(tcount);
CallRTL(IL._init, 3)
END prolog;
PROCEDURE epilog;
VAR
L1, L2, L3, L4: INTEGER;
BEGIN
Code(0BF30H); (* L2: wfi *)
Code(0E7FDH); (* b L2 *)
Label(genInt);
Code(0F3EFH); Code(08105H); (* mrs r1, ipsr *)
gen14(FALSE, TRUE, {R1}); (* push {LR, R1} *)
call(int0);
gen14(TRUE, TRUE, {R1}); (* pop {PC, R1} *)
Label(emptyProc);
Code(04770H); (* bx lr *)
Label(genTrap);
call(trap);
call(entry);
Label(sdivProc);
IF Target.InstrSet.sdiv THEN
Code(09800H); (* ldr r0, [sp + #0] *)
Code(09901H); (* ldr r1, [sp + #4] *)
Code(0FB91H); (* sdiv r2, r1, r0 *)
Code(0F2F0H);
Code(00013H); (* mov r3, r2 *)
Code(04343H); (* mul r3, r0 *)
Code(01AC9H); (* sub r1, r3 *)
Code(0DA01H); (* bge L *)
Code(04401H); (* add r1, r0 *)
Code(03A01H); (* sub r2, #1 *)
(* L: *)
Code(00010H); (* mov r0, r2 *)
Code(04770H); (* bx lr *)
ELSE
(* a / b; a >= 0 *)
L1 := NewLabel();
L2 := NewLabel();
L3 := NewLabel();
L4 := NewLabel();
LdrSp(R1, 1);
LdrSp(R2, 0);
MovConst(R0, 0);
push(R4);
Label(L4);
Cmp(R1, R2);
jcc(jl, L1);
MovConst(R3, 2);
mov(R4, R2);
LslImm(R4, 1);
Label(L3);
Cmp(R1, R4);
jcc(jl, L2);
CmpConst(R4, 0);
jcc(jle, L2);
LslImm(R4, 1);
LslImm(R3, 1);
jmp(L3);
Label(L2);
LsrImm(R4, 1);
LsrImm(R3, 1);
SubReg(R1, R1, R4);
AddReg(R0, R0, R3);
jmp(L4);
Label(L1);
(* a / b; a < 0 *)
L1 := NewLabel();
L2 := NewLabel();
L3 := NewLabel();
L4 := NewLabel();
Label(L4);
CmpConst(R1, 0);
jcc(jge, L1);
MovConst(R3, 2);
mov(R4, R2);
LslImm(R4, 1);
Neg(R1);
Label(L3);
Cmp(R1, R4);
jcc(jl, L2);
CmpConst(R4, 0);
jcc(jle, L2);
LslImm(R4, 1);
LslImm(R3, 1);
jmp(L3);
Label(L2);
Neg(R1);
LsrImm(R4, 1);
LsrImm(R3, 1);
AddReg(R1, R1, R4);
SubReg(R0, R0, R3);
jmp(L4);
Label(L1);
pop(R4);
Code(04770H); (* bx lr *)
END
END epilog;
PROCEDURE CortexM3;
BEGIN
Target.FlashAdr := 08000000H;
Target.SRAMAdr := 20000000H;
Target.IVTLen := 256;
Target.Reserved := 0;
Target.MinStack := 512;
Target.InstrSet.thumb2 := TRUE;
Target.InstrSet.it := TRUE;
Target.InstrSet.sdiv := TRUE;
Target.InstrSet.cbxz := TRUE
END CortexM3;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
opt: PROG.OPTIONS;
ram, rom: INTEGER;
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
File: WR.FILE;
BEGIN
IF target = TARGETS.STM32CM3 THEN
CortexM3
END;
ram := MIN(MAX(options.ram, STM32_minRAM), STM32_maxRAM) * 1024;
rom := MIN(MAX(options.rom, STM32_minROM), STM32_maxROM) * 1024;
tcount := CHL.Length(IL.codes.types);
opt := options;
CodeList := LISTS.create(NIL);
program := BIN.create(IL.codes.lcount);
REG.Init(R, push, pop, mov, xchg, NIL, NIL, {R0, R1, R2, R3}, {});
StkCount := 0;
DataAdr := Target.SRAMAdr + Target.Reserved;
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.Reserved;
WHILE DataSize MOD 4 # 0 DO
CHL.PushByte(IL.codes.data, 0);
INC(DataSize)
END;
BssAdr := DataAdr + DataSize - Target.Reserved;
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.FlashAdr, Target.SRAMAdr + ram, Target.IVTLen);
translate(ORD(opt.pic), tcount * 4);
epilog;
fixup(Target.FlashAdr, DataAdr, BssAdr);
INC(DataSize, BssSize);
CodeSize := CHL.Length(program.code);
IF CodeSize > rom THEN
ERRORS.Error(203)
END;
IF DataSize > ram - Target.MinStack THEN
ERRORS.Error(204)
END;
File := WR.Create(outname);
HEX.Data2(File, program.code, 0, CodeSize, high(Target.FlashAdr));
HEX.End(File);
WR.Close(File);
C.StringLn("--------------------------------------------");
C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(CodeSize * 100 DIV rom); 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("%)")
END CodeGen;
PROCEDURE SetIV* (idx: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := IVT[idx] = 0;
IVT[idx] := 1
RETURN res
END SetIV;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO LEN(IVT) - 1 DO
IVT[i] := 0
END
END init;
BEGIN
init
END THUMB.

/programs/develop/oberon07/Source/UTILS.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
23,7 → 23,15
min32* = -2147483647-1;
max32* = 2147483647;
vMajor* = 1;
vMinor* = 29;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
110,6 → 118,11
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
RETURN HOST.d2s(x)
END d2s;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN HOST.isRelative(path)
END isRelative;
143,7 → 156,7
END UnixTime;
PROCEDURE SetBitDepth* (BitDepth: INTEGER);
PROCEDURE SetBitDepth* (BitDepth: INTEGER; Double: BOOLEAN);
BEGIN
ASSERT((BitDepth = 16) OR (BitDepth = 32) OR (BitDepth = 64));
bit_diff := bit_depth - BitDepth;
154,8 → 167,13
target.maxHex := BitDepth DIV 4;
target.minInt := ASR(minint, bit_diff);
target.maxInt := ASR(maxint, bit_diff);
IF Double THEN
target.maxReal := maxreal
ELSE
target.maxReal := 1.9;
PACK(target.maxReal, 1023);
PACK(target.maxReal, 127)
END
END SetBitDepth;
197,8 → 215,6
n: INTEGER;
BEGIN
ASSERT(x > 0);
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
258,7 → 274,6
BEGIN
time := GetTickCount();
COPY(HOST.eol, eol);
maxreal := 1.9;
PACK(maxreal, 1023);
maxreal := HOST.maxreal;
init(days)
END UTILS.
END UTILS.

/programs/develop/oberon07/Source/WRITER.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Source/X86.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
8,7 → 8,7
MODULE X86;
IMPORT IL, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, PROG,
mConst := CONSTANTS, CHL := CHUNKLISTS, PATHS;
CHL := CHUNKLISTS, PATHS, TARGETS;
CONST
93,16 → 93,6
tcount: INTEGER;
PROCEDURE Byte (n: INTEGER): BYTE;
RETURN UTILS.Byte(n, 0)
END Byte;
PROCEDURE Word (n: INTEGER): INTEGER;
RETURN UTILS.Byte(n, 0) + UTILS.Byte(n, 1) * 256
END Word;
PROCEDURE OutByte* (n: BYTE);
VAR
c: CODE;
127,7 → 117,7
PROCEDURE OutInt (n: INTEGER);
BEGIN
OutByte(UTILS.Byte(n, 0));
OutByte(n MOD 256);
OutByte(UTILS.Byte(n, 1));
OutByte(UTILS.Byte(n, 2));
OutByte(UTILS.Byte(n, 3))
174,7 → 164,7
PROCEDURE OutIntByte (n: INTEGER);
BEGIN
IF isByte(n) THEN
OutByte(Byte(n))
OutByte(n MOD 256)
ELSE
OutInt(n)
END
194,7 → 184,7
PROCEDURE mov (reg1, reg2: INTEGER);
BEGIN
OutByte2(89H, 0C0H + reg2 * 8 + reg1) // mov reg1, reg2
OutByte2(89H, 0C0H + reg2 * 8 + reg1) (* mov reg1, reg2 *)
END mov;
205,11 → 195,11
BEGIN
regs := {reg1, reg2};
IF regs = {eax, ecx} THEN
OutByte(91H) // xchg eax, ecx
OutByte(91H) (* xchg eax, ecx *)
ELSIF regs = {eax, edx} THEN
OutByte(92H) // xchg eax, edx
OutByte(92H) (* xchg eax, edx *)
ELSIF regs = {ecx, edx} THEN
OutByte2(87H, 0D1H) // xchg ecx, edx
OutByte2(87H, 0D1H) (* xchg ecx, edx *)
END
END xchg;
216,19 → 206,19
PROCEDURE pop (reg: INTEGER);
BEGIN
OutByte(58H + reg) // pop reg
OutByte(58H + reg) (* pop reg *)
END pop;
PROCEDURE push (reg: INTEGER);
BEGIN
OutByte(50H + reg) // push reg
OutByte(50H + reg) (* push reg *)
END push;
PROCEDURE movrc (reg, n: INTEGER);
BEGIN
OutByte(0B8H + reg); // mov reg, n
OutByte(0B8H + reg); (* mov reg, n *)
OutInt(n)
END movrc;
235,7 → 225,7
PROCEDURE pushc (n: INTEGER);
BEGIN
OutByte(68H + short(n)); // push n
OutByte(68H + short(n)); (* push n *)
OutIntByte(n)
END pushc;
242,31 → 232,31
PROCEDURE test (reg: INTEGER);
BEGIN
OutByte2(85H, 0C0H + reg * 9) // test reg, reg
OutByte2(85H, 0C0H + reg * 9) (* test reg, reg *)
END test;
PROCEDURE neg (reg: INTEGER);
BEGIN
OutByte2(0F7H, 0D8H + reg) // neg reg
OutByte2(0F7H, 0D8H + reg) (* neg reg *)
END neg;
PROCEDURE not (reg: INTEGER);
BEGIN
OutByte2(0F7H, 0D0H + reg) // not reg
OutByte2(0F7H, 0D0H + reg) (* not reg *)
END not;
PROCEDURE add (reg1, reg2: INTEGER);
BEGIN
OutByte2(01H, 0C0H + reg2 * 8 + reg1) // add reg1, reg2
OutByte2(01H, 0C0H + reg2 * 8 + reg1) (* add reg1, reg2 *)
END add;
PROCEDURE andrc (reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0E0H + reg); // and reg, n
OutByte2(81H + short(n), 0E0H + reg); (* and reg, n *)
OutIntByte(n)
END andrc;
273,7 → 263,7
PROCEDURE orrc (reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0C8H + reg); // or reg, n
OutByte2(81H + short(n), 0C8H + reg); (* or reg, n *)
OutIntByte(n)
END orrc;
280,7 → 270,7
PROCEDURE addrc (reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0C0H + reg); // add reg, n
OutByte2(81H + short(n), 0C0H + reg); (* add reg, n *)
OutIntByte(n)
END addrc;
287,7 → 277,7
PROCEDURE subrc (reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0E8H + reg); // sub reg, n
OutByte2(81H + short(n), 0E8H + reg); (* sub reg, n *)
OutIntByte(n)
END subrc;
294,29 → 284,39
PROCEDURE cmprr (reg1, reg2: INTEGER);
BEGIN
OutByte2(39H, 0C0H + reg2 * 8 + reg1) // cmp reg1, reg2
OutByte2(39H, 0C0H + reg2 * 8 + reg1) (* cmp reg1, reg2 *)
END cmprr;
PROCEDURE cmprc (reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0F8H + reg); // cmp reg, n
IF n = 0 THEN
test(reg)
ELSE
OutByte2(81H + short(n), 0F8H + reg); (* cmp reg, n *)
OutIntByte(n)
END
END cmprc;
PROCEDURE setcc (cond, reg: INTEGER);
BEGIN
OutByte3(0FH, cond, 0C0H + reg) // setcc reg
OutByte3(0FH, cond, 0C0H + reg) (* setcc reg *)
END setcc;
PROCEDURE xor (reg1, reg2: INTEGER);
BEGIN
OutByte2(31H, 0C0H + reg2 * 8 + reg1) // xor reg1, reg2
OutByte2(31H, 0C0H + reg2 * 8 + reg1) (* xor reg1, reg2 *)
END xor;
PROCEDURE ret*;
BEGIN
OutByte(0C3H)
END ret;
PROCEDURE drop;
BEGIN
REG.Drop(R)
402,10 → 402,10
PROCEDURE Pic (reg, opcode, value: INTEGER);
BEGIN
OutByte(0E8H); OutInt(0); // call L
// L:
OutByte(0E8H); OutInt(0); (* call L
L: *)
pop(reg);
OutByte2(081H, 0C0H + reg); // add reg, ...
OutByte2(081H, 0C0H + reg); (* add reg, ... *)
Reloc(opcode, value)
END Pic;
423,10 → 423,10
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICIMP, label);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 015H); // call dword[label]
OutByte2(0FFH, 015H); (* call dword[label] *)
Reloc(BIN.RIMP, label)
END
ELSE
504,12 → 504,11
END
|LABEL:
BIN.SetLabel(program, code.label, code.offset)
|JMP:
IF code.short THEN
BIN.PutCode(program, 0EBH);
BIN.PutCode(program, Byte(code.diff))
BIN.PutCode(program, code.diff MOD 256)
ELSE
BIN.PutCode(program, 0E9H);
BIN.PutCode32LE(program, code.diff)
518,7 → 517,7
|JCC:
IF code.short THEN
BIN.PutCode(program, code.jmp - 16);
BIN.PutCode(program, Byte(code.diff))
BIN.PutCode(program, code.diff MOD 256)
ELSE
BIN.PutCode(program, 0FH);
BIN.PutCode(program, code.jmp);
573,9 → 572,127
END GetRegA;
PROCEDURE fcmp;
BEGIN
GetRegA;
OutByte2(0DAH, 0E9H); (* fucompp *)
OutByte3(09BH, 0DFH, 0E0H); (* fstsw ax *)
OutByte(09EH); (* sahf *)
movrc(eax, 0)
END fcmp;
PROCEDURE movzx* (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *)
VAR
b: BYTE;
BEGIN
OutByte2(0FH, 0B6H + ORD(word));
IF (offs = 0) & (reg2 # ebp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = esp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END movzx;
PROCEDURE _movrm* (reg1, reg2, offs, size: INTEGER; mr: BOOLEAN);
VAR
b: BYTE;
BEGIN
IF size = 16 THEN
OutByte(66H)
END;
IF (reg1 >= 8) OR (reg2 >= 8) OR (size = 64) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8) + 8 * ORD(size = 64))
END;
OutByte(8BH - 2 * ORD(mr) - ORD(size = 8));
IF (offs = 0) & (reg2 # ebp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = esp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END _movrm;
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_8 *)
BEGIN
_movrm(reg2, reg1, offs, 32, TRUE)
END movmr;
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, dword[reg2 + offs] *)
BEGIN
_movrm(reg1, reg2, offs, 32, FALSE)
END movrm;
PROCEDURE movmr8* (reg1, offs, reg2: INTEGER); (* mov byte[reg1+offs], reg2_8 *)
BEGIN
_movrm(reg2, reg1, offs, 8, TRUE)
END movmr8;
PROCEDURE movrm8* (reg1, reg2, offs: INTEGER); (* mov reg1_8, byte[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 8, FALSE)
END movrm8;
PROCEDURE movmr16* (reg1, offs, reg2: INTEGER); (* mov word[reg1+offs], reg2_16 *)
BEGIN
_movrm(reg2, reg1, offs, 16, TRUE)
END movmr16;
PROCEDURE movrm16* (reg1, reg2, offs: INTEGER); (* mov reg1_16, word[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 16, FALSE)
END movrm16;
PROCEDURE pushm* (reg, offs: INTEGER); (* push qword[reg+offs] *)
VAR
b: BYTE;
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte(0FFH);
IF (offs = 0) & (reg # ebp) THEN
b := 30H
ELSE
b := 70H + long(offs)
END;
OutByte(b + reg MOD 8);
IF reg = esp THEN
OutByte(24H)
END;
IF b # 30H THEN
OutIntByte(offs)
END
END pushm;
PROCEDURE translate (pic: BOOLEAN; stroffs: INTEGER);
VAR
cmd: COMMAND;
cmd, next: COMMAND;
reg1, reg2: INTEGER;
607,16 → 724,16
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICIMP, param1);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 015H); // call dword[L]
OutByte2(0FFH, 015H); (* call dword[L] *)
Reloc(BIN.RIMP, param1)
END
|IL.opCALLP:
UnOp(reg1);
OutByte2(0FFH, 0D0H + reg1); // call reg1
OutByte2(0FFH, 0D0H + reg1); (* call reg1 *)
drop;
ASSERT(R.top = -1)
627,7 → 744,7
END;
WHILE n > 0 DO
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H); // fstp qword[esp]
OutByte3(0DDH, 01CH, 024H); (* fstp qword[esp] *)
DEC(n)
END;
PushAll(0)
647,7 → 764,7
GetRegA;
n := param2;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8);
DEC(n)
END
656,12 → 773,12
n := param2;
IF n > 0 THEN
OutByte3(0DDH, 5CH + long(n * 8), 24H);
OutIntByte(n * 8); // fstp qword[esp + n*8]
OutIntByte(n * 8); (* fstp qword[esp + n*8] *)
INC(n)
END;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8);
DEC(n)
END
677,8 → 794,8
n := param2;
IF n > 4 THEN
movrc(ecx, n);
pushc(0); // @@: push 0
OutByte2(0E2H, 0FCH) // loop @b
pushc(0); (* L: push 0 *)
OutByte2(0E2H, 0FCH) (* loop L *)
ELSE
WHILE n > 0 DO
pushc(0);
708,14 → 825,18
n := param2;
IF n > 0 THEN
n := n * 4;
OutByte(0C2H); OutWord(Word(n)) // ret n
OutByte(0C2H); OutWord(n MOD 65536) (* ret n *)
ELSE
OutByte(0C3H) // ret
ret
END
|IL.opPUSHC:
pushc(param2)
|IL.opONERR:
pushc(param2);
jmp(param1)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
740,7 → 861,7
movrc(GetAnyReg(), param2)
|IL.opLABEL:
SetLabel(param1) // L:
SetLabel(param1) (* L: *)
|IL.opNOP:
749,19 → 870,17
IF pic THEN
Pic(reg1, BIN.PICBSS, param2)
ELSE
OutByte(0B8H + reg1); // mov reg1, _bss + param2
OutByte(0B8H + reg1); (* mov reg1, _bss + param2 *)
Reloc(BIN.RBSS, param2)
END
|IL.opLADR:
n := param2 * 4;
OutByte2(8DH, 45H + GetAnyReg() * 8 + long(n)); // lea reg1, dword[ebp + n]
OutByte2(8DH, 45H + GetAnyReg() * 8 + long(n)); (* lea reg1, dword[ebp + n] *)
OutIntByte(n)
|IL.opVADR:
n := param2 * 4;
OutByte2(8BH, 45H + GetAnyReg() * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
|IL.opVADR, IL.opLLOAD32:
movrm(GetAnyReg(), ebp, param2 * 4)
|IL.opSADR:
reg1 := GetAnyReg();
768,102 → 887,88
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
ELSE
OutByte(0B8H + reg1); // mov reg1, _data + stroffs + param2
OutByte(0B8H + reg1); (* mov reg1, _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2)
END
|IL.opSAVEC:
UnOp(reg1);
OutByte2(0C7H, reg1); OutInt(param2); // mov dword[reg1], param2
OutByte2(0C7H, reg1); OutInt(param2); (* mov dword[reg1], param2 *)
drop
|IL.opSAVE8C:
UnOp(reg1);
OutByte3(0C6H, reg1, Byte(param2)); // mov byte[reg1], param2
OutByte3(0C6H, reg1, param2 MOD 256); (* mov byte[reg1], param2 *)
drop
|IL.opSAVE16C:
UnOp(reg1);
OutByte3(66H, 0C7H, reg1); OutWord(Word(param2)); // mov word[reg1], param2
OutByte3(66H, 0C7H, reg1); OutWord(param2 MOD 65536); (* mov word[reg1], param2 *)
drop
|IL.opVLOAD32:
n := param2 * 4;
reg1 := GetAnyReg();
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
movrm(reg1, ebp, param2 * 4);
movrm(reg1, reg1, 0)
|IL.opGLOAD32:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
movrm(reg1, reg1, 0)
ELSE
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[_bss + param2]
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD32:
n := param2 * 4;
OutByte2(8BH, 45H + GetAnyReg() * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
|IL.opLOAD32:
UnOp(reg1);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
movrm(reg1, reg1, 0)
|IL.opVLOAD8:
n := param2 * 4;
reg1 := GetAnyReg();
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
movrm(reg1, ebp, param2 * 4);
movzx(reg1, reg1, 0, FALSE)
|IL.opGLOAD8:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
movzx(reg1, reg1, 0, FALSE)
ELSE
OutByte3(00FH, 0B6H, 05H + reg1 * 8); // movzx reg1, byte[_bss + param2]
OutByte3(00FH, 0B6H, 05H + reg1 * 8); (* movzx reg1, byte[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD8:
n := param2 * 4;
OutByte3(0FH, 0B6H, 45H + GetAnyReg() * 8 + long(n)); // movzx reg1, byte[ebp + n]
OutIntByte(n)
movzx(GetAnyReg(), ebp, param2 * 4, FALSE)
|IL.opLOAD8:
UnOp(reg1);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
movzx(reg1, reg1, 0, FALSE)
|IL.opVLOAD16:
n := param2 * 4;
reg1 := GetAnyReg();
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
movrm(reg1, ebp, param2 * 4);
movzx(reg1, reg1, 0, TRUE)
|IL.opGLOAD16:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
movzx(reg1, reg1, 0, TRUE)
ELSE
OutByte3(00FH, 0B7H, 05H + reg1 * 8); // movzx reg1, word[_bss + param2]
OutByte3(00FH, 0B7H, 05H + reg1 * 8); (* movzx reg1, word[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD16:
n := param2 * 4;
OutByte3(0FH, 0B7H, 45H + GetAnyReg() * 8 + long(n)); // movzx reg1, word[ebp + n]
OutIntByte(n)
movzx(GetAnyReg(), ebp, param2 * 4, TRUE)
|IL.opLOAD16:
UnOp(reg1);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
movzx(reg1, reg1, 0, TRUE)
|IL.opUMINUS:
UnOp(reg1);
877,18 → 982,35
|IL.opADDL, IL.opADDR:
IF param2 # 0 THEN
UnOp(reg1);
next := cmd.next(COMMAND);
CASE next.opcode OF
|IL.opLOAD32:
movrm(reg1, reg1, param2);
cmd := next
|IL.opLOAD16:
movzx(reg1, reg1, param2, TRUE);
cmd := next
|IL.opLOAD8:
movzx(reg1, reg1, param2, FALSE);
cmd := next
|IL.opLOAD32_PARAM:
pushm(reg1, param2);
drop;
cmd := next
ELSE
IF param2 = 1 THEN
OutByte(40H + reg1) // inc reg1
OutByte(40H + reg1) (* inc reg1 *)
ELSIF param2 = -1 THEN
OutByte(48H + reg1) // dec reg1
OutByte(48H + reg1) (* dec reg1 *)
ELSE
addrc(reg1, param2)
END
END
END
|IL.opSUB:
BinOp(reg1, reg2);
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
OutByte2(29H, 0C0H + reg2 * 8 + reg1); (* sub reg1, reg2 *)
drop
|IL.opSUBR, IL.opSUBL:
895,9 → 1017,9
UnOp(reg1);
n := param2;
IF n = 1 THEN
OutByte(48H + reg1) // dec reg1
OutByte(48H + reg1) (* dec reg1 *)
ELSIF n = -1 THEN
OutByte(40H + reg1) // inc reg1
OutByte(40H + reg1) (* inc reg1 *)
ELSIF n # 0 THEN
subrc(reg1, n)
END;
906,6 → 1028,12
END
|IL.opMULC:
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN
BinOp(reg1, reg2);
OutByte3(8DH, 04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2)); (* lea reg1, [reg1 + reg2 * param2] *)
drop;
cmd := cmd.next(COMMAND)
ELSE
UnOp(reg1);
a := param2;
930,36 → 1058,37
END;
IF n # 1 THEN
OutByte3(0C1H, 0E0H + reg1, n) // shl reg1, n
OutByte3(0C1H, 0E0H + reg1, n) (* shl reg1, n *)
ELSE
OutByte2(0D1H, 0E0H + reg1) // shl reg1, 1
OutByte2(0D1H, 0E0H + reg1) (* shl reg1, 1 *)
END
ELSE
OutByte2(69H + short(a), 0C0H + reg1 * 9); // imul reg1, a
OutByte2(69H + short(a), 0C0H + reg1 * 9); (* imul reg1, a *)
OutIntByte(a)
END
END
END
|IL.opMUL:
BinOp(reg1, reg2);
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); // imul reg1, reg2
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); (* imul reg1, reg2 *)
drop
|IL.opSAVE, IL.opSAVE32:
BinOp(reg2, reg1);
OutByte2(89H, reg2 * 8 + reg1); // mov dword[reg1], reg2
movmr(reg1, 0, reg2);
drop;
drop
|IL.opSAVE8:
BinOp(reg2, reg1);
OutByte2(88H, reg2 * 8 + reg1); // mov byte[reg1], reg2
movmr8(reg1, 0, reg2);
drop;
drop
|IL.opSAVE16:
BinOp(reg2, reg1);
OutByte3(66H, 89H, reg2 * 8 + reg1); // mov word[reg1], reg2
movmr16(reg1, 0, reg2);
drop;
drop
968,10 → 1097,10
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICCODE, param2);
OutByte2(089H, reg2 * 8 + reg1); // mov dword[reg1], reg2
movmr(reg1, 0, reg2);
drop
ELSE
OutByte2(0C7H, reg1); // mov dword[reg1], L
OutByte2(0C7H, reg1); (* mov dword[reg1], L *)
Reloc(BIN.RCODE, param2)
END;
drop
981,13 → 1110,13
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICIMP, param2);
OutByte2(0FFH, 30H + reg2); // push dword[reg2]
OutByte2(08FH, reg1); // pop dword[reg1]
pushm(reg2, 0);
OutByte2(08FH, reg1); (* pop dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 035H); // push dword[L]
OutByte2(0FFH, 035H); (* push dword[L] *)
Reloc(BIN.RIMP, param2);
OutByte2(08FH, reg1) // pop dword[reg1]
OutByte2(08FH, reg1) (* pop dword[reg1] *)
END;
drop
996,7 → 1125,7
IF pic THEN
Pic(reg1, BIN.PICCODE, param2)
ELSE
OutByte(0B8H + reg1); // mov reg1, L
OutByte(0B8H + reg1); (* mov reg1, L *)
Reloc(BIN.RCODE, param2)
END
1004,9 → 1133,9
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICIMP, param2);
OutByte2(08BH, reg1 * 9) // mov reg1, dword[reg1]
movrm(reg1, reg1, 0)
ELSE
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[L]
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[L] *)
Reloc(BIN.RIMP, param2)
END
1025,19 → 1154,15
|IL.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
OutByte3(0FH, 95H, reg1); // setne byte[reg1]
OutByte3(0FH, 95H, reg1); (* setne byte[reg1] *)
drop;
drop
|IL.opSBOOLC:
UnOp(reg1);
OutByte3(0C6H, reg1, ORD(param2 # 0)); // mov byte[reg1], 0/1
OutByte3(0C6H, reg1, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *)
drop
|IL.opODD:
UnOp(reg1);
andrc(reg1, 1)
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
1047,26 → 1172,19
drop
ELSE
UnOp(reg1);
IF param2 = 0 THEN
test(reg1)
ELSE
cmprc(reg1, param2)
END
END;
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF cmd.next(COMMAND).opcode = IL.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = IL.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(inv0(cc), label);
cmd := cmd.next(COMMAND)
IF next.opcode = IL.opJE THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
reg1 := GetAnyReg();
setcc(cc + 16, reg1);
1078,13 → 1196,13
drop;
test(reg1);
OutByte2(74H, 5); // je @f
movrc(reg1, 1); // mov reg1, 1
// @@:
OutByte2(74H, 5); (* je @f *)
movrc(reg1, 1); (* mov reg1, 1
@@: *)
test(reg2);
OutByte2(74H, 5); // je @f
movrc(reg2, 1); // mov reg2, 1
// @@:
OutByte2(74H, 5); (* je @f *)
movrc(reg2, 1); (* mov reg2, 1
@@: *)
cmprr(reg1, reg2);
IF opcode = IL.opEQB THEN
1116,6 → 1234,11
test(reg1);
jcc(je, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJE:
UnOp(reg1);
test(reg1);
1171,26 → 1294,15
drop;
drop;
CASE param2 OF
|1:
OutByte2(8AH, reg1 * 9); // mov reg1, byte[reg1]
OutByte2(88H, reg1 * 8 + reg2) // mov byte[reg2], reg1
|2:
OutByte3(66H, 8BH, reg1 * 9); // mov reg1, word[reg1]
OutByte3(66H, 89H, reg1 * 8 + reg2) // mov word[reg2], reg1
|4:
OutByte2(8BH, reg1 * 9); // mov reg1, dword[reg1]
OutByte2(89H, reg1 * 8 + reg2) // mov dword[reg2], reg1
|8:
IF param2 # 8 THEN
_movrm(reg1, reg1, 0, param2 * 8, FALSE);
_movrm(reg1, reg2, 0, param2 * 8, TRUE)
ELSE
PushAll(0);
push(reg1);
push(reg2);
pushc(8);
CallRTL(pic, IL._move)
END
|IL.opSAVES:
1203,7 → 1315,7
push(reg1);
drop
ELSE
OutByte(068H); // push _data + stroffs + param2
OutByte(068H); (* push _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2);
END;
1226,14 → 1338,11
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
mov(reg1, reg2);
drop;
jcc(jb, param1)
ELSE
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
|IL.opLEN:
n := param2;
1252,29 → 1361,35
|IL.opINCC:
UnOp(reg1);
OutByte2(81H + short(param2), reg1); OutIntByte(param2); // add dword[reg1], param2
IF param2 = 1 THEN
OutByte2(0FFH, reg1) (* inc dword[reg1] *)
ELSIF param2 = -1 THEN
OutByte2(0FFH, reg1 + 8) (* dec dword[reg1] *)
ELSE
OutByte2(81H + short(param2), reg1); OutIntByte(param2) (* add dword[reg1], param2 *)
END;
drop
|IL.opINC, IL.opDEC:
BinOp(reg1, reg2);
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg1 * 8 + reg2); // add/sub dword[reg2], reg1
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg1 * 8 + reg2); (* add/sub dword[reg2], reg1 *)
drop;
drop
|IL.opINCCB, IL.opDECCB:
UnOp(reg1);
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1, Byte(param2)); // add/sub byte[reg1], n
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1, param2 MOD 256); (* add/sub byte[reg1], n *)
drop
|IL.opINCB, IL.opDECB:
BinOp(reg1, reg2);
OutByte2(28H * ORD(opcode = IL.opDECB), reg1 * 8 + reg2); // add/sub byte[reg2], reg1
OutByte2(28H * ORD(opcode = IL.opDECB), reg1 * 8 + reg2); (* add/sub byte[reg2], reg1 *)
drop;
drop
|IL.opMULS:
BinOp(reg1, reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
OutByte2(21H, 0C0H + reg2 * 8 + reg1); (* and reg1, reg2 *)
drop
|IL.opMULSC:
1288,18 → 1403,18
|IL.opDIVSC:
UnOp(reg1);
OutByte2(81H + short(param2), 0F0H + reg1); // xor reg1, n
OutByte2(81H + short(param2), 0F0H + reg1); (* xor reg1, n *)
OutIntByte(param2)
|IL.opADDS:
BinOp(reg1, reg2);
OutByte2(9H, 0C0H + reg2 * 8 + reg1); // or reg1, reg2
OutByte2(9H, 0C0H + reg2 * 8 + reg1); (* or reg1, reg2 *)
drop
|IL.opSUBS:
BinOp(reg1, reg2);
not(reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
OutByte2(21H, 0C0H + reg2 * 8 + reg1); (* and reg1, reg2 *)
drop
|IL.opADDSL, IL.opADDSR:
1348,7 → 1463,7
BinOp(reg1, reg2);
ASSERT(reg2 = ecx);
OutByte(0D3H);
shift(opcode, reg1); // shift reg1, cl
shift(opcode, reg1); (* shift reg1, cl *)
drop
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1:
1364,7 → 1479,7
BinOp(reg1, reg2);
ASSERT(reg1 = ecx);
OutByte(0D3H);
shift(opcode, reg2); // shift reg2, cl
shift(opcode, reg2); (* shift reg2, cl *)
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
1377,74 → 1492,47
ELSE
OutByte(0D1H)
END;
shift(opcode, reg1); // shift reg1, n
shift(opcode, reg1); (* shift reg1, n *)
IF n # 1 THEN
OutByte(n)
END
|IL.opMIN:
|IL.opMAX, IL.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07EH, 002H); // jle @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
OutByte2(07DH + ORD(opcode = IL.opMIN), 2); (* jge/jle L *)
mov(reg1, reg2);
(* L: *)
drop
|IL.opMAX:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07DH, 002H); // jge @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
drop
|IL.opMINC:
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07EH, 005H); // jle @f
movrc(reg1, param2) // mov reg1, param2
// @@:
OutByte2(07DH + ORD(opcode = IL.opMINC), 5); (* jge/jle L *)
movrc(reg1, param2)
(* L: *)
|IL.opMAXC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07DH, 005H); // jge @f
movrc(reg1, param2) // mov reg1, param2
// @@:
|IL.opIN:
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
reg2 := GetAnyReg();
movrc(reg2, param2)
END;
label := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
OutByte2(72H, 4); (* jb L *)
xor(reg1, reg1);
jmp(label);
//L:
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); // bt reg2, reg1
(* L: *)
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); (* bt reg2, reg1 *)
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
|IL.opINR:
label := NewLabel();
UnOp(reg1);
reg2 := GetAnyReg();
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
xor(reg1, reg1);
jmp(label);
//L:
movrc(reg2, param2);
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
|IL.opINL:
UnOp(reg1);
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); // bt reg1, param2
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); (* bt reg1, param2 *)
setcc(setc, reg1);
andrc(reg1, 1)
1476,26 → 1564,26
|IL.opINCL, IL.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(73H, 03H); // jnb L
OutByte2(73H, 03H); (* jnb L *)
OutByte(0FH);
IF opcode = IL.opINCL THEN
OutByte(0ABH) // bts dword[reg2], reg1
OutByte(0ABH) (* bts dword[reg2], reg1 *)
ELSE
OutByte(0B3H) // btr dword[reg2], reg1
OutByte(0B3H) (* btr dword[reg2], reg1 *)
END;
OutByte(reg2 + 8 * reg1);
//L:
(* L: *)
drop;
drop
|IL.opINCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); //bts dword[reg1],param2
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); (* bts dword[reg1], param2 *)
drop
|IL.opEXCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); //btr dword[reg1],param2
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); (* btr dword[reg1], param2 *)
drop
|IL.opDIV:
1504,49 → 1592,20
GetRegA
|IL.opDIVR:
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
UnOp(reg1);
neg(reg1)
ELSE
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
IF a < 0 THEN
reg2 := GetAnyReg();
mov(reg2, reg1);
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
OutByte3(0C1H, 0F8H + reg1, n) (* sar reg1, n *)
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
END;
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
drop
ELSE
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
OutByte2(0D1H, 0F8H + reg1) (* sar reg1, 1 *)
END
END
ELSE
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(pic, IL._divmod);
GetRegA
END
END
|IL.opDIVL:
UnOp(reg1);
1564,43 → 1623,20
GetRegA
|IL.opMODR:
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF ABS(a) = 1 THEN
UnOp(reg1);
xor(reg1, reg1)
ELSE
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, ABS(a) - 1);
IF a < 0 THEN
test(reg1);
OutByte(74H); // je @f
IF isByte(a) THEN
OutByte(3)
ELSE
OutByte(6)
END;
addrc(reg1, a)
// @@:
END
ELSE
andrc(reg1, param2 - 1);
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(pic, IL._divmod);
mov(eax, edx);
GetRegA
ELSE
UnOp(reg1);
xor(reg1, reg1)
END
END
|IL.opMODL:
UnOp(reg1);
1618,9 → 1654,9
|IL.opABS:
UnOp(reg1);
test(reg1);
OutByte2(07DH, 002H); // jge @f
neg(reg1) // neg reg1
// @@:
OutByte2(07DH, 002H); (* jge L *)
neg(reg1) (* neg reg1
L: *)
|IL.opCOPY:
PushAll(2);
1682,7 → 1718,7
cmprr(reg1, reg2);
drop
ELSE
OutByte2(081H, 0F8H + reg1); // cmp reg1, L
OutByte2(081H, 0F8H + reg1); (* cmp reg1, L *)
Reloc(BIN.RCODE, param1)
END
1690,10 → 1726,10
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICIMP, param1);
OutByte2(03BH, reg1 * 8 + reg2); //cmp reg1, dword [reg2]
OutByte2(03BH, reg1 * 8 + reg2); (* cmp reg1, dword [reg2] *)
drop
ELSE
OutByte2(3BH, 05H + reg1 * 8); // cmp reg1, dword[L]
OutByte2(3BH, 05H + reg1 * 8); (* cmp reg1, dword[L] *)
Reloc(BIN.RIMP, param1)
END
1710,8 → 1746,7
|IL.opPUSHT:
UnOp(reg1);
reg2 := GetAnyReg();
OutByte3(8BH, 40H + reg2 * 8 + reg1, 0FCH) // mov reg2, dword[reg1 - 4]
movrm(GetAnyReg(), reg1, -4)
|IL.opISREC:
PushAll(2);
1742,7 → 1777,7
|IL.opTYPEGD:
UnOp(reg1);
PushAll(0);
OutByte3(0FFH, 070H + reg1, 0FCH); // push dword[reg1 - 4]
pushm(reg1, -4);
pushc(param2 * tcount);
CallRTL(pic, IL._guardrec);
GetRegA
1759,11 → 1794,11
|IL.opPACK:
BinOp(reg1, reg2);
push(reg2);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0FDH); // fscale
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0FDH); (* fscale *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(reg2);
drop;
drop
1771,187 → 1806,163
|IL.opPACKC:
UnOp(reg1);
pushc(param2);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0FDH); // fscale
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0FDH); (* fscale *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(reg1);
drop
|IL.opUNPK:
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0F4H); // fxtract
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte2(0DBH, 018H + reg2); // fistp dword[reg2]
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0F4H); (* fxtract *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *)
drop;
drop
|IL.opPUSHF:
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H) // fstp qword[esp]
OutByte3(0DDH, 01CH, 024H) (* fstp qword[esp] *)
|IL.opLOADF:
UnOp(reg1);
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
drop
|IL.opCONSTF:
float := cmd.float;
IF float = 0.0 THEN
OutByte2(0D9H, 0EEH) // fldz
OutByte2(0D9H, 0EEH) (* fldz *)
ELSIF float = 1.0 THEN
OutByte2(0D9H, 0E8H) // fld1
OutByte2(0D9H, 0E8H) (* fld1 *)
ELSIF float = -1.0 THEN
OutByte2(0D9H, 0E8H); // fld1
OutByte2(0D9H, 0E0H) // fchs
OutByte2(0D9H, 0E8H); (* fld1 *)
OutByte2(0D9H, 0E0H) (* fchs *)
ELSE
n := UTILS.splitf(float, a, b);
pushc(b);
pushc(a);
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8)
END
|IL.opSAVEF:
|IL.opSAVEF, IL.opSAVEFI:
UnOp(reg1);
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
drop
|IL.opADDF, IL.opADDFI:
OutByte2(0DEH, 0C1H) // faddp st1, st
OutByte2(0DEH, 0C1H) (* faddp st1, st *)
|IL.opSUBF:
OutByte2(0DEH, 0E9H) // fsubp st1, st
OutByte2(0DEH, 0E9H) (* fsubp st1, st *)
|IL.opSUBFI:
OutByte2(0DEH, 0E1H) // fsubrp st1, st
OutByte2(0DEH, 0E1H) (* fsubrp st1, st *)
|IL.opMULF:
OutByte2(0DEH, 0C9H) // fmulp st1, st
OutByte2(0DEH, 0C9H) (* fmulp st1, st *)
|IL.opDIVF:
OutByte2(0DEH, 0F9H) // fdivp st1, st
OutByte2(0DEH, 0F9H) (* fdivp st1, st *)
|IL.opDIVFI:
OutByte2(0DEH, 0F1H) // fdivrp st1, st
OutByte2(0DEH, 0F1H) (* fdivrp st1, st *)
|IL.opUMINF:
OutByte2(0D9H, 0E0H) // fchs
OutByte2(0D9H, 0E0H) (* fchs *)
|IL.opFABS:
OutByte2(0D9H, 0E1H) // fabs
OutByte2(0D9H, 0E1H) (* fabs *)
|IL.opFLT:
UnOp(reg1);
push(reg1);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
pop(reg1);
drop
|IL.opFLOOR:
subrc(esp, 8);
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); // fstcw word[esp+4]
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); // fstcw word[esp+6]
OutByte2(066H, 081H); OutByte3(064H, 024H, 004H); OutWord(0F3FFH); // and word[esp+4], 1111001111111111b
OutByte2(066H, 081H); OutByte3(04CH, 024H, 004H); OutWord(00400H); // or word[esp+4], 0000010000000000b
OutByte2(0D9H, 06CH); OutByte2(024H, 004H); // fldcw word[esp+4]
OutByte2(0D9H, 0FCH); // frndint
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); (* fstcw word[esp+4] *)
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); (* fstcw word[esp+6] *)
OutByte2(066H, 081H); OutByte3(064H, 024H, 004H); OutWord(0F3FFH); (* and word[esp+4], 1111001111111111b *)
OutByte2(066H, 081H); OutByte3(04CH, 024H, 004H); OutWord(00400H); (* or word[esp+4], 0000010000000000b *)
OutByte2(0D9H, 06CH); OutByte2(024H, 004H); (* fldcw word[esp+4] *)
OutByte2(0D9H, 0FCH); (* frndint *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(GetAnyReg());
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); // fldcw word[esp+2]
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); (* fldcw word[esp+2] *)
addrc(esp, 4)
|IL.opEQF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(sete, al)
// L:
(* L: *)
|IL.opNEF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setne, al)
// L:
(* L: *)
|IL.opLTF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00EH); // jp L
fcmp;
OutByte2(07AH, 00EH); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
test(eax);
setcc(sete, al);
andrc(eax, 1)
// L:
(* L: *)
|IL.opGTF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00FH); // jp L
fcmp;
OutByte2(07AH, 00FH); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
cmprc(eax, 1);
setcc(sete, al);
andrc(eax, 1)
// L:
(* L: *)
|IL.opLEF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setnc, al)
// L:
(* L: *)
|IL.opGEF:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 010H); // jp L
fcmp;
OutByte2(07AH, 010H); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
OutByte2(000H, 0E0H); // add al,ah
OutByte2(03CH, 001H); // cmp al,1
OutByte2(000H, 0E0H); (* add al, ah *)
OutByte2(03CH, 001H); (* cmp al, 1 *)
setcc(sete, al);
andrc(eax, 1)
// L:
(* L: *)
|IL.opINF:
pushc(7FF00000H);
pushc(0);
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8)
|IL.opLADR_UNPK:
n := param2 * 4;
reg1 := GetAnyReg();
OutByte2(8DH, 45H + reg1 * 8 + long(n)); // lea reg1, dword[ebp + n]
OutByte2(8DH, 45H + reg1 * 8 + long(n)); (* lea reg1, dword[ebp + n] *)
OutIntByte(n);
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0F4H); // fxtract
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte2(0DBH, 018H + reg2); // fistp dword[reg2]
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0F4H); (* fxtract *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *)
drop;
drop
1962,14 → 1973,12
push(reg1);
drop
ELSE
OutByte(068H); // push _data + stroffs + param2
OutByte(068H); (* push _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2)
END
|IL.opVADR_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
|IL.opVADR_PARAM, IL.opLLOAD32_PARAM:
pushm(ebp, param2 * 4)
|IL.opCONST_PARAM:
pushc(param2)
1978,21 → 1987,16
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICBSS, param2);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
pushm(reg1, 0);
drop
ELSE
OutByte2(0FFH, 035H); // push dword[_bss + param2]
OutByte2(0FFH, 035H); (* push dword[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD32_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
|IL.opLOAD32_PARAM:
UnOp(reg1);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
pushm(reg1, 0);
drop
|IL.opGADR_SAVEC:
1999,11 → 2003,11
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICBSS, param1);
OutByte2(0C7H, reg1); // mov dword[reg1], param2
OutByte2(0C7H, reg1); (* mov dword[reg1], param2 *)
OutInt(param2);
drop
ELSE
OutByte2(0C7H, 05H); // mov dword[_bss + param1], param2
OutByte2(0C7H, 05H); (* mov dword[_bss + param1], param2 *)
Reloc(BIN.RBSS, param1);
OutInt(param2)
END
2010,24 → 2014,22
|IL.opLADR_SAVEC:
n := param1 * 4;
OutByte2(0C7H, 45H + long(n)); // mov dword[ebp + n], param2
OutByte2(0C7H, 45H + long(n)); (* mov dword[ebp + n], param2 *)
OutIntByte(n);
OutInt(param2)
|IL.opLADR_SAVE:
n := param2 * 4;
UnOp(reg1);
OutByte2(89H, 45H + reg1 * 8 + long(n)); // mov dword[ebp + n], reg1
OutIntByte(n);
movmr(ebp, param2 * 4, reg1);
drop
|IL.opLADR_INCC:
n := param1 * 4;
IF ABS(param2) = 1 THEN
OutByte2(0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); // inc/dec dword[ebp + n]
OutByte2(0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec dword[ebp + n] *)
OutIntByte(n)
ELSE
OutByte2(81H + short(param2), 45H + long(n)); // add dword[ebp + n], param2
OutByte2(81H + short(param2), 45H + long(n)); (* add dword[ebp + n], param2 *)
OutIntByte(n);
OutIntByte(param2)
END
2035,10 → 2037,10
|IL.opLADR_INCCB, IL.opLADR_DECCB:
n := param1 * 4;
IF param2 = 1 THEN
OutByte2(0FEH, 45H + 8 * ORD(opcode = IL.opLADR_DECCB) + long(n)); // inc/dec byte[ebp + n]
OutByte2(0FEH, 45H + 8 * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* inc/dec byte[ebp + n] *)
OutIntByte(n)
ELSE
OutByte2(80H, 45H + 28H * ORD(opcode = IL.opLADR_DECCB) + long(n)); // add/sub byte[ebp + n], param2
OutByte2(80H, 45H + 28H * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* add/sub byte[ebp + n], param2 *)
OutIntByte(n);
OutByte(param2 MOD 256)
END
2046,7 → 2048,7
|IL.opLADR_INC, IL.opLADR_DEC:
n := param2 * 4;
UnOp(reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + reg1 * 8); // add/sub dword[ebp + n], reg1
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + reg1 * 8); (* add/sub dword[ebp + n], reg1 *)
OutIntByte(n);
drop
2053,7 → 2055,7
|IL.opLADR_INCB, IL.opLADR_DECB:
n := param2 * 4;
UnOp(reg1);
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + reg1 * 8); // add/sub byte[ebp + n], reg1
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + reg1 * 8); (* add/sub byte[ebp + n], reg1 *)
OutIntByte(n);
drop
2063,7 → 2065,7
cmprc(reg1, 32);
label := NewLabel();
jcc(jnb, label);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + reg1 * 8); // bts(r) dword[ebp + n], reg1
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + reg1 * 8); (* bts(r) dword[ebp + n], reg1 *)
OutIntByte(n);
SetLabel(label);
drop
2070,7 → 2072,7
|IL.opLADR_INCLC, IL.opLADR_EXCLC:
n := param1 * 4;
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC)); // bts(r) dword[ebp + n], param2
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC)); (* bts(r) dword[ebp + n], param2 *)
OutIntByte(n);
OutByte(param2)
2096,28 → 2098,28
entry := NewLabel();
SetLabel(entry);
IF target = mConst.Target_iDLL THEN
IF target = TARGETS.Win32DLL THEN
push(ebp);
mov(ebp, esp);
OutByte3(0FFH, 75H, 16); // push dword[ebp+16]
OutByte3(0FFH, 75H, 12); // push dword[ebp+12]
OutByte3(0FFH, 75H, 8); // push dword[ebp+8]
pushm(ebp, 16);
pushm(ebp, 12);
pushm(ebp, 8);
CallRTL(pic, IL._dllentry);
test(eax);
jcc(je, dllret)
ELSIF target = mConst.Target_iObject THEN
ELSIF target = TARGETS.KolibriOSDLL THEN
SetLabel(dllinit)
END;
IF target = mConst.Target_iKolibri THEN
IF target = TARGETS.KolibriOS THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.IMPTAB, 0);
push(reg1); // push IMPORT
push(reg1); (* push IMPORT *)
drop
ELSIF target = mConst.Target_iObject THEN
OutByte(68H); // push IMPORT
ELSIF target = TARGETS.KolibriOSDLL THEN
OutByte(68H); (* push IMPORT *)
Reloc(BIN.IMPTAB, 0)
ELSIF target = mConst.Target_iELF32 THEN
ELSIF target = TARGETS.Linux32 THEN
push(esp)
ELSE
pushc(0)
2126,10 → 2128,10
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICCODE, entry);
push(reg1); // push CODE
push(reg1); (* push CODE *)
drop
ELSE
OutByte(68H); // push CODE
OutByte(68H); (* push CODE *)
Reloc(BIN.RCODE, entry)
END;
2136,10 → 2138,10
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, 0);
push(reg1); // push _data
push(reg1); (* push _data *)
drop
ELSE
OutByte(68H); // push _data
OutByte(68H); (* push _data *)
Reloc(BIN.RDATA, 0)
END;
2150,16 → 2152,16
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount);
push(reg1); // push _data + tcount * 4 + dcount
push(reg1); (* push _data + tcount * 4 + dcount *)
drop
ELSE
OutByte(68H); // push _data
OutByte(68H); (* push _data *)
Reloc(BIN.RDATA, tcount * 4 + dcount)
END;
CallRTL(pic, IL._init);
IF target = mConst.Target_iELF32 THEN
IF target = TARGETS.Linux32 THEN
L := NewLabel();
pushc(0);
push(esp);
2207,22 → 2209,22
BEGIN
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iKolibri, mConst.Target_iELF32} THEN
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.KolibriOS, TARGETS.Linux32} THEN
pushc(0);
CallRTL(pic, IL._exit);
ELSIF target = mConst.Target_iDLL THEN
ELSIF target = TARGETS.Win32DLL THEN
SetLabel(dllret);
movrc(eax, 1);
OutByte(0C9H); // leave
OutByte3(0C2H, 0CH, 0) // ret 12
ELSIF target = mConst.Target_iObject THEN
OutByte(0C9H); (* leave *)
OutByte3(0C2H, 0CH, 0) (* ret 12 *)
ELSIF target = TARGETS.KolibriOSDLL THEN
movrc(eax, 1);
OutByte(0C3H) // ret
ELSIF target = mConst.Target_iELFSO32 THEN
OutByte(0C3H); // ret
ret
ELSIF target = TARGETS.Linux32SO THEN
ret;
SetLabel(sofinit);
CallRTL(pic, IL._sofinit);
OutByte(0C3H) // ret
ret
END;
fixup;
2244,7 → 2246,7
BIN.PutDataStr(program, ext);
BIN.PutData(program, 0);
IF target = mConst.Target_iObject THEN
IF target = TARGETS.KolibriOSDLL THEN
BIN.Export(program, "lib_init", dllinit);
END;
2280,11 → 2282,11
dllret := NewLabel();
sofinit := NewLabel();
IF target = mConst.Target_iObject THEN
IF target = TARGETS.KolibriOSDLL THEN
opt.pic := FALSE
END;
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL, mConst.Target_iELF32, mConst.Target_iELFSO32} THEN
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32} THEN
opt.pic := TRUE
END;
2296,14 → 2298,14
BIN.fixup(program);
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
PE32.write(program, outname, target = mConst.Target_iConsole, target = mConst.Target_iDLL, FALSE)
ELSIF target = mConst.Target_iKolibri THEN
IF TARGETS.OS = TARGETS.osWIN32 THEN
PE32.write(program, outname, target = TARGETS.Win32C, target = TARGETS.Win32DLL, FALSE)
ELSIF target = TARGETS.KolibriOS THEN
KOS.write(program, outname)
ELSIF target = mConst.Target_iObject THEN
ELSIF target = TARGETS.KolibriOSDLL THEN
MSCOFF.write(program, outname, opt.version)
ELSIF target IN {mConst.Target_iELF32, mConst.Target_iELFSO32} THEN
ELF.write(program, outname, sofinit, target = mConst.Target_iELFSO32, FALSE)
ELSIF TARGETS.OS = TARGETS.osLINUX32 THEN
ELF.write(program, outname, sofinit, target = TARGETS.Linux32SO, FALSE)
END
END CodeGen;