KolibriOS/kolibrios
15
21
Fork 36
Code Issues 129 Pull Requests 31 Actions 1 Projects 1 Releases Wiki Activity

Compare commits

base: KolibriOS:main
Branches Tags
KolibriOS:main KolibriOS:reshare-tweak KolibriOS:rewrite-piano KolibriOS:add-license-file-header-to-guide KolibriOS:blocks-add-models KolibriOS:shell-improve-cpuid KolibriOS:rewrite_ide_drv KolibriOS:refactor/links KolibriOS:add_usbother KolibriOS:webview-3.91 KolibriOS:qrcodegen KolibriOS:ci/update KolibriOS:floppybird-window-fix KolibriOS:laser-tank-fix-win-height KolibriOS:improvement/commit-and-branch-styles KolibriOS:docs/libs
KolibriOS:0.7.7.0 KolibriOS:0.7.5.0 KolibriOS:0.7.0.0 KolibriOS:0.6.5.0 KolibriOS:0.6.3.0 KolibriOS:0.6.0.0 KolibriOS:0.5.3.0 KolibriOS:0.5.2.1
..
compare: KolibriOS:shell-improve-cpuid
Branches Tags
KolibriOS:reshare-tweak KolibriOS:main KolibriOS:rewrite-piano KolibriOS:add-license-file-header-to-guide KolibriOS:blocks-add-models KolibriOS:shell-improve-cpuid KolibriOS:rewrite_ide_drv KolibriOS:refactor/links KolibriOS:add_usbother KolibriOS:webview-3.91 KolibriOS:qrcodegen KolibriOS:ci/update KolibriOS:floppybird-window-fix KolibriOS:laser-tank-fix-win-height KolibriOS:improvement/commit-and-branch-styles KolibriOS:docs/libs
KolibriOS:0.7.7.0 KolibriOS:0.7.5.0 KolibriOS:0.7.0.0 KolibriOS:0.6.5.0 KolibriOS:0.6.3.0 KolibriOS:0.6.0.0 KolibriOS:0.5.3.0 KolibriOS:0.5.2.1

1 Commits
main ... shell-impr

Author SHA1 Message Date
rgimad
bb075099b6 Shell: improve cpuid - view full brand string
All checks were successful
Build system / Check kernel codestyle (pull_request) Successful in 1m21s
Details
Build system / Build (pull_request) Successful in 16m21s
Details
2025-12-31 17:09:17 +03:00
122 changed files with 36780 additions and 1655 deletions
Expand all files Collapse all files

1
.gitea/workflows/build.yaml
View File

@@ -29,7 +29,6 @@ jobs:
- name: Checkout
uses: actions/checkout@v4
with:
submodules: true
fetch-depth: 0
- name: Get describe

1
.gitignore vendored
View File

@@ -9,3 +9,4 @@ ehthumbs_vista.db
._*
programs/cmm/cmm.code-workspace
programs/cmm/menu/.gitignore
.vscode

3
.gitmodules vendored
View File

@@ -1,3 +0,0 @@
[submodule "programs/develop/oberon07"]
path = programs/develop/oberon07
url = https://github.com/AntKrotov/oberon-07-compiler.git

28
data/Tupfile.lua
View File

@@ -25,6 +25,7 @@ img_files = {
{"MACROS.INC", SRC_PROGS .. "/macros.inc"},
-- {"CONFIG.INC", SRC_PROGS .. "/config.inc"},
{"STRUCT.INC", SRC_PROGS .. "/struct.inc"},
{"FB2READ", "common/fb2read"},
{"ALLGAMES", "common/allgames"},
{"HOME.PNG", "common/wallpapers/T_Home.png"},
{"ICONS32.PNG", "common/icons32.png"},
@@ -175,15 +176,10 @@ extra_files = {
{"kolibrios/develop/c--/manual_c--.htm", SRC_PROGS .. "/cmm/c--/manual_c--.htm"},
{"kolibrios/develop/fpc/", "common/develop/fpc/*"},
{"kolibrios/develop/fpc/examples/", "../programs/develop/fp/examples/src/*"},
{"kolibrios/develop/oberon07/compiler.kex", SRC_PROGS .. "/develop/oberon07/Compiler.kex"},
{"kolibrios/develop/oberon07/LICENSE", SRC_PROGS .. "/develop/oberon07/LICENSE"},
{"kolibrios/develop/oberon07/doc/CC.txt", SRC_PROGS .. "/develop/oberon07/doc/CC.txt"},
{"kolibrios/develop/oberon07/doc/KOSLib.txt", SRC_PROGS .. "/develop/oberon07/doc/KOSLib.txt"},
{"kolibrios/develop/oberon07/doc/x86.txt", SRC_PROGS .. "/develop/oberon07/doc/x86.txt"},
{"kolibrios/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf", SRC_PROGS .. "/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf"},
{"kolibrios/develop/oberon07/lib/KolibriOS/", SRC_PROGS .. "/develop/oberon07/lib/KolibriOS/*"},
{"kolibrios/develop/oberon07/lib/Math/", SRC_PROGS .. "/develop/oberon07/lib/Math/*"},
{"kolibrios/develop/oberon07/samples/", SRC_PROGS .. "/develop/oberon07/samples/KolibriOS/*"},
{"kolibrios/develop/oberon07/", "../programs/develop/oberon07/*"},
{"kolibrios/develop/oberon07/doc/", "../programs/develop/oberon07/doc/*"},
{"kolibrios/develop/oberon07/lib/KolibriOS/", "../programs/develop/oberon07/lib/KolibriOS/*"},
{"kolibrios/develop/oberon07/samples/", SRC_PROGS .. "/develop/oberon07/samples/*"},
{"kolibrios/develop/tcc/lib/", SRC_PROGS .. "/develop/ktcc/trunk/bin/lib/*"},
{"kolibrios/develop/tcc/include/", SRC_PROGS .. "/develop/ktcc/trunk/libc.obj/include/*"},
{"kolibrios/develop/tcc/include/clayer/", SRC_PROGS .. "/develop/ktcc/trunk/libc.obj/include/clayer/*"},
@@ -471,6 +467,7 @@ tup.append_table(img_files, {
{"DEMOS/ZEROLINE", VAR_PROGS .. "/demos/zeroline/trunk/zeroline"},
{"DEVELOP/BOARD", VAR_PROGS .. "/system/board/trunk/board"},
{"DEVELOP/DBGBOARD", VAR_PROGS .. "/system/dbgboard/dbgboard"},
{"DEVELOP/CEDIT", SRC_PROGS .. "/develop/cedit/CEDIT"},
{"DEVELOP/CHARSETS", VAR_PROGS .. "/develop/charsets/charsets"},
{"DEVELOP/COBJ", VAR_PROGS .. "/develop/cObj/trunk/cObj"},
{"DEVELOP/ENTROPYV", VAR_PROGS .. "/develop/entropyview/entropyview"},
@@ -532,7 +529,6 @@ tup.append_table(img_files, {
{"MEDIA/MP3INFO", VAR_PROGS .. "/media/mp3info/mp3info"},
{"MEDIA/PALITRA", VAR_PROGS .. "/media/palitra/trunk/palitra"},
{"MEDIA/PIANO", VAR_PROGS .. "/media/piano/piano"},
{"MEDIA/PIANO.MAP", VAR_PROGS .. "/media/piano/piano.map"},
{"MEDIA/STARTMUS", VAR_PROGS .. "/media/startmus/trunk/STARTMUS"},
{"NETWORK/PING", VAR_PROGS .. "/network/ping/ping"},
{"NETWORK/NETCFG", VAR_PROGS .. "/network/netcfg/netcfg"},
@@ -726,7 +722,6 @@ tup.append_table(img_files, {
{"SHELL", VAR_PROGS .. "/system/shell/shell"},
{"GAMES/DINO", VAR_PROGS .. "/games/dino/dino"},
{"GAMES/FLPYBIRD", VAR_PROGS .. "/games/flpybird/flpybird"},
{"LIB/LIBC.OBJ", VAR_PROGS .. "/develop/ktcc/trunk/libc.obj/source/libc.obj"},
})
tup.append_table(extra_files, {
{"kolibrios/utils/thashview", VAR_PROGS .. "/other/TinyHashView/thashview"},
@@ -735,6 +730,7 @@ tup.append_table(extra_files, {
{"kolibrios/develop/TinyBasic/TinyBasic", VAR_PROGS .. "/develop/tinybasic-1.0.4/tinybasic"},
{"kolibrios/develop/TinyBasic/bas/", SRC_PROGS .. "/develop/tinybasic-1.0.4/bas/*"},
{"kolibrios/develop/TinyBasic/TinyBasic.man", SRC_PROGS .. "/develop/tinybasic-1.0.4/doc/tinybasic.man"},
-- {"kolibrios/utils/teatool", VAR_PROGS .. "/other/TEAtool/teatool"},
{"kolibrios/utils/passwordgen", VAR_PROGS .. "/other/PasswordGen/passwordgen"},
{"kolibrios/utils/kruler", VAR_PROGS .. "/other/kruler/kruler"},
{"kolibrios/media/qr_tool", SRC_PROGS .. "/media/qr_tool/qr_tool"},
@@ -744,20 +740,14 @@ tup.append_table(extra_files, {
})
end -- tup.getconfig('NO_TCC') ~= 'full'
-- Programs that require oberon07 compiler.
if tup.getconfig('NO_OB07') ~= 'full' then
tup.append_table(img_files, {
{"DEVELOP/CEDIT", VAR_PROGS .. "/develop/cedit/cedit"},
{"FB2READ", VAR_PROGS .. "/other/fb2reader/fb2read"},
})
end -- tup.getconfig('NO_OB07') ~= 'full'
-- Programs that require GCC to compile.
if tup.getconfig('NO_GCC') ~= 'full' then
tup.append_table(img_files, {
{"GAMES/REVERSI", VAR_PROGS .. "/games/reversi/reversi"},
{"LIB/BASE64.OBJ", VAR_PROGS .. "/develop/libraries/base64/base64.obj"},
{"LIB/LIBC.OBJ", VAR_PROGS .. "/develop/ktcc/trunk/libc.obj/source/libc.obj"},
{"LIB/ICONV.OBJ", VAR_PROGS .. "/develop/libraries/iconv/iconv.obj"},
-- {"LIB/MTAR.OBJ", VAR_PROGS .. "/develop/libraries/microtar/mtar.obj"},
})
tup.append_table(extra_files, {
-- {"kolibrios/3D/cubeline", VAR_PROGS .. "/demos/cubeline/trunk/cubeline"},

BIN
data/common/fb2read Normal file
View File

Binary file not shown.

187
kernel/trunk/docs/sysfuncr.txt
View File

@@ -1985,7 +1985,7 @@ path db 'HD0/1',0
подфункция 2 функции 15.
---------------------- Константы для регистров: ----------------------
eax - SF_BACKGROUND_GET (39)
eax - SF_BACKGROUND_GET_RECT (39)
======================================================================
== Функция 39, подфункция 3 - получить прямоугольную область фона =
======================================================================
@@ -2169,7 +2169,7 @@ path db 'HD0/1',0
* ebx = 2 - номер подфункции
* ecx = указатель на таблицу цветов
* edx = размер таблицы цветов
(до 192 байт; 40 байт для базовой структуры)
(должен быть 40 байт для будущей совместимости)
Формат таблицы цветов указан в описании подфункции 3.
Возвращаемое значение:
* функция не возвращает значения
@@ -2196,33 +2196,32 @@ path db 'HD0/1',0
* ecx = указатель на буфер размером edx байт,
куда будет записана таблица
* edx = размер таблицы цветов
(до 192 байт; 40 байт для базовой структуры)
(должен быть 40 байт для будущей совместимости)
Возвращаемое значение:
* функция не возвращает значения
Формат таблицы цветов: каждый элемент -
dword-значение цвета 0x00RRGGBB
* +0: dword: frame
* +4: dword: grab
* +0: dword: none - зарезервировано
* +4: dword: none - зарезервировано
* +8: dword: work_dark - темный цвет рабочей области для придания
объемна элементам интерфейса
* +12 = +0xC: dword: work_light - светлый цвет рабочей области для
придания объемна элементам интерфейса
* +16 = +0x10: dword: grab_text - цвет текста на заголовке
* +20 = +0x14: dword: work - цвет рабочей области
* +24 = +0x18: dword: work_button - цвет кнопки в рабочей области
* +28 = +0x1C: dword: work_button_text - цвет текста на кнопке
* +24 = +0x18: dword: button - цвет кнопки в рабочей области
* +28 = +0x1C: dword: button_text - цвет текста на кнопке
в рабочей области
* +32 = +0x20: dword: work_text - цвет текста в рабочей области
* +36 = +0x24: dword: graph - цвет графики в рабочей области
Замечания:
* Структура таблицы цветов описана в стандартном включаемом файле
macros.inc под названием system_colors; например, можно писать:
sc system_colors ; объявление переменной
... ; вызов описываемой функции с ecx = sc
mov ecx, [sc.work_button_text] ; устанавливаем цвет текста
; на кнопке в рабочей области
* Таблица может быть больше (до 192 байт); дополнительные поля
копируются как есть и интерпретируются скинами.
sc system_colors ; объявление переменной
... ; где-то надо вызвать
; описываемую функцию с ecx=sc
mov ecx, [sc.button_text] ; читаем цвет текста
; на кнопке в рабочей области
* Использование/неиспользование этих цветов - дело исключительно
самой программы. Для использования нужно просто при вызове функций
рисования указывать цвет, взятый из этой таблицы.
@@ -2492,7 +2491,6 @@ dword-значение цвета 0x00RRGGBB
---------------------- Константы для регистров: ----------------------
eax - SF_SET_WINDOW_SHAPE (50)
======================================================================
===================== Функция 51, подфункция 1 =======================
========================== Создать поток =============================
@@ -2507,19 +2505,16 @@ dword-значение цвета 0x00RRGGBB
* иначе eax = TID - идентификатор потока
---------------------- Константы для регистров: ----------------------
eax - SF_CREATE_THREAD (51) /
ebx - SSF_CREATE_THREAD (1), SSF_GET_CURR_THREAD_SLOT (2),
SSF_GET_THREAD_PRIORITY (3), SSF_SET_THREAD_PRIORITY (4)
eax - SF_CREATE_THREAD (51)
======================================================================
===================== Функция 51, подфункция 2 =======================
============= Получить номер слота текущего потока ===================
=================== Получить номер слота потока ======================
======================================================================
Параметры:
* eax = 51 - номер функции
* ebx = 2 - номер подфункции
Возвращаемое значение:
* eax = номер слота текущего потока
* eax = номер слота потока
======================================================================
===================== Функция 51, подфункция 3 =======================
@@ -2760,10 +2755,10 @@ IPC применяется для посылок сообщений от одн
Программе доступны данные графического экрана (область памяти, которая
собственно и отображает содержимое экрана) напрямую без вызовов
системных функций через селектор gs:
mov eax, [gs:0]
mov eax, [gs:0]
поместит в eax первый dword буфера, содержащий информацию о цвете
левой верхней точки (и, возможно, цвета нескольких следующих).
mov [gs:0], eax
mov [gs:0], eax
при работе в режимах VESA c LFB
установит цвет левой верхней точки
(и возможно, цвета нескольких следующих).
@@ -3361,7 +3356,6 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
---------------------- Константы для регистров: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_MEM_FREE (13)
======================================================================
====================== Функция 68, подфункция 14 =====================
====== Ожидать получения сигнала от других приложений/драйверов. =====
@@ -3374,16 +3368,12 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* eax разрушается
* буфер, на который указывает ecx, содержит следующую информацию:
* +0: dword: идентификатор последующих данных сигнала
* +4: 5 dword: данные принятого сигнала, формат которых
* +4: данные принятого сигнала (20 байт), формат которых
определяется первым dword-ом
Замечания:
* Бесконечно ожидает любое событие в очереди событий текущего потока.
* Сбрасывает байт приоритета в буфере.
---------------------- Константы для регистров: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_WAIT_SIGNAL (14)
======================================================================
=========== Функция 68, подфункция 16 - загрузить драйвер. ===========
======================================================================
@@ -3392,20 +3382,19 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* ebx = 16 - номер подфункции
* ecx = указатель на ASCIIZ-строку с именем драйвера
Возвращаемое значение:
* eax = хэндл драйвера
0 при ошибке
* eax = 0 - неудача
* иначе eax = хэндл драйвера
Замечания:
* Если драйвер ещё не загружен, он загружается;
если драйвер уже загружен, ничего не меняется.
* Имя драйвера чувствительно к регистру символов.
Максимальная длина имени - 16 символов, включая завершающий
нулевой символ, остальные символы игнорируются.
* Драйвер с именем "ABC" загружается из файла /sys/drivers/ABC.sys.
* Драйвер с именем ABC загружается из файла /sys/drivers/ABC.sys.
---------------------- Константы для регистров: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_LOAD_DRIVER (16)
======================================================================
========== Функция 68, подфункция 17 - управление драйвером. =========
======================================================================
@@ -3416,21 +3405,19 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* +0: dword: хэндл драйвера
* +4: dword: код функции драйвера
* +8: dword: указатель на входные данные
* +12 = +0x0C: dword: размер входных данных
* +12 = +0xC: dword: размер входных данных
* +16 = +0x10: dword: указатель на выходные данные
* +20 = +0x14: dword: размер выходных данных
Возвращаемое значение:
* eax = определяется драйвером
-1 при ошибке
Замечания:
* Коды функций и структура входных/выходных данных
определяются драйвером.
* Хэндл драйвера необходимо предварительно получить подфункцией 16.
* Предварительно должен быть получен хэндл драйвера подфункцией 16.
---------------------- Константы для регистров: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_CONTROL_DRIVER (17)
======================================================================
== Функция 68, подфункция 18 - загрузить DLL с указанием кодировки. ==
======================================================================
@@ -3495,7 +3482,7 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
Параметры:
* eax = 68 - номер функции
* ebx = 21 - номер подфункции
* ecx = указатель на ASCIIZ-строку с путем к файлу драйвера
* ecx = указатель на ASCIIZ-строку с именем драйвера
* edx = указатель на командную строку
Возвращаемое значение:
* eax = 0 - неудача
@@ -3687,40 +3674,22 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* функция загружает и, при необходимости, распаковывает файл (kunpack)
======================================================================
======= Функция 68, подфункция 29 - выделить кольцевую память. =======
======== Функция 68, подфункция 29 - allocate ring memory. =========
======================================================================
Параметры:
* eax = 68 - номер функции
* ebx = 29 - номер подфункции
* ecx = требуемый размер в байтах
Возвращаемое значение:
* eax = 0 - неудача
* eax = указатель на выделенную кольцевую память
Замечания:
* Запрошенный размер должен быть кратен размеру страницы (4 Кб).
* Память выделяется так, что доступ за пределами буфера приводит
к чтению/записи в его начало.
Parameters:
* eax = 68 - function number
* ebx = 29 - subfunction number
* ecx = required size in bytes
Returned value:
* eax = 0 - failed
* eax = pointer to the allocated ring
Remarks:
* The requested size must be an exact multiple of pagesize (4 Kb)
* The function allocates memory in such a way that you can read and
write beyond the size of the allocated memory and will reach the
beginning of the buffer again.
======================================================================
=========== Функция 68, подфункция 30 - выгрузить драйвер. ===========
======================================================================
Параметры:
* eax = 68 - номер функции
* ebx = 30 - номер подфункции
* ecx = указатель на структуру SRV (хэндл драйвера)
* edx = указатель на командную строку (может быть 0)
Возвращаемое значение:
* eax = -1 - неверные параметры
* eax = -2 - ошибка при освобождении памяти драйвера
* иначе eax = указатель на следующую структуру SRV (бывший SRV.fd)
Замечания:
* Перед выгрузкой вызывается точка входа драйвера с DRV_EXIT.
---------------------- Константы для регистров: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_UNLOAD_DRIVER (30)
======================================================================
======== Функция 68, подфункция 31 - получить данные драйвера. =======
======================================================================
@@ -3819,7 +3788,7 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
и при поступлении нового сообщения система будет ждать.
Для синхронизации обрамляйте всю работу с буфером операциями
блокировки/разблокировки
neg [bufsize]
neg [bufsize]
* Данные в буфере трактуются как массив элементов переменной длины -
сообщений. Формат сообщения указан в общем описании.
@@ -4558,7 +4527,7 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
---------------------- Константы для регистров: ----------------------
eax - SF_NETWORK_GET (74)
bl - SSF_DEVICE_COUNT (-1)
bl - SSF_DEVICE_COUNT (255)
======================================================================
==== Функция 74, подфункция 0, Получить тип сетевого устройства. =====
======================================================================
@@ -4754,11 +4723,10 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
Возвращаемое значение:
* eax = число пакетов, полученных с ошибкой с момента запуска
устройства, -1 при ошибке
---------------------- Константы для регистров: ----------------------
eax - SF_NETWORK_GET (74)
bl - SSF_RX_PACKET_ERROR_COUNT (14)
======================================================================
== Функция 74.15, Получить число пакетов отброшенных при получении. ==
======================================================================
@@ -4772,7 +4740,7 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
---------------------- Константы для регистров: ----------------------
eax - SF_NETWORK_GET (74)
bl - SSF_RX_PACKET_DROP_COUNT (15)
bl - SSF_RX_PACKET_DROP_COUNT (12)
======================================================================
=== Функция 74.16, Получить число пакетов утерянных при получении. ===
======================================================================
@@ -5022,39 +4990,13 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
---------------------- Константы для регистров: ----------------------
eax - SF_NETWORK_PROTOCOL (76)
ebx - SSF_ETHERNET_READ_MAC (0x0000)
ebx - SSF_IP4_PACKETS_SENT (0x10000)
ebx - SSF_IP4_PACKETS_RECEIVED (0x10001)
ebx - SSF_IP4_READ_IP (0x10002)
ebx - SSF_IP4_WRITE_IP (0x10003)
ebx - SSF_IP4_READ_DNS (0x10004)
ebx - SSF_IP4_WRITE_DNS (0x10005)
ebx - SSF_IP4_READ_SUBNET (0x10006)
ebx - SSF_IP4_WRITE_SUBNET (0x10007)
ebx - SSF_IP4_READ_GATEWAY (0x10008)
ebx - SSF_IP4_WRITE_GATEWAY (0x10009)
ebx - SSF_ICMP_PACKETS_SENT (0x20000)
ebx - SSF_ICMP_PACKETS_RECEIVED (0x20001)
ebx - SSF_ICMP_ECHO_REPLY (0x20003)
ebx - SSF_UDP_PACKETS_SENT (0x30000)
ebx - SSF_UDP_PACKETS_RECEIVED (0x30001)
ebx - SSF_TCP_PACKETS_SENT (0x40000)
ebx - SSF_TCP_PACKETS_RECEIVED (0x40001)
ebx - SSF_ARP_PACKETS_SENT (0x50000)
ebx - SSF_ARP_PACKETS_RECEIVED (0x50001)
ebx - SSF_ARP_GET_ENTRY_COUNT (0x50002)
ebx - SSF_ARP_READ_ENTRY (0x50003)
ebx - SSF_ARP_ADD_STATIC_ENTRY (0x50004)
ebx - SSF_ARP_DEL_ENTRY (0x50005)
ebx - SSF_ARP_SEND_ANNOUNCE (0x50006)
ebx - SSF_ARP_CONFLICTS_COUNT (0x50007)
======================================================================
============= Функция 77, подфункция 0, Создать фьютекс. =============
======================================================================
Параметры:
* eax = 77 - номер функции
* ebx = 0 - номер подфункции
* ecx = контрольное значение фьютекса (dword)
* ecx = указатель на контрольное значение фьютекса (dword)
Возвращаемое значение:
* eax = дескриптор фьютекса, 0 при ошибке
@@ -5083,12 +5025,11 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* eax = 77 - номер функции
* ebx = 2 - номер подфункции
* ecx = дескриптор фьютекса
* edx = контрольное значение фьютекса (dword)
* edx = контрольное значение
* esi = таймаут в сотых секунды, 0 - ждать бесконечно
Возвращаемое значение:
* eax = 0 - успешно,
-1 - таймаут,
-2 - контрольное значение фьютекса не соответствует
* eax = 0 - успешно, -1 - таймаут,
-2 - контрольное значение не соответствует
---------------------- Константы для регистров: ----------------------
eax - SF_FUTEX (77)
@@ -5108,11 +5049,7 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
eax - SF_FUTEX (77)
ebx - SSF_WAKE (3)
======================================================================
Замечания:
* Подфункции 4-7 зарезервированы и сейчас возвращают -1.
* Подфункции 8, 9 и 12 не реализованы и возвращают -EBADF (-9).
======================================================================
=========== Функция 77, подфункция 10, Прочитать из файла. ===========
======= Функция 77, подфункция 10, Прочитать из файла в буфер. =======
======================================================================
Параметры:
* eax = 77 - номер функции
@@ -5122,15 +5059,10 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* esi = сколько байт прочитать
Возвращаемое значение:
* eax = количество прочитанных байт
0 при EOF
-EBADF (-9) при ошибке
Замечания:
* Поддерживаются только pipe-дескрипторы.
---------------------- Константы для регистров: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_FILE_READ (10)
ebx - ...
======================================================================
======== Функция 77, подфункция 11, Записать из буфера в файл. =======
======================================================================
@@ -5138,19 +5070,14 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* eax = 77 - номер функции
* ebx = 11 - номер подфункции
* ecx = дескриптор файла
* edx = указатель на буфер, откуда брать данные для записи
* edx = указатель на буфер, откуда брать данные для записи
* esi = сколько байт записать
Возвращаемое значение:
* eax = количество записанных байт
-EBADF (-9) при ошибке
-EPIPE (-32) если нет читателей
Замечания:
* Поддерживаются только pipe-дескрипторы.
---------------------- Константы для регистров: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_FILE_WRITE (11)
ebx - ...
======================================================================
=========== Функция 77, подфункция 13, Создать новый pipe. ===========
======================================================================
@@ -5162,20 +5089,15 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
* eax = 77 - номер функции
* ebx = 13 - номер подфункции
* ecx = адрес pipefd
* edx = флаги. Разрешен только O_CLOEXEC (0x40000).
Любые другие биты приводят к -EINVAL (-11).
* edx = флаги. На данный момент если поднят O_CLOEXEC (0x40000), то
сисфункция завершится с ошибкой. Поэтому в качестве флагов можно
передать просто 0.
Возвращаемое значение:
* eax = 0 если успех,
иначе отрицательный код ошибки:
-EINVAL (-11), -EFAULT (-14), -ENFILE (-23), -EMFILE (-24)
Примечания:
* В случае успеха pipefd[0] является дескриптором чтения, а pipefd[1]
- дескриптором записи.
* eax = 0 если успех, иначе ошибка.
---------------------- Константы для регистров: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_PIPE_CREATE (13)
ebx - ...
======================================================================
========== Функция -1 - завершить выполнение потока/процесса =========
======================================================================
@@ -5193,7 +5115,6 @@ Architecture Software Developer's Manual, Volume 3, Appendix B);
---------------------- Константы для регистров: ----------------------
eax - SF_TERMINATE_PROCESS (-1)
======================================================================
=== Функция 80 - работа с файловой системой с указанием кодировки. ===
======================================================================

252
kernel/trunk/docs/sysfuncs.txt
View File

@@ -1972,7 +1972,7 @@ Remarks:
subfunction 2 of function 15.
---------------------- Constants for registers: ----------------------
eax - SF_BACKGROUND_GET (39)
eax - SF_BACKGROUND_GET_RECT (39)
======================================================================
== Function 39, subfunction 3 - get rect from the background image. =
======================================================================
@@ -2152,7 +2152,7 @@ Parameters:
* ebx = 2 - subfunction number
* ecx = pointer to the color table
* edx = size of the color table
(up to 192 bytes; 40 bytes for the base structure)
(must be 40 bytes for future compatibility)
Format of the color table is shown in description of subfunction 3.
Returned value:
* function does not return value
@@ -2179,21 +2179,21 @@ Parameters:
* ecx = pointer to the buffer with size edx bytes,
where table will be written
* edx = size of color table
(up to 192 bytes; 40 bytes for the base structure)
(must be 40 bytes for future compatibility)
Returned value:
* function does not return value
Format of the color table:
each item is dword-value for color 0x00RRGGBB
* +0: dword: frame
* +4: dword: grab
* +0: dword: none - reserved
* +4: dword: none - reserved
* +8: dword: work_dark - dark color of working area
used to give a user 3D-like feelings about interface elements
* +12 = +0xC: dword: work_light - light color of working area
used to give a user 3D-like feelings about interface elements
* +16 = +0x10: dword: grab_text - color of text on header
* +20 = +0x14: dword: work - color of working area
* +24 = +0x18: dword: work_button - color of button in working area
* +28 = +0x1C: dword: work_button_text - color of text on button
* +24 = +0x18: dword: button - color of button in working area
* +28 = +0x1C: dword: button_text - color of text on button
in working area
* +32 = +0x20: dword: work_text - color of text in working area
* +36 = +0x24: dword: graph - color of graphics in working area
@@ -2206,8 +2206,6 @@ Remarks:
; this function with ecx=sc
mov ecx, [sc.work_button_text] ; read text color on
; button in working area
* The table may be longer (up to 192 bytes); extra fields are copied
as-is and are interpreted by skins.
* A program itself decides to use or not to use color table.
For usage program must simply at calls to drawing functions select
color taken from the table.
@@ -2480,11 +2478,11 @@ Remarks:
---------------------- Constants for registers: ----------------------
eax - SF_SET_WINDOW_SHAPE (50)
======================================================================
============= Function 51, subfunction 1 - create thread. ============
==================== Function 51 - create thread. ====================
======================================================================
Parameters:
* eax = 51 - function number
* ebx = 1 - subfunction number
* ebx = 1 - unique subfunction
* ecx = address of thread entry point (starting eip)
* edx = pointer to thread stack (starting esp)
Returned value:
@@ -2493,49 +2491,6 @@ Returned value:
---------------------- Constants for registers: ----------------------
eax - SF_CREATE_THREAD (51)
ebx - SSF_CREATE_THREAD (1), SSF_GET_CURR_THREAD_SLOT (2),
SSF_GET_THREAD_PRIORITY (3), SSF_SET_THREAD_PRIORITY (4)
======================================================================
================== Function 51, subfunction 2 ========================
================== Get current thread slot number ====================
======================================================================
Parameters:
* eax = 51 - function number
* ebx = 2 - subfunction number
Returned value:
* eax = slot number of the current thread
======================================================================
================== Function 51, subfunction 3 ========================
===================== Get thread priority ============================
======================================================================
Parameters:
* eax = 51 - function number
* ebx = 3 - subfunction number
* ecx = slot number of the thread or -1 (current thread)
Returned value:
* eax = -1 - error (invalid slot number or thread terminated)
* otherwise eax = thread priority
Remarks:
* Priority range is 0..255.
0 is the highest priority and is set by default at creation.
======================================================================
================== Function 51, subfunction 4 ========================
===================== Set thread priority ============================
======================================================================
Parameters:
* eax = 51 - function number
* ebx = 4 - subfunction number
* ecx = slot number of the thread or -1 (current thread)
* edx = new thread priority
Returned value:
* eax = -1 - error (invalid slot number or thread terminated)
* otherwise eax = previous thread priority
Remarks:
* Priority range is 0..255.
0 is the highest priority and is set by default at creation.
======================================================================
==================== Function 54, subfunction 0 ======================
============== Get the number of slots in the clipboard. =============
@@ -3334,63 +3289,61 @@ Remarks:
ebx - SSF_MEM_FREE (13)
======================================================================
===================== Function 68, subfunction 14 ====================
======= Wait for a signal from other applications/drivers. ===========
============ Wait for signal from another program/driver. ============
======================================================================
Parameters:
* eax = 68 - function number
* ebx = 14 - subfunction number
* ecx = pointer to data buffer (6 dword = 24 bytes)
* ecx = pointer to the buffer for information (24 bytes)
Returned value:
* eax is destroyed
* buffer pointed to by ecx contains the following information:
* +0: dword: EVENT.code (identifier of following data)
* +4: 5 dword: EVENT.data, format depends on EVENT.code
Remarks:
* Waits indefinitely for any event in the current thread event queue.
* The priority byte in the buffer is cleared by the kernel.
* +0: dword: identifier for following data of signal
* +4: dword: data of signal (20 bytes), format of which is defined
by the first dword
---------------------- Constants for registers: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_WAIT_SIGNAL (14)
======================================================================
=========== Function 68, subfunction 16 - load driver. ===============
============= Function 68, subfunction 16 - load driver. =============
======================================================================
Parameters:
* eax = 68 - function number
* ebx = 16 - subfunction number
* ecx = pointer to ASCIIZ-string with driver name
Returned value:
* eax = driver handle, 0 on error
* eax = 0 - failed
* otherwise eax = driver handle
Remarks:
* If the driver is not loaded yet, it is loaded;
if the driver is already loaded, nothing changes.
* If the driver was not loaded yet, it is loaded;
if the driver was loaded yet, nothing happens.
* Driver name is case-sensitive.
Maximum length of the name is 16 characters, including
terminating null character, the rest is ignored.
* Driver with name "ABC" is loaded from /sys/drivers/ABC.sys.
* Driver ABC is loaded from file /sys/drivers/ABC.sys.
---------------------- Constants for registers: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_LOAD_DRIVER (16)
======================================================================
========== Function 68, subfunction 17 - control driver. =============
============ Function 68, subfunction 17 - driver control. ===========
======================================================================
Parameters:
* eax = 68 - function number
* ebx = 17 - subfunction number
* ecx = pointer to the control structure:
* +0: dword: driver handle
* +4: dword: driver function code
* +8: dword: pointer to input data
* +12: dword: size of input data
* +16: dword: pointer to output data
* +20: dword: size of output data
* +0: dword: handle of driver
* +4: dword: code of driver function
* +8: dword: pointer to input data
* +12 = +0xC: dword: size of input data
* +16 = +0x10: dword: pointer to output data
* +20 = +0x14: dword: size of output data
Returned value:
* eax = determined by driver, -1 on error
* eax = determined by driver
Remarks:
* Function codes and the structure of input/output data
are defined by the driver.
* Driver handle can be obtained by subfunction 16.
are defined by driver.
* Previously one must obtain driver handle by subfunction 16.
---------------------- Constants for registers: ----------------------
eax - SF_SYS_MISC (68)
@@ -3458,7 +3411,7 @@ Remarks:
Parameters:
* eax = 68 - function number
* ebx = 21 - subfunction number
* ecx = pointer to ASCIIZ-string with path to driver file
* ecx = pointer to ASCIIZ-string with driver name
* edx = pointer to command line
Returned value:
* eax = 0 - failed
@@ -3663,24 +3616,9 @@ Remarks:
write beyond the size of the allocated memory and will reach the
beginning of the buffer again.
======================================================================
=========== Function 68, subfunction 30 - unload driver. ============
======================================================================
Parameters:
* eax = 68 - function number
* ebx = 30 - subfunction number
* ecx = pointer to SRV structure (driver handle)
* edx = pointer to command line (may be 0)
Returned value:
* eax = -1 - invalid parameters
* eax = -2 - error while freeing driver memory
* otherwise eax = pointer to the next SRV structure (former SRV.fd)
Remarks:
* The driver entry is called with DRV_EXIT before unloading.
---------------------- Constants for registers: ----------------------
eax - SF_SYS_MISC (68)
ebx - SSF_UNLOAD_DRIVER (30)
ebx - SSF_MEM_ALLOC_RING (29)
======================================================================
=========== Function 68, subfunction 31 - get driver data. ===========
@@ -3895,7 +3833,7 @@ Remarks:
eax - SF_DEBUG (69)
ebx - SSF_RESUME (5)
======================================================================
= Function 69, subfunction 6 - read from memory of debugged process. =
= Fucntion 69, subfunction 6 - read from memory of debugged process. =
======================================================================
Parameters:
* eax = 69 - function number
@@ -4504,17 +4442,17 @@ Returned value:
---------------------- Constants for registers: ----------------------
eax - SF_BLITTER (73)
======================================================================
= Function 74, Subfunction -1, Get number of active network devices. =
= Function 74, Subfunction 255, Get number of active network devices. =
======================================================================
Parameters:
* eax = 74 - function number
* bl = -1 - subfunction number
* bl = 255 - subfunction number
Returned value:
* eax = number of active network devices
---------------------- Constants for registers: ----------------------
eax - SF_NETWORK_GET (74)
bl - SSF_DEVICE_COUNT (-1)
bl - SSF_DEVICE_COUNT (255)
======================================================================
======== Function 74, Subfunction 0, Get network device type. ========
======================================================================
@@ -4667,7 +4605,7 @@ Parameters:
* bl = 11 - subfunction number
* bh = device number
Returned value:
* eax = Number of erroneous packets transmitted since device start, -1 on error
* eax = Number of erroneous packets received since device start, -1 on error
---------------------- Constants for registers: ----------------------
eax - SF_NETWORK_GET (74)
@@ -4723,7 +4661,7 @@ Returned value:
---------------------- Constants for registers: ----------------------
eax - SF_NETWORK_GET (74)
bl - SSF_RX_PACKET_DROP_COUNT (15)
bl - SSF_RX_PACKET_DROP_COUNT (12)
======================================================================
==== Function 74, Subfunction 16, Get RX missed packets counter. =====
======================================================================
@@ -5236,41 +5174,19 @@ Returned value:
---------------------- Constants for registers: ----------------------
eax - SF_NETWORK_PROTOCOL (76)
ebx - SSF_ETHERNET_READ_MAC (0x0000)
ebx - SSF_IP4_PACKETS_SENT (0x10000)
ebx - SSF_IP4_PACKETS_RECEIVED (0x10001)
ebx - SSF_IP4_READ_IP (0x10002)
ebx - SSF_IP4_WRITE_IP (0x10003)
ebx - SSF_IP4_READ_DNS (0x10004)
ebx - SSF_IP4_WRITE_DNS (0x10005)
ebx - SSF_IP4_READ_SUBNET (0x10006)
ebx - SSF_IP4_WRITE_SUBNET (0x10007)
ebx - SSF_IP4_READ_GATEWAY (0x10008)
ebx - SSF_IP4_WRITE_GATEWAY (0x10009)
ebx - SSF_ICMP_PACKETS_SENT (0x20000)
ebx - SSF_ICMP_PACKETS_RECEIVED (0x20001)
ebx - SSF_ICMP_ECHO_REPLY (0x20003)
ebx - SSF_UDP_PACKETS_SENT (0x30000)
ebx - SSF_UDP_PACKETS_RECEIVED (0x30001)
ebx - SSF_TCP_PACKETS_SENT (0x40000)
ebx - SSF_TCP_PACKETS_RECEIVED (0x40001)
ebx - SSF_ARP_PACKETS_SENT (0x50000)
ebx - SSF_ARP_PACKETS_RECEIVED (0x50001)
ebx - SSF_ARP_GET_ENTRY_COUNT (0x50002)
ebx - SSF_ARP_READ_ENTRY (0x50003)
ebx - SSF_ARP_ADD_STATIC_ENTRY (0x50004)
ebx - SSF_ARP_DEL_ENTRY (0x50005)
ebx - SSF_ARP_SEND_ANNOUNCE (0x50006)
ebx - SSF_ARP_CONFLICTS_COUNT (0x50007)
======================================================================
========== Function 77, Subfunction 0, Create futex object ===========
======================================================================
Parameters:
* eax = 77 - function number
* ebx = 0 - subfunction number
* ecx = futex control value (dword)
* ecx = pointer to futex dword
Returned value:
* eax = futex handle, 0 on error
Remarks:
* Use subfunction 1 to destroy the futex.
The kernel destroys the futexes automatically when the process
terminates.
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
@@ -5285,8 +5201,7 @@ Parameters:
Returned value:
* eax = 0 - successfull, -1 on error
Remarks:
* The kernel destroys the futexes automatically when the process
terminates.
* The futex handle must have been created by subfunction 0
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
@@ -5298,12 +5213,17 @@ Parameters:
* eax = 77 - function number
* ebx = 2 - subfunction number
* ecx = futex handle
* edx = futex control value (dword)
* esi = timeout in hundredths of a second, 0 - wait forever
* edx = control value
* esi = timeout in system ticks or 0 for infinity
Returned value:
* eax = 0 - successfull
-1 - timeout
-2 - futex control value doesn't match
-1 - timeout
-2 - futex dword does not have the same value as edx
Remarks:
* This functionn tests that the value at the futex dword still
contains the expected control value, and if so, then sleeps
waiting for a wake operation on the futex.
* The futex handle must have been created by subfunction 0
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
@@ -5319,71 +5239,15 @@ Parameters:
Returned value:
* eax = number of waiters that were woken up
Remarks:
* This function wakes at most edx of the waiters that are
waiting (e.g., inside futex wait) on the futex dword
* The futex handle must have been created by subfunction 0
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_WAKE (3)
======================================================================
Remarks:
* Subfunctions 4-7 are reserved and currently return -1.
* Subfunctions 8-9 and 12 are not implemented and return -EBADF (-9).
======================================================================
============ Function 77, Subfunction 10, Read from file. ============
======================================================================
Parameters:
* eax = 77 - function number
* ebx = 10 - subfunction number
* ecx = file handle
* edx = pointer to destination buffer
* esi = number of bytes to read
Returned value:
* eax = number of bytes read,
0 on EOF,
-EBADF (-9) on error
Remarks:
* Only pipe descriptors are supported.
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_FILE_READ (10)
======================================================================
=========== Function 77, Subfunction 11, Write to file. =============
======================================================================
Parameters:
* eax = 77 - function number
* ebx = 11 - subfunction number
* ecx = file handle
* edx = pointer to source buffer
* esi = number of bytes to write
Returned value:
* eax = number of bytes written,
-EBADF (-9) on error,
-EPIPE (-32) if no readers
Remarks:
* Only pipe descriptors are supported.
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_FILE_WRITE (11)
======================================================================
========== Function 77, Subfunction 13, Create pipe. ================
======================================================================
Parameters:
* eax = 77 - function number
* ebx = 13 - subfunction number
* ecx = pointer to pipefd[2] array (two dword handles)
* edx = flags (only O_CLOEXEC is allowed)
Returned value:
* eax = 0 on success,
negative errno value on error:
-EINVAL (-11), -EFAULT (-14), -ENFILE (-23), -EMFILE (-24)
Remarks:
* On success, pipefd[0] is a read handle and pipefd[1] is a
write handle.
---------------------- Constants for registers: ----------------------
eax - SF_FUTEX (77)
ebx - SSF_PIPE_CREATE (13)
======================================================================
=== Function 80 - file system interface with parameter of encoding ===
======================================================================
Parameters:

26
programs/KOSfuncs.inc
View File

@@ -70,11 +70,11 @@ SF_SYSTEM=18
SSF_WINDOW_BEHAVIOR=25 ; window focus relation with other windows
SSSF_GET_WB=1
SSSF_SET_WB=2
SF_MIDI=20 ; deprecated/undefined in current kernel
SSF_RESET=1 ; deprecated
SSF_OUTPUT=2 ; deprecated
SF_MIDI=20
SSF_RESET=1
SSF_OUTPUT=2
SF_SYSTEM_SET=21
SSF_MPU_MIDI_BASE=1 ; not used (reserved)
SSF_MPU_MIDI_BASE=1
SSF_KEYBOARD_LAYOUT=2
SSF_SYS_LANG=5
SSF_ACCESS_HD_LBA=11 ; setting of low-level access to HD
@@ -112,7 +112,7 @@ SF_BACKGROUND_GET=39
;SSF_PIXEL_BG=2
;SSF_MODE_BG=4
SF_SET_EVENTS_MASK=40 ; turn on/off desired events
SF_PORT_IN_OUT=43 ; deprecated/undefined in current kernel
SF_PORT_IN_OUT=43 ; input/output to a port
SF_SET_PORTS=46 ; reserve/free a group of input/output ports
SF_DRAW_NUMBER=47 ; draw number to the window
SF_STYLE_SETTINGS=48
@@ -132,10 +132,6 @@ SF_STYLE_SETTINGS=48
SF_APM=49
SF_SET_WINDOW_SHAPE=50
SF_CREATE_THREAD=51
SSF_CREATE_THREAD=1
SSF_GET_CURR_THREAD_SLOT=2
SSF_GET_THREAD_PRIORITY=3
SSF_SET_THREAD_PRIORITY=4
SF_CLIPBOARD=54
SSF_GET_SLOT_COUNT=0 ; get the number of slots in the clipboard
SSF_READ_CB=1
@@ -188,7 +184,7 @@ SF_SYS_MISC=68
SSF_HEAP_INIT=11
SSF_MEM_ALLOC=12
SSF_MEM_FREE=13
SSF_WAIT_SIGNAL=14 ; wait for a signal from other process
SSF_WAIT_SIGNAL=14 ; wait for signal from another program/driver
SSF_LOAD_DRIVER=16
SSF_CONTROL_DRIVER=17
SSF_LOAD_DLL=19
@@ -200,9 +196,6 @@ SF_SYS_MISC=68
SSF_SET_EXCEPTION_STATE=25
SSF_MEM_FREE_EXT=26
SSF_LOAD_FILE=27
SSF_MEM_ALLOC_RING=29
SSF_UNLOAD_DRIVER=30
SSF_GET_DRIVER_DATA=31
SF_DEBUG=69
SSF_SET_MESSAGE_AREA=0
SSF_GET_REGISTERS=1
@@ -228,7 +221,7 @@ SF_FILE=70
SF_SET_CAPTION=71
SF_SEND_MESSAGE=72
SF_BLITTER=73
SF_NETWORK_GET=74
SF_NETWORK_DEVICE=74
SSF_DEVICE_COUNT=255 ; get number of active network devices
SSF_DEVICE_TYPE=0
SSF_DEVICE_NAME=1
@@ -257,7 +250,7 @@ SF_NETWORK_SOCKET=75
SSF_RECEIVE=7
SSF_SET_OPTIONS=8
SSF_GET_OPTIONS=9
SSF_GET_PAIR=10
SSF_SOCKET_PAIR=10
SF_NETWORK_PROTOCOL=76
SSF_ETHERNET_READ_MAC=0
SSF_IP4_PACKETS_SENT=10000h
@@ -290,9 +283,6 @@ SF_FUTEX=77
SSF_DESTROY=1
SSF_WAIT=2
SSF_WAKE=3
SSF_FILE_READ=10
SSF_FILE_WRITE=11
SSF_PIPE_CREATE=13
; File system errors:
FSERR_SUCCESS=0

BIN
programs/develop/cedit/CEDIT Normal file
View File

Binary file not shown.

6
programs/develop/cedit/SHORTCUT.TXT
View File

@@ -47,9 +47,3 @@
перемещение по тексту:
(ctrl+)Home, (ctrl+)End, (ctrl+)PageUp, (ctrl+)PageDown
ctrl+Left, ctrl+Right
перемещение в панели поиска:
Tab к следующему полю ввода
Shift-Tab к предыдущему полю ввода
Enter поиск следующего вхождения

28
programs/develop/cedit/SRC/CEdit.ob07
View File

@@ -28,7 +28,7 @@ IMPORT
RW, Ini, EB := EditBox, Tabs, Toolbar, SB := StatusBar;
CONST
HEADER = "CEdit (11-jan-2026)";
HEADER = "CEdit (30-apr-2025)";
ShellFilter = "";
EditFilter = "sh|inc|txt|asm|ob07|c|cpp|h|pas|pp|lua|ini|json";
@@ -1750,15 +1750,7 @@ BEGIN
ELSE
IF EditBox_Focus(FindEdit) THEN
IF keyCode = 15 THEN (* Tab *)
IF shift THEN
SetFocus(GotoEdit, TRUE)
ELSE
SetFocus(ReplaceEdit, TRUE)
END
ELSIF keyCode = 28 THEN (* Enter *)
IF searchOpened & (searchText # "") THEN
notFound := ~T.findNext(text, BKW.value)
END
SetFocus(ReplaceEdit, TRUE)
ELSE
EB.key(FindEdit, key);
EditBox_Get(FindEdit, new_searchText);
@@ -1769,26 +1761,14 @@ BEGIN
END
ELSIF EditBox_Focus(ReplaceEdit) THEN
IF keyCode = 15 THEN (* Tab *)
IF shift THEN
SetFocus(FindEdit, TRUE)
ELSE
SetFocus(GotoEdit, TRUE)
END
ELSIF keyCode = 28 THEN (* Enter *)
IF searchOpened & (searchText # "") THEN
notFound := ~T.findNext(text, BKW.value)
END
SetFocus(GotoEdit, TRUE)
ELSE
EB.key(ReplaceEdit, key);
EditBox_Get(ReplaceEdit, replaceText)
END
ELSIF EditBox_Focus(GotoEdit) THEN
IF keyCode = 15 THEN (* Tab *)
IF shift THEN
SetFocus(ReplaceEdit, TRUE)
ELSE
SetFocus(FindEdit, TRUE)
END
SetFocus(FindEdit, TRUE)
ELSE
IF (key DIV 256) MOD 256 = 13 THEN
goto

9
programs/develop/cedit/Tupfile.lua
View File

@@ -1,9 +0,0 @@
if tup.getconfig("NO_OB07") ~= "" then return end
if tup.getconfig("HELPERDIR") == ""
then
HELPERDIR = "../../"
end
tup.include(HELPERDIR .. "/use_ob07.lua")
build_ob07({"SRC/CEdit.ob07"}, "cedit");

2
programs/develop/koldbg/koldbg.asm
View File

@@ -172,7 +172,7 @@ else
end if
}
include '../../KOSfuncs.inc'
include 'kosfuncs.inc'
include '../../macros.inc'
include 'font.inc'

298
programs/develop/koldbg/kosfuncs.inc Normal file
View File

@@ -0,0 +1,298 @@
; KolibriOS system functions:
SF_TERMINATE_PROCESS=-1
SF_CREATE_WINDOW=0 ; define and draw the window
SF_PUT_PIXEL=1 ; draw pixel to the window
SF_GET_KEY=2 ; get code of the pressed key
SF_GET_SYS_TIME=3
SF_DRAW_TEXT=4
SF_SLEEP=5 ; pause process
SF_PUT_IMAGE=7 ; draw image to the window
SF_DEFINE_BUTTON=8 ; define/delete the button
SF_THREAD_INFO=9 ; information on execution thread
SF_WAIT_EVENT=10 ; wait for event
SF_CHECK_EVENT=11 ; check for event and return
SF_REDRAW=12
SSF_BEGIN_DRAW=1
SSF_END_DRAW=2
SF_DRAW_RECT=13 ; draw rectangle to the window
SF_GET_SCREEN_SIZE=14 ; get screen resolution
SF_BACKGROUND_SET=15 ; work with desktop background graphics
SSF_SIZE_BG=1 ; set a size of the background image
SSF_PIXEL_BG=2 ; put pixel on the background image
SSF_REDRAW_BG=3 ; redraw background
SSF_MODE_BG=4 ; set drawing mode for the background
SSF_IMAGE_BG=5 ; put block of pixels on the background image
SSF_MAP_BG=6 ; map background image to the address space of the process
SSF_UNMAP_BG=7 ; close mapped background data
SSF_LAST_DRAW=8 ; get coordinates of the last draw to the background
SSF_REDRAW_RECT=9 ; redraws a rectangular part of the background
SF_RD_TO_FLOPPY=16 ; save ramdisk on the floppy
SF_GET_BUTTON=17 ; get ID of the pressed button
SF_SYSTEM=18
SSF_UNFOCUS_WINDOW=1 ; take focus from the window of the given thread
SSF_TERMINATE_THREAD=2 ; terminate process/thread by the slot number
SSF_FOCUS_WINDOW=3 ; give focus to the window of the given thread
SSF_GET_IDLE_COUNT=4 ; get counter of idle cycles per second
SSF_GET_CPU_FREQUENCY=5 ; get CPU clock rate
SSF_RD_TO_HDD=6 ; save ramdisk to the file on hard disk
SSF_GET_ACTIVE_WINDOW=7 ; get slot number of the active window
SSF_SPEAKER=8
SSSF_GET_STATE=1
SSSF_TOGGLE=2
SSF_SHUTDOWN=9 ; system shutdown/reboot
SSF_MINIMIZE_WINDOW=10 ; minimize active window
SSF_INFO_DISC_SYS=11 ; get disk subsystem information
SSF_KERNEL_VERSION=13 ; get kernel version
SSF_WAIT_RETRACE=14 ; wait for screen retrace
SSF_CURSOR_CENTER=15 ; center mouse cursor on the screen
SSF_GET_FREE_RAM=16 ; get size of free RAM
SSF_GET_TOTAL_RAM=17 ; get total amount of RAM
SSF_TERMINATE_THREAD_ID=18 ; Terminate process/thread by the ID
SSF_MOUSE_SETTINGS=19
SSSF_GET_SPEED=0
SSSF_SET_SPEED=1
SSSF_GET_SPEEDUP=2
SSSF_SET_SPEEDUP=3 ; set mouse acceleration
SSSF_SET_POS=4 ; set mouse pointer position
SSSF_SET_BUTTON=5 ; simulate state of mouse buttons
SSSF_GET_DOUBLE_CLICK_DELAY=6
SSSF_SET_DOUBLE_CLICK_DELAY=7
SSF_GET_RAM_INFO=20 ; get information on RAM
SSF_GET_THREAD_SLOT=21 ; get slot number of process/thread by the ID
SSF_FOREIGN_WINDOW=22 ; operations with window of another thread by slot/ID
SSSF_MINIMIZE=0
SSSF_MINIMIZE_ID=1
SSSF_RESTORE=2
SSSF_RESTORE_ID=3
SSF_MINIMIZE_ALL=23
SSF_SET_SCREEN_LIMITS=24
SSF_WINDOW_BEHAVIOR=25 ; window focus relation with other windows
SSSF_GET_WB=1
SSSF_SET_WB=2
SF_MIDI=20
SSF_RESET=1
SSF_OUTPUT=2
SF_SYSTEM_SET=21
SSF_MPU_MIDI_BASE=1
SSF_KEYBOARD_LAYOUT=2
SSF_SYS_LANG=5
SSF_ACCESS_HD_LBA=11 ; setting of low-level access to HD
SSF_ACCESS_PCI=12 ; setting of low-level access to PCI
SF_SET_TIME_DATE=22
SF_WAIT_EVENT_TIMEOUT=23; wait for event with timeout
SF_CD=24
SSF_EJECT_TRAY=4
SSF_INSERT_TRAY=5
SF_SCREEN_PUT_IMAGE=25 ; put image on the background layer
SF_SYSTEM_GET=26
; Same as SF_SYSTEM_SET, plus:
SSF_TIME_COUNT=9
SSF_TIME_COUNT_PRO=10 ; get value of the high precision time counter
SF_GET_SYS_DATE=29
SF_CURRENT_FOLDER=30
SSF_SET_CF=1 ; set current folder for the thread
SSF_GET_CF=2
SSF_ADD_SYS_FOLDER=3 ; install the add.system directory for the kernel
SF_GET_PIXEL_OWNER=34 ; get slot number of the screen pixel owner
SF_GET_PIXEL=35 ; read the screen pixel color
SF_GET_IMAGE=36 ; read the screen area
SF_MOUSE_GET=37
SSF_SCREEN_POSITION=0
SSF_WINDOW_POSITION=1
SSF_BUTTON=2 ; states of the mouse buttons
SSF_BUTTON_EXT=3 ; states and events of the mouse buttons
SSF_LOAD_CURSOR=4
SSF_SET_CURSOR=5
SSF_DEL_CURSOR=6
SSF_SCROLL_DATA=7
SF_DRAW_LINE=38
SF_BACKGROUND_GET=39
;SSF_SIZE_BG=1
;SSF_PIXEL_BG=2
;SSF_MODE_BG=4
SF_SET_EVENTS_MASK=40 ; turn on/off desired events
SF_PORT_IN_OUT=43 ; input/output to a port
SF_SET_PORTS=46 ; reserve/free a group of input/output ports
SF_DRAW_NUMBER=47 ; draw number to the window
SF_STYLE_SETTINGS=48
SSF_APPLY=0 ; apply screen settings
SSF_SET_BUTTON_STYLE=1
SSF_SET_COLORS=2
SSF_GET_COLORS=3 ; get standard window colors
SSF_GET_SKIN_HEIGHT=4
SSF_GET_SCREEN_AREA=5 ; get screen working area
SSF_SET_SCREEN_AREA=6
SSF_GET_SKIN_MARGINS=7
SSF_SET_SKIN=8
SSF_GET_FONT_SMOOTH=9
SSF_SET_FONT_SMOOTH=10
SSF_GET_FONT_SIZE=11
SSF_SET_FONT_SIZE=12
SF_APM=49
SF_SET_WINDOW_SHAPE=50
SF_CREATE_THREAD=51
SF_CLIPBOARD=54
SSF_GET_SLOT_COUNT=0 ; get the number of slots in the clipboard
SSF_READ_CB=1
SSF_WRITE_CB=2
SSF_DEL_SLOT=3 ; delete the last slot in the clipboard
SSF_UNLOCK_BUFFER=4 ; emergency buffer unlock
SF_SPEAKER_PLAY=55
SF_PCI_BIOS=57
SF_IPC=60 ; Inter Process Communication
SSF_SET_AREA=1 ; set area for IPC receiving
SSF_SEND_MESSAGE=2
SF_GET_GRAPHICAL_PARAMS=61
SSF_SCREEN_SIZE=1
SSF_BITS_PER_PIXEL=2
SSF_BYTES_PER_LINE=3
SF_PCI=62
SSF_GET_VERSION=0 ; get version of PCI-interface
SSF_GET_LAST_BUS=1 ; get number of the last PCI-bus
SSF_GET_ADRR_MODE=2 ; get addressing mode of the PCI configuration space
SSF_READ_BYTE=4
SSF_READ_WORD=5
SSF_READ_DWORD=6
SSF_WRITE_BYTE=8
SSF_WRITE_WORD=9
SSF_WRITE_DWORD=10
SF_BOARD=63
SSF_DEBUG_WRITE=1
SSF_DEBUG_READ=2
SF_MEMORY_RESIZE=64 ; resize total application memory
SF_PUT_IMAGE_EXT=65 ; draw image with palette to the window
SF_KEYBOARD=66
SSF_SET_INPUT_MODE=1
SSF_GET_INPUT_MODE=2
SSF_GET_CONTROL_KEYS=3; get status of control keys
SSF_SET_SYS_HOTKEY=4
SSF_DEL_SYS_HOTKEY=5
SSF_LOCK_INPUT=6 ; block normal input
SSF_UNLOCK_INPUT=7 ; restore normal input
SF_CHANGE_WINDOW=67 ; change position/sizes of the window
SF_SYS_MISC=68
SSF_GET_TASK_SWITCH_COUNT=0
SSF_SWITCH_TASK=1
SSF_PERFORMANCE=2
SSSF_ALLOW_RDPMC=0
SSSF_CACHE_STATUS=1
SSSF_CACHE_ON=2
SSSF_CACHE_OFF=3
SSF_READ_MSR=3
SSF_WRITE_MSR=4
SSF_HEAP_INIT=11
SSF_MEM_ALLOC=12
SSF_MEM_FREE=13
SSF_WAIT_SIGNAL=14 ; wait for signal from another program/driver
SSF_LOAD_DRIVER=16
SSF_CONTROL_DRIVER=17
SSF_LOAD_DLL=19
SSF_MEM_REALLOC=20
SSF_LOAD_DRIVER_PE=21
SSF_MEM_OPEN=22 ; open named memory area
SSF_MEM_CLOSE=23
SSF_SET_EXCEPTION_HANDLER=24
SSF_SET_EXCEPTION_STATE=25
SSF_MEM_FREE_EXT=26
SSF_LOAD_FILE=27
SF_DEBUG=69
SSF_SET_MESSAGE_AREA=0
SSF_GET_REGISTERS=1
SSF_SET_REGISTERS=2
SSF_DETACH=3
SSF_SUSPEND=4
SSF_RESUME=5
SSF_READ_MEMORY=6
SSF_WRITE_MEMORY=7
SSF_TERMINATE=8
SSF_DEFINE_BREAKPOINT=9
SF_FILE=70
SSF_READ_FILE=0
SSF_READ_FOLDER=1
SSF_CREATE_FILE=2
SSF_WRITE_FILE=3
SSF_SET_END=4
SSF_GET_INFO=5
SSF_SET_INFO=6
SSF_START_APP=7
SSF_DELETE=8
SSF_CREATE_FOLDER=9
SF_SET_CAPTION=71
SF_SEND_MESSAGE=72
SF_BLITTER=73
SF_NETWORK_DEVICE=74
SSF_DEVICE_COUNT=255 ; get number of active network devices
SSF_DEVICE_TYPE=0
SSF_DEVICE_NAME=1
SSF_RESET_DEVICE=2
SSF_STOP_DEVICE=3
SSF_DEVICE_POINTER=4
SSF_TX_PACKET_COUNT=6
SSF_RX_PACKET_COUNT=7
SSF_TX_BYTE_COUNT=8
SSF_RX_BYTE_COUNT=9
SSF_LINK_STATUS=10
SSF_TX_PACKET_ERROR_COUNT=11
SSF_TX_PACKET_DROP_COUNT=12
SSF_TX_PACKET_MISS_COUNT=13
SSF_RX_PACKET_ERROR_COUNT=14
SSF_RX_PACKET_DROP_COUNT=15
SSF_RX_PACKET_MISS_COUNT=16
SF_NETWORK_SOCKET=75
SSF_OPEN=0
SSF_CLOSE=1
SSF_BIND=2
SSF_LISTEN=3
SSF_CONNECT=4
SSF_ACCEPT=5
SSF_SEND=6
SSF_RECEIVE=7
SSF_SET_OPTIONS=8
SSF_GET_OPTIONS=9
SSF_SOCKET_PAIR=10
SF_NETWORK_PROTOCOL=76
SSF_ETHERNET_READ_MAC=0
SSF_IP4_PACKETS_SENT=10000h
SSF_IP4_PACKETS_RECEIVED=10001h
SSF_IP4_READ_IP=10002h
SSF_IP4_WRITE_IP=10003h
SSF_IP4_READ_DNS=10004h
SSF_IP4_WRITE_DNS=10005h
SSF_IP4_READ_SUBNET=10006h
SSF_IP4_WRITE_SUBNET=10007h
SSF_IP4_READ_GATEWAY=10008h
SSF_IP4_WRITE_GATEWAY=10009h
SSF_ICMP_PACKETS_SENT=20000h
SSF_ICMP_PACKETS_RECEIVED=20001h
SSF_ICMP_ECHO_REPLY=20003h
SSF_UDP_PACKETS_SENT=30000h
SSF_UDP_PACKETS_RECEIVED=30001h
SSF_TCP_PACKETS_SENT=40000h
SSF_TCP_PACKETS_RECEIVED=40001h
SSF_ARP_PACKETS_SENT=50000h
SSF_ARP_PACKETS_RECEIVED=50001h
SSF_ARP_GET_ENTRY_COUNT=50002h
SSF_ARP_READ_ENTRY=50003h
SSF_ARP_ADD_STATIC_ENTRY=50004h
SSF_ARP_DEL_ENTRY=50005h
SSF_ARP_SEND_ANNOUNCE=50006h
SSF_ARP_CONFLICTS_COUNT=50007h
SF_FUTEX=77
SSF_CREATE=0
SSF_DESTROY=1
SSF_WAIT=2
SSF_WAKE=3
; File system errors:
FSERR_SUCCESS=0
FSERR_UNSUPPORTED=2
FSERR_UNKNOWN=3
FSERR_FILE_NOT_FOUND=5
FSERR_END_OF_FILE=6
FSERR_INVALID_BUFFER=7
FSERR_DISK_FULL=8
FSERR_FAIL=9
FSERR_ACCESS_DENIED=10
FSERR_DEVICE_FAIL=11
FSERR_OUT_OF_MEMORY=12

1
programs/develop/ktcc/trunk/libc.obj/include/string.h
View File

@@ -32,7 +32,6 @@ DLLAPI char* strrchr(const char* s, int c);
DLLAPI size_t strspn(const char* s1, const char* s2);
DLLAPI char* strstr(const char* s1, const char* s2);
DLLAPI char* strtok(char* s1, const char* s2);
DLLAPI char* strtok_r(char* s1, const char* s2, char** saveptr);
DLLAPI char* strerror(int errnum);
DLLAPI size_t strlen(const char* s);
DLLAPI char* strrev(char* str);

2
programs/develop/ktcc/trunk/libc.obj/source/libc.c
View File

@@ -203,9 +203,7 @@ ksys_dll_t EXPORTS[] = {
{ "strspn", &strspn },
{ "strstr", &strstr },
{ "strtok", &strtok },
{ "strtok_r", &strtok_r },
{ "strxfrm", &strxfrm },
{ "strpbrk", &strpbrk },
{ "__errno", &__errno },
{ "closedir", &closedir },
{ "opendir", &opendir },

25
programs/develop/ktcc/trunk/libc.obj/source/string/strtok.c
View File

@@ -1,12 +1,14 @@
/* Copyright (C) 1994 DJ Delorie, see COPYING.DJ for details */
#include <string.h>
char* strtok_r(char* s, const char* delim, char** last)
char* strtok(char* s, const char* delim)
{
char *spanp, *tok;
const char* spanp;
int c, sc;
char* tok;
static char* last;
if (s == NULL && (s = *last) == NULL)
if (s == NULL && (s = last) == NULL)
return (NULL);
/*
@@ -14,13 +16,13 @@ char* strtok_r(char* s, const char* delim, char** last)
*/
cont:
c = *s++;
for (spanp = (char*)delim; (sc = *spanp++) != 0;) {
for (spanp = delim; (sc = *spanp++) != 0;) {
if (c == sc)
goto cont;
}
if (c == 0) { /* no non-delimiter characters */
*last = NULL;
last = NULL;
return (NULL);
}
tok = s - 1;
@@ -31,24 +33,17 @@ cont:
*/
for (;;) {
c = *s++;
spanp = (char*)delim;
spanp = delim;
do {
if ((sc = *spanp++) == c) {
if (c == 0)
s = NULL;
else
s[-1] = '\0';
*last = s;
s[-1] = 0;
last = s;
return (tok);
}
} while (sc != 0);
}
/* NOTREACHED */
}
char *strtok(char *s, const char *delim)
{
static char *last;
return (strtok_r(s, delim, &last));
}

19
programs/develop/libraries/microtar/LICENSE Normal file
View File

@@ -0,0 +1,19 @@
Copyright (c) 2017 rxi
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

99
programs/develop/libraries/microtar/README.md Normal file
View File

@@ -0,0 +1,99 @@
# microtar
A lightweight tar library written in ANSI C
## Basic Usage
The library consists of `microtar.c` and `microtar.h`. These two files can be
dropped into an existing project and compiled along with it.
#### Reading
```c
mtar_t tar;
mtar_header_t h;
char *p;
/* Open archive for reading */
mtar_open(&tar, "test.tar", "r");
/* Print all file names and sizes */
while ( (mtar_read_header(&tar, &h)) != MTAR_ENULLRECORD ) {
printf("%s (%d bytes)\n", h.name, h.size);
mtar_next(&tar);
}
/* Load and print contents of file "test.txt" */
mtar_find(&tar, "test.txt", &h);
p = calloc(1, h.size + 1);
mtar_read_data(&tar, p, h.size);
printf("%s", p);
free(p);
/* Close archive */
mtar_close(&tar);
```
#### Writing
```c
mtar_t tar;
const char *str1 = "Hello world";
const char *str2 = "Goodbye world";
/* Open archive for writing */
mtar_open(&tar, "test.tar", "w");
/* Write strings to files `test1.txt` and `test2.txt` */
mtar_write_file_header(&tar, "test1.txt", strlen(str1));
mtar_write_data(&tar, str1, strlen(str1));
mtar_write_file_header(&tar, "test2.txt", strlen(str2));
mtar_write_data(&tar, str2, strlen(str2));
/* Finalize -- this needs to be the last thing done before closing */
mtar_finalize(&tar);
/* Close archive */
mtar_close(&tar);
```
## Error handling
All functions which return an `int` will return `MTAR_ESUCCESS` if the operation
is successful. If an error occurs an error value less-than-zero will be
returned; this value can be passed to the function `mtar_strerror()` to get its
corresponding error string.
## Wrapping a stream
If you want to read or write from something other than a file, the `mtar_t`
struct can be manually initialized with your own callback functions and a
`stream` pointer.
All callback functions are passed a pointer to the `mtar_t` struct as their
first argument. They should return `MTAR_ESUCCESS` if the operation succeeds
without an error, or an integer below zero if an error occurs.
After the `stream` field has been set, all required callbacks have been set and
all unused fields have been zeroset the `mtar_t` struct can be safely used with
the microtar functions. `mtar_open` *should not* be called if the `mtar_t`
struct was initialized manually.
#### Reading
The following callbacks should be set for reading an archive from a stream:
Name | Arguments | Description
--------|------------------------------------------|---------------------------
`read` | `mtar_t *tar, void *data, unsigned size` | Read data from the stream
`seek` | `mtar_t *tar, unsigned pos` | Set the position indicator
`close` | `mtar_t *tar` | Close the stream
#### Writing
The following callbacks should be set for writing an archive to a stream:
Name | Arguments | Description
--------|------------------------------------------------|---------------------
`write` | `mtar_t *tar, const void *data, unsigned size` | Write data to the stream
## License
This library is free software; you can redistribute it and/or modify it under
the terms of the MIT license. See [LICENSE](LICENSE) for details.

8
programs/develop/libraries/microtar/Tupfile.lua Executable file
View File

@@ -0,0 +1,8 @@
if tup.getconfig("NO_GCC") ~= "" then return end
HELPERDIR = (tup.getconfig("HELPERDIR") == "") and "../../../" or tup.getconfig("HELPERDIR")
tup.include(HELPERDIR .. "/use_gcc.lua")
CFLAGS = " -c -w -nostdinc -DGNUC -DMTAR_OBJ -Os -fno-common -fno-builtin -fno-leading-underscore -fno-pie"
INCLUDES = " -I../include -I../../ktcc/trunk/libc.obj/include"
tup.rule("microtar.c", "kos32-gcc" .. CFLAGS .. INCLUDES .. " -o %o %f " .. tup.getconfig("KPACK_CMD"), "mtar.obj")

78
programs/develop/libraries/microtar/example/read.asm Normal file
View File

@@ -0,0 +1,78 @@
format binary as "kex"
use32
org 0x0
db 'MENUET01'
dd 0x01
dd START
dd IM_END
dd MEM
dd MEM
dd 0
dd 0
include '../../../../macros.inc'
include '../../../../proc32.inc'
include '../../../../KOSfuncs.inc'
include '../../../../dll.inc'
include '../mtar.inc'
;include '../../../../debug-fdo.inc'
;__DEBUG__ = 1
;__DEBUG_LEVEL__ = 2
START:
stdcall dll.Load, @IMPORT ; Имортироуем функции из mtar.obj
test eax, eax
jnz exit
ccall [mtar_init] ; Инициализируем библиотеку (на самом деле подгружается libc.obj
ccall [mtar_open], tar, tar_fname, tar_fmode ; Открываем для чтения файл 'test.tar'
; DEBUGF 2, "%d", eax
print_next:
ccall [mtar_read_header], tar, header ; Читаем заголовок
cmp eax, MTAR_ENULLRECORD ; Если заголовок не был прочитан (return -7) выходим из цикла
je exit
ccall [printf], format_str, header+mtar_header_t.name, dword[header+mtar_header_t.size] ; Выводим в консоль имя файла и размер в байтах
ccall [mtar_next], tar ; Переходим к следующему заголовку
jmp print_next ; прыгаем в начало цикла
exit:
ccall [mtar_close], tar ; Закрываем 'test.tar'
mcall SF_TERMINATE_PROCESS ; Выходим из программы
; data
tar_fname db 'test.tar', 0
tar_fmode db 'r', 0
tar rb sizeof.mtar_t
header rb sizeof.mtar_header_t
format_str db '%-10s (%-4d bytes)', 0x0A,0
align 4
@IMPORT:
library mtar, 'mtar.obj', libc , 'libc.obj'
import mtar, \
mtar_init, 'mtar_init', \
mtar_open, 'mtar_open', \
mtar_next, 'mtar_next', \
mtar_strerror, 'mtar_strerror', \
mtar_read_header, 'mtar_read_header', \
mtar_write_data, 'mtar_write_data', \
mtar_finalize, 'mtar_finalize', \
mtar_close, 'mtar_close'
import libc, \
printf, 'printf'
IM_END:
align 4
rb 4096 ; stack
MEM:

70
programs/develop/libraries/microtar/example/write.asm Normal file
View File

@@ -0,0 +1,70 @@
format binary as "kex"
use32
org 0x0
db 'MENUET01'
dd 0x01
dd START
dd IM_END
dd MEM
dd MEM
dd 0
dd 0
include '../../../../macros.inc'
include '../../../../proc32.inc'
include '../../../../KOSfuncs.inc'
include '../../../../dll.inc'
include '../mtar.inc'
;include '../../../../debug-fdo.inc'
;__DEBUG__ = 1
;__DEBUG_LEVEL__ = 2
START:
stdcall dll.Load, @IMPORT ; Имортироуем функции из mtar.obj
test eax, eax
jnz exit
ccall [mtar_init] ; Инициализируем библиотеку (на самом деле подгружается libc.obj
ccall [mtar_open], tar, tar_fname, tar_fmode ; Создаём новый файл 'test.tar'
ccall [mtar_write_file_header], tar, test1_txt , str1_len ; Создаём внутри 'test.tar' пустрой файл 'test1.txt'
ccall [mtar_write_data], tar, str1, str1_len ; Записываем данныев в этот файл
ccall [mtar_finalize], tar ; Указываем что больше с tar работать не будем
ccall [mtar_close], tar ; Закрываем 'test.tar'
exit:
mcall SF_TERMINATE_PROCESS ; Выходим из программы
; data
str1 db 'Hello world!', 0
str1_len = $ - str1
str2 db 'Goodbye world!', 0
tar_fname db 'test.tar', 0
tar_fmode db 'w', 0
test1_txt db 'test1.txt', 0
tar rb 32
align 4
@IMPORT:
library mtar, 'mtar.obj'
import mtar, \
mtar_init, 'mtar_init', \
mtar_open, 'mtar_open', \
mtar_write_file_header, 'mtar_write_file_header', \
mtar_write_data, 'mtar_write_data', \
mtar_finalize, 'mtar_finalize', \
mtar_close, 'mtar_close'
IM_END:
align 4
rb 4096 ; stack
MEM:

450
programs/develop/libraries/microtar/microtar.c Normal file
View File

@@ -0,0 +1,450 @@
/*
* Copyright (c) 2017 rxi
*
* Permission is hereby granted, free of charge, to any person obtaining a copy
* of this software and associated documentation files (the "Software"), to
* deal in the Software without restriction, including without limitation the
* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
* sell copies of the Software, and to permit persons to whom the Software is
* furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
* IN THE SOFTWARE.
*/
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <string.h>
#include <sys/ksys.h>
#include "microtar.h"
typedef struct {
char name[100];
char mode[8];
char owner[8];
char group[8];
char size[12];
char mtime[12];
char checksum[8];
char type;
char linkname[100];
char _padding[255];
} mtar_raw_header_t;
static void * mtar_memset( void * s, int c, size_t n ){
unsigned char * p = ( unsigned char * ) s;
while ( n-- ){
*p++ = ( unsigned char ) c;
}
return s;
}
#ifdef MTAR_OBJ
// All pointers was changed for compatible to latest version tcc and the libc.obj headers
size_t (*_fread)(void *restrict, size_t size, size_t count, FILE *restrict)=NULL;
size_t (*_fwrite)(const void *restrict, size_t size, size_t count, FILE *restrict)=NULL;
int (*_fclose)(FILE *)=NULL;
FILE* (*_fopen)(const char *restrict, const char *restrict)=NULL;
int (*_fseek)(FILE *, long, int)=NULL;
long (*_ftell)(FILE *)=NULL;
int (*_sprintf)(char* buffer, const char* format, ...)=NULL;
int (*_sscanf)(const char*, const char *restrict, ...)=NULL;
int (*_strcmp)(const char * s1, const char* s2)=NULL;
char* (*_strchr)(const char* s, int c)=NULL;
char* (*_strcpy)(char* s1, const char* s2)=NULL;
#endif
static unsigned round_up(unsigned n, unsigned incr) {
return n + (incr - n % incr) % incr;
}
static unsigned checksum(const mtar_raw_header_t* rh) {
unsigned i;
unsigned char *p = (unsigned char*) rh;
unsigned res = 256;
for (i = 0; i < offsetof(mtar_raw_header_t, checksum); i++) {
res += p[i];
}
for (i = offsetof(mtar_raw_header_t, type); i < sizeof(*rh); i++) {
res += p[i];
}
return res;
}
static int tread(mtar_t *tar, void *data, unsigned size) {
int err = tar->read(tar, data, size);
tar->pos += size;
return err;
}
static int twrite(mtar_t *tar, const void *data, unsigned size) {
int err = tar->write(tar, data, size);
tar->pos += size;
return err;
}
static int write_null_bytes(mtar_t *tar, int n) {
int i, err;
char nul = '\0';
for (i = 0; i < n; i++) {
err = twrite(tar, &nul, 1);
if (err) {
return err;
}
}
return MTAR_ESUCCESS;
}
static int raw_to_header(mtar_header_t *h, const mtar_raw_header_t *rh) {
unsigned chksum1, chksum2;
/* If the checksum starts with a null byte we assume the record is NULL */
if (*rh->checksum == '\0') {
return MTAR_ENULLRECORD;
}
/* Build and compare checksum */
chksum1 = checksum(rh);
_sscanf(rh->checksum, "%o", &chksum2);
if (chksum1 != chksum2) {
return MTAR_EBADCHKSUM;
}
/* Load raw header into header */
_sscanf(rh->mode, "%o", &h->mode);
_sscanf(rh->owner, "%o", &h->owner);
_sscanf(rh->size, "%o", &h->size);
_sscanf(rh->mtime, "%o", &h->mtime);
h->type = rh->type;
_strcpy(h->name, rh->name);
_strcpy(h->linkname, rh->linkname);
return MTAR_ESUCCESS;
}
static int header_to_raw(mtar_raw_header_t *rh, const mtar_header_t *h) {
unsigned chksum;
/* Load header into raw header */
mtar_memset(rh, 0, sizeof(*rh));
_sprintf(rh->mode, "%o", h->mode);
_sprintf(rh->owner, "%o", h->owner);
_sprintf(rh->size, "%o", h->size);
_sprintf(rh->mtime, "%o", h->mtime);
rh->type = h->type ? h->type : MTAR_TREG;
_strcpy(rh->name, h->name);
_strcpy(rh->linkname, h->linkname);
/* Calculate and write checksum */
chksum = checksum(rh);
_sprintf(rh->checksum, "%06o", chksum);
rh->checksum[7] = ' ';
return MTAR_ESUCCESS;
}
const char* mtar_strerror(int err) {
switch (err) {
case MTAR_ESUCCESS : return "success";
case MTAR_EFAILURE : return "failure";
case MTAR_EOPENFAIL : return "could not open";
case MTAR_EREADFAIL : return "could not read";
case MTAR_EWRITEFAIL : return "could not write";
case MTAR_ESEEKFAIL : return "could not seek";
case MTAR_EBADCHKSUM : return "bad checksum";
case MTAR_ENULLRECORD : return "null record";
case MTAR_ENOTFOUND : return "file not found";
}
return "unknown error";
}
static int file_write(mtar_t *tar, const void *data, unsigned size) {
unsigned res = _fwrite(data, 1, size, tar->stream);
return (res == size) ? MTAR_ESUCCESS : MTAR_EWRITEFAIL;
}
static int file_read(mtar_t *tar, void *data, unsigned size) {
unsigned res = _fread(data, 1, size, tar->stream);
return (res == size) ? MTAR_ESUCCESS : MTAR_EREADFAIL;
}
static int file_seek(mtar_t *tar, unsigned offset) {
int res = _fseek(tar->stream, offset, SEEK_SET);
return (res == 0) ? MTAR_ESUCCESS : MTAR_ESEEKFAIL;
}
static int file_close(mtar_t *tar) {
_fclose(tar->stream);
return MTAR_ESUCCESS;
}
int mtar_open(mtar_t *tar, const char *filename, const char *mode) {
int err;
mtar_header_t h;
/* Init tar struct and functions */
mtar_memset(tar, 0, sizeof(*tar));
tar->write = file_write;
tar->read = file_read;
tar->seek = file_seek;
tar->close = file_close;
/* Assure mode is always binary */
if ( _strchr(mode, 'r') ) mode = "rb";
if ( _strchr(mode, 'w') ) mode = "wb";
if ( _strchr(mode, 'a') ) mode = "ab";
/* Open file */
tar->stream = _fopen(filename, mode);
if (!tar->stream) {
return MTAR_EOPENFAIL;
}
/* Read first header to check it is valid if mode is `r` */
if (*mode == 'r') {
err = mtar_read_header(tar, &h);
if (err != MTAR_ESUCCESS) {
mtar_close(tar);
return err;
}
}
/* Return ok */
return MTAR_ESUCCESS;
}
int mtar_close(mtar_t *tar) {
return tar->close(tar);
}
int mtar_seek(mtar_t *tar, unsigned pos) {
int err = tar->seek(tar, pos);
tar->pos = pos;
return err;
}
int mtar_rewind(mtar_t *tar) {
tar->remaining_data = 0;
tar->last_header = 0;
return mtar_seek(tar, 0);
}
int mtar_next(mtar_t *tar) {
int err, n;
mtar_header_t h;
/* Load header */
err = mtar_read_header(tar, &h);
if (err) {
return err;
}
/* Seek to next record */
n = round_up(h.size, 512) + sizeof(mtar_raw_header_t);
return mtar_seek(tar, tar->pos + n);
}
int mtar_find(mtar_t *tar, const char *name, mtar_header_t *h) {
int err;
mtar_header_t header;
/* Start at beginning */
err = mtar_rewind(tar);
if (err) {
return err;
}
/* Iterate all files until we hit an error or find the file */
while ( (err = mtar_read_header(tar, &header)) == MTAR_ESUCCESS ) {
if ( !_strcmp(header.name, name) ) {
if (h) {
*h = header;
}
return MTAR_ESUCCESS;
}
mtar_next(tar);
}
/* Return error */
if (err == MTAR_ENULLRECORD) {
err = MTAR_ENOTFOUND;
}
return err;
}
int mtar_read_header(mtar_t *tar, mtar_header_t *h) {
int err;
mtar_raw_header_t rh;
/* Save header position */
tar->last_header = tar->pos;
/* Read raw header */
err = tread(tar, &rh, sizeof(rh));
if (err) {
return err;
}
/* Seek back to start of header */
err = mtar_seek(tar, tar->last_header);
if (err) {
return err;
}
/* Load raw header into header struct and return */
return raw_to_header(h, &rh);
}
int mtar_read_data(mtar_t *tar, void *ptr, unsigned size) {
int err;
/* If we have no remaining data then this is the first read, we get the size,
* set the remaining data and seek to the beginning of the data */
if (tar->remaining_data == 0) {
mtar_header_t h;
/* Read header */
err = mtar_read_header(tar, &h);
if (err) {
return err;
}
/* Seek past header and init remaining data */
err = mtar_seek(tar, tar->pos + sizeof(mtar_raw_header_t));
if (err) {
return err;
}
tar->remaining_data = h.size;
}
/* Read data */
err = tread(tar, ptr, size);
if (err) {
return err;
}
tar->remaining_data -= size;
/* If there is no remaining data we've finished reading and seek back to the
* header */
if (tar->remaining_data == 0) {
return mtar_seek(tar, tar->last_header);
}
return MTAR_ESUCCESS;
}
int mtar_write_header(mtar_t *tar, const mtar_header_t *h) {
mtar_raw_header_t rh;
/* Build raw header and write */
header_to_raw(&rh, h);
tar->remaining_data = h->size;
return twrite(tar, &rh, sizeof(rh));
}
int mtar_write_file_header(mtar_t *tar, const char *name, unsigned size) {
mtar_header_t h;
/* Build header */
mtar_memset(&h, 0, sizeof(h));
_strcpy(h.name, name);
h.size = size;
h.type = MTAR_TREG;
h.mode = 0664;
/* Write header */
return mtar_write_header(tar, &h);
}
int mtar_write_dir_header(mtar_t *tar, const char *name) {
mtar_header_t h;
/* Build header */
mtar_memset(&h, 0, sizeof(h));
_strcpy(h.name, name);
h.type = MTAR_TDIR;
h.mode = 0775;
/* Write header */
return mtar_write_header(tar, &h);
}
int mtar_write_data(mtar_t *tar, const void *data, unsigned size) {
int err;
/* Write data */
err = twrite(tar, data, size);
if (err) {
return err;
}
tar->remaining_data -= size;
/* Write padding if we've written all the data for this file */
if (tar->remaining_data == 0) {
return write_null_bytes(tar, round_up(tar->pos, 512) - tar->pos);
}
return MTAR_ESUCCESS;
}
int mtar_finalize(mtar_t *tar) {
/* Write two NULL records */
return write_null_bytes(tar, sizeof(mtar_raw_header_t) * 2);
}
/* Load libc.obj */
#ifdef MTAR_OBJ
#include <sys/ksys.h>
int mtar_init(){
ksys_dll_t *libc = _ksys_dlopen("/sys/lib/libc.obj");
if(!libc){
_ksys_debug_puts("mtar.obj: libc.obj not loaded!");
return 1;
}
_fread = _ksys_dlsym(libc, "fread");
_fwrite = _ksys_dlsym(libc, "fwrite");
_fclose = _ksys_dlsym(libc, "fclose");
_fopen = _ksys_dlsym(libc, "fopen");
_fseek = _ksys_dlsym(libc, "fseek");
_ftell = _ksys_dlsym(libc, "ftell");
_sprintf= _ksys_dlsym(libc, "sprintf");
_sscanf = _ksys_dlsym(libc, "sscanf");
_strcmp = _ksys_dlsym(libc, "strcmp");
_strchr = _ksys_dlsym(libc, "strchr");
_strcpy = _ksys_dlsym(libc, "strcpy");
return 0;
}
ksys_dll_t EXPORTS[] = {
{"mtar_init", mtar_init},
{"mtar_open", mtar_open},
{"mtar_close", mtar_close},
{"mtar_seek", mtar_seek},
{"mtar_rewind", mtar_rewind},
{"mtar_next", mtar_next},
{"mtar_find", mtar_find},
{"mtar_read_header", mtar_read_header},
{"mtar_read_data", mtar_read_data},
{"mtar_write_header", mtar_write_header},
{"mtar_write_file_header", mtar_write_file_header},
{"mtar_write_dir_header", mtar_write_dir_header},
{"mtar_write_data",mtar_write_data},
{"mtar_finalize", mtar_finalize},
{"mtar_strerror", mtar_strerror},
NULL
};
#endif

91
programs/develop/libraries/microtar/microtar.h Normal file
View File

@@ -0,0 +1,91 @@
/**
* Copyright (c) 2017 rxi
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the MIT license. See `microtar.c` for details.
*/
#ifndef MICROTAR_H
#define MICROTAR_H
#ifdef __cplusplus
extern "C"
{
#endif
#include <stdio.h>
#include <stdlib.h>
#define MTAR_VERSION "0.1.0"
enum {
MTAR_ESUCCESS = 0,
MTAR_EFAILURE = -1,
MTAR_EOPENFAIL = -2,
MTAR_EREADFAIL = -3,
MTAR_EWRITEFAIL = -4,
MTAR_ESEEKFAIL = -5,
MTAR_EBADCHKSUM = -6,
MTAR_ENULLRECORD = -7,
MTAR_ENOTFOUND = -8
};
enum {
MTAR_TREG = '0',
MTAR_TLNK = '1',
MTAR_TSYM = '2',
MTAR_TCHR = '3',
MTAR_TBLK = '4',
MTAR_TDIR = '5',
MTAR_TFIFO = '6'
};
typedef struct {
unsigned mode;
unsigned owner;
unsigned size;
unsigned mtime;
unsigned type;
char name[100];
char linkname[100];
} mtar_header_t;
typedef struct mtar_t mtar_t;
#pragma pack(push,1)
struct mtar_t {
int (*read)(mtar_t *tar, void *data, unsigned size);
int (*write)(mtar_t *tar, const void *data, unsigned size);
int (*seek)(mtar_t *tar, unsigned pos);
int (*close)(mtar_t *tar);
void *stream;
unsigned pos;
unsigned remaining_data;
unsigned last_header;
};
#pragma pack(pop)
const char* mtar_strerror(int err);
int mtar_open(mtar_t *tar, const char *filename, const char *mode);
int mtar_close(mtar_t *tar);
int mtar_seek(mtar_t *tar, unsigned pos);
int mtar_rewind(mtar_t *tar);
int mtar_next(mtar_t *tar);
int mtar_find(mtar_t *tar, const char *name, mtar_header_t *h);
int mtar_read_header(mtar_t *tar, mtar_header_t *h);
int mtar_read_data(mtar_t *tar, void *ptr, unsigned size);
int mtar_write_header(mtar_t *tar, const mtar_header_t *h);
int mtar_write_file_header(mtar_t *tar, const char *name, unsigned size);
int mtar_write_dir_header(mtar_t *tar, const char *name);
int mtar_write_data(mtar_t *tar, const void *data, unsigned size);
int mtar_finalize(mtar_t *tar);
#ifdef __cplusplus
}
#endif
#endif

38
programs/develop/libraries/microtar/mtar.inc Normal file
View File

@@ -0,0 +1,38 @@
MTAR_ESUCCESS = 0
MTAR_EFAILURE = -1
MTAR_EOPENFAIL = -2
MTAR_EREADFAIL = -3
MTAR_EWRITEFAIL = -4
MTAR_ESEEKFAIL = -5
MTAR_EBADCHKSUM = -6
MTAR_ENULLRECORD = -7
MTAR_ENOTFOUND = -8
MTAR_TREG = '0'
MTAR_TLNK = '1'
MTAR_TSYM = '2'
MTAR_TCHR = '3'
MTAR_TBLK = '4'
MTAR_TDIR = '5'
MTAR_TFIFO = '6'
struct mtar_header_t
mode dd ?
owner dd ?
size dd ?
mtime dd ?
type dd ?
name rb 100
linkname rb 100
ends
struct mtar_t
read_func dd ?
write_func dd ?
seek_func dd ?
close_func dd ?
stream dd ?
pos dd ?
remaining_data dd ?
last_header dd ?
ends

45
programs/develop/mtdbg/gui.inc
View File

@@ -122,13 +122,7 @@ struc fpcvt
.sizeof:
}
;-----------------------------------------------------------------------------
; Command flags
CMD_WITHOUT_PARAM = 1b ; command may be called without parameters
CMD_WITH_PARAM = 10b ; command may be called with parameters
CMD_WITHOUT_LOADED_APP = 100b ; command may be called without loaded program
CMD_WITH_LOADED_APP = 1000b ; command may be called with loaded program
;-----------------------------------------------------------------------------
; Entry point
@@ -455,56 +449,63 @@ z1:
mov esi, commands
call find_cmd
mov eax, aUnknownCommand
jc .cmd_procg
jc .x11
; check command requirements
; flags field:
; &1: command may be called without parameters
; &2: command may be called with parameters
; &4: command may be called without loaded program
; &8: command may be called with loaded program
mov eax, [esi+8]
mov ecx, [curarg]
cmp byte [ecx], 0
jz .noargs
test byte [esi+16], CMD_WITH_PARAM
jz .cmd_procg
test byte [esi+16], 2
jz .x11
jmp @f
.noargs:
test byte [esi+16], CMD_WITHOUT_PARAM
jz .cmd_procg
test byte [esi+16], 1
jz .x11
@@:
cmp [debuggee_pid], 0
jz .nodebuggee
mov eax, aAlreadyLoaded
test byte [esi+16], CMD_WITH_LOADED_APP
jz .cmd_procg
jmp .run_cmd
test byte [esi+16], 8
jz .x11
jmp .x9
.nodebuggee:
mov eax, need_debuggee
test byte [esi+16], CMD_WITHOUT_LOADED_APP
jnz .run_cmd
test byte [esi+16], 4
jnz .x9
.cmd_procg:
.x11:
xchg esi, eax
call put_message
; store cmdline for repeating
.cmd_procg_no_put_msg:
.x10:
mov esi, cmdline
mov ecx, [cmdline_len]
@@:
cmp ecx, 0
jle .wait_event
jle .we
mov al, [esi + ecx]
mov [cmdline_prev + ecx], al
dec ecx
jmp @b
.wait_event:
.we:
mov [cmdline_len], 0
jmp waitevent
.run_cmd:
.x9:
call dword [esi+4]
jmp .cmd_procg_no_put_msg
jmp .x10
;-----------------------------------------------------------------------------
; Cmdline handling

209
programs/develop/mtdbg/mtdbg.asm
View File

@@ -2,10 +2,7 @@
COLOR_THEME fix MOVIEOS
format binary as ""
include '../../macros.inc'
include '../../KOSfuncs.inc'
use32
db 'MENUET01'
dd 1
@@ -1148,105 +1145,6 @@ OnDump:
.ret:
ret
;-----------------------------------------------------------------------------
; Print Backtrace
struct STACK_FRAME
prev_frame rd 1
ret_addr rd 1
ends
OnBacktrace:
push ebp
; Set max depth counter
xor eax, eax
dec eax
mov esi, [curarg]
cmp byte [esi], 0
jz .save_depth
call get_hex_number
mov esi, aParseError
jc .exit
; If depth 0
test eax, eax
jz .done
.save_depth:
mov [bt_depth], eax
; Get start frame addres
mov ebp, [_ebp]
test ebp, ebp
jz .done
mov edi, stack_frame_dump
.next:
mcall SF_DEBUG, SSF_READ_MEMORY, [debuggee_pid], sizeof.STACK_FRAME, ebp
cmp eax, -1
mov esi, read_mem_err
jz .exit
; The address of the previous frame must be less than the current one
mov eax, [edi + STACK_FRAME.prev_frame]
test eax, eax
jz .done
; Save stack_frame_dump
push edi
; Save previous frame
push ebp
; Save return address
mov eax, [edi + STACK_FRAME.ret_addr]
push eax
; Print frame address and return address
push eax ; pop in put_message_nodraw
push ebp ; pop in put_message_nodraw
mov esi, aBacktraceFmt
call put_message_nodraw
; Restore return address
pop eax
; Find symbol by return address
call find_near_symbol
test esi, esi
jnz .print_sym
mov esi, aBacktraceSymStub
.print_sym:
call put_message_nodraw
mov esi, newline
call put_message_nodraw
; Restore previous frame
pop ebp
; Restore stack_frame_dump
pop edi
; The address of the previous frame must be greater than the current one.
cmp [edi + STACK_FRAME.prev_frame], ebp
jna .done
; Set previous frame
mov ebp, [edi + STACK_FRAME.prev_frame]
dec [bt_depth]
jnz .next
.done:
mov esi, newline
.exit:
call put_message
pop ebp
ret
;-----------------------------------------------------------------------------
; Dissassemble block of executable event
@@ -1966,7 +1864,7 @@ include 'disasm.inc'
caption_str db 'Kolibri Debugger',0
begin_str db 'Kolibri Debugger, version 0.36',10
begin_str db 'Kolibri Debugger, version 0.35',10
db 'Hint: type "help" for help, "quit" to quit'
newline db 10,0
prompt db '> ',0
@@ -1982,88 +1880,66 @@ help_groups:
;-----------------------------------------------------------------------------
; Commands format definitions
; TODO: make it with macros
; flags field:
; &1: command may be called without parameters
; &2: command may be called with parameters
; &4: command may be called without loaded program
; &8: command may be called with loaded program
commands:
dd _aH, OnHelp, HelpSyntax, HelpHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITHOUT_LOADED_APP or CMD_WITH_LOADED_APP
db 0Fh
dd aHelp, OnHelp, HelpSyntax, HelpHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITHOUT_LOADED_APP or CMD_WITH_LOADED_APP
db 0Fh
dd aQuit, OnQuit, QuitSyntax, QuitHelp
db CMD_WITHOUT_PARAM or CMD_WITHOUT_LOADED_APP or CMD_WITH_LOADED_APP
db 0Dh
dd aLoad, OnLoad, LoadSyntax, LoadHelp
db CMD_WITH_PARAM or CMD_WITHOUT_LOADED_APP
db 6
dd aReload, OnReload, ReloadSyntax, ReloadHelp
db CMD_WITHOUT_PARAM or CMD_WITHOUT_LOADED_APP or CMD_WITH_LOADED_APP
db 0Dh
dd aTerminate, OnTerminate, TerminateSyntax, TerminateHelp
db CMD_WITHOUT_PARAM or CMD_WITH_LOADED_APP
db 9
dd aDetach, OnDetach, DetachSyntax, DetachHelp
db CMD_WITHOUT_PARAM or CMD_WITH_LOADED_APP
db 9
dd aSuspend, OnSuspend, SuspendSyntax, SuspendHelp
db CMD_WITHOUT_PARAM or CMD_WITH_LOADED_APP
db 9
dd aResume, OnResume, ResumeSyntax, ResumeHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aStep, OnStepMultiple, StepSyntax, StepHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aProceed, OnProceedMultiple, ProceedSyntax, ProceedHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aCalc, OnCalc, CalcSyntax, CalcHelp
db CMD_WITH_PARAM or CMD_WITHOUT_LOADED_APP or CMD_WITH_LOADED_APP
db 0Eh
dd aDump, OnDump, DumpSyntax, DumpHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
dd aBacktrace, OnBacktrace, BacktraceSyntax, BacktraceHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aUnassemble, OnUnassemble, UnassembleSyntax, UnassembleHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aBp, OnBp, BpSyntax, BpHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBpm, OnBpmb, BpmSyntax, BpmHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBpmb, OnBpmb, BpmSyntax, BpmHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBpmw, OnBpmw, BpmSyntax, BpmHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBpmd, OnBpmd, BpmSyntax, BpmHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBl, OnBl, BlSyntax, BlHelp
db CMD_WITHOUT_PARAM or CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Bh
dd aBc, OnBc, BcSyntax, BcHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBd, OnBd, BdSyntax, BdHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aBe, OnBe, BeSyntax, BeHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aReg, OnReg, RSyntax, RHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd aUnpack, OnUnpack, UnpackSyntax, UnpackHelp
db CMD_WITHOUT_PARAM or CMD_WITH_LOADED_APP
db 9
dd aLoadSymbols, OnLoadSymbols, LoadSymbolsSyntax, LoadSymbolsHelp
db CMD_WITH_PARAM or CMD_WITH_LOADED_APP
db 0Ah
dd 0
;-----------------------------------------------------------------------------
@@ -2104,8 +1980,7 @@ help_data_msg db 'List of data commands:',10
db 'd [<expression>] - dump data at given address',10
db 'u [<expression>] - unassemble instructions at given address',10
db 'r <register> <expression> or',10
db 'r <register>=<expression> - set register value',10
db 'bt [<number>] - display backtrace / stacktrace',10,0
db 'r <register>=<expression> - set register value',10,0
; Breakpoints commands group
@@ -2163,11 +2038,6 @@ DumpHelp db 'Dump data of debugged program',10
DumpSyntax db 'Usage: d <expression> - dump data at specified address',10
db ' or: d - continue current dump',10,0
aBacktrace db 3,'bt',0
BacktraceHelp db 'Display backtrace / stacktrace',10
BacktraceSyntax db 'Usage: bt <number> - display backtrace with depth',10
db ' or: bt display all backtrace',10,0
aCalc db 2,'?',0
CalcHelp db 'Calculate value of expression',10
CalcSyntax db 'Usage: ? <expression>',10,0
@@ -2232,11 +2102,6 @@ LoadSymbolsSyntax db 'Usage: load-symbols <symbols-file-name>',10,0
aUnknownCommand db 'Unknown command',10,0
;-----------------------------------------------------------------------------
; Info messages
aBacktraceSymStub db '??',0
aBacktraceFmt db '[0x%8X] 0x%8X in ',0
;-----------------------------------------------------------------------------
; Error messages
@@ -2609,13 +2474,11 @@ disasm_cur_pos dd ?
disasm_cur_str dd ?
disasm_string rb 256
stack_frame_dump rb sizeof.STACK_FRAME
bt_depth rd 1
thread_info process_information
;-----------------------------------------------------------------------------
; Coordinates and sizes for GUI
thread_info process_information
data_x_size_dd dd ?, ?
messages_x_size_dd dd ?, ?
registers_x_pos_dd dd ?, ?

72
programs/develop/mtdbg/symbols.inc
View File

@@ -4,11 +4,6 @@
include 'sort.inc'
struct DEBUG_SYMBOL
addr rd 1
string rd 0
ends
; compare proc for sorter
compare:
cmpsd
@@ -464,69 +459,4 @@ find_symbol_name:
@@:
pop esi
ret
;-----------------------------------------------------------------------------
;
; Find the nearest symol using binary search
;
; in: eax - target addres
; out: esi - symbol name
; destroys: ebx, ecx, edx, edi, ebp
;
find_near_symbol:
mov edi, [symbols]
xor esi, esi ; Result
mov ecx, esi ; Left
mov edx, [num_symbols] ; Right
dec edx
js .end
; If the first address is already greater than the target
mov ebp, [edi + ecx * sizeof.DEBUG_SYMBOL]
cmp [ebp + DEBUG_SYMBOL.addr], eax
ja .end
; If the last address is less than or equal to the target
mov ebp, [edi + edx * sizeof.DEBUG_SYMBOL]
cmp [ebp + DEBUG_SYMBOL.addr], eax
jbe .found
.loop:
cmp ecx, edx
ja .end
; Calc middle:
mov ebx, edx ; Middle
sub ebx, ecx ; (right - left)
shr ebx, 1 ; / 2
add ebx, ecx ; + left
; Equal
mov ebp, [edi + ebx * sizeof.DEBUG_SYMBOL]
cmp [ebp + DEBUG_SYMBOL.addr], eax
jz .found
jb .update_left
; Update right
mov edx, ebx
dec edx
jmp .loop
.update_left:
; Save potential result
mov esi, ebp
add esi, DEBUG_SYMBOL.string
; Update left
mov ecx, ebx
inc ecx
jmp .loop
.found:
mov esi, ebp
add esi, DEBUG_SYMBOL.string
.end:
ret
ret

1
programs/develop/oberon07

Submodule programs/develop/oberon07 deleted from 07f0da001b

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

Binary file not shown.

25
programs/develop/oberon07/LICENSE Normal file
View File

@@ -0,0 +1,25 @@
BSD 2-Clause License
Copyright (c) 2018-2023, 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.

61
programs/develop/oberon07/doc/CC.txt Normal file
View File

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

566
programs/develop/oberon07/doc/KOSLib.txt Normal file
View File

@@ -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
------------------------------------------------------------------------------

BIN
programs/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf Normal file
View File

Binary file not shown.

423
programs/develop/oberon07/doc/x86.txt Normal file
View File

@@ -0,0 +1,423 @@
Компилятор языка программирования 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 Мб)
-tab <width> размер табуляции (используется для вычисления координат в
исходном коде), по умолчанию - 4
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре (по умолчанию)
-upper только верхний регистр для ключевых слов и встроенных
идентификаторов
-def <имя> задать символ условной компиляции
-ver <major.minor> версия программы (только для kosdll)
-uses вывести список импортированных модулей
параметр -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
12. Добавлена операция конкатенации строковых и символьных констант
13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно
16. Разрешено использовать нижний регистр для ключевых слов
------------------------------------------------------------------------------
Особенности реализации
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. Максимальная длина идентификаторов - 255 символов
3. Максимальная длина строковых констант - 511 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
10 WCHR(x), если (x < 0) OR (x > 65535)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE VAL(v: любой тип; T): T
v - переменная;
интерпретирует v, как переменную типа T
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : INTEGER)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall],
[cdecl], [fastcall], [ccall], [windows], [linux], [oberon]. Например:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
Если указан флаг [ccall], то принимается соглашение cdecl, но перед
вызовом указатель стэка будет выравнен по границе 16 байт.
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall].
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Case {"|" Case}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 с BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
DISPOSE (VAR v: любой_указатель)
Освобождает память, выделенную процедурой NEW для
динамической переменной v^, и присваивает переменной v
значение NIL.
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импорт модулей с указанием пути и имени файла
Примеры:
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *)
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *)
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [windows, "kernel32.dll", ""] ExitProcess (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 импортировать процедуры можно только из библиотек, размещенных
в /sys/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
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, и ее имя должно быть отмечено символом
экспорта ("*"). Нельзя экспортировать процедуры, которые импортированы из
других dll-библиотек.
KolibriOS DLL всегда экспортируют идентификаторы "version" (версия
программы) и "lib_init" - адрес процедуры инициализации DLL:
PROCEDURE [stdcall] lib_init (): INTEGER
Эта процедура должна быть вызвана перед использованием DLL.
Процедура всегда возвращает 1.

290
programs/develop/oberon07/lib/KolibriOS/API.ob07 Normal file
View File

@@ -0,0 +1,290 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2020-2022, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM, K := KOSAPI;
CONST
eol* = 0DX + 0AX;
BIT_DEPTH* = 32;
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
_new = 1;
_dispose = 2;
SizeOfHeader = 36;
TYPE
CRITICAL_SECTION = ARRAY 2 OF INTEGER;
VAR
heap, endheap: INTEGER;
pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER;
CriticalSection: CRITICAL_SECTION;
multi: BOOLEAN;
base*: INTEGER;
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER);
BEGIN
SYSTEM.CODE(
0FCH, (* cld *)
031H, 0C0H, (* xor eax, eax *)
057H, (* push edi *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0F3H, 0ABH, (* rep stosd *)
05FH (* pop edi *)
)
END zeromem;
PROCEDURE mem_commit* (adr, size: INTEGER);
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE switch_task;
BEGIN
K.sysfunc2(68, 1)
END switch_task;
PROCEDURE futex_create (ptr: INTEGER): INTEGER;
RETURN K.sysfunc3(77, 0, ptr)
END futex_create;
PROCEDURE futex_wait (futex, value, timeout: INTEGER);
BEGIN
K.sysfunc5(77, 2, futex, value, timeout)
END futex_wait;
PROCEDURE futex_wake (futex, number: INTEGER);
BEGIN
K.sysfunc4(77, 3, futex, number)
END futex_wake;
PROCEDURE EnterCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
switch_task;
futex_wait(CriticalSection[0], 1, 10000);
CriticalSection[1] := 1
END EnterCriticalSection;
PROCEDURE LeaveCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[1] := 0;
futex_wake(CriticalSection[0], 1)
END LeaveCriticalSection;
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1]));
CriticalSection[1] := 0
END InitializeCriticalSection;
PROCEDURE __NEW (size: INTEGER): INTEGER;
VAR
res, idx, temp: INTEGER;
BEGIN
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
SYSTEM.GET(res, pockets[idx]);
SYSTEM.PUT(res, size);
INC(res, 4)
ELSE
temp := 0;
IF heap + size >= endheap THEN
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := K.sysfunc3(68, 12, HEAP_SIZE)
ELSE
temp := 0
END;
IF temp # 0 THEN
mem_commit(temp, HEAP_SIZE);
heap := temp;
endheap := heap + HEAP_SIZE
ELSE
temp := -1
END
END;
IF (heap # 0) & (temp # -1) THEN
SYSTEM.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
res := 0
END
END
ELSE
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN
res := K.sysfunc3(68, 12, size);
IF res # 0 THEN
mem_commit(res, size);
SYSTEM.PUT(res, size);
INC(res, 4)
END
ELSE
res := 0
END
END;
IF (res # 0) & (size <= MAX_SIZE) THEN
zeromem(ASR(size, 2) - 1, res)
END
RETURN res
END __NEW;
PROCEDURE __DISPOSE (ptr: INTEGER): INTEGER;
VAR
size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
SYSTEM.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
SYSTEM.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := K.sysfunc3(68, 13, ptr)
END
RETURN 0
END __DISPOSE;
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF multi THEN
EnterCriticalSection(CriticalSection)
END;
IF func = _new THEN
res := __NEW(arg)
ELSIF func = _dispose THEN
res := __DISPOSE(arg)
END;
IF multi THEN
LeaveCriticalSection(CriticalSection)
END
RETURN res
END NEW_DISPOSE;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN NEW_DISPOSE(_new, size)
END _NEW;
PROCEDURE _DISPOSE* (ptr: INTEGER): INTEGER;
RETURN NEW_DISPOSE(_dispose, ptr)
END _DISPOSE;
PROCEDURE exit* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit;
PROCEDURE exit_thread* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit_thread;
PROCEDURE OutStr (pchar: INTEGER);
VAR
c: CHAR;
BEGIN
IF pchar # 0 THEN
REPEAT
SYSTEM.GET(pchar, c);
IF c # 0X THEN
K.OutChar(c)
END;
INC(pchar)
UNTIL c = 0X
END
END OutStr;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
IF lpCaption # 0 THEN
K.OutLn;
OutStr(lpCaption);
K.OutChar(":");
K.OutLn
END;
OutStr(lpText);
IF lpCaption # 0 THEN
K.OutLn
END
END DebugMsg;
PROCEDURE init* (import_, code: INTEGER);
BEGIN
multi := FALSE;
base := code - SizeOfHeader;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init(import_)
END init;
PROCEDURE SetMultiThr* (value: BOOLEAN);
BEGIN
multi := value
END SetMultiThr;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9) * 10
END GetTickCount;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
END sofinit;
END API.

100
programs/develop/oberon07/lib/KolibriOS/Args.ob07 Normal file
View File

@@ -0,0 +1,100 @@
(*
Copyright 2016, 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 Args;
IMPORT sys := SYSTEM, KOSAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: 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
END ChangeCond;
BEGIN
p := KOSAPI.GetCommandLine();
name := KOSAPI.GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
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;
BEGIN
ParamParse
END Args.

105
programs/develop/oberon07/lib/KolibriOS/ColorDlg.ob07 Normal file
View File

@@ -0,0 +1,105 @@
(*
Copyright 2016, 2018, 2020, 2022 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 ColorDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
_type,
procinfo,
com_area_name,
com_area,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
X, Y,
color_type,
color*: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (cd: Dialog);
PROCEDURE Show*(cd: Dialog);
BEGIN
IF cd # NIL THEN
cd.X := 0;
cd.Y := 0;
Dialog_start(cd)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW): Dialog;
VAR res: Dialog;
BEGIN
NEW(res);
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res._type := 0;
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/sys/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
res.Y := 0;
res.color := 0;
Dialog_init(res)
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR cd: Dialog);
BEGIN
IF cd # NIL THEN
DISPOSE(cd)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/sys/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN
Load
END ColorDlg.

94
programs/develop/oberon07/lib/KolibriOS/Console.ob07 Normal file
View File

@@ -0,0 +1,94 @@
(*
Copyright 2016, 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 Console;
IMPORT ConsoleLib, 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;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
VAR
res: INTEGER;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
PROCEDURE open*;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "");
In.Open;
Out.Open
END open;
PROCEDURE exit* (bCloseWindow: BOOLEAN);
BEGIN
ConsoleLib.exit(bCloseWindow)
END exit;
END Console.

103
programs/develop/oberon07/lib/KolibriOS/ConsoleLib.ob07 Normal file
View File

@@ -0,0 +1,103 @@
(*
Copyright 2016, 2018, 2022 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 ConsoleLib;
IMPORT sys := SYSTEM, KOSAPI;
CONST
COLOR_BLUE* = 001H;
COLOR_GREEN* = 002H;
COLOR_RED* = 004H;
COLOR_BRIGHT* = 008H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BRIGHT* = 080H;
IGNORE_SPECIALS* = 100H;
WINDOW_CLOSED* = 200H;
TYPE
gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER);
VAR
version* : INTEGER;
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
write_asciiz* : PROCEDURE [stdcall] (string: INTEGER);
write_string* : PROCEDURE [stdcall] (string, length: INTEGER);
get_flags* : PROCEDURE [stdcall] (): INTEGER;
set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER;
get_font_height* : PROCEDURE [stdcall] (): INTEGER;
get_cursor_height* : PROCEDURE [stdcall] (): INTEGER;
set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER;
getch* : PROCEDURE [stdcall] (): INTEGER;
getch2* : PROCEDURE [stdcall] (): INTEGER;
kbhit* : PROCEDURE [stdcall] (): INTEGER;
gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER;
gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER;
cls* : PROCEDURE [stdcall] ();
get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER);
set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER);
set_title* : PROCEDURE [stdcall] (title: INTEGER);
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR);
BEGIN
init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0]))
END open;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/sys/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(version), "version");
GetProc(Lib, sys.ADR(init), "con_init");
GetProc(Lib, sys.ADR(exit), "con_exit");
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(Lib, sys.ADR(write_string), "con_write_string");
GetProc(Lib, sys.ADR(get_flags), "con_get_flags");
GetProc(Lib, sys.ADR(set_flags), "con_set_flags");
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height");
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(Lib, sys.ADR(getch), "con_getch");
GetProc(Lib, sys.ADR(getch2), "con_getch2");
GetProc(Lib, sys.ADR(kbhit), "con_kbhit");
GetProc(Lib, sys.ADR(gets), "con_gets");
GetProc(Lib, sys.ADR(gets2), "con_gets2");
GetProc(Lib, sys.ADR(cls), "con_cls");
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(Lib, sys.ADR(set_title), "con_set_title");
END main;
BEGIN
main
END ConsoleLib.

141
programs/develop/oberon07/lib/KolibriOS/DateTime.ob07 Normal file
View File

@@ -0,0 +1,141 @@
(*
Copyright 2016, 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 DateTime;
IMPORT KOSAPI;
CONST ERR* = -7.0E5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL;
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; 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) THEN
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594;
FOR i := 1 TO Month - 1 DO
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0
END
END
RETURN Res
END Encode;
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR;
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
IF d > ORD(M[n]) - ORD("0") + 28 THEN
d := d - ORD(M[n]) + ORD("0") - 28;
INC(Month);
Res := TRUE
END
RETURN Res
END MonthDay;
BEGIN
IF (Date >= -693593.0) & (Date < 2958466.0) THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
d := d + 693593;
Year := 1;
Month := 1;
WHILE d > 0 DO
d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
INC(Year)
END;
IF d < 0 THEN
DEC(Year);
d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0))
END;
INC(d);
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i, d, Month, M);
INC(i)
END;
Day := d;
Hour := t DIV 3600000;
t := t MOD 3600000;
Min := t DIV 60000;
t := t MOD 60000;
Sec := t DIV 1000;
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
time := KOSAPI.sysfunc1(3);
Year := date MOD 16;
date := date DIV 16;
Year := (date MOD 16) * 10 + Year;
date := date DIV 16;
Month := date MOD 16;
date := date DIV 16;
Month := (date MOD 16) * 10 + Month;
date := date DIV 16;
Day := date MOD 16;
date := date DIV 16;
Day := (date MOD 16) * 10 + Day;
date := date DIV 16;
Hour := time MOD 16;
time := time DIV 16;
Hour := (time MOD 16) * 10 + Hour;
time := time DIV 16;
Min := time MOD 16;
time := time DIV 16;
Min := (time MOD 16) * 10 + Min;
time := time DIV 16;
Sec := time MOD 16;
time := time DIV 16;
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
Year := Year + 2000;
Msec := 0
END Now;
END DateTime.

292
programs/develop/oberon07/lib/KolibriOS/Debug.ob07 Normal file
View File

@@ -0,0 +1,292 @@
(*
Copyright 2016, 2018, 2022 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 Debug;
IMPORT KOSAPI, sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc3(63, 1, ORD(c))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR n, i: INTEGER;
BEGIN
n := LENGTH(s);
FOR i := 0 TO n - 1 DO
Char(s[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(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
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;
Realp := Real;
_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*;
TYPE
info_struct = RECORD
subfunc: INTEGER;
flags: INTEGER;
param: INTEGER;
rsrvd1: INTEGER;
rsrvd2: INTEGER;
fname: ARRAY 1024 OF CHAR
END;
VAR info: info_struct; res: INTEGER;
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.SADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/sys/develop/board";
res := KOSAPI.sysfunc2(70, sys.ADR(info))
END Open;
END Debug.

330
programs/develop/oberon07/lib/KolibriOS/File.ob07 Normal file
View File

@@ -0,0 +1,330 @@
(*
Copyright 2016, 2018, 2021 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 File;
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
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;
PROCEDURE [stdcall] f_68_27 (file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE(
053H, (* push ebx *)
06AH, 044H, (* push 68 *)
058H, (* pop eax *)
06AH, 01BH, (* push 27 *)
05BH, (* pop ebx *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
089H, 011H, (* mov dword [ecx], edx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END f_68_27;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
END Load;
PROCEDURE GetFileInfo* (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER; fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := sys.ADR(Info);
COPY(FName, fs.name)
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE FileSize* (FName: ARRAY OF CHAR): INTEGER;
VAR
Info: rFD;
res: INTEGER;
BEGIN
IF GetFileInfo(FName, Info) THEN
res := Info.size
ELSE
res := -1
END
RETURN res
END FileSize;
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close* (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END Delete;
PROCEDURE Seek* (F: FS; Offset, Origin: INTEGER): INTEGER;
VAR
res: INTEGER;
fd: rFD;
BEGIN
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN
CASE Origin OF
|SEEK_BEG: F.pos := Offset
|SEEK_CUR: F.pos := F.pos + Offset
|SEEK_END: F.pos := fd.size + Offset
ELSE
END;
res := F.pos
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Read* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE DirExists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr))
END DirExists;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
RETURN res = 0
END CreateDir;
PROCEDURE DeleteDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END DeleteDir;
END File.

553
programs/develop/oberon07/lib/KolibriOS/HOST.ob07 Normal file
View File

@@ -0,0 +1,553 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, K := KOSAPI, API;
CONST
slash* = "/";
eol* = 0DX + 0AX;
bit_depth* = API.BIT_DEPTH;
maxint* = ROR(-2, 1);
minint* = ROR(1, 1);
MAX_PARAM = 1024;
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
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;
VAR
Console: BOOLEAN;
days: DAYS;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
maxreal*, inf*: 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);
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER);
PROCEDURE ExitProcess* (p1: INTEGER);
BEGIN
IF Console THEN
con_exit(FALSE)
END;
K.sysfunc1(-1)
END ExitProcess;
PROCEDURE OutChar* (c: CHAR);
BEGIN
IF Console THEN
con_write_string(SYSTEM.ADR(c), 1)
ELSE
K.sysfunc3(63, 1, ORD(c))
END
END OutChar;
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER;
fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := SYSTEM.ADR(Info);
COPY(FName, fs.name)
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Create(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
VAR
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
Close(fs)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Open(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine (): INTEGER;
VAR
param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName (): INTEGER;
VAR
name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, name, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: 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
END ChangeCond;
BEGIN
p := GetCommandLine();
name := GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); 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 GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := K.sysfunc4(30, 2, SYSTEM.ADR(path[0]), LEN(path) - 2);
path[n - 1] := slash;
path[n] := 0X
END GetCurrentDirectory;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
VAR
date, time, year, month, day, hour, min, sec: INTEGER;
BEGIN
date := K.sysfunc1(29);
time := K.sysfunc1(3);
year := date MOD 16;
date := date DIV 16;
year := (date MOD 16) * 10 + year;
date := date DIV 16;
month := date MOD 16;
date := date DIV 16;
month := (date MOD 16) * 10 + month;
date := date DIV 16;
day := date MOD 16;
date := date DIV 16;
day := (date MOD 16) * 10 + day;
date := date DIV 16;
hour := time MOD 16;
time := time DIV 16;
hour := (time MOD 16) * 10 + hour;
time := time DIV 16;
min := time MOD 16;
time := time DIV 16;
min := (time MOD 16) * 10 + min;
time := time DIV 16;
sec := time MOD 16;
time := time DIV 16;
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
INC(year, 2000)
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 UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET32(SYSTEM.ADR(x), a);
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
e := splitf(x, l, 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 init (VAR days: DAYS);
VAR
i, j, 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 i := 0 TO 1 DO
days[ 1, 29, i] := -1;
days[ 1, 30, i] := -1;
days[ 3, 30, i] := -1;
days[ 5, 30, i] := -1;
days[ 8, 30, i] := -1;
days[10, 30, i] := -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;
inf := SYSTEM.INF();
maxreal := 1.9;
PACK(maxreal, 1023);
Console := TRUE;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END init;
BEGIN
init(days)
END HOST.

282
programs/develop/oberon07/lib/KolibriOS/In.ob07 Normal file
View File

@@ -0,0 +1,282 @@
(*
Copyright 2016, 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, ConsoleLib;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done* : BOOLEAN;
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 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): 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 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): 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 res, m: REAL; VAR scale: INTEGER);
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(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN
part3(err, minus, res, m, scale)
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 res, length: INTEGER; str: STRING;
BEGIN
res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str));
length := LENGTH(str);
IF length > 0 THEN
str[length - 1] := 0X
END;
COPY(str, s);
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
Done := TRUE
END Open;
END In.

436
programs/develop/oberon07/lib/KolibriOS/KOSAPI.ob07 Normal file
View File

@@ -0,0 +1,436 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2019, 2022 Anton Krotov
All rights reserved.
*)
MODULE KOSAPI;
IMPORT SYSTEM;
TYPE
STRING = ARRAY 1024 OF CHAR;
VAR
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
0C9H, (* leave *)
0C2H, 004H, 000H (* ret 4 *)
)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall-] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall-] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 16 *)
)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0CDH, 040H, (* int 64 *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
RETURN 0
END sysfunc5;
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 040H, (* int 64 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END sysfunc6;
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
055H, (* push ebp *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *)
0CDH, 040H, (* int 64 *)
05DH, (* pop ebp *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 01CH, 000H (* ret 28 *)
)
RETURN 0
END sysfunc7;
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 019H, (* mov dword [ecx], ebx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc22;
PROCEDURE mem_commit (adr, size: INTEGER);
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE [stdcall] malloc* (size: INTEGER): INTEGER;
VAR
ptr: INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
mem_commit(ptr, size)
END
ELSE
ptr := 0
END;
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END malloc;
PROCEDURE [stdcall] free* (ptr: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
SYSTEM.CODE(061H) (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc* (ptr, size: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END realloc;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine* (): INTEGER;
VAR
param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName* (): INTEGER;
VAR
name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE [stdcall] dll_init2 (arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
SYSTEM.CODE(
060H, (* pusha *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0FFH, 0D6H, (* call esi *)
061H, (* popa *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
END dll_init2;
PROCEDURE GetProcAdr* (name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR
cur, procname, adr: INTEGER;
PROCEDURE streq (str1, str2: INTEGER): BOOLEAN;
VAR
c1, c2: CHAR;
BEGIN
REPEAT
SYSTEM.GET(str1, c1);
SYSTEM.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
SYSTEM.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0]));
IF procname # 0 THEN
SYSTEM.GET(cur - 4, adr)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE init (dll: INTEGER);
VAR
lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END
END init;
PROCEDURE OutChar* (c: CHAR);
BEGIN
sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE OutLn*;
BEGIN
OutChar(0DX);
OutChar(0AX)
END OutLn;
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
OutChar(s[i]);
INC(i)
END
END OutString;
PROCEDURE imp_error (lib, proc: STRING);
BEGIN
OutString("import error: ");
IF proc = "" THEN
OutString("can't load '")
ELSE
OutString("not found '"); OutString(proc); OutString("' in '")
END;
OutString(lib);
OutString("'" + 0DX + 0AX)
END imp_error;
PROCEDURE GetStr (adr, i: INTEGER; VAR str: STRING);
VAR
c: CHAR;
BEGIN
REPEAT
SYSTEM.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
PROCEDURE [stdcall-] dll_Load* (import_table: INTEGER): INTEGER;
CONST
path = "/sys/lib/";
VAR
imp, lib, exp, proc, pathLen: INTEGER;
procname, libname: STRING;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
libname := path;
pathLen := LENGTH(libname);
SYSTEM.GET(import_table, imp);
WHILE imp # 0 DO
SYSTEM.GET(import_table + 4, lib);
GetStr(lib, pathLen, libname);
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0]));
IF exp = 0 THEN
imp_error(libname, "")
ELSE
REPEAT
SYSTEM.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
SYSTEM.PUT(imp, proc)
ELSE
proc := 1;
imp_error(libname, procname)
END;
INC(imp, 4)
END
UNTIL proc = 0;
init(exp)
END;
INC(import_table, 8);
SYSTEM.GET(import_table, imp);
END;
SYSTEM.CODE(061H) (* popa *)
RETURN 0
END dll_Load;
PROCEDURE [stdcall] dll_Init (entry: INTEGER);
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF entry # 0 THEN
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry)
END;
SYSTEM.CODE(061H); (* popa *)
END dll_Init;
PROCEDURE LoadLib* (name: ARRAY OF CHAR): INTEGER;
VAR
Lib: INTEGER;
BEGIN
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
END LoadLib;
PROCEDURE _init* (import_table: INTEGER);
BEGIN
DLL_INIT := dll_Init;
dll_Load(import_table)
END _init;
END KOSAPI.

449
programs/develop/oberon07/lib/KolibriOS/Math.ob07 Normal file
View File

@@ -0,0 +1,449 @@
(*
BSD 2-Clause License
Copyright (c) 2013-2014, 2018-2022 Anton Krotov
All rights reserved.
*)
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 sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
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 := 1.0 - 2.0 / (exp(2.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 ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
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 DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

107
programs/develop/oberon07/lib/KolibriOS/NetDevices.ob07 Normal file
View File

@@ -0,0 +1,107 @@
(*
Copyright 2017 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 NetDevices;
IMPORT sys := SYSTEM, K := KOSAPI;
CONST
//net devices types
LOOPBACK* = 0;
ETH* = 1;
SLIP* = 2;
//Link status
LINK_DOWN* = 0;
LINK_UNKNOWN* = 1;
LINK_FD* = 2; //full duplex flag
LINK_10M* = 4;
LINK_100M* = 8;
LINK_1G* = 12;
TYPE
DEVICENAME* = ARRAY 64 OF CHAR;
PROCEDURE Number* (): INTEGER;
RETURN K.sysfunc2(74, -1)
END Number;
PROCEDURE Type* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256)
END Type;
PROCEDURE Name* (num: INTEGER; VAR name: DEVICENAME): BOOLEAN;
VAR err: BOOLEAN;
BEGIN
err := K.sysfunc3(74, num * 256 + 1, sys.ADR(name[0])) = -1;
IF err THEN
name := ""
END
RETURN ~err
END Name;
PROCEDURE Reset* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 2) # -1
END Reset;
PROCEDURE Stop* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 3) # -1
END Stop;
PROCEDURE Pointer* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 4)
END Pointer;
PROCEDURE SentPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 6)
END SentPackets;
PROCEDURE ReceivedPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 7)
END ReceivedPackets;
PROCEDURE SentBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 8, hValue)
END SentBytes;
PROCEDURE ReceivedBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 9, hValue)
END ReceivedBytes;
PROCEDURE LinkStatus* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 10)
END LinkStatus;
END NetDevices.

158
programs/develop/oberon07/lib/KolibriOS/OpenDlg.ob07 Normal file
View File

@@ -0,0 +1,158 @@
(*
Copyright 2016, 2018, 2020-2022 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 OpenDlg;
IMPORT sys := SYSTEM, KOSAPI;
CONST
topen* = 0;
tsave* = 1;
tdir* = 2;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
_type*,
procinfo,
com_area_name,
com_area,
opendir_path,
dir_default_path,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
openfile_path,
filename_area: INTEGER;
filter_area:
POINTER TO RECORD
size: INTEGER;
filter: ARRAY 4096 OF CHAR
END;
X, Y: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR;
s_opendir_path,
s_dir_default_path,
FilePath*,
FileName*: ARRAY 4096 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (od: Dialog);
PROCEDURE Show*(od: Dialog; Width, Height: INTEGER);
BEGIN
IF od # NIL THEN
od.X := Width;
od.Y := Height;
Dialog_start(od)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; _type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
VAR res: Dialog; n, i: INTEGER;
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR);
VAR i: INTEGER;
BEGIN
i := LENGTH(str) - 1;
WHILE i >= 0 DO
IF str[i] = c1 THEN
str[i] := c2
END;
DEC(i)
END
END replace;
BEGIN
NEW(res);
IF res # NIL THEN
NEW(res.filter_area);
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res._type := _type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);
n := LENGTH(res.filter_area.filter);
FOR i := 0 TO 3 DO
res.filter_area.filter[n + i] := "|"
END;
res.filter_area.filter[n + 4] := 0X;
res.X := 0;
res.Y := 0;
res.s_opendir_path := res.s_dir_default_path;
res.FilePath := "";
res.FileName := "";
res.status := 0;
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/sys/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
res.filename_area := sys.ADR(res.FileName[0]);
replace(res.filter_area.filter, "|", 0X);
Dialog_init(res)
ELSE
DISPOSE(res)
END
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR od: Dialog);
BEGIN
IF od # NIL THEN
DISPOSE(od.filter_area);
DISPOSE(od)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/sys/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN
Load
END OpenDlg.

267
programs/develop/oberon07/lib/KolibriOS/Out.ob07 Normal file
View File

@@ -0,0 +1,267 @@
(*
Copyright 2016, 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 ConsoleLib, sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(c), 1)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s))
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(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
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;
Realp := Real;
_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.

543
programs/develop/oberon07/lib/KolibriOS/RTL.ob07 Normal file
View File

@@ -0,0 +1,543 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
minint = ROR(1, 1);
WORD = API.BIT_DEPTH DIV 8;
VAR
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _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 [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall] _rot* (Len, Ptr: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- Len *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- Ptr *)
049H, (* dec ecx *)
053H, (* push ebx *)
08BH, 018H, (* mov ebx, dword [eax] *)
(* L: *)
08BH, 050H, 004H, (* mov edx, dword [eax + 4] *)
089H, 010H, (* mov dword [eax], edx *)
083H, 0C0H, 004H, (* add eax, 4 *)
049H, (* dec ecx *)
075H, 0F5H, (* jnz L *)
089H, 018H, (* mov dword [eax], ebx *)
05BH, (* pop ebx *)
05DH, (* pop ebp *)
0C2H, 008H, 000H (* ret 8 *)
)
END _rot;
PROCEDURE [stdcall] _set* (b, a: INTEGER); (* {a..b} -> eax *)
BEGIN
SYSTEM.CODE(
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- b *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- a *)
039H, 0C8H, (* cmp eax, ecx *)
07FH, 033H, (* jg L1 *)
083H, 0F8H, 01FH, (* cmp eax, 31 *)
07FH, 02EH, (* jg L1 *)
085H, 0C9H, (* test ecx, ecx *)
07CH, 02AH, (* jl L1 *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
07EH, 005H, (* jle L3 *)
0B9H, 01FH, 000H, 000H, 000H, (* mov ecx, 31 *)
(* L3: *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L2 *)
031H, 0C0H, (* xor eax, eax *)
(* L2: *)
089H, 0CAH, (* mov edx, ecx *)
029H, 0C2H, (* sub edx, eax *)
0B8H, 000H, 000H, 000H, 080H, (* mov eax, 0x80000000 *)
087H, 0CAH, (* xchg edx, ecx *)
0D3H, 0F8H, (* sar eax, cl *)
087H, 0CAH, (* xchg edx, ecx *)
083H, 0E9H, 01FH, (* sub ecx, 31 *)
0F7H, 0D9H, (* neg ecx *)
0D3H, 0E8H, (* shr eax, cl *)
05DH, (* pop ebp *)
0C2H, 008H, 000H, (* ret 8 *)
(* L1: *)
031H, 0C0H, (* xor eax, eax *)
05DH, (* pop ebp *)
0C2H, 008H, 000H (* ret 8 *)
)
END _set;
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
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;
PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *)
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- x *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
074H, 018H, (* je L2 *)
07FH, 002H, (* jg L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
089H, 0C3H, (* mov ebx, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- y *)
0F7H, 0F9H, (* idiv ecx *)
085H, 0D2H, (* test edx, edx *)
074H, 009H, (* je L2 *)
031H, 0CBH, (* xor ebx, ecx *)
085H, 0DBH, (* test ebx, ebx *)
07DH, 003H, (* jge L2 *)
048H, (* dec eax *)
001H, 0CAH, (* add edx, ecx *)
(* L2: *)
05BH (* pop ebx *)
)
END _divmod;
PROCEDURE [stdcall] _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 [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH (* sub eax, dword [ebp + 0Ch] *)
)
END _length;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H (* shr eax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 017H, (* jle L3 *)
08AH, 00EH, (* mov cl, byte[esi] *)
08AH, 017H, (* mov dl, byte[edi] *)
046H, (* inc esi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E7H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 01BH, (* jle L3 *)
066H, 08BH, 00EH, (* mov cx, word[esi] *)
066H, 08BH, 017H, (* mov dx, word[edi] *)
046H, (* inc esi *)
046H, (* inc esi *)
047H, (* inc edi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E3H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall] _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 [stdcall] _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: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (modnum, _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 + "module: "); PCharToStr(_module, temp); append(s, temp);
append(s, API.eol + "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _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 [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _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 [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
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;
name := modname
END _init;
END RTL.

124
programs/develop/oberon07/lib/KolibriOS/RasterWorks.ob07 Normal file
View File

@@ -0,0 +1,124 @@
(*
Copyright 2016, 2018, 2022 KolibriOS team
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 RasterWorks;
IMPORT sys := SYSTEM, KOSAPI;
CONST
(* flags *)
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
align_right *= 16;
align_center *= 32;
bpp32 *= 128;
(* encoding *)
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
VAR
// draw text on 24bpp or 32bpp image
// autofits text between 'x' and 'xSize'
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER;
(*
[canvas]:
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
params dd ffeewwhh
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
returns: char width (0 = error)
*)
// calculate amount of valid chars in UTF-8 string
// supports zero terminated string (set byteQuantity = -1)
countUTF8Z *: PROCEDURE (string, byteQuantity: INTEGER): INTEGER;
// calculate amount of chars that fits given width
charsFit *: PROCEDURE (areaWidth, charHeight: INTEGER): INTEGER;
// calculate string width in pixels
strWidth *: PROCEDURE (charQuantity, charHeight: INTEGER): INTEGER;
PROCEDURE params* (charHeight, charWidth, encoding, flags: INTEGER): INTEGER;
(*
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
*)
RETURN charHeight + LSL(charWidth, 8) + LSL(encoding, 16) + LSL(flags, 24)
END params;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/sys/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(drawText), "drawText");
GetProc(Lib, sys.ADR(countUTF8Z), "countUTF8Z");
GetProc(Lib, sys.ADR(charsFit), "charsFit");
GetProc(Lib, sys.ADR(strWidth), "strWidth");
END main;
BEGIN
main
END RasterWorks.

46
programs/develop/oberon07/lib/KolibriOS/Read.ob07 Normal file
View File

@@ -0,0 +1,46 @@
(*
Copyright 2016, 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 Read;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; VAR x: CHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; VAR x: INTEGER): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; VAR x: REAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; VAR x: SET): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE WChar*(F: File.FS; VAR x: WCHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR)
END WChar;
END Read.

64
programs/develop/oberon07/lib/KolibriOS/UnixTime.ob07 Normal file
View File

@@ -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.

121
programs/develop/oberon07/lib/KolibriOS/Vector.ob07 Normal file
View File

@@ -0,0 +1,121 @@
(*
Copyright 2016 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 Vector;
IMPORT sys := SYSTEM, K := KOSAPI;
TYPE
DESC_VECTOR = RECORD
data : INTEGER;
count : INTEGER;
size : INTEGER
END;
VECTOR* = POINTER TO DESC_VECTOR;
ANYREC* = RECORD END;
ANYPTR* = POINTER TO ANYREC;
DESTRUCTOR* = PROCEDURE (VAR ptr: ANYPTR);
PROCEDURE count* (vector: VECTOR): INTEGER;
BEGIN
ASSERT(vector # NIL)
RETURN vector.count
END count;
PROCEDURE push* (vector: VECTOR; value: ANYPTR);
BEGIN
ASSERT(vector # NIL);
IF vector.count = vector.size THEN
vector.data := K.realloc(vector.data, (vector.size + 1024) * 4);
ASSERT(vector.data # 0);
vector.size := vector.size + 1024
END;
sys.PUT(vector.data + vector.count * 4, value);
INC(vector.count)
END push;
PROCEDURE get* (vector: VECTOR; idx: INTEGER): ANYPTR;
VAR res: ANYPTR;
BEGIN
ASSERT(vector # NIL);
ASSERT( (0 <= idx) & (idx < vector.count) );
sys.GET(vector.data + idx * 4, res)
RETURN res
END get;
PROCEDURE put* (vector: VECTOR; idx: INTEGER; value: ANYPTR);
BEGIN
ASSERT(vector # NIL);
ASSERT( (0 <= idx) & (idx < vector.count) );
sys.PUT(vector.data + idx * 4, value)
END put;
PROCEDURE create* (size: INTEGER): VECTOR;
VAR vector: VECTOR;
BEGIN
NEW(vector);
IF vector # NIL THEN
vector.data := K.malloc(4 * size);
IF vector.data # 0 THEN
vector.size := size;
vector.count := 0
ELSE
DISPOSE(vector)
END
END
RETURN vector
END create;
PROCEDURE def_destructor (VAR any: ANYPTR);
BEGIN
DISPOSE(any)
END def_destructor;
PROCEDURE destroy* (VAR vector: VECTOR; destructor: DESTRUCTOR);
VAR i: INTEGER;
any: ANYPTR;
BEGIN
ASSERT(vector # NIL);
IF destructor = NIL THEN
destructor := def_destructor
END;
FOR i := 0 TO vector.count - 1 DO
any := get(vector, i);
destructor(any)
END;
vector.data := K.free(vector.data);
DISPOSE(vector)
END destroy;
END Vector.

46
programs/develop/oberon07/lib/KolibriOS/Write.ob07 Normal file
View File

@@ -0,0 +1,46 @@
(*
Copyright 2016, 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 Write;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; x: CHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; x: INTEGER): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; x: REAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; x: SET): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE WChar*(F: File.FS; x: WCHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR)
END WChar;
END Write.

492
programs/develop/oberon07/lib/KolibriOS/kfonts.ob07 Normal file
View File

@@ -0,0 +1,492 @@
(*
Copyright 2016, 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 kfonts;
IMPORT sys := SYSTEM, File, KOSAPI;
CONST
MIN_FONT_SIZE = 8;
MAX_FONT_SIZE = 46;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
smoothing *= 16;
bpp32 *= 32;
TYPE
Glyph = RECORD
base: INTEGER;
xsize, ysize: INTEGER;
width: INTEGER
END;
TFont_desc = RECORD
data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER;
glyphs: ARRAY 4, 256 OF Glyph
END;
TFont* = POINTER TO TFont_desc;
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.PUT(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3)
END
END
END pset;
PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR xsize, ysize, color: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.GET(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3)
END
END
RETURN color
END pget;
PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER);
BEGIN
b := LSR(LSL(color, 24), 24);
g := LSR(LSL(color, 16), 24);
r := LSR(LSL(color, 8), 24);
END getrgb;
PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
RETURN b + LSL(g, 8) + LSL(r, 16)
END rgb;
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
BEGIN
glyph.base := Font.mempos;
glyph.xsize := xsize;
glyph.ysize := ysize;
Font.mempos := Font.mempos + xsize * ysize
END create_glyph;
PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(Font.mem + n + x + y * xsize, res)
RETURN res
END getpix;
PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR);
BEGIN
sys.PUT(Font.mem + n + x + y * xsize, c)
END setpix;
PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER);
VAR x, y: INTEGER;
BEGIN
FOR y := 1 TO ysize - 1 DO
FOR x := 1 TO xsize - 1 DO
IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) &
(getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN
setpix(Font, n, x - 1, y, xsize, 2X);
setpix(Font, n, x, y - 1, xsize, 2X)
END;
IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) &
(getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN
setpix(Font, n, x, y, xsize, 2X);
setpix(Font, n, x - 1, y - 1, xsize, 2X)
END
END
END
END smooth;
PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER);
VAR i, j, k: INTEGER; pix: CHAR;
BEGIN
FOR i := 0 TO src_xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, src, i, j, src_xsize);
IF pix = 1X THEN
FOR k := 0 TO n DO
setpix(Font, dst, i + k, j, dst_xsize, pix)
END
END
END
END
END _bold;
PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER);
VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN;
glyph: Glyph; pix: CHAR; bold_width: INTEGER;
BEGIN
create_glyph(Font, glyph, Font.width, Font.height);
x := 0;
y := 0;
max := 0;
ptr := Font.font + Font.char_size * c;
eoc := FALSE;
REPEAT
sys.GET(ptr, s);
INC(ptr, 4);
FOR i := 0 TO 31 DO
IF ~eoc THEN
IF i IN s THEN
setpix(Font, glyph.base, x, y, Font.width, 1X);
IF x > max THEN
max := x
END
ELSE
setpix(Font, glyph.base, x, y, Font.width, 0X)
END
END;
INC(x);
IF x = Font.width THEN
x := 0;
INC(y);
eoc := eoc OR (y = Font.height)
END
END
UNTIL eoc;
IF max = 0 THEN
max := Font.width DIV 3
END;
glyph.width := max;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
Font.glyphs[0, c] := glyph;
bold_width := 1;
create_glyph(Font, glyph, Font.width + bold_width, Font.height);
_bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[1, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height);
FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize);
IF pix = 1X THEN
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
END
END
END;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max;
Font.glyphs[2, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height);
_bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[3, c] := glyph;
END make_glyph;
PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER;
VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph;
BEGIN
x0 := x;
y0 := y;
style := style MOD 4;
glyph := Font.glyphs[style, c];
xsize := glyph.xsize;
xmax := x0 + xsize;
mem := Font.mem + glyph.base;
getrgb(color, r0, g0, b0);
FOR i := mem TO mem + xsize * Font.height - 1 DO
sys.GET(i, ch);
IF ch = 1X THEN
pset(buf, x, y, color, bpp32);
ELSIF (ch = 2X) & smoothing THEN
getrgb(pget(buf, x, y, bpp32), r, g, b);
r := (r * 3 + r0) DIV 4;
g := (g * 3 + g0) DIV 4;
b := (b * 3 + b0) DIV 4;
pset(buf, x, y, rgb(r, g, b), bpp32)
END;
INC(x);
IF x = xmax THEN
x := x0;
INC(y)
END
END
RETURN glyph.width
END OutChar;
PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := x TO x + width - 1 DO
pset(buf, i, y, color, bpp32)
END
END hline;
PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER;
VAR res: INTEGER; c: CHAR;
BEGIN
res := 0;
params := params MOD 4;
IF Font # NIL THEN
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
res := res + Font.glyphs[params, ORD(c)].width;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END
END
RETURN res
END TextWidth;
PROCEDURE TextHeight*(Font: TFont): INTEGER;
VAR res: INTEGER;
BEGIN
IF Font # NIL THEN
res := Font.height
ELSE
res := 0
END
RETURN res
END TextHeight;
PROCEDURE TextClipLeft(Font: TFont; str, length, params: INTEGER; VAR x: INTEGER): INTEGER;
VAR x1: INTEGER; c: CHAR;
BEGIN
params := params MOD 4;
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
x1 := x;
x := x + Font.glyphs[params, ORD(c)].width;
IF x > 0 THEN
length := 0;
END;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END;
x := x1
RETURN str - 1
END TextClipLeft;
PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER);
VAR width, xsize, ysize, str1, n: INTEGER; c: CHAR; bpp32, smoothing, underline, strike: BOOLEAN;
BEGIN
IF Font # NIL THEN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
IF (y <= -TextHeight(Font)) OR (y >= ysize) THEN
length := 0
END;
IF length # 0 THEN
smoothing := 4 IN BITS(params);
bpp32 := 5 IN BITS(params);
underline := 2 IN BITS(params);
strike := 3 IN BITS(params);
str1 := TextClipLeft(Font, str, length, params, x);
n := str1 - str;
str := str1;
IF length >= n THEN
length := length - n
END;
sys.GET(str, c)
END;
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
IF strike THEN
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32)
END;
IF underline THEN
hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32)
END;
x := x + width;
IF x > xsize THEN
length := 0
END;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END
END
END TextOut;
PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN;
VAR temp, offset, fsize, i, memsize, mem: INTEGER;
c: CHAR; Font, Font2: TFont_desc;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN
Font := _Font^;
Font2 := Font;
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset);
IF offset # -1 THEN
Font.font_size := font_size;
INC(offset, 156);
offset := offset + Font.data;
IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN
sys.GET(offset, fsize);
IF fsize > 256 + 6 THEN
temp := offset + fsize - 1;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN
sys.GET(temp, c);
IF c # 0X THEN
Font.height := ORD(c);
DEC(temp);
sys.GET(temp, c);
IF c # 0X THEN
Font.width := ORD(c);
DEC(fsize, 6);
Font.char_size := fsize DIV 256;
IF fsize MOD 256 # 0 THEN
INC(Font.char_size)
END;
IF Font.char_size > 0 THEN
Font.font := offset + 4;
Font.mempos := 0;
memsize := (Font.width + 10) * Font.height * 1024;
mem := Font.mem;
Font.mem := KOSAPI.sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := KOSAPI.sysfunc3(68, 13, mem)
END;
zeromem(memsize DIV 4, Font.mem);
FOR i := 0 TO 255 DO
make_glyph(Font, i)
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
END;
ELSE
offset := -1
END;
IF offset # -1 THEN
_Font^ := Font
ELSE
_Font^ := Font2
END
END
RETURN offset # -1
END SetSize;
PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN;
VAR offset, temp: INTEGER;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset)
END
END
RETURN offset # -1
END Enabled;
PROCEDURE Destroy*(VAR Font: TFont);
BEGIN
IF Font # NIL THEN
IF Font.mem # 0 THEN
Font.mem := KOSAPI.sysfunc3(68, 13, Font.mem)
END;
IF Font.data # 0 THEN
Font.data := KOSAPI.sysfunc3(68, 13, Font.data)
END;
DISPOSE(Font)
END
END Destroy;
PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont;
VAR Font: TFont; data, size, n: INTEGER;
BEGIN
data := File.Load(file_name, size);
IF (data # 0) & (size > 156) THEN
NEW(Font);
Font.data := data;
Font.size := size;
Font.font_size := 0;
n := MIN_FONT_SIZE;
WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO
INC(n)
END;
IF Font.font_size = 0 THEN
Destroy(Font)
END
ELSE
IF data # 0 THEN
data := KOSAPI.sysfunc3(68, 13, data)
END;
Font := NIL
END
RETURN Font
END LoadFont;
END kfonts.

435
programs/develop/oberon07/lib/KolibriOS/libimg.ob07 Normal file
View File

@@ -0,0 +1,435 @@
(*
Copyright 2016, 2018, 2020, 2022 KolibriOS team
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 libimg;
IMPORT sys := SYSTEM, KOSAPI;
CONST
FLIP_VERTICAL *= 1;
FLIP_HORIZONTAL *= 2;
ROTATE_90_CW *= 1;
ROTATE_180 *= 2;
ROTATE_270_CW *= 3;
ROTATE_90_CCW *= ROTATE_270_CW;
ROTATE_270_CCW *= ROTATE_90_CW;
// scale type corresponding img_scale params
LIBIMG_SCALE_INTEGER *= 1; // scale factor ; reserved 0
LIBIMG_SCALE_TILE *= 2; // new width ; new height
LIBIMG_SCALE_STRETCH *= 3; // new width ; new height
LIBIMG_SCALE_FIT_RECT *= 4; // new width ; new height
LIBIMG_SCALE_FIT_WIDTH *= 5; // new width ; new height
LIBIMG_SCALE_FIT_HEIGHT *= 6; // new width ; new height
LIBIMG_SCALE_FIT_MAX *= 7; // new width ; new height
// interpolation algorithm
LIBIMG_INTER_NONE *= 0; // use it with LIBIMG_SCALE_INTEGER, LIBIMG_SCALE_TILE, etc
LIBIMG_INTER_BILINEAR *= 1;
LIBIMG_INTER_DEFAULT *= LIBIMG_INTER_BILINEAR;
// list of format id's
LIBIMG_FORMAT_BMP *= 1;
LIBIMG_FORMAT_ICO *= 2;
LIBIMG_FORMAT_CUR *= 3;
LIBIMG_FORMAT_GIF *= 4;
LIBIMG_FORMAT_PNG *= 5;
LIBIMG_FORMAT_JPEG *= 6;
LIBIMG_FORMAT_TGA *= 7;
LIBIMG_FORMAT_PCX *= 8;
LIBIMG_FORMAT_XCF *= 9;
LIBIMG_FORMAT_TIFF *= 10;
LIBIMG_FORMAT_PNM *= 11;
LIBIMG_FORMAT_WBMP *= 12;
LIBIMG_FORMAT_XBM *= 13;
LIBIMG_FORMAT_Z80 *= 14;
// encode flags (byte 0x02 of common option)
LIBIMG_ENCODE_STRICT_SPECIFIC *= 01H;
LIBIMG_ENCODE_STRICT_BIT_DEPTH *= 02H;
LIBIMG_ENCODE_DELETE_ALPHA *= 08H;
LIBIMG_ENCODE_FLUSH_ALPHA *= 10H;
// values for Image.Type
// must be consecutive to allow fast switch on Image.Type in support functions
bpp8i *= 1; // indexed
bpp24 *= 2;
bpp32 *= 3;
bpp15 *= 4;
bpp16 *= 5;
bpp1 *= 6;
bpp8g *= 7; // grayscale
bpp2i *= 8;
bpp4i *= 9;
bpp8a *= 10; // grayscale with alpha channel; application layer only!!! kernel doesn't handle this image type, libimg can only create and destroy such images
// bits in Image.Flags
IsAnimated *= 1;
TYPE
Image* = RECORD
Checksum *: INTEGER;
Width *: INTEGER;
Height *: INTEGER;
Next *: INTEGER;
Previous *: INTEGER;
Type *: INTEGER; // one of bppN
Data *: INTEGER;
Palette *: INTEGER; // used iff Type eq bpp1, bpp2, bpp4 or bpp8i
Extended *: INTEGER;
Flags *: INTEGER; // bitfield
Delay *: INTEGER // used iff IsAnimated is set in Flags
END;
ImageDecodeOptions* = RECORD
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on
BackgroundColor *: INTEGER // used for transparent images as background
END;
FormatsTableEntry* = RECORD
Format_id *: INTEGER;
Is *: INTEGER;
Decode *: INTEGER;
Encode *: INTEGER;
Capabilities *: INTEGER
END;
VAR
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER;
img_to_rgb2 *: PROCEDURE (img: INTEGER; out: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and stores them where out points to ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;> out = where to store RGB triplets ;;
;;================================================================================================;;
*)
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and returns pointer to memory area containing them ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to rgb_data (array of [rgb] triplets) ;;
;;================================================================================================;;
*)
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes loaded into memory graphic file ;;
;;------------------------------------------------------------------------------------------------;;
;> data = pointer to file in memory ;;
;> length = size in bytes of memory area pointed to by data ;;
;> options = 0 / pointer to the structure of additional options ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? encode image to some format ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to input image ;;
;> common = some most important options ;;
; 0x00 : byte : format id ;;
; 0x01 : byte : fast encoding (0) / best compression ratio (255) ;;
; 0 : store uncompressed data (if supported both by the format and libimg) ;;
; 1 - 255 : use compression, if supported ;;
; this option may be ignored if any format specific options are defined ;;
; i.e. the 0 here will be ignored if some compression algorithm is specified ;;
; 0x02 : byte : flags (bitfield) ;;
; 0x01 : return an error if format specific conditions cannot be met ;;
; 0x02 : preserve current bit depth. means 8bpp/16bpp/24bpp and so on ;;
; 0x04 : delete alpha channel, if any ;;
; 0x08 : flush alpha channel with 0xff, if any; add it if none ;;
; 0x03 : byte : reserved, must be 0 ;;
;> specific = 0 / pointer to the structure of format specific options ;;
; see <format_name>.inc for description ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to encoded data ;;
;;================================================================================================;;
*)
img_create *: PROCEDURE (width, height, _type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;
;;------------------------------------------------------------------------------------------------;;
;> width = width of an image in pixels ;;
;> height = height of an image in pixels ;;
;> type = one of the bppN constants ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_destroy *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? follows Previous/Next pointers and deletes all the images in sequence ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_destroy_layer *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? for image sequences deletes only one frame and fixes Previous/Next pointers ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_count *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? Get number of images in the list (e.g. in animated GIF file) ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< -1 (fail) / >0 (ok) ;;
;;================================================================================================;;
*)
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_flip_layer *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate_layer *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? Draw image in the window ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> x = x-coordinate in the window ;;
;> y = y-coordinate in the window ;;
;> width = maximum width to draw ;;
;> height = maximum height to draw ;;
;> xpos = offset in image by x-axis ;;
;> ypos = offset in image by y-axis ;;
;;================================================================================================;;
*)
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> crop_x = left coord of cropping rect ;;
;> crop_y = top coord of cropping rect ;;
;> crop_width = width of cropping rect ;;
;> crop_height = height of cropping rect ;;
;> dst = pointer to resulting image / 0 ;;
;> scale = how to change width and height. see libimg.inc ;;
;> inter = interpolation algorithm ;;
;> param1 = see libimg.inc ;;
;> param2 = see libimg.inc ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to scaled image ;;
;;================================================================================================;;
*)
img_convert *: PROCEDURE (src, dst: INTEGER; dst_type, flags, param: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> flags = see libimg.inc ;;
;> dst_type = the Image.Type of converted image ;;
;> dst = pointer to destination image, if any ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to converted image ;;
;;================================================================================================;;
*)
img_formats_table *: ARRAY 20 OF FormatsTableEntry;
PROCEDURE GetImageStruct* (img: INTEGER; VAR ImageStruct: Image): BOOLEAN;
BEGIN
IF img # 0 THEN
sys.MOVE(img, sys.ADR(ImageStruct), sys.SIZE(Image))
END
RETURN img # 0
END GetImageStruct;
PROCEDURE GetFormatsTable(ptr: INTEGER);
VAR i: INTEGER; eot: BOOLEAN;
BEGIN
i := 0;
REPEAT
sys.MOVE(ptr, sys.ADR(img_formats_table[i]), sys.SIZE(FormatsTableEntry));
ptr := ptr + sys.SIZE(FormatsTableEntry);
eot := img_formats_table[i].Format_id = 0;
INC(i)
UNTIL eot OR (i = LEN(img_formats_table))
END GetFormatsTable;
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/sys/lib/libimg.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img");
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(Lib, sys.ADR(img_decode) , "img_decode");
GetProc(Lib, sys.ADR(img_encode) , "img_encode");
GetProc(Lib, sys.ADR(img_create) , "img_create");
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy");
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(Lib, sys.ADR(img_count) , "img_count");
GetProc(Lib, sys.ADR(img_flip) , "img_flip");
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate");
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(Lib, sys.ADR(img_draw) , "img_draw");
GetProc(Lib, sys.ADR(img_scale) , "img_scale");
GetProc(Lib, sys.ADR(img_convert) , "img_convert");
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table");
GetFormatsTable(formats_table_ptr)
END main;
BEGIN
main
END libimg.

462
programs/develop/oberon07/lib/Math/CMath.ob07 Normal file
View File

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

33
programs/develop/oberon07/lib/Math/MathBits.ob07 Normal file
View File

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

99
programs/develop/oberon07/lib/Math/MathRound.ob07 Normal file
View File

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

238
programs/develop/oberon07/lib/Math/MathStat.ob07 Normal file
View File

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

81
programs/develop/oberon07/lib/Math/Rand.ob07 Normal file
View File

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

298
programs/develop/oberon07/lib/Math/RandExt.ob07 Normal file
View File

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

5
programs/develop/oberon07/samples/BUILD_ALL.SH Normal file
View File

@@ -0,0 +1,5 @@
#SHS
/kolibrios/develop/oberon07/compiler.kex HW.ob07 kosexe -out /tmp0/1/HW.kex -stk 1
/kolibrios/develop/oberon07/compiler.kex HW_con.ob07 kosexe -out /tmp0/1/HW_con.kex -stk 1
/kolibrios/develop/oberon07/compiler.kex Dialogs.ob07 kosexe -out /tmp0/1/Dialogs.kex -stk 1
exit

159
programs/develop/oberon07/samples/Dialogs.ob07 Normal file
View File

@@ -0,0 +1,159 @@
MODULE Dialogs;
IMPORT
KOSAPI, SYSTEM, OpenDlg, ColorDlg;
CONST
btnNone = 0;
btnClose = 1;
btnOpen = 17;
btnColor = 18;
VAR
header: ARRAY 1024 OF CHAR;
back_color: INTEGER;
PROCEDURE BeginDraw;
BEGIN
KOSAPI.sysfunc2(12, 1)
END BeginDraw;
PROCEDURE EndDraw;
BEGIN
KOSAPI.sysfunc2(12, 2)
END EndDraw;
PROCEDURE DefineAndDrawWindow (left, top, width, height, color, style, hcolor, hstyle: INTEGER; header: ARRAY OF CHAR);
BEGIN
KOSAPI.sysfunc6(0, left*65536 + width, top*65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), SYSTEM.ADR(header[0]))
END DefineAndDrawWindow;
PROCEDURE WaitForEvent (): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
BEGIN
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE pause (t: INTEGER);
BEGIN
KOSAPI.sysfunc2(5, t)
END pause;
PROCEDURE Buttons;
PROCEDURE Button (id, X, Y, W, H: INTEGER; Caption: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := LENGTH(Caption);
KOSAPI.sysfunc5(8, X*65536 + W, Y*65536 + H, id, 00C0C0C0H);
X := X + (W - 8*n) DIV 2;
Y := Y + (H - 14) DIV 2;
KOSAPI.sysfunc6(4, X*65536 + Y, LSL(48, 24), SYSTEM.ADR(Caption[0]), n, 0)
END Button;
BEGIN
Button(btnOpen, 5, 5, 70, 25, "open");
Button(btnColor, 85, 5, 70, 25, "color");
END Buttons;
PROCEDURE draw_window;
BEGIN
BeginDraw;
DefineAndDrawWindow(200, 200, 500, 100, back_color, 51, 0, 0, header);
Buttons;
EndDraw;
END draw_window;
PROCEDURE OpenFile (Open: OpenDlg.Dialog);
BEGIN
IF Open # NIL THEN
OpenDlg.Show(Open, 500, 450);
WHILE Open.status = 2 DO
pause(30)
END;
IF Open.status = 1 THEN
COPY(Open.FilePath, header)
END
END
END OpenFile;
PROCEDURE SelColor (Color: ColorDlg.Dialog);
BEGIN
IF Color # NIL THEN
ColorDlg.Show(Color);
WHILE Color.status = 2 DO
pause(30)
END;
IF Color.status = 1 THEN
back_color := Color.color
END
END
END SelColor;
PROCEDURE GetButton (): INTEGER;
VAR
btn: INTEGER;
BEGIN
btn := KOSAPI.sysfunc1(17);
IF btn MOD 256 = 0 THEN
btn := btn DIV 256
ELSE
btn := btnNone
END
RETURN btn
END GetButton;
PROCEDURE main;
CONST
EVENT_REDRAW = 1;
EVENT_KEY = 2;
EVENT_BUTTON = 3;
VAR
Open: OpenDlg.Dialog;
Color: ColorDlg.Dialog;
BEGIN
back_color := 00FFFFFFH;
header := "Dialogs";
Open := OpenDlg.Create(draw_window, 0, "/sys", "ASM|TXT|INI");
Color := ColorDlg.Create(draw_window);
WHILE TRUE DO
CASE WaitForEvent() OF
|EVENT_REDRAW:
draw_window
|EVENT_KEY:
|EVENT_BUTTON:
CASE GetButton() OF
|btnNone:
|btnClose: ExitApp
|btnOpen: OpenFile(Open)
|btnColor: SelColor(Color)
END
END
END
END main;
BEGIN
main
END Dialogs.

78
programs/develop/oberon07/samples/HW.ob07 Normal file
View File

@@ -0,0 +1,78 @@
MODULE HW;
IMPORT
SYSTEM, KOSAPI;
PROCEDURE BeginDraw;
BEGIN
KOSAPI.sysfunc2(12, 1)
END BeginDraw;
PROCEDURE EndDraw;
BEGIN
KOSAPI.sysfunc2(12, 2)
END EndDraw;
PROCEDURE DefineAndDrawWindow (left, top, width, height, color, style, hcolor, hstyle: INTEGER; header: ARRAY OF CHAR);
BEGIN
KOSAPI.sysfunc6(0, left*65536 + width, top*65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), SYSTEM.ADR(header[0]))
END DefineAndDrawWindow;
PROCEDURE WriteTextToWindow (x, y, color: INTEGER; text: ARRAY OF CHAR);
BEGIN
KOSAPI.sysfunc6(4, x*65536 + y, color + LSL(48, 24), SYSTEM.ADR(text[0]), LENGTH(text), 0)
END WriteTextToWindow;
PROCEDURE WaitForEvent (): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
BEGIN
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE draw_window (header, text: ARRAY OF CHAR);
CONST
WHITE = 0FFFFFFH;
RED = 0C00000H;
GREEN = 0008000H;
BLUE = 00000C0H;
GRAY = 0808080H;
BEGIN
BeginDraw;
DefineAndDrawWindow(200, 200, 300, 150, WHITE, 51, 0, 0, header);
WriteTextToWindow( 5, 10, RED, text);
WriteTextToWindow(35, 30, GREEN, text);
WriteTextToWindow(65, 50, BLUE, text);
WriteTextToWindow(95, 70, GRAY, text);
EndDraw
END draw_window;
PROCEDURE main (header, text: ARRAY OF CHAR);
CONST
EVENT_REDRAW = 1;
EVENT_KEY = 2;
EVENT_BUTTON = 3;
BEGIN
WHILE TRUE DO
CASE WaitForEvent() OF
|EVENT_REDRAW: draw_window(header, text)
|EVENT_KEY: ExitApp
|EVENT_BUTTON: ExitApp
END
END
END main;
BEGIN
main("Hello", "Hello, world!")
END HW.

59
programs/develop/oberon07/samples/HW_con.ob07 Normal file
View File

@@ -0,0 +1,59 @@
MODULE HW_con;
IMPORT
Out, In, Console, DateTime;
PROCEDURE OutInt2 (n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 99));
IF n < 10 THEN
Out.Char("0")
END;
Out.Int(n, 0)
END OutInt2;
PROCEDURE OutMonth (n: INTEGER);
VAR
str: ARRAY 4 OF CHAR;
BEGIN
CASE n OF
| 1: str := "jan"
| 2: str := "feb"
| 3: str := "mar"
| 4: str := "apr"
| 5: str := "may"
| 6: str := "jun"
| 7: str := "jul"
| 8: str := "aug"
| 9: str := "sep"
|10: str := "oct"
|11: str := "nov"
|12: str := "dec"
END;
Out.String(str)
END OutMonth;
PROCEDURE main;
VAR
Year, Month, Day,
Hour, Min, Sec, Msec: INTEGER;
BEGIN
Out.String("Hello, world!"); Out.Ln;
Console.SetColor(Console.White, Console.Red);
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec);
OutInt2(Day); Out.Char("-"); OutMonth(Month); Out.Char("-"); Out.Int(Year, 0); Out.Char(" ");
OutInt2(Hour); Out.Char(":"); OutInt2(Min); Out.Char(":"); OutInt2(Sec); Out.Ln;
Console.SetColor(Console.Blue, Console.LightGray);
Out.Ln; Out.String("press enter...");
In.Ln
END main;
BEGIN
Console.open;
main;
Console.exit(TRUE)
END HW_con.

2424
programs/develop/oberon07/source/AMD64.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

797
programs/develop/oberon07/source/ARITH.ob07 Normal file
View File

@@ -0,0 +1,797 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
All rights reserved.
*)
MODULE ARITH;
IMPORT STRINGS, UTILS, LISTS;
CONST
tINTEGER* = 1; tREAL* = 2; tSET* = 3;
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6;
tSTRING* = 7;
opEQ* = 0; opNE* = 1; opLT* = 2; opLE* = 3; opGT* = 4; opGE* = 5;
opIN* = 6; opIS* = 7;
TYPE
VALUE* = RECORD
typ*: INTEGER;
int: INTEGER;
float: REAL;
set: SET;
bool: BOOLEAN;
string*: LISTS.ITEM
END;
VAR
digit: ARRAY 256 OF INTEGER;
PROCEDURE Int* (v: VALUE): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE v.typ OF
|tINTEGER, tCHAR, tWCHAR:
res := v.int
|tSET:
res := UTILS.Long(ORD(v.set))
|tBOOLEAN:
res := ORD(v.bool)
END
RETURN res
END Int;
PROCEDURE getBool* (v: VALUE): BOOLEAN;
BEGIN
ASSERT(v.typ = tBOOLEAN);
RETURN v.bool
END getBool;
PROCEDURE Float* (v: VALUE): REAL;
BEGIN
ASSERT(v.typ = tREAL);
RETURN v.float
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;
BEGIN
CASE v.typ OF
|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
RETURN res
END check;
PROCEDURE isZero* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
CASE v.typ OF
|tINTEGER: res := v.int = 0
|tREAL: res := v.float = 0.0
END
RETURN res
END isZero;
PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
d: INTEGER;
BEGIN
error := 0;
value := 0;
i := 0;
WHILE STRINGS.digit(s[i]) & (error = 0) DO
d := digit[ORD(s[i])];
IF value <= (UTILS.maxint - d) DIV 10 THEN
value := value * 10 + d;
INC(i)
ELSE
error := 1
END
END;
IF error = 0 THEN
v.int := value;
v.typ := tINTEGER;
IF ~check(v) THEN
error := 1
END
END
END iconv;
PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
n: INTEGER;
d: INTEGER;
BEGIN
ASSERT(STRINGS.digit(s[0]));
error := 0;
value := 0;
n := -1;
i := 0;
WHILE (s[i] # "H") & (s[i] # "X") & (s[i] # "h") & (s[i] # "x") & (error = 0) DO
d := digit[ORD(s[i])];
IF (n = -1) & (d # 0) THEN
n := i
END;
IF (n # -1) & (i - n + 1 > UTILS.target.maxHex) THEN
error := 2
ELSE
value := value * 16 + d;
INC(i)
END
END;
value := UTILS.Long(value);
IF ((s[i] = "X") OR (s[i] = "x")) & (n # -1) & (i - n > 4) THEN
error := 3
END;
IF error = 0 THEN
v.int := value;
IF (s[i] = "X") OR (s[i] = "x") THEN
v.typ := tCHAR;
IF ~check(v) THEN
v.typ := tWCHAR;
IF ~check(v) THEN
error := 3
END
END
ELSE
v.typ := tINTEGER;
IF ~check(v) THEN
error := 2
END
END
END
END hconv;
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN;
BEGIN
CASE op OF
|"+": a := a + b
|"-": a := a - b
|"*": a := a * b
|"/": a := a / b
END
RETURN (-UTILS.maxreal <= a) & (a <= UTILS.maxreal) (* +inf > UTILS.maxreal *)
END opFloat2;
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: REAL;
exp10: REAL;
i, n, d: INTEGER;
minus: BOOLEAN;
BEGIN
error := 0;
value := 0.0;
minus := FALSE;
n := 0;
exp10 := 0.0;
WHILE (error = 0) & (STRINGS.digit(s[i]) OR (s[i] = ".")) DO
IF s[i] = "." THEN
exp10 := 1.0;
INC(i)
ELSE
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") & opFloat2(exp10, 10.0, "*") THEN
INC(i)
ELSE
error := 4
END
END
END;
IF ~opFloat2(value, exp10, "/") THEN
error := 4
END;
IF (s[i] = "E") OR (s[i] = "e") THEN
INC(i)
END;
IF (s[i] = "-") OR (s[i] = "+") THEN
minus := s[i] = "-";
INC(i)
END;
WHILE (error = 0) & STRINGS.digit(s[i]) DO
d := digit[ORD(s[i])];
IF n <= (UTILS.maxint - d) DIV 10 THEN
n := n * 10 + d;
INC(i)
ELSE
error := 5
END
END;
exp10 := 1.0;
WHILE (error = 0) & (n > 0) DO
IF opFloat2(exp10, 10.0, "*") THEN
DEC(n)
ELSE
error := 4
END
END;
IF error = 0 THEN
IF minus THEN
IF ~opFloat2(value, exp10, "/") THEN
error := 4
END
ELSE
IF ~opFloat2(value, exp10, "*") THEN
error := 4
END
END
END;
IF error = 0 THEN
v.float := value;
v.typ := tREAL;
IF ~check(v) THEN
error := 4
END
END
END fconv;
PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tCHAR;
v.int := ord
END setChar;
PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tWCHAR;
v.int := ord
END setWChar;
PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b > 0) THEN
error := a > UTILS.maxint - b
ELSIF (a < 0) & (b < 0) THEN
error := a < UTILS.minint - b
ELSE
error := FALSE
END;
IF ~error THEN
a := a + b
ELSE
a := 0
END
RETURN ~error
END addInt;
PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b < 0) THEN
error := a > UTILS.maxint + b
ELSIF (a < 0) & (b > 0) THEN
error := a < UTILS.minint + b
ELSIF (a = 0) & (b < 0) THEN
error := b = UTILS.minint
ELSE
error := FALSE
END;
IF ~error THEN
a := a - b
ELSE
a := 0
END
RETURN ~error
END subInt;
PROCEDURE lg2 (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
ASSERT(x > 0);
n := UTILS.Log2(x);
IF n = -1 THEN
n := 255
END
RETURN n
END lg2;
PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
min, max: INTEGER;
BEGIN
min := UTILS.minint;
max := UTILS.maxint;
IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN
error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b))
ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN
error := (a = min) OR (b = min);
IF ~error THEN
IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN
error := ABS(a) > max DIV ABS(b)
END
END
ELSE
error := FALSE
END;
IF ~error THEN
a := a * b
ELSE
a := 0
END
RETURN ~error
END mulInt;
PROCEDURE _ASR (x, n: INTEGER): INTEGER;
RETURN ASR(UTILS.Long(x), n)
END _ASR;
PROCEDURE _LSR (x, n: INTEGER): INTEGER;
RETURN UTILS.Long(LSR(UTILS.Short(x), n))
END _LSR;
PROCEDURE _LSL (x, n: INTEGER): INTEGER;
RETURN UTILS.Long(LSL(x, n))
END _LSL;
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
x := UTILS.Short(x);
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
RETURN UTILS.Long(x)
END _ROR1_32;
PROCEDURE _ROR1_16 (x: INTEGER): INTEGER;
BEGIN
x := x MOD 65536;
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 15)))
RETURN UTILS.Long(x)
END _ROR1_16;
PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN
CASE UTILS.bit_diff OF
|0: x := ROR(x, n)
|16, 48:
n := n MOD 16;
WHILE n > 0 DO
x := _ROR1_16(x);
DEC(n)
END
|32:
n := n MOD 32;
WHILE n > 0 DO
x := _ROR1_32(x);
DEC(n)
END
END
RETURN x
END _ROR;
PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
VAR
success: BOOLEAN;
BEGIN
success := TRUE;
CASE op OF
|"+": success := addInt(a.int, b.int)
|"-": success := subInt(a.int, b.int)
|"*": success := mulInt(a.int, b.int)
|"/": success := FALSE
|"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)
|"O": a.int := _ROR(a.int, b.int)
|"R": a.int := _LSR(a.int, b.int)
|"m": a.int := MIN(a.int, b.int)
|"x": a.int := MAX(a.int, b.int)
END;
a.typ := tINTEGER
RETURN success & check(a)
END opInt;
PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR);
BEGIN
s[0] := CHR(c.int);
s[1] := 0X
END charToStr;
PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"+": a.set := a.set + b.set
|"-": a.set := a.set - b.set
|"*": a.set := a.set * b.set
|"/": a.set := a.set / b.set
END;
a.typ := tSET
END opSet;
PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
BEGIN
a.typ := tREAL
RETURN opFloat2(a.float, b.float, op) & check(a)
END opFloat;
PROCEDURE ord* (VAR v: VALUE);
BEGIN
CASE v.typ OF
|tCHAR, tWCHAR:
|tBOOLEAN: v.int := ORD(v.bool)
|tSET: v.int := UTILS.Long(ORD(v.set))
END;
v.typ := tINTEGER
END ord;
PROCEDURE odd* (VAR v: VALUE);
BEGIN
v.typ := tBOOLEAN;
v.bool := ODD(v.int)
END odd;
PROCEDURE bits* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := BITS(v.int)
END bits;
PROCEDURE abs* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
CASE v.typ OF
|tREAL:
v.float := ABS(v.float);
res := TRUE
|tINTEGER:
IF v.int # UTILS.minint THEN
v.int := ABS(v.int);
res := TRUE
END
END
RETURN res
END abs;
PROCEDURE floor* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
v.typ := tINTEGER;
res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint));
IF res THEN
v.int := FLOOR(v.float)
END
RETURN res
END floor;
PROCEDURE flt* (VAR v: VALUE);
BEGIN
v.typ := tREAL;
v.float := FLT(v.int)
END flt;
PROCEDURE neg* (VAR v: VALUE): BOOLEAN;
VAR
z: VALUE;
res: BOOLEAN;
BEGIN
res := TRUE;
z.typ := tINTEGER;
z.int := 0;
CASE v.typ OF
|tREAL: v.float := -v.float
|tSET: v.set := -v.set
|tINTEGER: res := opInt(z, v, "-"); v := z
|tBOOLEAN: v.bool := ~v.bool
END
RETURN res
END neg;
PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN);
BEGIN
v.bool := b;
v.typ := tBOOLEAN
END setbool;
PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"&": a.bool := a.bool & b.bool
|"|": a.bool := a.bool OR b.bool
END;
a.typ := tBOOLEAN
END opBoolean;
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int < v2.int
|tREAL: res := v.float < v2.float
|tBOOLEAN,
tSET: error := 1
END
ELSE
error := 1
END
RETURN res
END less;
PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int = v2.int
|tREAL: res := v.float = v2.float
|tBOOLEAN: res := v.bool = v2.bool
|tSET: res := v.set = v2.set
END
ELSE
error := 1
END
RETURN res
END equal;
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; op: INTEGER; VAR error: INTEGER);
VAR
res: BOOLEAN;
BEGIN
error := 0;
res := FALSE;
CASE op OF
|opEQ:
res := equal(v, v2, error)
|opNE:
res := ~equal(v, v2, error)
|opLT:
res := less(v, v2, error)
|opLE:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END
|opGE:
res := ~less(v, v2, error)
|opGT:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END;
res := ~res
|opIN:
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, UTILS.target.maxSet) THEN
res := v.int IN v2.set
ELSE
error := 2
END
ELSE
error := 1
END
END;
IF error = 0 THEN
v.bool := res;
v.typ := tBOOLEAN
END
END relation;
PROCEDURE emptySet* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := {}
END emptySet;
PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE);
BEGIN
v.typ := tSET;
v.set := {a.int .. b.int}
END constrSet;
PROCEDURE getInt* (v: VALUE): INTEGER;
BEGIN
ASSERT(check(v))
RETURN v.int
END getInt;
PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN;
BEGIN
v.int := i;
v.typ := tINTEGER
RETURN check(v)
END setInt;
PROCEDURE concat* (VAR s: ARRAY OF CHAR; s1: ARRAY OF CHAR): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := LENGTH(s) + LENGTH(s1) < LEN(s);
IF res THEN
STRINGS.append(s, s1)
END
RETURN res
END concat;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO LEN(digit) - 1 DO
digit[i] := -1
END;
FOR i := ORD("0") TO ORD("9") DO
digit[i] := i - ORD("0")
END;
FOR i := ORD("A") TO ORD("F") DO
digit[i] := i - ORD("A") + 10
END
END init;
BEGIN
init
END ARITH.

197
programs/develop/oberon07/source/AVLTREES.ob07 Normal file
View File

@@ -0,0 +1,197 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE AVLTREES;
IMPORT C := COLLECTIONS;
TYPE
DATA* = POINTER TO RECORD (C.ITEM) END;
NODE* = POINTER TO RECORD (C.ITEM)
data*: DATA;
height: INTEGER;
left*, right*: NODE
END;
CMP* = PROCEDURE (a, b: DATA): INTEGER;
DESTRUCTOR* = PROCEDURE (VAR data: DATA);
VAR
nodes: C.COLLECTION;
PROCEDURE NewNode (data: DATA): NODE;
VAR
node: NODE;
citem: C.ITEM;
BEGIN
citem := C.pop(nodes);
IF citem = NIL THEN
NEW(node)
ELSE
node := citem(NODE)
END;
node.data := data;
node.left := NIL;
node.right := NIL;
node.height := 1
RETURN node
END NewNode;
PROCEDURE height (p: NODE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF p = NIL THEN
res := 0
ELSE
res := p.height
END
RETURN res
END height;
PROCEDURE bfactor (p: NODE): INTEGER;
RETURN height(p.right) - height(p.left)
END bfactor;
PROCEDURE fixheight (p: NODE);
BEGIN
p.height := MAX(height(p.left), height(p.right)) + 1
END fixheight;
PROCEDURE rotateright (p: NODE): NODE;
VAR
q: NODE;
BEGIN
q := p.left;
p.left := q.right;
q.right := p;
fixheight(p);
fixheight(q)
RETURN q
END rotateright;
PROCEDURE rotateleft (q: NODE): NODE;
VAR
p: NODE;
BEGIN
p := q.right;
q.right := p.left;
p.left := q;
fixheight(q);
fixheight(p)
RETURN p
END rotateleft;
PROCEDURE balance (p: NODE): NODE;
VAR
res: NODE;
BEGIN
fixheight(p);
IF bfactor(p) = 2 THEN
IF bfactor(p.right) < 0 THEN
p.right := rotateright(p.right)
END;
res := rotateleft(p)
ELSIF bfactor(p) = -2 THEN
IF bfactor(p.left) > 0 THEN
p.left := rotateleft(p.left)
END;
res := rotateright(p)
ELSE
res := p
END
RETURN res
END balance;
PROCEDURE insert* (p: NODE; data: DATA; cmp: CMP; VAR newnode: BOOLEAN; VAR node: NODE): NODE;
VAR
res: NODE;
rescmp: INTEGER;
BEGIN
IF p = NIL THEN
res := NewNode(data);
node := res;
newnode := TRUE
ELSE
rescmp := cmp(data, p.data);
IF rescmp < 0 THEN
p.left := insert(p.left, data, cmp, newnode, node);
res := balance(p)
ELSIF rescmp > 0 THEN
p.right := insert(p.right, data, cmp, newnode, node);
res := balance(p)
ELSE
res := p;
node := res;
newnode := FALSE
END
END
RETURN res
END insert;
PROCEDURE destroy* (VAR node: NODE; destructor: DESTRUCTOR);
VAR
left, right: NODE;
BEGIN
IF node # NIL THEN
left := node.left;
right := node.right;
IF destructor # NIL THEN
destructor(node.data)
END;
C.push(nodes, node);
node := NIL;
destroy(left, destructor);
destroy(right, destructor)
END
END destroy;
BEGIN
nodes := C.create()
END AVLTREES.

384
programs/develop/oberon07/source/BIN.ob07 Normal file
View File

@@ -0,0 +1,384 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE BIN;
IMPORT LISTS, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
RCODE* = 0; PICCODE* = RCODE + 1;
RDATA* = 2; PICDATA* = RDATA + 1;
RBSS* = 4; PICBSS* = RBSS + 1;
RIMP* = 6; PICIMP* = RIMP + 1;
IMPTAB* = 8;
TYPE
RELOC* = POINTER TO RECORD (LISTS.ITEM)
opcode*: INTEGER;
offset*: INTEGER
END;
IMPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER;
OriginalFirstThunk*,
FirstThunk*: INTEGER
END;
EXPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER
END;
PROGRAM* = POINTER TO RECORD
code*: CHL.BYTELIST;
data*: CHL.BYTELIST;
labels: CHL.INTLIST;
bss*: INTEGER;
stack*: INTEGER;
vmajor*,
vminor*: WCHAR;
modname*: INTEGER;
_import*: CHL.BYTELIST;
export*: CHL.BYTELIST;
rel_list*: LISTS.LIST;
imp_list*: LISTS.LIST;
exp_list*: LISTS.LIST
END;
PROCEDURE create* (NumberOfLabels: INTEGER): PROGRAM;
VAR
program: PROGRAM;
i: INTEGER;
BEGIN
NEW(program);
program.bss := 0;
program.labels := CHL.CreateIntList();
FOR i := 0 TO NumberOfLabels - 1 DO
CHL.PushInt(program.labels, 0)
END;
program.rel_list := LISTS.create(NIL);
program.imp_list := LISTS.create(NIL);
program.exp_list := LISTS.create(NIL);
program.data := CHL.CreateByteList();
program.code := CHL.CreateByteList();
program._import := CHL.CreateByteList();
program.export := CHL.CreateByteList()
RETURN program
END create;
PROCEDURE SetParams* (program: PROGRAM; bss, stack: INTEGER; vmajor, vminor: WCHAR);
BEGIN
program.bss := bss;
program.stack := stack;
program.vmajor := vmajor;
program.vminor := vminor
END SetParams;
PROCEDURE PutReloc* (program: PROGRAM; opcode: INTEGER);
VAR
cmd: RELOC;
BEGIN
NEW(cmd);
cmd.opcode := opcode;
cmd.offset := CHL.Length(program.code);
LISTS.push(program.rel_list, cmd)
END PutReloc;
PROCEDURE PutData* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.data, b)
END PutData;
PROCEDURE get32le* (_array: CHL.BYTELIST; idx: INTEGER): INTEGER;
VAR
i: INTEGER;
x: INTEGER;
BEGIN
x := 0;
FOR i := 3 TO 0 BY -1 DO
x := LSL(x, 8) + CHL.GetByte(_array, idx + i)
END;
IF UTILS.bit_depth = 64 THEN
x := LSL(x, 16);
x := LSL(x, 16);
x := ASR(x, 16);
x := ASR(x, 16)
END
RETURN x
END get32le;
PROCEDURE put32le* (_array: CHL.BYTELIST; idx: INTEGER; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.SetByte(_array, idx + i, UTILS.Byte(x, i))
END
END put32le;
PROCEDURE PutData32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData32LE;
PROCEDURE PutData64LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData64LE;
PROCEDURE PutDataStr* (program: PROGRAM; s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
PutData(program, ORD(s[i]));
INC(i)
END
END PutDataStr;
PROCEDURE PutCode* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.code, b)
END PutCode;
PROCEDURE PutCode32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.code, UTILS.Byte(x, i))
END
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)
END SetLabel;
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
imp: IMPRT;
BEGIN
CHL.PushByte(program._import, 0);
CHL.PushByte(program._import, 0);
IF ODD(CHL.Length(program._import)) THEN
CHL.PushByte(program._import, 0)
END;
NEW(imp);
imp.nameoffs := CHL.PushStr(program._import, name);
imp.label := label;
LISTS.push(program.imp_list, imp)
END Import;
PROCEDURE less (bytes: CHL.BYTELIST; a, b: EXPRT): BOOLEAN;
VAR
i, j: INTEGER;
BEGIN
i := a.nameoffs;
j := b.nameoffs;
WHILE (CHL.GetByte(bytes, i) # 0) & (CHL.GetByte(bytes, j) # 0) &
(CHL.GetByte(bytes, i) = CHL.GetByte(bytes, j)) DO
INC(i);
INC(j)
END
RETURN CHL.GetByte(bytes, i) < CHL.GetByte(bytes, j)
END less;
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
exp, cur: EXPRT;
BEGIN
NEW(exp);
exp.label := CHL.GetInt(program.labels, label);
exp.nameoffs := CHL.PushStr(program.export, name);
cur := program.exp_list.first(EXPRT);
WHILE (cur # NIL) & less(program.export, cur, exp) DO
cur := cur.next(EXPRT)
END;
IF cur # NIL THEN
IF cur.prev # NIL THEN
LISTS.insert(program.exp_list, cur.prev, exp)
ELSE
LISTS.insertL(program.exp_list, cur, exp)
END
ELSE
LISTS.push(program.exp_list, exp)
END
END Export;
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT;
VAR
_import, res: IMPRT;
BEGIN
_import := program.imp_list.first(IMPRT);
res := NIL;
WHILE (_import # NIL) & (n >= 0) DO
IF _import.label # 0 THEN
res := _import;
DEC(n)
END;
_import := _import.next(IMPRT)
END;
ASSERT(n = -1)
RETURN res
END GetIProc;
PROCEDURE GetLabel* (program: PROGRAM; label: INTEGER): INTEGER;
RETURN CHL.GetInt(program.labels, label)
END GetLabel;
PROCEDURE NewLabel* (program: PROGRAM);
BEGIN
CHL.PushInt(program.labels, 0)
END NewLabel;
PROCEDURE fixup* (program: PROGRAM);
VAR
rel: RELOC;
imp: IMPRT;
nproc: INTEGER;
L: INTEGER;
BEGIN
nproc := 0;
imp := program.imp_list.first(IMPRT);
WHILE imp # NIL DO
IF imp.label # 0 THEN
CHL.SetInt(program.labels, imp.label, nproc);
INC(nproc)
END;
imp := imp.next(IMPRT)
END;
rel := program.rel_list.first(RELOC);
WHILE rel # NIL DO
IF rel.opcode IN {RIMP, PICIMP} THEN
L := get32le(program.code, rel.offset);
put32le(program.code, rel.offset, GetLabel(program, L))
END;
rel := rel.next(RELOC)
END
END fixup;
PROCEDURE InitArray* (VAR _array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR);
VAR
i, k: INTEGER;
PROCEDURE hexdgt (dgt: CHAR): INTEGER;
VAR
res: INTEGER;
BEGIN
IF dgt < "A" THEN
res := ORD(dgt) - ORD("0")
ELSE
res := ORD(dgt) - ORD("A") + 10
END
RETURN res
END hexdgt;
BEGIN
k := LENGTH(hex);
ASSERT(~ODD(k));
k := k DIV 2;
FOR i := 0 TO k - 1 DO
_array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
END;
INC(idx, k)
END InitArray;
END BIN.

255
programs/develop/oberon07/source/CHUNKLISTS.ob07 Normal file
View File

@@ -0,0 +1,255 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE CHUNKLISTS;
IMPORT LISTS, WR := WRITER;
CONST
LENOFBYTECHUNK = 65536;
LENOFINTCHUNK = 16384;
TYPE
ANYLIST = POINTER TO RECORD (LISTS.LIST)
length: INTEGER
END;
BYTELIST* = POINTER TO RECORD (ANYLIST) END;
BYTECHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFBYTECHUNK OF BYTE;
count: INTEGER
END;
INTLIST* = POINTER TO RECORD (ANYLIST) END;
INTCHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFINTCHUNK OF INTEGER;
count: INTEGER
END;
PROCEDURE SetByte* (list: BYTELIST; idx: INTEGER; byte: BYTE);
VAR
chunk: BYTECHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK);
ASSERT(item # NIL);
chunk := item(BYTECHUNK);
idx := idx MOD LENOFBYTECHUNK;
ASSERT(idx < chunk.count);
chunk.data[idx] := byte
END SetByte;
PROCEDURE GetByte* (list: BYTELIST; idx: INTEGER): BYTE;
VAR
chunk: BYTECHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK);
ASSERT(item # NIL);
chunk := item(BYTECHUNK);
idx := idx MOD LENOFBYTECHUNK;
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetByte;
PROCEDURE PushByte* (list: BYTELIST; byte: BYTE);
VAR
chunk: BYTECHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(BYTECHUNK);
IF chunk.count = LENOFBYTECHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := byte;
INC(chunk.count);
INC(list.length)
END PushByte;
PROCEDURE PushStr* (list: BYTELIST; str: ARRAY OF CHAR): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := list.length;
i := 0;
REPEAT
PushByte(list, ORD(str[i]));
INC(i)
UNTIL str[i - 1] = 0X
RETURN res
END PushStr;
PROCEDURE GetStr* (list: BYTELIST; pos: INTEGER; VAR str: ARRAY OF CHAR): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := FALSE;
i := 0;
WHILE (pos < list.length) & (i < LEN(str)) & ~res DO
str[i] := CHR(GetByte(list, pos));
res := str[i] = 0X;
INC(pos);
INC(i)
END
RETURN res
END GetStr;
PROCEDURE WriteToFile* (list: BYTELIST);
VAR
chunk: BYTECHUNK;
BEGIN
chunk := list.first(BYTECHUNK);
WHILE chunk # NIL DO
WR.Write(chunk.data, chunk.count);
chunk := chunk.next(BYTECHUNK)
END
END WriteToFile;
PROCEDURE CreateByteList* (): BYTELIST;
VAR
bytelist: BYTELIST;
list: LISTS.LIST;
chunk: BYTECHUNK;
BEGIN
NEW(bytelist);
list := LISTS.create(bytelist);
bytelist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(BYTELIST)
END CreateByteList;
PROCEDURE SetInt* (list: INTLIST; idx: INTEGER; int: INTEGER);
VAR
chunk: INTCHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK);
ASSERT(item # NIL);
chunk := item(INTCHUNK);
idx := idx MOD LENOFINTCHUNK;
ASSERT(idx < chunk.count);
chunk.data[idx] := int
END SetInt;
PROCEDURE GetInt* (list: INTLIST; idx: INTEGER): INTEGER;
VAR
chunk: INTCHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK);
ASSERT(item # NIL);
chunk := item(INTCHUNK);
idx := idx MOD LENOFINTCHUNK;
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetInt;
PROCEDURE PushInt* (list: INTLIST; int: INTEGER);
VAR
chunk: INTCHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(INTCHUNK);
IF chunk.count = LENOFINTCHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := int;
INC(chunk.count);
INC(list.length)
END PushInt;
PROCEDURE CreateIntList* (): INTLIST;
VAR
intlist: INTLIST;
list: LISTS.LIST;
chunk: INTCHUNK;
BEGIN
NEW(intlist);
list := LISTS.create(intlist);
intlist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(INTLIST)
END CreateIntList;
PROCEDURE Length* (list: ANYLIST): INTEGER;
RETURN list.length
END Length;
END CHUNKLISTS.

59
programs/develop/oberon07/source/COLLECTIONS.ob07 Normal file
View File

@@ -0,0 +1,59 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD
link: ITEM
END;
COLLECTION* = POINTER TO RECORD
last: ITEM
END;
PROCEDURE push* (collection: COLLECTION; item: ITEM);
BEGIN
item.link := collection.last;
collection.last := item
END push;
PROCEDURE pop* (collection: COLLECTION): ITEM;
VAR
item: ITEM;
BEGIN
item := collection.last;
IF item # NIL THEN
collection.last := item.link
END
RETURN item
END pop;
PROCEDURE create* (): COLLECTION;
VAR
collection: COLLECTION;
BEGIN
NEW(collection);
collection.last := NIL
RETURN collection
END create;
END COLLECTIONS.

78
programs/develop/oberon07/source/CONSOLE.ob07 Normal file
View File

@@ -0,0 +1,78 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE CONSOLE;
IMPORT UTILS, STRINGS;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
UTILS.OutChar(s[i]);
INC(i)
END
END String;
PROCEDURE Int* (x: INTEGER);
VAR
s: ARRAY 24 OF CHAR;
BEGIN
STRINGS.IntToStr(x, s);
String(s)
END Int;
PROCEDURE Int2* (x: INTEGER);
BEGIN
IF x < 10 THEN
String("0")
END;
Int(x)
END Int2;
PROCEDURE Ln*;
BEGIN
String(UTILS.eol)
END Ln;
PROCEDURE StringLn* (s: ARRAY OF CHAR);
BEGIN
String(s);
Ln
END StringLn;
PROCEDURE IntLn* (x: INTEGER);
BEGIN
Int(x);
Ln
END IntLn;
PROCEDURE Int2Ln* (x: INTEGER);
BEGIN
Int2(x);
Ln
END Int2Ln;
PROCEDURE Dashes*;
BEGIN
StringLn("------------------------------------------------")
END Dashes;
END CONSOLE.

352
programs/develop/oberon07/source/Compiler.ob07 Normal file
View File

@@ -0,0 +1,352 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
*)
MODULE Compiler;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE,
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS, SCAN, TEXTDRV;
CONST
DEF_WINDOWS = "WINDOWS";
DEF_LINUX = "LINUX";
DEF_KOLIBRIOS = "KOLIBRIOS";
DEF_CPU_X86 = "CPU_X86";
DEF_CPU_X8664 = "CPU_X8664";
PROCEDURE keys (VAR options: PROG.OPTIONS; VAR out: PARS.PATH);
VAR
param: PARS.PATH;
i, j: INTEGER;
_end: BOOLEAN;
value: INTEGER;
minor,
major: INTEGER;
checking: SET;
PROCEDURE getVal (VAR i: INTEGER; VAR value: INTEGER);
VAR
param: PARS.PATH;
val: INTEGER;
BEGIN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, val) THEN
value := val
END;
IF param[0] = "-" THEN
DEC(i)
END
END getVal;
BEGIN
options.lower := TRUE;
out := "";
checking := options.checking;
_end := FALSE;
i := 3;
REPEAT
UTILS.GetArg(i, param);
IF param = "-stk" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
options.stack := value
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-out" THEN
INC(i);
UTILS.GetArg(i, param);
IF param[0] = "-" THEN
DEC(i)
ELSE
out := param
END
ELSIF param = "-tab" THEN
getVal(i, options.tab)
ELSIF param = "-ram" THEN
getVal(i, options.ram)
ELSIF param = "-rom" THEN
getVal(i, options.rom)
ELSIF param = "-nochk" THEN
INC(i);
UTILS.GetArg(i, param);
IF param[0] = "-" THEN
DEC(i)
ELSE
j := 0;
WHILE param[j] # 0X DO
IF param[j] = "p" THEN
EXCL(checking, ST.chkPTR)
ELSIF param[j] = "t" THEN
EXCL(checking, ST.chkGUARD)
ELSIF param[j] = "i" THEN
EXCL(checking, ST.chkIDX)
ELSIF param[j] = "b" THEN
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "c" THEN
EXCL(checking, ST.chkCHR)
ELSIF param[j] = "w" THEN
EXCL(checking, ST.chkWCHR)
ELSIF param[j] = "r" THEN
EXCL(checking, ST.chkCHR);
EXCL(checking, ST.chkWCHR);
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "s" THEN
EXCL(checking, ST.chkSTK)
ELSIF param[j] = "a" THEN
checking := {}
END;
INC(j)
END;
END
ELSIF param = "-ver" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToVer(param, major, minor) THEN
options.version := major * 65536 + minor
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-lower" THEN
options.lower := TRUE
ELSIF param = "-upper" THEN
options.lower := FALSE
ELSIF param = "-pic" THEN
options.pic := TRUE
ELSIF param = "-uses" THEN
options.uses := TRUE
ELSIF param = "-def" THEN
INC(i);
UTILS.GetArg(i, param);
SCAN.NewDef(param)
ELSIF param = "" THEN
_end := TRUE
ELSE
ERRORS.BadParam(param)
END;
INC(i)
UNTIL _end;
options.checking := checking
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;
inname: PARS.PATH;
ext: PARS.PATH;
app_path: PARS.PATH;
lib_path: PARS.PATH;
modname: PARS.PATH;
outname: PARS.PATH;
param: PARS.PATH;
temp: PARS.PATH;
target: INTEGER;
time: INTEGER;
options: PROG.OPTIONS;
BEGIN
options.stack := 2;
options.tab := TEXTDRV.defTabSize;
options.version := 65536;
options.pic := FALSE;
options.lower := FALSE;
options.uses := FALSE;
options.checking := ST.chkALL;
PATHS.GetCurrentDirectory(app_path);
UTILS.GetArg(0, temp);
PATHS.split(temp, path, modname, ext);
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
END;
lib_path := path;
UTILS.GetArg(1, inname);
STRINGS.replace(inname, "\", UTILS.slash);
STRINGS.replace(inname, "/", UTILS.slash);
C.Ln;
C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit) " + UTILS.Date);
C.StringLn("Copyright (c) 2018-2023, 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
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 Mbytes (Windows, Linux, KolibriOS)"); C.Ln;
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,");
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln;
C.StringLn(" -lower allow lower case for keywords (default)"); C.Ln;
C.StringLn(" -upper only upper case for keywords"); C.Ln;
C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln;
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
C.StringLn(" -tab <width> set width for tabs"); C.Ln;
C.StringLn(" -uses list imported modules"); C.Ln;
UTILS.Exit(0)
END;
C.Dashes;
PATHS.split(inname, path, modname, ext);
IF ext # UTILS.FILE_EXT THEN
ERRORS.Error(207)
END;
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
END;
UTILS.GetArg(2, param);
IF param = "" THEN
ERRORS.Error(205)
END;
SCAN.NewDef(param);
IF TARGETS.Select(param) THEN
target := TARGETS.target
ELSE
ERRORS.Error(206)
END;
IF TARGETS.CPU = TARGETS.cpuMSP430 THEN
options.ram := MSP430.minRAM;
options.rom := MSP430.minROM
END;
IF (TARGETS.CPU = TARGETS.cpuTHUMB) & (TARGETS.OS = TARGETS.osNONE) THEN
options.ram := THUMB.minRAM;
options.rom := THUMB.minROM
END;
IF UTILS.bit_depth < TARGETS.BitDepth THEN
ERRORS.Error(206)
END;
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
STRINGS.append(lib_path, TARGETS.LibDir);
STRINGS.append(lib_path, UTILS.slash);
keys(options, outname);
TEXTDRV.setTabSize(options.tab);
IF outname = "" THEN
outname := path;
STRINGS.append(outname, modname);
STRINGS.append(outname, TARGETS.FileExt)
ELSE
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
outname := temp
END
END;
PARS.init(options);
CASE TARGETS.OS OF
|TARGETS.osNONE:
|TARGETS.osWIN32,
TARGETS.osWIN64: SCAN.NewDef(DEF_WINDOWS)
|TARGETS.osLINUX32,
TARGETS.osLINUX64: SCAN.NewDef(DEF_LINUX)
|TARGETS.osKOS: SCAN.NewDef(DEF_KOLIBRIOS)
END;
CASE TARGETS.CPU OF
|TARGETS.cpuX86: SCAN.NewDef(DEF_CPU_X86)
|TARGETS.cpuAMD64: SCAN.NewDef(DEF_CPU_X8664)
|TARGETS.cpuMSP430:
|TARGETS.cpuTHUMB:
|TARGETS.cpuRVM32I:
|TARGETS.cpuRVM64I:
END;
ST.compile(path, lib_path, modname, outname, target, options);
time := UTILS.GetTickCount() - UTILS.time;
C.Dashes;
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");
UTILS.Exit(0)
END main;
BEGIN
main
END Compiler.

592
programs/develop/oberon07/source/ELF.ob07 Normal file
View File

@@ -0,0 +1,592 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE ELF;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PE32, UTILS, STRINGS;
CONST
EI_NIDENT = 16;
ET_EXEC = 2;
ET_DYN = 3;
EM_386 = 3;
EM_8664 = 3EH;
ELFCLASS32 = 1;
ELFCLASS64 = 2;
ELFDATA2LSB = 1;
ELFDATA2MSB = 2;
PF_X = 1;
PF_W = 2;
PF_R = 4;
TYPE
Elf32_Ehdr = RECORD
e_ident: ARRAY EI_NIDENT OF BYTE;
e_type,
e_machine: WCHAR;
e_version,
e_entry,
e_phoff,
e_shoff,
e_flags: INTEGER;
e_ehsize,
e_phentsize,
e_phnum,
e_shentsize,
e_shnum,
e_shstrndx: WCHAR
END;
Elf32_Phdr = RECORD
p_type,
p_offset,
p_vaddr,
p_paddr,
p_filesz,
p_memsz,
p_flags,
p_align: INTEGER
END;
Elf32_Dyn = POINTER TO RECORD (LISTS.ITEM)
d_tag, d_val: INTEGER
END;
Elf32_Sym = POINTER TO RECORD (LISTS.ITEM)
name, value, size: INTEGER;
info, other: CHAR;
shndx: WCHAR
END;
VAR
dynamic: LISTS.LIST;
strtab: CHL.BYTELIST;
symtab: LISTS.LIST;
hashtab, bucket, chain: CHL.INTLIST;
PROCEDURE Write16 (w: WCHAR);
BEGIN
WR.Write16LE(ORD(w))
END Write16;
PROCEDURE WritePH (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_offset);
WR.Write32LE(ph.p_vaddr);
WR.Write32LE(ph.p_paddr);
WR.Write32LE(ph.p_filesz);
WR.Write32LE(ph.p_memsz);
WR.Write32LE(ph.p_flags);
WR.Write32LE(ph.p_align)
END WritePH;
PROCEDURE WritePH64 (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_flags);
WR.Write64LE(ph.p_offset);
WR.Write64LE(ph.p_vaddr);
WR.Write64LE(ph.p_paddr);
WR.Write64LE(ph.p_filesz);
WR.Write64LE(ph.p_memsz);
WR.Write64LE(ph.p_align)
END WritePH64;
PROCEDURE NewDyn (tag, val: INTEGER);
VAR
dyn: Elf32_Dyn;
BEGIN
NEW(dyn);
dyn.d_tag := tag;
dyn.d_val := val;
LISTS.push(dynamic, dyn)
END NewDyn;
PROCEDURE NewSym (name, value, size: INTEGER; info, other: CHAR; shndx: WCHAR);
VAR
sym: Elf32_Sym;
BEGIN
NEW(sym);
sym.name := name;
sym.value := value;
sym.size := size;
sym.info := info;
sym.other := other;
sym.shndx := shndx;
LISTS.push(symtab, sym)
END NewSym;
PROCEDURE MakeHash (bucket, chain: CHL.INTLIST; symCount: INTEGER);
VAR
symi, hi, k: INTEGER;
BEGIN
FOR symi := 0 TO symCount - 1 DO
CHL.SetInt(chain, symi, 0);
hi := CHL.GetInt(hashtab, symi) MOD symCount;
IF CHL.GetInt(bucket, hi) # 0 THEN
k := symi;
WHILE CHL.GetInt(chain, k) # 0 DO
k := CHL.GetInt(chain, k)
END;
CHL.SetInt(chain, k, CHL.GetInt(bucket, hi))
END;
CHL.SetInt(bucket, hi, symi)
END
END MakeHash;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; fini: INTEGER; so, amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
header = 2;
text = 3;
data = 4;
bss = 5;
linuxInterpreter64 = "/lib64/ld-linux-x86-64.so.2";
linuxInterpreter32 = "/lib/ld-linux.so.2";
exeBaseAddress32 = 8048000H;
exeBaseAddress64 = 400000H;
dllBaseAddress = 0;
DT_NULL = 0;
DT_NEEDED = 1;
DT_HASH = 4;
DT_STRTAB = 5;
DT_SYMTAB = 6;
DT_RELA = 7;
DT_RELASZ = 8;
DT_RELAENT = 9;
DT_STRSZ = 10;
DT_SYMENT = 11;
DT_INIT = 12;
DT_FINI = 13;
DT_SONAME = 14;
DT_REL = 17;
DT_RELSZ = 18;
DT_RELENT = 19;
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, BaseAdr, DynAdr, offset, pad, VA, symCount: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
Offset: RECORD symtab, reltab, hash, strtab: INTEGER END;
Interpreter: ARRAY 40 OF CHAR; lenInterpreter: INTEGER;
item: LISTS.ITEM;
Name: ARRAY 2048 OF CHAR;
Address: PE32.VIRTUAL_ADDR;
BEGIN
dynamic := LISTS.create(NIL);
symtab := LISTS.create(NIL);
strtab := CHL.CreateByteList();
IF amd64 THEN
BaseAdr := exeBaseAddress64;
Interpreter := linuxInterpreter64
ELSE
BaseAdr := exeBaseAddress32;
Interpreter := linuxInterpreter32
END;
IF so THEN
BaseAdr := dllBaseAddress
END;
lenInterpreter := LENGTH(Interpreter) + 1;
SizeOf.code := CHL.Length(program.code);
SizeOf.data := CHL.Length(program.data);
SizeOf.bss := program.bss;
ehdr.e_ident[0] := 7FH;
ehdr.e_ident[1] := ORD("E");
ehdr.e_ident[2] := ORD("L");
ehdr.e_ident[3] := ORD("F");
IF amd64 THEN
ehdr.e_ident[4] := ELFCLASS64
ELSE
ehdr.e_ident[4] := ELFCLASS32
END;
ehdr.e_ident[5] := ELFDATA2LSB;
ehdr.e_ident[6] := 1;
ehdr.e_ident[7] := 3;
FOR i := 8 TO EI_NIDENT - 1 DO
ehdr.e_ident[i] := 0
END;
IF so THEN
ehdr.e_type := WCHR(ET_DYN)
ELSE
ehdr.e_type := WCHR(ET_EXEC)
END;
ehdr.e_version := 1;
ehdr.e_shoff := 0;
ehdr.e_flags := 0;
ehdr.e_shnum := WCHR(0);
ehdr.e_shstrndx := WCHR(0);
ehdr.e_phnum := WCHR(6);
IF amd64 THEN
ehdr.e_machine := WCHR(EM_8664);
ehdr.e_phoff := 40H;
ehdr.e_ehsize := WCHR(40H);
ehdr.e_phentsize := WCHR(38H);
ehdr.e_shentsize := WCHR(40H)
ELSE
ehdr.e_machine := WCHR(EM_386);
ehdr.e_phoff := 34H;
ehdr.e_ehsize := WCHR(34H);
ehdr.e_phentsize := WCHR(20H);
ehdr.e_shentsize := WCHR(28H)
END;
SizeOf.header := ORD(ehdr.e_ehsize) + ORD(ehdr.e_phentsize) * ORD(ehdr.e_phnum);
phdr[interp].p_type := 3;
phdr[interp].p_offset := SizeOf.header;
phdr[interp].p_vaddr := BaseAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := phdr[interp].p_vaddr;
phdr[interp].p_filesz := lenInterpreter;
phdr[interp].p_memsz := lenInterpreter;
phdr[interp].p_flags := PF_R;
phdr[interp].p_align := 1;
phdr[dyn].p_type := 2;
phdr[dyn].p_offset := phdr[interp].p_offset + phdr[interp].p_filesz;
phdr[dyn].p_vaddr := BaseAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := phdr[dyn].p_vaddr;
hashtab := CHL.CreateIntList();
CHL.PushInt(hashtab, STRINGS.HashStr(""));
NewSym(CHL.PushStr(strtab, ""), 0, 0, 0X, 0X, 0X);
CHL.PushInt(hashtab, STRINGS.HashStr("dlopen"));
NewSym(CHL.PushStr(strtab, "dlopen"), 0, 0, 12X, 0X, 0X);
CHL.PushInt(hashtab, STRINGS.HashStr("dlsym"));
NewSym(CHL.PushStr(strtab, "dlsym"), 0, 0, 12X, 0X, 0X);
IF so THEN
item := program.exp_list.first;
WHILE item # NIL DO
ASSERT(CHL.GetStr(program.export, item(BIN.EXPRT).nameoffs, Name));
CHL.PushInt(hashtab, STRINGS.HashStr(Name));
NewSym(CHL.PushStr(strtab, Name), item(BIN.EXPRT).label, 0, 12X, 0X, 0X);
item := item.next
END;
ASSERT(CHL.GetStr(program.data, program.modname, Name))
END;
symCount := LISTS.count(symtab);
bucket := CHL.CreateIntList();
chain := CHL.CreateIntList();
FOR i := 1 TO symCount DO
CHL.PushInt(bucket, 0);
CHL.PushInt(chain, 0)
END;
MakeHash(bucket, chain, symCount);
NewDyn(DT_NEEDED, CHL.PushStr(strtab, "libdl.so.2"));
NewDyn(DT_STRTAB, 0);
NewDyn(DT_STRSZ, CHL.Length(strtab));
NewDyn(DT_SYMTAB, 0);
IF amd64 THEN
NewDyn(DT_SYMENT, 24);
NewDyn(DT_RELA, 0);
NewDyn(DT_RELASZ, 48);
NewDyn(DT_RELAENT, 24)
ELSE
NewDyn(DT_SYMENT, 16);
NewDyn(DT_REL, 0);
NewDyn(DT_RELSZ, 16);
NewDyn(DT_RELENT, 8)
END;
NewDyn(DT_HASH, 0);
IF so THEN
NewDyn(DT_SONAME, CHL.PushStr(strtab, Name));
NewDyn(DT_INIT, 0);
NewDyn(DT_FINI, 0)
END;
NewDyn(DT_NULL, 0);
Offset.symtab := LISTS.count(dynamic) * (8 + 8 * ORD(amd64));
Offset.reltab := Offset.symtab + symCount * (16 + 8 * ORD(amd64));
Offset.hash := Offset.reltab + (8 + 16 * ORD(amd64)) * 2;
Offset.strtab := Offset.hash + (symCount * 2 + 2) * 4;
DynAdr := phdr[dyn].p_offset + BaseAdr;
item := LISTS.getidx(dynamic, 1); item(Elf32_Dyn).d_val := Offset.strtab + DynAdr;
item := LISTS.getidx(dynamic, 3); item(Elf32_Dyn).d_val := Offset.symtab + DynAdr;
item := LISTS.getidx(dynamic, 5); item(Elf32_Dyn).d_val := Offset.reltab + DynAdr;
item := LISTS.getidx(dynamic, 8); item(Elf32_Dyn).d_val := Offset.hash + DynAdr;
phdr[dyn].p_filesz := Offset.strtab + CHL.Length(strtab) + 8 + 8 * ORD(amd64);
phdr[dyn].p_memsz := phdr[dyn].p_filesz;
phdr[dyn].p_flags := PF_R;
phdr[dyn].p_align := 1;
offset := 0;
phdr[header].p_type := 1;
phdr[header].p_offset := offset;
phdr[header].p_vaddr := BaseAdr;
phdr[header].p_paddr := BaseAdr;
phdr[header].p_filesz := SizeOf.header + lenInterpreter + phdr[dyn].p_filesz;
phdr[header].p_memsz := phdr[header].p_filesz;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
INC(offset, phdr[header].p_filesz);
VA := BaseAdr + offset + 1000H;
phdr[text].p_type := 1;
phdr[text].p_offset := offset;
phdr[text].p_vaddr := VA;
phdr[text].p_paddr := VA;
phdr[text].p_filesz := SizeOf.code;
phdr[text].p_memsz := SizeOf.code;
phdr[text].p_flags := PF_X + PF_R;
phdr[text].p_align := 1000H;
ehdr.e_entry := phdr[text].p_vaddr;
INC(offset, phdr[text].p_filesz);
VA := BaseAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
phdr[data].p_type := 1;
phdr[data].p_offset := offset;
phdr[data].p_vaddr := VA;
phdr[data].p_paddr := VA;
phdr[data].p_filesz := SizeOf.data + pad;
phdr[data].p_memsz := SizeOf.data + pad;
phdr[data].p_flags := PF_R + PF_W;
phdr[data].p_align := 1000H;
INC(offset, phdr[data].p_filesz);
VA := BaseAdr + offset + 3000H;
phdr[bss].p_type := 1;
phdr[bss].p_offset := offset;
phdr[bss].p_vaddr := VA;
phdr[bss].p_paddr := VA;
phdr[bss].p_filesz := 0;
phdr[bss].p_memsz := SizeOf.bss + 16;
phdr[bss].p_flags := PF_R + PF_W;
phdr[bss].p_align := 1000H;
Address.Code := ehdr.e_entry;
Address.Data := phdr[data].p_vaddr + pad;
Address.Bss := WR.align(phdr[bss].p_vaddr, 16);
Address.Import := 0;
PE32.fixup(program, Address, amd64);
item := symtab.first;
WHILE item # NIL DO
IF item(Elf32_Sym).value # 0 THEN
INC(item(Elf32_Sym).value, ehdr.e_entry)
END;
item := item.next
END;
IF so THEN
item := LISTS.getidx(dynamic, 10); item(Elf32_Dyn).d_val := ehdr.e_entry;
item := LISTS.getidx(dynamic, 11); item(Elf32_Dyn).d_val := BIN.GetLabel(program, fini) + ehdr.e_entry
END;
WR.Create(FileName);
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(ehdr.e_ident[i])
END;
Write16(ehdr.e_type);
Write16(ehdr.e_machine);
WR.Write32LE(ehdr.e_version);
IF amd64 THEN
WR.Write64LE(ehdr.e_entry);
WR.Write64LE(ehdr.e_phoff);
WR.Write64LE(ehdr.e_shoff)
ELSE
WR.Write32LE(ehdr.e_entry);
WR.Write32LE(ehdr.e_phoff);
WR.Write32LE(ehdr.e_shoff)
END;
WR.Write32LE(ehdr.e_flags);
Write16(ehdr.e_ehsize);
Write16(ehdr.e_phentsize);
Write16(ehdr.e_phnum);
Write16(ehdr.e_shentsize);
Write16(ehdr.e_shnum);
Write16(ehdr.e_shstrndx);
IF amd64 THEN
WritePH64(phdr[interp]);
WritePH64(phdr[dyn]);
WritePH64(phdr[header]);
WritePH64(phdr[text]);
WritePH64(phdr[data]);
WritePH64(phdr[bss])
ELSE
WritePH(phdr[interp]);
WritePH(phdr[dyn]);
WritePH(phdr[header]);
WritePH(phdr[text]);
WritePH(phdr[data]);
WritePH(phdr[bss])
END;
FOR i := 0 TO lenInterpreter - 1 DO
WR.WriteByte(ORD(Interpreter[i]))
END;
IF amd64 THEN
item := dynamic.first;
WHILE item # NIL DO
WR.Write64LE(item(Elf32_Dyn).d_tag);
WR.Write64LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Sym).name);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
WR.Write64LE(item(Elf32_Sym).value);
WR.Write64LE(item(Elf32_Sym).size);
item := item.next
END;
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 16);
WR.Write32LE(1);
WR.Write32LE(1);
WR.Write64LE(0);
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(1);
WR.Write32LE(2);
WR.Write64LE(0)
ELSE
item := dynamic.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Dyn).d_tag);
WR.Write32LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Sym).name);
WR.Write32LE(item(Elf32_Sym).value);
WR.Write32LE(item(Elf32_Sym).size);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
item := item.next
END;
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(00000101H);
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 4);
WR.Write32LE(00000201H)
END;
WR.Write32LE(symCount);
WR.Write32LE(symCount);
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(CHL.GetInt(bucket, i))
END;
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(CHL.GetInt(chain, i))
END;
CHL.WriteToFile(strtab);
IF amd64 THEN
WR.Write64LE(0);
WR.Write64LE(0)
ELSE
WR.Write32LE(0);
WR.Write32LE(0)
END;
CHL.WriteToFile(program.code);
WHILE pad > 0 DO
WR.WriteByte(0);
DEC(pad)
END;
CHL.WriteToFile(program.data);
WR.Close;
UTILS.chmod(FileName)
END write;
END ELF.

222
programs/develop/oberon07/source/ERRORS.ob07 Normal file
View File

@@ -0,0 +1,222 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
All rights reserved.
*)
MODULE ERRORS;
IMPORT C := CONSOLE, UTILS;
PROCEDURE HintMsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
BEGIN
IF hint = 0 THEN
C.String(" hint ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
C.String("variable '"); C.String(name); C.StringLn("' never used")
END
END HintMsg;
PROCEDURE WarningMsg* (line, col, warning: INTEGER);
BEGIN
C.String(" warning ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE warning OF
|0: C.StringLn("passing a string value as a fixed array")
|1: C.StringLn("endless FOR loop")
|2: C.StringLn("identifier too long")
END
END WarningMsg;
PROCEDURE ErrorMsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
str: ARRAY 80 OF CHAR;
BEGIN
C.Ln;
C.String(" error ("); C.Int(errno); C.String(") ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE errno OF
| 1: str := "missing 'H' or 'X'"
| 2: str := "missing scale"
| 3: str := "unclosed string"
| 4: str := "illegal character"
| 5: str := "string too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
| 13: str := "real numbers not supported"
| 21: str := "'MODULE' expected"
| 22: str := "identifier expected"
| 23: str := "module name does not match file name"
| 24: str := "';' expected"
| 25: str := "identifier does not match module name"
| 26: str := "'.' expected"
| 27: str := "'END' expected"
| 28: str := "',', ';' or ':=' expected"
| 29: str := "module not found"
| 30: str := "multiply defined identifier"
| 31: str := "recursive import"
| 32: str := "'=' expected"
| 33: str := "')' expected"
| 34: str := "syntax error in expression"
| 35: str := "'}' expected"
| 36: str := "incompatible operand"
| 37: str := "incompatible operands"
| 38: str := "'RETURN' expected"
| 39: str := "integer overflow"
| 40: str := "floating point overflow"
| 41: str := "not enough floating point registers; simplify expression"
| 42: str := "out of range 0..255"
| 43: str := "expression is not an integer"
| 44: str := "out of range 0..MAXSET"
| 45: str := "division by zero"
| 46: str := "IV out of range"
| 47: str := "'OF' or ',' expected"
| 48: str := "undeclared identifier"
| 49: str := "type expected"
| 50: str := "recursive type definition"
| 51: str := "illegal value of constant"
| 52: str := "not a record type"
| 53: str := "':' expected"
| 54: str := "need to import SYSTEM"
| 55: str := "pointer type not defined"
| 56: str := "out of range 0..MAXSET"
| 57: str := "'TO' expected"
| 58: str := "not a record type"
| 59: str := "this expression cannot be a procedure"
| 60: str := "identifier does not match procedure name"
| 61: str := "illegally marked identifier"
| 62: str := "expression should be constant"
| 63: str := "not enough RAM"
| 64: str := "'(' expected"
| 65: str := "',' expected"
| 66: str := "incompatible parameter"
| 67: str := "'OF' expected"
| 68: str := "type expected"
| 69: str := "result type of procedure is not a basic type"
| 70: str := "import not supported"
| 71: str := "']' expected"
| 72: str := "expression is not BOOLEAN"
| 73: str := "not a record"
| 74: str := "undefined record field"
| 75: str := "not an array"
| 76: str := "expression is not an integer"
| 77: str := "not a pointer"
| 78: str := "type guard not allowed"
| 79: str := "not a type"
| 80: str := "not a record type"
| 81: str := "not a pointer type"
| 82: str := "type guard not allowed"
| 83: str := "index out of range"
| 84: str := "dimension too large"
| 85: str := "procedure must have level 0"
| 86: str := "not a procedure"
| 87: str := "incompatible expression (RETURN)"
| 88: str := "'THEN' expected"
| 89: str := "'DO' expected"
| 90: str := "'UNTIL' expected"
| 91: str := "incompatible assignment"
| 92: str := "procedure call of a function"
| 93: str := "not a variable"
| 94: str := "read only variable"
| 95: str := "invalid type of expression (CASE)"
| 96: str := "':=' expected"
| 97: str := "not INTEGER variable"
| 98: str := "illegal value of constant (0)"
| 99: str := "incompatible label"
|100: str := "multiply defined label"
|101: str := "too large parameter of WCHR"
|102: str := "label expected"
|103: str := "illegal value of constant"
|104: str := "type too large"
|105: str := "access to intermediate variables not allowed"
|106: str := "qualified identifier expected"
|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"
|114: str := "identifiers 'lib_init' and 'version' are reserved"
|115: str := "recursive constant definition"
|116: str := "procedure too deep nested"
|117: str := "string expected"
|118: str := "'$END', '$ELSE' or '$ELSIF' without '$IF'"
|119: str := "'$IF', '$ELSIF', '$ELSE' or '$END' expected"
|120: str := "too many formal parameters"
|121: str := "multiply defined handler"
|122: str := "bad divisor"
|123: str := "illegal flag"
|124: str := "unknown flag"
|125: str := "flag not supported"
|126: str := "type of formal parameter should not be REAL"
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END ErrorMsg;
PROCEDURE Error1 (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END Error1;
PROCEDURE Error3 (s1, s2, s3: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END Error3;
PROCEDURE Error5 (s1, s2, s3, s4, s5: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END Error5;
PROCEDURE WrongRTL* (ProcName: ARRAY OF CHAR);
BEGIN
Error5("procedure ", UTILS.RTL_NAME, ".", ProcName, " not found")
END WrongRTL;
PROCEDURE BadParam* (param: ARRAY OF CHAR);
BEGIN
Error3("bad parameter: ", param, "")
END BadParam;
PROCEDURE FileNotFound* (Path, Name, Ext: ARRAY OF CHAR);
BEGIN
Error5("file ", Path, Name, Ext, " not found")
END FileNotFound;
PROCEDURE Error* (n: INTEGER);
BEGIN
CASE n OF
|201: Error1("writing file error")
|202: Error1("too many relocations")
|203: Error1("size of program is too large")
|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 "', UTILS.FILE_EXT, '"')
|208: Error1("not enough RAM")
END
END Error;
END ERRORS.

200
programs/develop/oberon07/source/FILES.ob07 Normal file
View File

@@ -0,0 +1,200 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
All rights reserved.
*)
MODULE FILES;
IMPORT UTILS, C := COLLECTIONS;
TYPE
FILE* = POINTER TO RECORD (C.ITEM)
ptr: INTEGER;
buffer: ARRAY 64*1024 OF BYTE;
count: INTEGER
END;
VAR
files: C.COLLECTION;
PROCEDURE copy (src: ARRAY OF BYTE; src_idx: INTEGER; VAR dst: ARRAY OF BYTE; dst_idx: INTEGER; bytes: INTEGER);
BEGIN
WHILE bytes > 0 DO
dst[dst_idx] := src[src_idx];
INC(dst_idx);
INC(src_idx);
DEC(bytes)
END
END copy;
PROCEDURE flush (file: FILE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileWrite(file.ptr, file.buffer, file.count);
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END flush;
PROCEDURE NewFile (): FILE;
VAR
file: FILE;
citem: C.ITEM;
BEGIN
citem := C.pop(files);
IF citem = NIL THEN
NEW(file)
ELSE
file := citem(FILE)
END
RETURN file
END NewFile;
PROCEDURE create* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileCreate(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := 0
ELSE
file := NIL
END
RETURN file
END create;
PROCEDURE open* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileOpen(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := -1
ELSE
file := NIL
END
RETURN file
END open;
PROCEDURE close* (VAR file: FILE);
VAR
n: INTEGER;
BEGIN
IF file # NIL THEN
IF file.count > 0 THEN
n := flush(file)
END;
file.count := -1;
UTILS.FileClose(file.ptr);
file.ptr := 0;
C.push(files, file);
file := NIL
END
END close;
PROCEDURE read* (file: FILE; VAR chunk: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileRead(file.ptr, chunk, MAX(MIN(bytes, LEN(chunk)), 0));
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END read;
PROCEDURE write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
free, n, idx: INTEGER;
BEGIN
idx := 0;
IF (file # NIL) & (file.count >= 0) THEN
free := LEN(file.buffer) - file.count;
WHILE bytes > 0 DO
n := MIN(free, bytes);
copy(chunk, idx, file.buffer, file.count, n);
DEC(free, n);
DEC(bytes, n);
INC(idx, n);
INC(file.count, n);
IF free = 0 THEN
IF flush(file) # LEN(file.buffer) THEN
bytes := 0;
DEC(idx, n)
ELSE
file.count := 0;
free := LEN(file.buffer)
END
END
END
END
RETURN idx
END write;
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN;
VAR
arr: ARRAY 1 OF BYTE;
BEGIN
arr[0] := byte
RETURN write(file, arr, 1) = 1
END WriteByte;
BEGIN
files := C.create()
END FILES.

117
programs/develop/oberon07/source/HEX.ob07 Normal file
View File

@@ -0,0 +1,117 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE HEX;
IMPORT WRITER, CHL := CHUNKLISTS, UTILS;
VAR
chksum: INTEGER;
PROCEDURE Byte (byte: BYTE);
BEGIN
WRITER.WriteByte(UTILS.hexdgt(byte DIV 16));
WRITER.WriteByte(UTILS.hexdgt(byte MOD 16));
INC(chksum, byte)
END Byte;
PROCEDURE Byte4 (a, b, c, d: BYTE);
BEGIN
Byte(a);
Byte(b);
Byte(c);
Byte(d)
END Byte4;
PROCEDURE NewLine;
BEGIN
Byte((-chksum) MOD 256);
chksum := 0;
WRITER.WriteByte(0DH);
WRITER.WriteByte(0AH)
END NewLine;
PROCEDURE StartCode;
BEGIN
WRITER.WriteByte(ORD(":"));
chksum := 0
END StartCode;
PROCEDURE Data* (mem: ARRAY OF BYTE; idx, cnt: INTEGER);
VAR
i, len: INTEGER;
BEGIN
WHILE cnt > 0 DO
len := MIN(cnt, 16);
StartCode;
Byte4(len, idx DIV 256, idx MOD 256, 0);
FOR i := 1 TO len DO
Byte(mem[idx]);
INC(idx)
END;
DEC(cnt, len);
NewLine
END
END Data;
PROCEDURE ExtLA* (LA: INTEGER);
BEGIN
ASSERT((0 <= LA) & (LA <= 0FFFFH));
StartCode;
Byte4(2, 0, 0, 4);
Byte(LA DIV 256);
Byte(LA MOD 256);
NewLine
END ExtLA;
PROCEDURE Data2* (mem: CHL.BYTELIST; idx, cnt, LA: INTEGER);
VAR
i, len, offset: INTEGER;
BEGIN
ExtLA(LA);
offset := 0;
WHILE cnt > 0 DO
ASSERT(offset <= 65536);
IF offset = 65536 THEN
INC(LA);
ExtLA(LA);
offset := 0
END;
len := MIN(cnt, 16);
StartCode;
Byte4(len, offset DIV 256, offset MOD 256, 0);
FOR i := 1 TO len DO
Byte(CHL.GetByte(mem, idx));
INC(idx);
INC(offset)
END;
DEC(cnt, len);
NewLine
END
END Data2;
PROCEDURE End*;
BEGIN
StartCode;
Byte4(0, 0, 0, 1);
NewLine
END End;
END HEX.

1201
programs/develop/oberon07/source/IL.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

206
programs/develop/oberon07/source/KOS.ob07 Normal file
View File

@@ -0,0 +1,206 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE KOS;
IMPORT BIN, WR := WRITER, LISTS, CHL := CHUNKLISTS;
CONST
HEADER_SIZE = 36;
SIZE_OF_DWORD = 4;
TYPE
HEADER = RECORD
menuet01: ARRAY 9 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
END;
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER);
VAR
i: INTEGER;
imp: BIN.IMPRT;
BEGIN
libcount := 0;
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcount)
END;
imp := imp.next(BIN.IMPRT)
END;
len := libcount * 2 + 2;
size := (LISTS.count(program.imp_list) + len + 1) * SIZE_OF_DWORD;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO size DIV SIZE_OF_DWORD - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
CHL.SetInt(ImportTable, len, 0);
INC(len);
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD);
INC(i);
CHL.SetInt(ImportTable, i, imp.nameoffs + size + idata);
INC(i)
ELSE
CHL.SetInt(ImportTable, len, imp.nameoffs + size + idata);
imp.label := len * SIZE_OF_DWORD;
INC(len)
END;
imp := imp.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, len, 0);
CHL.SetInt(ImportTable, i, 0);
CHL.SetInt(ImportTable, i + 1, 0);
INC(len);
INC(size, CHL.Length(program._import))
END Import;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR);
CONST
PARAM_SIZE = 2048;
FileAlignment = 16;
VAR
header: HEADER;
base, text, data, idata, bss, offset: INTEGER;
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
i: INTEGER;
ImportTable: CHL.INTLIST;
ILen, libcount, isize: INTEGER;
icount, dcount, ccount: INTEGER;
code: CHL.BYTELIST;
BEGIN
base := 0;
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
text := base + HEADER_SIZE;
data := WR.align(text + ccount, FileAlignment);
idata := WR.align(data + dcount, FileAlignment);
Import(program, idata, ImportTable, ILen, libcount, isize);
bss := WR.align(idata + isize, FileAlignment);
header.menuet01 := "MENUET01";
header.ver := 1;
header.start := text;
header.size := idata + isize - base;
header.mem := WR.align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment);
header.sp := base + header.mem - PARAM_SIZE * 2;
header.param := header.sp;
header.path := header.param + PARAM_SIZE;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := 3 - offset - text;
CASE reloc.opcode OF
|BIN.RIMP:
iproc := BIN.GetIProc(program, L);
delta := idata + iproc.label
|BIN.RBSS:
delta := L + bss
|BIN.RDATA:
delta := L + data
|BIN.RCODE:
delta := BIN.GetLabel(program, L) + text
|BIN.PICDATA:
INC(delta, L + data)
|BIN.PICCODE:
INC(delta, BIN.GetLabel(program, L) + text)
|BIN.PICBSS:
INC(delta, L + bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
INC(delta, idata + iproc.label)
|BIN.IMPTAB:
INC(delta, idata)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END;
WR.Create(FileName);
FOR i := 0 TO 7 DO
WR.WriteByte(ORD(header.menuet01[i]))
END;
WR.Write32LE(header.ver);
WR.Write32LE(header.start);
WR.Write32LE(header.size);
WR.Write32LE(header.mem);
WR.Write32LE(header.sp);
WR.Write32LE(header.param);
WR.Write32LE(header.path);
CHL.WriteToFile(code);
WR.Padding(FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(program._import);
WR.Close
END write;
END KOS.

199
programs/develop/oberon07/source/LISTS.ob07 Normal file
View File

@@ -0,0 +1,199 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE LISTS;
IMPORT C := COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD (C.ITEM)
prev*, next*: ITEM
END;
LIST* = POINTER TO RECORD
first*, last*: ITEM
END;
PROCEDURE push* (list: LIST; item: ITEM);
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
IF list.first = NIL THEN
list.first := item;
item.prev := NIL
ELSE
ASSERT(list.last # NIL);
item.prev := list.last;
list.last.next := item
END;
list.last := item;
item.next := NIL
END push;
PROCEDURE pop* (list: LIST): ITEM;
VAR
last: ITEM;
BEGIN
ASSERT(list # NIL);
last := list.last;
IF last # NIL THEN
IF last = list.first THEN
list.first := NIL;
list.last := NIL
ELSE
list.last := last.prev;
list.last.next := NIL
END;
last.next := NIL;
last.prev := NIL
END
RETURN last
END pop;
PROCEDURE insert* (list: LIST; cur, nov: ITEM);
VAR
next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
next := cur.next;
IF next # NIL THEN
next.prev := nov;
nov.next := next;
cur.next := nov;
nov.prev := cur
ELSE
push(list, nov)
END
END insert;
PROCEDURE insertL* (list: LIST; cur, nov: ITEM);
VAR
prev: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
prev := cur.prev;
IF prev # NIL THEN
prev.next := nov;
nov.prev := prev
ELSE
nov.prev := NIL;
list.first := nov
END;
cur.prev := nov;
nov.next := cur
END insertL;
PROCEDURE delete* (list: LIST; item: ITEM);
VAR
prev, next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
prev := item.prev;
next := item.next;
IF next # NIL THEN
IF prev # NIL THEN
prev.next := next;
next.prev := prev
ELSE
next.prev := NIL;
list.first := next
END
ELSE
IF prev # NIL THEN
prev.next := NIL;
list.last := prev
ELSE
list.first := NIL;
list.last := NIL
END
END
END delete;
PROCEDURE count* (list: LIST): INTEGER;
VAR
item: ITEM;
res: INTEGER;
BEGIN
ASSERT(list # NIL);
res := 0;
item := list.first;
WHILE item # NIL DO
INC(res);
item := item.next
END
RETURN res
END count;
PROCEDURE getidx* (list: LIST; idx: INTEGER): ITEM;
VAR
item: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(idx >= 0);
item := list.first;
WHILE (item # NIL) & (idx > 0) DO
item := item.next;
DEC(idx)
END
RETURN item
END getidx;
PROCEDURE create* (list: LIST): LIST;
BEGIN
IF list = NIL THEN
NEW(list)
END;
list.first := NIL;
list.last := NIL
RETURN list
END create;
END LISTS.

309
programs/develop/oberon07/source/MSCOFF.ob07 Normal file
View File

@@ -0,0 +1,309 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE MSCOFF;
IMPORT BIN, PE32, KOS, WR := WRITER, UTILS, ERRORS, LISTS, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
(* SectionHeader.Characteristics *)
SHC_flat = 040500020H;
SHC_data = 0C0500040H;
SHC_bss = 0C03000C0H;
TYPE
FH = PE32.IMAGE_FILE_HEADER;
SH = PE32.IMAGE_SECTION_HEADER;
PROCEDURE WriteReloc (VirtualAddress, SymbolTableIndex, Type: INTEGER);
BEGIN
WR.Write32LE(VirtualAddress);
WR.Write32LE(SymbolTableIndex);
WR.Write16LE(Type)
END WriteReloc;
PROCEDURE Reloc (program: BIN.PROGRAM);
VAR
reloc: BIN.RELOC;
offset: INTEGER;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
offset := reloc.offset;
CASE reloc.opcode OF
|BIN.RIMP,
BIN.IMPTAB: WriteReloc(offset, 4, 6)
|BIN.RBSS: WriteReloc(offset, 5, 6)
|BIN.RDATA: WriteReloc(offset, 2, 6)
|BIN.RCODE: WriteReloc(offset, 1, 6)
END;
reloc := reloc.next(BIN.RELOC)
END;
END Reloc;
PROCEDURE RelocCount (program: BIN.PROGRAM): INTEGER;
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
res, L: INTEGER;
offset: INTEGER;
code: CHL.BYTELIST;
BEGIN
res := 0;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
INC(res);
offset := reloc.offset;
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(code, offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(code, offset);
BIN.put32le(code, offset, BIN.GetLabel(program, L))
END;
reloc := reloc.next(BIN.RELOC)
END
RETURN res
END RelocCount;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER);
VAR
exp: BIN.EXPRT;
n, i: INTEGER;
szversion: PE32.NAME;
ImportTable: CHL.INTLIST;
ILen, LibCount, isize: INTEGER;
ExpCount: INTEGER;
icount, ecount, dcount, ccount: INTEGER;
FileHeader: FH;
flat, data, edata, idata, bss: SH;
PROCEDURE ICount (ImportTable: CHL.INTLIST; ILen: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := 0;
FOR i := 0 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
INC(res)
END
END
RETURN res
END ICount;
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER);
BEGIN
IF NumberOfRelocations >= 65536 THEN
ERRORS.Error(202)
END;
section.NumberOfRelocations := WCHR(NumberOfRelocations)
END SetNumberOfRelocations;
BEGIN
szversion := "version";
ASSERT(LENGTH(szversion) = 7);
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize);
ExpCount := LISTS.count(program.exp_list);
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
ecount := CHL.Length(program.export);
FileHeader.Machine := 014CX;
FileHeader.NumberOfSections := 5X;
FileHeader.TimeDateStamp := UTILS.UnixTime();
(* FileHeader.PointerToSymbolTable := 0; *)
FileHeader.NumberOfSymbols := 6;
FileHeader.SizeOfOptionalHeader := 0X;
FileHeader.Characteristics := 0184X;
flat.Name := ".flat";
flat.VirtualSize := 0;
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.PointerToLinenumbers := 0;
SetNumberOfRelocations(flat, RelocCount(program));
flat.NumberOfLinenumbers := 0X;
flat.Characteristics := SHC_flat;
data.Name := ".data";
data.VirtualSize := 0;
data.VirtualAddress := 0;
data.SizeOfRawData := dcount;
data.PointerToRawData := flat.PointerToRawData + flat.SizeOfRawData;
data.PointerToRelocations := 0;
data.PointerToLinenumbers := 0;
data.NumberOfRelocations := 0X;
data.NumberOfLinenumbers := 0X;
data.Characteristics := SHC_data;
edata.Name := ".edata";
edata.VirtualSize := 0;
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.PointerToLinenumbers := 0;
SetNumberOfRelocations(edata, ExpCount * 2 + 1);
edata.NumberOfLinenumbers := 0X;
edata.Characteristics := SHC_data;
idata.Name := ".idata";
idata.VirtualSize := 0;
idata.VirtualAddress := 0;
idata.SizeOfRawData := isize;
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData;
(* idata.PointerToRelocations := 0; *)
idata.PointerToLinenumbers := 0;
SetNumberOfRelocations(idata, ICount(ImportTable, ILen));
idata.NumberOfLinenumbers := 0X;
idata.Characteristics := SHC_data;
bss.Name := ".bss";
bss.VirtualSize := 0;
bss.VirtualAddress := 0;
bss.SizeOfRawData := program.bss;
bss.PointerToRawData := 0;
bss.PointerToRelocations := 0;
bss.PointerToLinenumbers := 0;
bss.NumberOfRelocations := 0X;
bss.NumberOfLinenumbers := 0X;
bss.Characteristics := SHC_bss;
flat.PointerToRelocations := idata.PointerToRawData + idata.SizeOfRawData;
edata.PointerToRelocations := flat.PointerToRelocations + ORD(flat.NumberOfRelocations) * 10;
idata.PointerToRelocations := edata.PointerToRelocations + ORD(edata.NumberOfRelocations) * 10;
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10;
WR.Create(FileName);
PE32.WriteFileHeader(FileHeader);
PE32.WriteSectionHeader(flat);
PE32.WriteSectionHeader(data);
PE32.WriteSectionHeader(edata);
PE32.WriteSectionHeader(idata);
PE32.WriteSectionHeader(bss);
CHL.WriteToFile(program.code);
CHL.WriteToFile(program.data);
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WR.Write32LE(exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(exp.label);
exp := exp.next(BIN.EXPRT)
END;
WR.Write32LE(((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(ver);
WR.Write32LE(0);
PE32.WriteName(szversion);
CHL.WriteToFile(program.export);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(program._import);
Reloc(program);
n := 0;
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WriteReloc(n, 3, 6);
INC(n, 4);
WriteReloc(n, 1, 6);
INC(n, 4);
exp := exp.next(BIN.EXPRT)
END;
WriteReloc(n, 3, 6);
FOR i := 0 TO LibCount * 2 - 1 DO
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END;
FOR i := LibCount * 2 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END
END;
PE32.WriteName("EXPORTS");
WriteReloc(0, 3, 2);
PE32.WriteName(".flat");
WriteReloc(0, 1, 3);
PE32.WriteName(".data");
WriteReloc(0, 2, 3);
PE32.WriteName(".edata");
WriteReloc(0, 3, 3);
PE32.WriteName(".idata");
WriteReloc(0, 4, 3);
PE32.WriteName(".bss");
WriteReloc(0, 5, 3);
WR.Write32LE(4);
WR.Close
END write;
END MSCOFF.

1771
programs/develop/oberon07/source/MSP430.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

671
programs/develop/oberon07/source/MSP430RTL.ob07 Normal file
View File

@@ -0,0 +1,671 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE MSP430RTL;
CONST
_mul* = 0;
_divmod* = 1;
_lsl* = 2;
_asr* = 3;
_ror* = 4;
_lsr* = 5;
_in* = 6;
_in2* = 7;
_set1* = 8;
_incl* = 9;
_excl* = 10;
_move* = 11;
_set* = 12;
_arrcpy* = 13;
_rot* = 14;
_strcmp* = 15;
_error* = 16;
_is* = 17;
_guard* = 18;
_guardrec* = 19;
_length* = 20;
_new* = 21;
HP* = 15;
LenIV* = 32;
iv = 10000H - LenIV * 2;
bsl = iv - 2;
sp = bsl - 2;
empty_proc* = sp - 2;
bits = empty_proc - 272;
bits_offs = bits - 32;
DataSize* = iv - bits_offs;
types = bits_offs - 2;
IntVectorSize* = LenIV * 2 + DataSize;
VarSize* = 4;
StkReserve* = 40;
trap = 2;
TYPE
EMITPROC = PROCEDURE (n: INTEGER);
VAR
ram*: INTEGER;
rtl*: ARRAY 22 OF
RECORD
label*: INTEGER;
used: BOOLEAN
END;
Label, Word, Call: EMITPROC;
PROCEDURE Gen*;
PROCEDURE Word1 (word: INTEGER);
BEGIN
Word(word)
END Word1;
PROCEDURE Word2 (word1, word2: INTEGER);
BEGIN
Word1(word1);
Word1(word2)
END Word2;
PROCEDURE Word3 (word1, word2, word3: INTEGER);
BEGIN
Word1(word1);
Word1(word2);
Word1(word3)
END Word3;
BEGIN
(* _lsl (n, x: INTEGER): INTEGER *)
IF rtl[_lsl].used THEN
Label(rtl[_lsl].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(5404H); (* ADD R4, R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _asr (n, x: INTEGER): INTEGER *)
IF rtl[_asr].used THEN
Label(rtl[_asr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(1104H); (* RRA R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _ror (n, x: INTEGER): INTEGER *)
IF rtl[_ror].used THEN
Label(rtl[_ror].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 5); (* JZ L1 *)
Word1(4406H); (* MOV R4, R6 *)
(* L2: *)
Word1(1006H); (* RRC R6 *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _lsr (n, x: INTEGER): INTEGER *)
IF rtl[_lsr].used THEN
Label(rtl[_lsr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 4); (* JZ L1 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _set (b, a: INTEGER): SET *)
IF rtl[_set].used THEN
Label(rtl[_set].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- b *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(9504H); (* CMP R5, R4 *)
Word1(3800H + 24); (* JL L1 *)
Word2(9035H, 16); (* CMP #16, R5 *)
Word1(3400H + 21); (* JGE L1 *)
Word1(9304H); (* CMP #0, R4 *)
Word1(3800H + 19); (* JL L1 *)
Word2(9034H, 16); (* CMP #16, R4 *)
Word1(3800H + 2); (* JL L2 *)
Word2(4034H, 15); (* MOV #15, R4 *)
(* L2: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 1); (* JGE L3 *)
Word1(4305H); (* MOV #0, R5 *)
(* L3: *)
Word1(8504H); (* SUB R5, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits_offs); (* ADD bits_offs, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(5405H); (* ADD R4, R5 *)
Word2(5035H, bits); (* ADD bits, R5 *)
Word1(4524H); (* MOV @R5, R4 *)
Word1(4130H); (* RET *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _set1 (a: INTEGER): SET *)
IF rtl[_set1].used THEN
Label(rtl[_set1].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- a *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 5); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(4130H); (* RET *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _in2 (i, s: INTEGER): BOOLEAN *)
IF rtl[_in2].used THEN
Label(rtl[_in2].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- i *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 4); (* AND 4(SP), R4 *)
Word1(2400H + 1); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _in (s, i: INTEGER): BOOLEAN *)
IF rtl[_in].used THEN
Label(rtl[_in].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 9); (* JNZ L2 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 2); (* AND 2(SP), R4 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* RET *)
(* L2: *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _incl (VAR s: SET; i: INTEGER) *)
IF rtl[_incl].used THEN
Label(rtl[_incl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0D485H, 0); (* BIS R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _excl (VAR s: SET; i: INTEGER) *)
IF rtl[_excl].used THEN
Label(rtl[_excl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0C485H, 0); (* BIC R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _rot (len, adr: INTEGER) *)
IF rtl[_rot].used THEN
Label(rtl[_rot].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- len *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- adr *)
Word1(8314H); (* SUB #1, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word1(1225H); (* PUSH @R5 *)
Word1(4406H); (* MOV R4, R6 *)
(* L1: *)
Word3(4595H, 2, 0); (* MOV 2(R5), 0(R5) *)
Word1(5325H); (* ADD #2, R5 *)
Word1(8326H); (* SUB #2, R6 *)
Word1(2000H + 400H - 6); (* JNZ L1 *)
Word2(41B5H, 0); (* MOV @SP+, 0(R5) *)
Word1(4130H) (* RET *)
END;
(* _divmod (b, a: INTEGER): INTEGER (* res -> R4, mod -> R5 *) *)
IF rtl[_divmod].used THEN
Label(rtl[_divmod].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 17); (* JL L3 *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(8605H); (* SUB R6, R5 *)
Word1(5704H); (* ADD R7, R4 *)
Word1(3C00H + 400H - 21); (* JMP L1 *)
(* L3: *)
(*----------- (a < 0) --------------*)
(* L1: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 23); (* JGE L3 *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(8704H); (* SUB R7, R4 *)
Word1(3C00H + 400H - 25); (* JMP L1 *)
(* L3: *)
Word1(4130H) (* RET *)
END;
(* _mul (a, b: INTEGER): INTEGER *)
IF rtl[_mul].used THEN
Label(rtl[_mul].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- a *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- b *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 7); (* JZ L1 *)
(* L2: *)
Word1(0B316H); (* BIT #1, R6 *)
Word1(2400H + 1); (* JZ L3 *)
Word1(5504H); (* ADD R5, R4 *)
(* L3: *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(2000H + 400H - 7); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _error (modNum, modName, err, line: INTEGER) *)
IF rtl[_error].used THEN
Label(rtl[_error].label);
Word1(5321H); (* ADD #2, SP *)
Word1(4134H); (* POP R4; R4 <- modNum *)
Word1(4135H); (* POP R5; R5 <- modName *)
Word1(4136H); (* POP R6; R6 <- err *)
Word1(4137H); (* POP 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 *)
Word2(4214H, sp); (* MOV sp(SR), R4 *)
Word2(1294H, trap); (* CALL trap(R4) *)
Word2(04032H, 0F0H) (* MOV CPUOFF+OSCOFF+SCG0+SCG1, SR *)
END;
(* _new (t, size: INTEGER; VAR ptr: INTEGER) *)
IF rtl[_new].used THEN
Label(rtl[_new].label);
Word1(1202H); (* PUSH SR *)
Word1(4302H); (* MOV #0, SR *)
Word1(4303H); (* NOP *)
Word1(4104H); (* MOV SP, R4 *)
Word2(8034H, StkReserve); (* SUB #StkReserve, R4 *)
Word1(4005H + 100H * HP); (* MOV HP, R5 *)
Word2(5115H, 6); (* ADD 6(SP), R5 *)
Word1(9504H); (* CMP R5, R4 *)
Word2(4114H, 8); (* MOV 8(SP), R4 *)
Word1(3800H + 12); (* JL L1 *)
Word3(4190H + HP, 4, 0); (* MOV 4(SP), 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word2(4084H + 100H * HP, 0); (* MOV HP, 0(R4) *)
(* L3 *)
Word2(4380H + HP, 0); (* MOV #0, 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word1(9500H + HP); (* CMP R5, HP *)
Word1(3800H + 400H - 5); (* JL L3 *)
Word1(3C00H + 2); (* JMP L2 *)
(* L1 *)
Word2(4384H, 0); (* MOV #0, 0(R4) *)
(* L2 *)
Word1(1300H) (* RETI *)
END;
(* _guardrec (t0, t1: INTEGER): INTEGER *)
IF rtl[_guardrec].used THEN
Label(rtl[_guardrec].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t0 *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- t1 *)
Word2(4036H, types); (* MOV #types, R6 *)
(* L3: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 8); (* JZ L1 *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 10); (* JZ L2 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(3C00H + 400H - 10); (* JMP L3 *)
(* L1: *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H); (* RET *)
(* L2: *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H) (* RET *)
END;
(* _is (t, p: INTEGER): INTEGER *)
IF rtl[_is].used THEN
Label(rtl[_is].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- p *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- t *)
Word1(9304H); (* TST R4 *)
Word1(2400H + 2); (* JZ L *)
Word2(4414H, -2); (* MOV -2(R4), R4 *)
(* L: *)
Word1(1204H); (* PUSH R4 *)
Word1(1205H); (* PUSH R5 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
Word1(4130H) (* RET *)
END;
(* _guard (t, p: INTEGER): INTEGER *)
IF rtl[_guard].used THEN
Label(rtl[_guard].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- p *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(9305H); (* TST R5 *)
Word1(2400H + 9); (* JZ L *)
Word2(4515H, -2); (* MOV -2(R5), R5 *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t *)
Word1(1205H); (* PUSH R5 *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
(* L: *)
Word1(4130H) (* RET *)
END;
(* _move (bytes, dest, source: INTEGER) *)
IF rtl[_move].used THEN
Label(rtl[_move].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- bytes *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- dest *)
Word2(4115H, 6); (* MOV 6(SP), R5; R5 <- source *)
Word1(9306H); (* CMP #0, R6 *)
Word1(3800H + 6); (* JL L1 *)
Word1(2400H + 5); (* JZ L1 *)
(* L2: *)
Word2(45F7H, 0); (* MOV.B @R5+, 0(R7) *)
Word1(5317H); (* ADD #1, R7 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 5); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _arrcpy (base_size, len_dst, dst, len_src, src: INTEGER) *)
IF rtl[_arrcpy].used THEN
Label(rtl[_arrcpy].label);
Word3(9191H, 8, 4); (* CMP 8(SP), 4(SP) *)
Word1(3800H + 18); (* JL L1 *)
Word2(1211H, 12); (* PUSH 12(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Word2(1211H, 14); (* PUSH 14(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Call(rtl[_mul].label); (* CALL _mul *)
Word1(5221H); (* ADD #4, SP *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_move].label); (* CALL _move *)
Word2(5031H, 6); (* ADD #6, SP *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* RET *)
(* L1 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _length (len, str: INTEGER): INTEGER *)
IF rtl[_length].used THEN
Label(rtl[_length].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- len *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- str *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
(* L2: *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 6); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _strcmp (op, len2, str2, len1, str1: INTEGER): BOOLEAN *)
IF rtl[_strcmp].used THEN
Label(rtl[_strcmp].label);
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(3400H + 1); (* JGE L5 *)
Word1(4706H); (* MOV R7, R6 *)
(* L5: *)
Word1(1206H); (* PUSH R6 *)
Word2(4116H, 12); (* MOV 12(SP), R6; R6 <- str1 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- str2 *)
(* L3: *)
Word2(9381H, 0); (* CMP #0, 0(SP) *)
Word1(2400H + 11); (* JZ L1 *)
Word1(4674H); (* MOV.B @R6+, R4 *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word2(8391H, 0); (* SUB #1, 0(SP) *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(8504H); (* SUB R5, R4 *)
Word1(3C00H + 5); (* JMP L4 *)
(* L2: *)
Word1(9304H); (* CMP #0, R4 *)
Word1(2000H + 400H - 13); (* JNZ L3 *)
Word1(3C00H + 2); (* JMP L4 *)
(* L1: *)
Word2(4034H, 8000H); (* MOV #8000H, R4 *)
(* L4: *)
Word1(5321H); (* ADD #2, SP *)
Word2(9034H, 8000H); (* CMP #8000H, R4 *)
Word1(2000H + 18); (* JNZ L6 *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(2400H + 11); (* JZ L7 *)
Word1(3800H + 4); (* JL L8 *)
Word2(5116H, 10); (* ADD 10(SP), R6 *)
Word1(4664H); (* MOV.B @R6, R4 *)
Word1(3C00H + 7); (* JMP L6 *)
(* L8: *)
Word2(5117H, 6); (* ADD 6(SP), R7 *)
Word1(4764H); (* MOV.B @R7, R4 *)
Word1(0E334H); (* XOR #-1, R4 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(3C00H + 1); (* JMP L6 *)
(* L7: *)
Word1(4304H); (* MOV #0, R4 *)
(* L6: *)
Word2(5110H, 2); (* ADD 2(SP), PC; PC <- PC + op *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2000H + 1); (* JNZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 1); (* JL L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4314H); (* MOV #1, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3400H + 1); (* JGE L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H) (* RET *)
END
END Gen;
PROCEDURE Set* (idx, label: INTEGER);
BEGIN
rtl[idx].label := label;
rtl[idx].used := FALSE
END Set;
PROCEDURE Used* (idx: INTEGER);
BEGIN
rtl[idx].used := TRUE;
IF (idx = _guard) OR (idx = _is) THEN
rtl[_guardrec].used := TRUE
ELSIF idx = _arrcpy THEN
rtl[_move].used := TRUE;
rtl[_mul].used := TRUE
END
END Used;
PROCEDURE Init* (pLabel, pWord, pCall: EMITPROC);
BEGIN
Label := pLabel;
Word := pWord;
Call := pCall;
ram := 200H;
END Init;
END MSP430RTL.

1397
programs/develop/oberon07/source/PARS.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

151
programs/develop/oberon07/source/PATHS.ob07 Normal file
View File

@@ -0,0 +1,151 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE PATHS;
IMPORT STRINGS, UTILS;
CONST
slash = UTILS.slash;
PATHLEN = 2048;
TYPE
PATH* = ARRAY PATHLEN OF CHAR;
PROCEDURE split* (fname: ARRAY OF CHAR; VAR path, name, ext: ARRAY OF CHAR);
VAR
pos1, pos2, len: INTEGER;
BEGIN
len := LENGTH(fname);
pos1 := len - 1;
pos2 := pos1;
STRINGS.search(fname, pos1, slash, FALSE);
STRINGS.search(fname, pos2, ".", FALSE);
path := fname;
path[pos1 + 1] := 0X;
IF (pos2 = -1) OR (pos2 < pos1) THEN
pos2 := len
END;
INC(pos1);
STRINGS.copy(fname, name, pos1, 0, pos2 - pos1);
name[pos2 - pos1] := 0X;
STRINGS.copy(fname, ext, pos2, 0, len - pos2);
ext[len - pos2] := 0X
END split;
PROCEDURE RelPath* (absolute, relative: ARRAY OF CHAR; VAR res: ARRAY OF CHAR);
VAR
i, j: INTEGER;
error: BOOLEAN;
BEGIN
COPY(absolute, res);
i := LENGTH(res) - 1;
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
INC(i);
res[i] := 0X;
error := FALSE;
j := 0;
WHILE (relative[j] = ".") & (relative[j + 1] = slash) DO
INC(j, 2)
ELSIF relative[j] = slash DO
INC(j)
END;
WHILE ~error & (relative[j] # 0X) DO
IF (relative[j] = ".") & (relative[j + 1] = ".") & (relative[j + 2] = slash) & (i > 0) & (res[i - 1] = slash) THEN
DEC(i, 2);
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
IF i < 0 THEN
error := TRUE
ELSE
INC(i);
INC(j, 3)
END
ELSE
res[i] := relative[j];
INC(i);
INC(j)
END
END;
IF error THEN
COPY(relative, res)
ELSE
res[i] := 0X
END
END RelPath;
PROCEDURE DelSlashes* (VAR path: ARRAY OF CHAR);
VAR
i, j, k: INTEGER;
c: CHAR;
BEGIN
i := 0;
j := 0;
k := 0;
REPEAT
c := path[j];
INC(j);
IF c = slash THEN
INC(k)
ELSE
k := 0
END;
IF k <= 1 THEN
path[i] := c;
INC(i)
END
UNTIL c = 0X;
i := 0;
j := 0;
REPEAT
c := path[j];
INC(j);
path[i] := c;
INC(i);
IF (c = slash) & (path[j] = ".") & (path[j + 1] = slash) THEN
INC(j, 2)
END
UNTIL c = 0X
END DelSlashes;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN UTILS.isRelative(path)
END isRelative;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
UTILS.GetCurrentDirectory(path)
END GetCurrentDirectory;
END PATHS.

695
programs/develop/oberon07/source/PE32.ob07 Normal file
View File

@@ -0,0 +1,695 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE PE32;
IMPORT BIN, LISTS, UTILS, WR := WRITER, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
SIZE_OF_WORD = 2;
SIZE_OF_IMAGE_EXPORT_DIRECTORY = 40;
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
IMAGE_SIZEOF_SHORT_NAME = 8;
SIZE_OF_IMAGE_FILE_HEADER* = 20;
SIZE_OF_IMAGE_SECTION_HEADER* = 40;
(* SectionHeader.Characteristics *)
SHC_text = 060000020H;
SHC_data = 040000040H;
SHC_bss = 0C0000080H;
SectionAlignment = 1000H;
FileAlignment = 200H;
TYPE
WORD = WCHAR;
DWORD = INTEGER;
NAME* = ARRAY IMAGE_SIZEOF_SHORT_NAME OF CHAR;
IMAGE_DATA_DIRECTORY = RECORD
VirtualAddress: DWORD;
Size: DWORD
END;
IMAGE_OPTIONAL_HEADER = RECORD
Magic: WORD;
MajorLinkerVersion: BYTE;
MinorLinkerVersion: BYTE;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
BaseOfData: DWORD;
ImageBase: DWORD;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: WORD;
MinorOperatingSystemVersion: WORD;
MajorImageVersion: WORD;
MinorImageVersion: WORD;
MajorSubsystemVersion: WORD;
MinorSubsystemVersion: WORD;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: WORD;
DllCharacteristics: WORD;
SizeOfStackReserve: DWORD;
SizeOfStackCommit: DWORD;
SizeOfHeapReserve: DWORD;
SizeOfHeapCommit: DWORD;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: ARRAY IMAGE_NUMBEROF_DIRECTORY_ENTRIES OF IMAGE_DATA_DIRECTORY
END;
IMAGE_FILE_HEADER* = RECORD
Machine*: WORD;
NumberOfSections*: WORD;
TimeDateStamp*: DWORD;
PointerToSymbolTable*: DWORD;
NumberOfSymbols*: DWORD;
SizeOfOptionalHeader*: WORD;
Characteristics*: WORD
END;
IMAGE_SECTION_HEADER* = RECORD
Name*: NAME;
VirtualSize*,
VirtualAddress*,
SizeOfRawData*,
PointerToRawData*,
PointerToRelocations*,
PointerToLinenumbers*: DWORD;
NumberOfRelocations*,
NumberOfLinenumbers*: WORD;
Characteristics*: DWORD
END;
IMAGE_EXPORT_DIRECTORY = RECORD
Characteristics: DWORD;
TimeDateStamp: DWORD;
MajorVersion: WORD;
MinorVersion: WORD;
Name,
Base,
NumberOfFunctions,
NumberOfNames,
AddressOfFunctions,
AddressOfNames,
AddressOfNameOrdinals: DWORD
END;
VIRTUAL_ADDR* = RECORD
Code*, Data*, Bss*, Import*: INTEGER
END;
VAR
Signature: ARRAY 4 OF BYTE;
FileHeader: IMAGE_FILE_HEADER;
OptionalHeader: IMAGE_OPTIONAL_HEADER;
msdos: ARRAY 128 OF BYTE;
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER;
libcnt: INTEGER;
SizeOfWord: INTEGER;
PROCEDURE Export (program: BIN.PROGRAM; name: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
BEGIN
ExportDir.Characteristics := 0;
ExportDir.TimeDateStamp := FileHeader.TimeDateStamp;
ExportDir.MajorVersion := 0X;
ExportDir.MinorVersion := 0X;
ExportDir.Name := name;
ExportDir.Base := 0;
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list);
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions;
ExportDir.AddressOfFunctions := SIZE_OF_IMAGE_EXPORT_DIRECTORY;
ExportDir.AddressOfNames := ExportDir.AddressOfFunctions + ExportDir.NumberOfFunctions * SIZE_OF_DWORD;
ExportDir.AddressOfNameOrdinals := ExportDir.AddressOfNames + ExportDir.NumberOfFunctions * SIZE_OF_DWORD
RETURN SIZE_OF_IMAGE_EXPORT_DIRECTORY + ExportDir.NumberOfFunctions * (2 * SIZE_OF_DWORD + SIZE_OF_WORD)
END Export;
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER;
VAR
imp: BIN.IMPRT;
res: INTEGER;
BEGIN
res := 0;
imp := lib.next(BIN.IMPRT);
WHILE (imp # NIL) & (imp.label # 0) DO
INC(res);
imp := imp.next(BIN.IMPRT)
END
RETURN res
END GetProcCount;
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER;
VAR
imp: BIN.IMPRT;
proccnt: INTEGER;
procoffs: INTEGER;
OriginalCurrentThunk,
CurrentThunk: INTEGER;
BEGIN
libcnt := 0;
proccnt := 0;
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcnt)
ELSE
INC(proccnt)
END;
imp := imp.next(BIN.IMPRT)
END;
procoffs := 0;
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
imp.OriginalFirstThunk := procoffs;
imp.FirstThunk := procoffs + (GetProcCount(imp) + 1);
OriginalCurrentThunk := imp.OriginalFirstThunk;
CurrentThunk := imp.FirstThunk;
INC(procoffs, (GetProcCount(imp) + 1) * 2)
ELSE
imp.OriginalFirstThunk := OriginalCurrentThunk;
imp.FirstThunk := CurrentThunk;
INC(OriginalCurrentThunk);
INC(CurrentThunk)
END;
imp := imp.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord
END GetImportSize;
PROCEDURE fixup* (program: BIN.PROGRAM; Address: VIRTUAL_ADDR; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
code: CHL.BYTELIST;
L, delta, delta0, AdrImp, offset: 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(amd64) - Address.Code;
WHILE reloc # NIL DO
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := delta0 - offset;
CASE reloc.opcode OF
|BIN.PICDATA:
INC(delta, L + Address.Data)
|BIN.PICCODE:
INC(delta, BIN.GetLabel(program, L) + Address.Code)
|BIN.PICBSS:
INC(delta, L + Address.Bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
INC(delta, iproc.FirstThunk * SizeOfWord + AdrImp)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END
END fixup;
PROCEDURE WriteWord (w: WORD);
BEGIN
WR.Write16LE(ORD(w))
END WriteWord;
PROCEDURE WriteName* (name: NAME);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(ORD(name[i]))
END;
i := LEN(name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(0);
DEC(i)
END
END WriteName;
PROCEDURE WriteSectionHeader* (h: IMAGE_SECTION_HEADER);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(h.Name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(ORD(h.Name[i]))
END;
i := LEN(h.Name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(0);
DEC(i)
END;
WR.Write32LE(h.VirtualSize);
WR.Write32LE(h.VirtualAddress);
WR.Write32LE(h.SizeOfRawData);
WR.Write32LE(h.PointerToRawData);
WR.Write32LE(h.PointerToRelocations);
WR.Write32LE(h.PointerToLinenumbers);
WriteWord(h.NumberOfRelocations);
WriteWord(h.NumberOfLinenumbers);
WR.Write32LE(h.Characteristics)
END WriteSectionHeader;
PROCEDURE WriteFileHeader* (h: IMAGE_FILE_HEADER);
BEGIN
WriteWord(h.Machine);
WriteWord(h.NumberOfSections);
WR.Write32LE(h.TimeDateStamp);
WR.Write32LE(h.PointerToSymbolTable);
WR.Write32LE(h.NumberOfSymbols);
WriteWord(h.SizeOfOptionalHeader);
WriteWord(h.Characteristics)
END WriteFileHeader;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; console, dll, amd64: BOOLEAN);
VAR
i, n, temp: INTEGER;
Size: RECORD
Code, Data, Bss, Import, Reloc, Export: INTEGER
END;
BaseAddress: INTEGER;
Address: VIRTUAL_ADDR;
_import: BIN.IMPRT;
ImportTable: CHL.INTLIST;
ExportDir: IMAGE_EXPORT_DIRECTORY;
export: BIN.EXPRT;
PROCEDURE WriteExportDir (e: IMAGE_EXPORT_DIRECTORY);
BEGIN
WR.Write32LE(e.Characteristics);
WR.Write32LE(e.TimeDateStamp);
WriteWord(e.MajorVersion);
WriteWord(e.MinorVersion);
WR.Write32LE(e.Name);
WR.Write32LE(e.Base);
WR.Write32LE(e.NumberOfFunctions);
WR.Write32LE(e.NumberOfNames);
WR.Write32LE(e.AddressOfFunctions);
WR.Write32LE(e.AddressOfNames);
WR.Write32LE(e.AddressOfNameOrdinals)
END WriteExportDir;
PROCEDURE WriteOptHeader (h: IMAGE_OPTIONAL_HEADER; amd64: BOOLEAN);
VAR
i: INTEGER;
BEGIN
WriteWord(h.Magic);
WR.WriteByte(h.MajorLinkerVersion);
WR.WriteByte(h.MinorLinkerVersion);
WR.Write32LE(h.SizeOfCode);
WR.Write32LE(h.SizeOfInitializedData);
WR.Write32LE(h.SizeOfUninitializedData);
WR.Write32LE(h.AddressOfEntryPoint);
WR.Write32LE(h.BaseOfCode);
IF amd64 THEN
WR.Write64LE(h.ImageBase)
ELSE
WR.Write32LE(h.BaseOfData);
WR.Write32LE(h.ImageBase)
END;
WR.Write32LE(h.SectionAlignment);
WR.Write32LE(h.FileAlignment);
WriteWord(h.MajorOperatingSystemVersion);
WriteWord(h.MinorOperatingSystemVersion);
WriteWord(h.MajorImageVersion);
WriteWord(h.MinorImageVersion);
WriteWord(h.MajorSubsystemVersion);
WriteWord(h.MinorSubsystemVersion);
WR.Write32LE(h.Win32VersionValue);
WR.Write32LE(h.SizeOfImage);
WR.Write32LE(h.SizeOfHeaders);
WR.Write32LE(h.CheckSum);
WriteWord(h.Subsystem);
WriteWord(h.DllCharacteristics);
IF amd64 THEN
WR.Write64LE(h.SizeOfStackReserve);
WR.Write64LE(h.SizeOfStackCommit);
WR.Write64LE(h.SizeOfHeapReserve);
WR.Write64LE(h.SizeOfHeapCommit)
ELSE
WR.Write32LE(h.SizeOfStackReserve);
WR.Write32LE(h.SizeOfStackCommit);
WR.Write32LE(h.SizeOfHeapReserve);
WR.Write32LE(h.SizeOfHeapCommit)
END;
WR.Write32LE(h.LoaderFlags);
WR.Write32LE(h.NumberOfRvaAndSizes);
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO
WR.Write32LE(h.DataDirectory[i].VirtualAddress);
WR.Write32LE(h.DataDirectory[i].Size)
END
END WriteOptHeader;
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; VirtualSize: INTEGER; Characteristics: DWORD);
BEGIN
section.Name := Name;
section.VirtualSize := VirtualSize;
section.SizeOfRawData := WR.align(VirtualSize, FileAlignment);
section.PointerToRelocations := 0;
section.PointerToLinenumbers := 0;
section.NumberOfRelocations := 0X;
section.NumberOfLinenumbers := 0X;
section.Characteristics := Characteristics
END InitSection;
BEGIN
SizeOfWord := SIZE_OF_DWORD * (ORD(amd64) + 1);
Size.Code := CHL.Length(program.code);
Size.Data := CHL.Length(program.data);
Size.Bss := program.bss;
IF dll THEN
BaseAddress := 10000000H
ELSE
BaseAddress := 400000H
END;
Signature[0] := 50H;
Signature[1] := 45H;
Signature[2] := 0;
Signature[3] := 0;
IF amd64 THEN
FileHeader.Machine := 08664X
ELSE
FileHeader.Machine := 014CX
END;
FileHeader.NumberOfSections := WCHR(4 + ORD(dll));
FileHeader.TimeDateStamp := UTILS.UnixTime();
FileHeader.PointerToSymbolTable := 0H;
FileHeader.NumberOfSymbols := 0H;
FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64));
FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
OptionalHeader.SizeOfCode := WR.align(Size.Code, FileAlignment);
OptionalHeader.SizeOfInitializedData := 0;
OptionalHeader.SizeOfUninitializedData := 0;
OptionalHeader.AddressOfEntryPoint := SectionAlignment;
OptionalHeader.BaseOfCode := SectionAlignment;
OptionalHeader.BaseOfData := OptionalHeader.BaseOfCode + WR.align(Size.Code, SectionAlignment);
OptionalHeader.ImageBase := BaseAddress;
OptionalHeader.SectionAlignment := SectionAlignment;
OptionalHeader.FileAlignment := FileAlignment;
OptionalHeader.MajorOperatingSystemVersion := 1X;
OptionalHeader.MinorOperatingSystemVersion := 0X;
OptionalHeader.MajorImageVersion := 0X;
OptionalHeader.MinorImageVersion := 0X;
OptionalHeader.MajorSubsystemVersion := 4X;
OptionalHeader.MinorSubsystemVersion := 0X;
OptionalHeader.Win32VersionValue := 0H;
OptionalHeader.SizeOfImage := SectionAlignment;
OptionalHeader.SizeOfHeaders := 400H;
OptionalHeader.CheckSum := 0;
OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll));
OptionalHeader.DllCharacteristics := 0040X;
OptionalHeader.SizeOfStackReserve := 100000H;
OptionalHeader.SizeOfStackCommit := 10000H;
OptionalHeader.SizeOfHeapReserve := 100000H;
OptionalHeader.SizeOfHeapCommit := 10000H;
OptionalHeader.LoaderFlags := 0;
OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
OptionalHeader.DataDirectory[i].VirtualAddress := 0;
OptionalHeader.DataDirectory[i].Size := 0
END;
InitSection(SectionHeaders[0], ".text", Size.Code, SHC_text);
SectionHeaders[0].VirtualAddress := SectionAlignment;
SectionHeaders[0].PointerToRawData := OptionalHeader.SizeOfHeaders;
InitSection(SectionHeaders[1], ".data", Size.Data, SHC_data);
SectionHeaders[1].VirtualAddress := WR.align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
InitSection(SectionHeaders[2], ".bss", Size.Bss, SHC_bss);
SectionHeaders[2].VirtualAddress := WR.align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
SectionHeaders[2].SizeOfRawData := 0;
Size.Import := GetImportSize(program.imp_list);
InitSection(SectionHeaders[3], ".idata", Size.Import + CHL.Length(program._import), SHC_data);
SectionHeaders[3].VirtualAddress := WR.align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
Address.Code := SectionHeaders[0].VirtualAddress + OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + OptionalHeader.ImageBase;
Address.Bss := SectionHeaders[2].VirtualAddress + OptionalHeader.ImageBase;
Address.Import := SectionHeaders[3].VirtualAddress + OptionalHeader.ImageBase;
fixup(program, Address, amd64);
IF dll THEN
Size.Export := Export(program, SectionHeaders[1].VirtualAddress + program.modname, ExportDir);
InitSection(SectionHeaders[4], ".edata", Size.Export + CHL.Length(program.export), SHC_data);
SectionHeaders[4].VirtualAddress := WR.align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress;
OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize
END;
OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress;
OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize;
FOR i := 1 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData)
END;
OptionalHeader.SizeOfUninitializedData := WR.align(SectionHeaders[2].VirtualSize, FileAlignment);
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfImage, WR.align(SectionHeaders[i].VirtualSize, SectionAlignment))
END;
n := 0;
BIN.InitArray(msdos, n, "4D5A80000100000004001000FFFF000040010000000000004000000000000000");
BIN.InitArray(msdos, n, "0000000000000000000000000000000000000000000000000000000080000000");
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000");
WR.Create(FileName);
WR.Write(msdos, LEN(msdos));
WR.Write(Signature, LEN(Signature));
WriteFileHeader(FileHeader);
WriteOptHeader(OptionalHeader, amd64);
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
WriteSectionHeader(SectionHeaders[i])
END;
WR.Padding(FileAlignment);
CHL.WriteToFile(program.code);
WR.Padding(FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SizeOfWord + n - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label = 0 THEN
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 * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
INC(i, 5)
END;
_import := _import.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, i + 0, 0);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, 0);
CHL.SetInt(ImportTable, i + 4, 0);
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label # 0 THEN
temp := _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2;
CHL.SetInt(ImportTable, _import.OriginalFirstThunk + n, temp);
CHL.SetInt(ImportTable, _import.FirstThunk + n, temp)
END;
_import := _import.next(BIN.IMPRT)
END;
FOR i := 0 TO n - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
FOR i := n TO CHL.Length(ImportTable) - 1 DO
IF amd64 THEN
WR.Write64LE(CHL.GetInt(ImportTable, i))
ELSE
WR.Write32LE(CHL.GetInt(ImportTable, i))
END
END;
CHL.WriteToFile(program._import);
WR.Padding(FileAlignment);
IF dll THEN
INC(ExportDir.AddressOfFunctions, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress);
WriteExportDir(ExportDir);
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(export.label + SectionHeaders[0].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO
WriteWord(WCHR(i))
END;
CHL.WriteToFile(program.export);
WR.Padding(FileAlignment)
END;
WR.Close
END write;
END PE32.

1283
programs/develop/oberon07/source/PROG.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

286
programs/develop/oberon07/source/REG.ob07 Normal file
View File

@@ -0,0 +1,286 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE REG;
CONST
N = 16;
R0* = 0; R1* = 1; R2* = 2; R3* = 3;
R4* = 4; R5* = 5; R6* = 6; R7* = 7;
R8* = 8; R9* = 9; R10* = 10; R11* = 11;
R12* = 12; R13* = 13; R14* = 14; R15* = 15;
TYPE
OP1 = PROCEDURE (arg: INTEGER);
OP2 = PROCEDURE (arg1, arg2: INTEGER);
REGS* = RECORD
regs*: SET;
stk*: ARRAY N OF INTEGER;
top*: INTEGER;
pushed*: INTEGER;
push, pop: OP1;
mov, xch: OP2
END;
PROCEDURE push (VAR R: REGS);
VAR
i, reg: INTEGER;
BEGIN
reg := R.stk[0];
INCL(R.regs, reg);
R.push(reg);
FOR i := 0 TO R.top - 1 DO
R.stk[i] := R.stk[i + 1]
END;
DEC(R.top);
INC(R.pushed)
END push;
PROCEDURE pop (VAR R: REGS; reg: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := R.top + 1 TO 1 BY -1 DO
R.stk[i] := R.stk[i - 1]
END;
R.stk[0] := reg;
EXCL(R.regs, reg);
R.pop(reg);
INC(R.top);
DEC(R.pushed)
END pop;
PROCEDURE InStk (R: REGS; reg: INTEGER): INTEGER;
VAR
i: INTEGER;
BEGIN
i := R.top;
WHILE (i >= 0) & (R.stk[i] # reg) DO
DEC(i)
END
RETURN i
END InStk;
PROCEDURE GetFreeReg (R: REGS): INTEGER;
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < N) & ~(i IN R.regs) DO
INC(i)
END;
IF i = N THEN
i := -1
END
RETURN i
END GetFreeReg;
PROCEDURE Put (VAR R: REGS; reg: INTEGER);
BEGIN
EXCL(R.regs, reg);
INC(R.top);
R.stk[R.top] := reg
END Put;
PROCEDURE PopAnyReg (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
ASSERT(reg # -1);
ASSERT(R.top < LEN(R.stk) - 1);
ASSERT(R.pushed > 0);
pop(R, reg)
RETURN reg
END PopAnyReg;
PROCEDURE GetAnyReg* (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
IF reg = -1 THEN
ASSERT(R.top >= 0);
reg := R.stk[0];
push(R)
END;
Put(R, reg)
RETURN reg
END GetAnyReg;
PROCEDURE GetReg* (VAR R: REGS; reg: INTEGER): BOOLEAN;
VAR
free: INTEGER;
res: BOOLEAN;
PROCEDURE exch (VAR R: REGS; reg1, reg2: INTEGER);
VAR
n1, n2: INTEGER;
BEGIN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg1, reg2)
END exch;
BEGIN
IF reg IN R.regs THEN
Put(R, reg);
res := TRUE
ELSE
res := InStk(R, reg) # -1;
IF res THEN
free := GetFreeReg(R);
IF free # -1 THEN
Put(R, free);
exch(R, reg, free)
ELSE
push(R);
free := GetFreeReg(R);
ASSERT(free # -1);
Put(R, free);
IF free # reg THEN
exch(R, reg, free)
END
END
END
END
RETURN res
END GetReg;
PROCEDURE Exchange* (VAR R: REGS; reg1, reg2: INTEGER): BOOLEAN;
VAR
n1, n2: INTEGER;
res: BOOLEAN;
BEGIN
res := TRUE;
IF reg1 # reg2 THEN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
IF (n1 # -1) & (n2 # -1) THEN
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg2, reg1)
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN
R.stk[n1] := reg2;
INCL(R.regs, reg1);
EXCL(R.regs, reg2);
R.mov(reg2, reg1)
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN
R.stk[n2] := reg1;
EXCL(R.regs, reg1);
INCL(R.regs, reg2);
R.mov(reg1, reg2)
ELSE
res := FALSE
END
END
RETURN res
END Exchange;
PROCEDURE Drop* (VAR R: REGS);
BEGIN
INCL(R.regs, R.stk[R.top]);
DEC(R.top)
END Drop;
PROCEDURE BinOp* (VAR R: REGS; VAR reg1, reg2: INTEGER);
BEGIN
IF R.top > 0 THEN
reg1 := R.stk[R.top - 1];
reg2 := R.stk[R.top]
ELSIF R.top = 0 THEN
reg1 := PopAnyReg(R);
reg2 := R.stk[1]
ELSE (* R.top = -1 *)
reg2 := PopAnyReg(R);
reg1 := PopAnyReg(R)
END
END BinOp;
PROCEDURE UnOp* (VAR R: REGS; VAR reg: INTEGER);
BEGIN
IF R.top >= 0 THEN
reg := R.stk[R.top]
ELSE
reg := PopAnyReg(R)
END
END UnOp;
PROCEDURE PushAll* (VAR R: REGS);
BEGIN
WHILE R.top >= 0 DO
push(R)
END
END PushAll;
PROCEDURE PushAll_1* (VAR R: REGS);
BEGIN
WHILE R.top >= 1 DO
push(R)
END
END PushAll_1;
PROCEDURE Init* (VAR R: REGS; push, pop: OP1; mov, xch: OP2; regs: SET);
BEGIN
R.regs := regs;
R.pushed := 0;
R.top := -1;
R.push := push;
R.pop := pop;
R.mov := mov;
R.xch := xch;
END Init;
END REG.

1415
programs/develop/oberon07/source/RVMxI.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

783
programs/develop/oberon07/source/SCAN.ob07 Normal file
View File

@@ -0,0 +1,783 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE SCAN;
IMPORT TXT := TEXTDRV, ARITH, S := STRINGS, ERRORS, LISTS;
CONST
NUMLEN = 256;
IDLEN = 256;
TEXTLEN = 512;
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3;
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7;
lxEOF* = 8;
lxPLUS* = 21; lxMINUS* = 22; lxMUL* = 23; lxSLASH* = 24;
lxNOT* = 25; lxAND* = 26; lxPOINT* = 27; lxCOMMA* = 28;
lxSEMI* = 29; lxBAR* = 30; lxLROUND* = 31; lxLSQUARE* = 32;
lxLCURLY* = 33; lxCARET* = 34; lxEQ* = 35; lxNE* = 36;
lxLT* = 37; lxGT* = 38; lxCOLON* = 39; lxRROUND* = 40;
lxRSQUARE* = 41; lxRCURLY* = 42; lxLE* = 43; lxGE* = 44;
lxASSIGN* = 45; lxRANGE* = 46;
lxKW = 51;
lxARRAY* = 51; lxBEGIN* = 52; lxBY* = 53; lxCASE* = 54;
lxCONST* = 55; lxDIV* = 56; lxDO* = 57; lxELSE* = 58;
lxELSIF* = 59; lxEND* = 60; lxFALSE* = 61; lxFOR* = 62;
lxIF* = 63; lxIMPORT* = 64; lxIN* = 65; lxIS* = 66;
lxMOD* = 67; lxMODULE* = 68; lxNIL* = 69; lxOF* = 70;
lxOR* = 71; lxPOINTER* = 72; lxPROCEDURE* = 73; lxRECORD* = 74;
lxREPEAT* = 75; lxRETURN* = 76; lxTHEN* = 77; lxTO* = 78;
lxTRUE* = 79; lxTYPE* = 80; lxUNTIL* = 81; lxVAR* = 82;
lxWHILE* = 83;
lxERROR01* = -1; lxERROR02* = -2; lxERROR03* = -3; lxERROR04* = -4;
lxERROR05* = -5; (*lxERROR06* = -6;*) lxERROR07* = -7; lxERROR08* = -8;
lxERROR09* = -9; lxERROR10* = -10; lxERROR11* = -11; lxERROR12* = -12;
lxERROR13* = -13;
TYPE
TEXTSTR* = ARRAY TEXTLEN OF CHAR;
IDSTR* = ARRAY IDLEN OF CHAR;
DEF = POINTER TO RECORD (LISTS.ITEM)
ident: IDSTR
END;
STRING* = POINTER TO RECORD (LISTS.ITEM)
s*: TEXTSTR;
offset*, offsetW*, hash: INTEGER
END;
IDENT* = RECORD
s*: IDSTR;
hash*: INTEGER
END;
POSITION* = RECORD
line*, col*: INTEGER
END;
LEX* = RECORD
sym*: INTEGER;
pos*: POSITION;
ident*: IDENT;
string*: STRING;
value*: ARITH.VALUE;
error*: INTEGER
END;
SCANNER* = TXT.TEXT;
KEYWORD = ARRAY 10 OF CHAR;
VAR
delimiters: ARRAY 256 OF BOOLEAN;
upto, LowerCase, _if: BOOLEAN;
strings, def: LISTS.LIST;
KW: ARRAY 33 OF RECORD upper, lower: KEYWORD; uhash, lhash: INTEGER END;
PROCEDURE enterKW (s: KEYWORD; idx: INTEGER);
BEGIN
KW[idx].lower := s;
KW[idx].upper := s;
S.UpCase(KW[idx].upper);
KW[idx].uhash := S.HashStr(KW[idx].upper);
KW[idx].lhash := S.HashStr(KW[idx].lower);
END enterKW;
PROCEDURE checkKW (ident: IDENT): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := lxIDENT;
i := 0;
WHILE i < LEN(KW) DO
IF (KW[i].uhash = ident.hash) & (KW[i].upper = ident.s)
OR LowerCase & (KW[i].lhash = ident.hash) & (KW[i].lower = ident.s) THEN
res := i + lxKW;
i := LEN(KW)
END;
INC(i)
END
RETURN res
END checkKW;
PROCEDURE enterStr* (s: TEXTSTR): STRING;
VAR
str, res: STRING;
hash: INTEGER;
BEGIN
hash := S.HashStr(s);
str := strings.first(STRING);
res := NIL;
WHILE str # NIL DO
IF (str.hash = hash) & (str.s = s) THEN
res := str;
str := NIL
ELSE
str := str.next(STRING)
END
END;
IF res = NIL THEN
NEW(res);
res.s := s;
res.offset := -1;
res.offsetW := -1;
res.hash := hash;
LISTS.push(strings, res)
END
RETURN res
END enterStr;
PROCEDURE nextc (text: TXT.TEXT): CHAR;
BEGIN
TXT.next(text)
RETURN text.peak
END nextc;
PROCEDURE setIdent* (VAR ident: IDENT; s: IDSTR);
BEGIN
ident.s := s;
ident.hash := S.HashStr(s)
END setIdent;
PROCEDURE ident (text: TXT.TEXT; VAR lex: LEX);
VAR
c: CHAR;
i: INTEGER;
BEGIN
c := text.peak;
ASSERT(S.letter(c));
i := 0;
WHILE (i < IDLEN - 1) & (S.letter(c) OR S.digit(c)) DO
lex.ident.s[i] := c;
INC(i);
c := nextc(text)
END;
lex.ident.s[i] := 0X;
lex.ident.hash := S.HashStr(lex.ident.s);
lex.sym := checkKW(lex.ident);
IF S.letter(c) OR S.digit(c) THEN
ERRORS.WarningMsg(lex.pos.line, lex.pos.col, 2);
WHILE S.letter(c) OR S.digit(c) DO
c := nextc(text)
END
END
END ident;
PROCEDURE number (text: TXT.TEXT; VAR lex: LEX);
TYPE
NUMSTR = ARRAY NUMLEN OF CHAR;
VAR
c: CHAR;
hex: BOOLEAN;
error, sym, i: INTEGER;
num: NUMSTR;
PROCEDURE push (VAR num: NUMSTR; VAR i: INTEGER; c: CHAR);
BEGIN
IF i < NUMLEN - 1 THEN
num[i] := c;
INC(i)
END
END push;
BEGIN
c := text.peak;
ASSERT(S.digit(c));
i := 0;
error := 0;
sym := lxINTEGER;
hex := FALSE;
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END;
WHILE S.hexdigit(c) OR LowerCase & ("a" <= c) & (c <= "f") DO
S.cap(c);
push(num, i, c);
c := nextc(text);
hex := TRUE
END;
IF (c = "H") OR LowerCase & (c = "h") THEN
push(num, i, c);
TXT.next(text);
sym := lxHEX
ELSIF (c = "X") OR LowerCase & (c = "x") THEN
push(num, i, c);
TXT.next(text);
sym := lxCHAR
ELSIF c = "." THEN
IF hex THEN
sym := lxERROR01
ELSE
c := nextc(text);
IF c # "." THEN
push(num, i, ".");
sym := lxFLOAT
ELSE
sym := lxINTEGER;
text.peak := 7FX;
upto := TRUE
END;
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END;
IF (c = "E") OR LowerCase & (c = "e") THEN
push(num, i, c);
c := nextc(text);
IF (c = "+") OR (c = "-") THEN
push(num, i, c);
c := nextc(text)
END;
IF S.digit(c) THEN
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END
ELSE
sym := lxERROR02
END
END
END
ELSIF hex THEN
sym := lxERROR01
END;
IF (i = NUMLEN - 1) & (sym >= 0) THEN
sym := lxERROR07
END;
num[i] := 0X;
IF sym = lxINTEGER THEN
ARITH.iconv(num, lex.value, error)
ELSIF (sym = lxHEX) OR (sym = lxCHAR) THEN
ARITH.hconv(num, lex.value, error)
ELSIF sym = lxFLOAT THEN
ARITH.fconv(num, lex.value, error)
END;
CASE error OF
|0:
|1: sym := lxERROR08
|2: sym := lxERROR09
|3: sym := lxERROR10
|4: sym := lxERROR11
|5: sym := lxERROR12
END;
lex.sym := sym
END number;
PROCEDURE string (text: TXT.TEXT; VAR lex: LEX; quot: CHAR);
VAR
c: CHAR;
i: INTEGER;
str: TEXTSTR;
BEGIN
c := nextc(text);
i := 0;
WHILE (i < LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
str[i] := c;
c := nextc(text);
INC(i)
END;
str[i] := 0X;
IF (i = LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof THEN
lex.sym := lxERROR05
END;
IF c = quot THEN
TXT.next(text);
IF i # 1 THEN
lex.sym := lxSTRING
ELSE
lex.sym := lxCHAR;
ARITH.setChar(lex.value, ORD(str[0]))
END
ELSIF lex.sym # lxERROR05 THEN
lex.sym := lxERROR03
END;
IF lex.sym = lxSTRING THEN
lex.string := enterStr(str);
lex.value.typ := ARITH.tSTRING;
lex.value.string := lex.string
END
END string;
PROCEDURE comment (text: TXT.TEXT);
VAR
c: CHAR;
cond, depth: INTEGER;
BEGIN
cond := 0;
depth := 1;
REPEAT
c := text.peak;
TXT.next(text);
IF c = "*" THEN
IF cond = 1 THEN
cond := 0;
INC(depth)
ELSE
cond := 2
END
ELSIF c = ")" THEN
IF cond = 2 THEN
DEC(depth)
END;
cond := 0
ELSIF c = "(" THEN
cond := 1
ELSE
cond := 0
END
UNTIL (depth = 0) OR text.eof
END comment;
PROCEDURE delimiter (text: TXT.TEXT; c: CHAR): INTEGER;
VAR
sym: INTEGER;
c0: CHAR;
BEGIN
c0 := c;
c := nextc(text);
CASE c0 OF
|"+":
sym := lxPLUS
|"-":
sym := lxMINUS
|"*":
sym := lxMUL
|"/":
sym := lxSLASH;
IF c = "/" THEN
sym := lxCOMMENT;
REPEAT
TXT.next(text)
UNTIL text.eol OR text.eof
END
|"~":
sym := lxNOT
|"&":
sym := lxAND
|".":
sym := lxPOINT;
IF c = "." THEN
sym := lxRANGE;
TXT.next(text)
END
|",":
sym := lxCOMMA
|";":
sym := lxSEMI
|"|":
sym := lxBAR
|"(":
sym := lxLROUND;
IF c = "*" THEN
sym := lxCOMMENT;
TXT.next(text);
comment(text)
END
|"[":
sym := lxLSQUARE
|"{":
sym := lxLCURLY
|"^":
sym := lxCARET
|"=":
sym := lxEQ
|"#":
sym := lxNE
|"<":
sym := lxLT;
IF c = "=" THEN
sym := lxLE;
TXT.next(text)
END
|">":
sym := lxGT;
IF c = "=" THEN
sym := lxGE;
TXT.next(text)
END
|":":
sym := lxCOLON;
IF c = "=" THEN
sym := lxASSIGN;
TXT.next(text)
END
|")":
sym := lxRROUND
|"]":
sym := lxRSQUARE
|"}":
sym := lxRCURLY
END
RETURN sym
END delimiter;
PROCEDURE Next* (text: SCANNER; VAR lex: LEX);
VAR
c: CHAR;
PROCEDURE check (cond: BOOLEAN; text: SCANNER; lex: LEX; errno: INTEGER);
BEGIN
IF ~cond THEN
ERRORS.ErrorMsg(text.fname, lex.pos.line, lex.pos.col, errno)
END
END check;
PROCEDURE IsDef (str: ARRAY OF CHAR): BOOLEAN;
VAR
cur: DEF;
BEGIN
cur := def.first(DEF);
WHILE (cur # NIL) & (cur.ident # str) DO
cur := cur.next(DEF)
END
RETURN cur # NIL
END IsDef;
PROCEDURE Skip (text: SCANNER);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i <= text.ifc) & ~text._skip[i] DO
INC(i)
END;
text.skip := i <= text.ifc
END Skip;
PROCEDURE prep_if (text: SCANNER; VAR lex: LEX);
VAR
skip: BOOLEAN;
BEGIN
INC(text.ifc);
text._elsif[text.ifc] := lex.sym = lxELSIF;
IF lex.sym = lxIF THEN
INC(text.elsec);
text._else[text.elsec] := FALSE
END;
_if := TRUE;
skip := TRUE;
text.skip := FALSE;
Next(text, lex);
check(lex.sym = lxLROUND, text, lex, 64);
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22);
REPEAT
IF IsDef(lex.ident.s) THEN
skip := FALSE
END;
Next(text, lex);
IF lex.sym = lxBAR THEN
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22)
ELSE
check(lex.sym = lxRROUND, text, lex, 33)
END
UNTIL lex.sym = lxRROUND;
_if := FALSE;
text._skip[text.ifc] := skip;
Skip(text);
Next(text, lex)
END prep_if;
PROCEDURE prep_end (text: SCANNER; VAR lex: LEX);
BEGIN
check(text.ifc > 0, text, lex, 118);
IF lex.sym = lxEND THEN
WHILE text._elsif[text.ifc] DO
DEC(text.ifc)
END;
DEC(text.ifc);
DEC(text.elsec)
ELSIF (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
check(~text._else[text.elsec], text, lex, 118);
text._skip[text.ifc] := ~text._skip[text.ifc];
text._else[text.elsec] := lex.sym = lxELSE
END;
Skip(text);
IF lex.sym = lxELSIF THEN
prep_if(text, lex)
ELSE
Next(text, lex)
END
END prep_end;
BEGIN
REPEAT
c := text.peak;
WHILE S.space(c) DO
c := nextc(text)
END;
lex.pos.line := text.line;
lex.pos.col := text.col;
IF S.letter(c) THEN
ident(text, lex)
ELSIF S.digit(c) THEN
number(text, lex)
ELSIF (c = '"') OR (c = "'") THEN
string(text, lex, c)
ELSIF delimiters[ORD(c)] THEN
lex.sym := delimiter(text, c)
ELSIF c = "$" THEN
IF S.letter(nextc(text)) THEN
ident(text, lex);
IF lex.sym = lxIF THEN
IF ~_if THEN
prep_if(text, lex)
END
ELSIF (lex.sym = lxEND) OR (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
IF ~_if THEN
prep_end(text, lex)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSIF c = 0X THEN
lex.sym := lxEOF;
text.skip := FALSE;
IF text.eof THEN
INC(lex.pos.col)
END
ELSIF (c = 7FX) & upto THEN
upto := FALSE;
lex.sym := lxRANGE;
DEC(lex.pos.col);
TXT.next(text)
ELSE
TXT.next(text);
lex.sym := lxERROR04
END;
IF lex.sym < 0 THEN
lex.error := -lex.sym
ELSE
lex.error := 0
END
UNTIL (lex.sym # lxCOMMENT) & ~text.skip
END Next;
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER;
RETURN TXT.open(name)
END open;
PROCEDURE close* (VAR scanner: SCANNER);
BEGIN
TXT.close(scanner)
END close;
PROCEDURE init* (lower: BOOLEAN);
VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
BEGIN
upto := FALSE;
LowerCase := lower;
FOR i := 0 TO 255 DO
delimiters[i] := FALSE
END;
delim := "+-*/~&.,;|([{^=#<>:)]}";
FOR i := 0 TO LEN(delim) - 2 DO
delimiters[ORD(delim[i])] := TRUE
END;
enterKW("array", 0);
enterKW("begin", 1);
enterKW("by", 2);
enterKW("case", 3);
enterKW("const", 4);
enterKW("div", 5);
enterKW("do", 6);
enterKW("else", 7);
enterKW("elsif", 8);
enterKW("end", 9);
enterKW("false", 10);
enterKW("for", 11);
enterKW("if", 12);
enterKW("import", 13);
enterKW("in", 14);
enterKW("is", 15);
enterKW("mod", 16);
enterKW("module", 17);
enterKW("nil", 18);
enterKW("of", 19);
enterKW("or", 20);
enterKW("pointer", 21);
enterKW("procedure", 22);
enterKW("record", 23);
enterKW("repeat", 24);
enterKW("return", 25);
enterKW("then", 26);
enterKW("to", 27);
enterKW("true", 28);
enterKW("type", 29);
enterKW("until", 30);
enterKW("var", 31);
enterKW("while", 32)
END init;
PROCEDURE NewDef* (str: ARRAY OF CHAR);
VAR
item: DEF;
BEGIN
NEW(item);
COPY(str, item.ident);
LISTS.push(def, item)
END NewDef;
BEGIN
def := LISTS.create(NIL);
strings := LISTS.create(NIL)
END SCAN.

3444
programs/develop/oberon07/source/STATEMENTS.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

342
programs/develop/oberon07/source/STRINGS.ob07 Normal file
View File

@@ -0,0 +1,342 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE STRINGS;
IMPORT UTILS;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO
dst[dpos] := src[spos];
INC(spos);
INC(dpos);
DEC(count)
END
END copy;
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
copy(s2, s1, 0, n1, n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
IF x = UTILS.minint THEN
IF UTILS.bit_depth = 32 THEN
COPY("-2147483648", str)
ELSIF UTILS.bit_depth = 64 THEN
COPY("-9223372036854775808", str)
END
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END
END IntToStr;
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN);
VAR
length: INTEGER;
BEGIN
length := LENGTH(s);
IF (0 <= pos) & (pos < length) THEN
IF forward THEN
WHILE (pos < length) & (s[pos] # c) DO
INC(pos)
END;
IF pos = length THEN
pos := -1
END
ELSE
WHILE (pos >= 0) & (s[pos] # c) DO
DEC(pos)
END
END
ELSE
pos := -1
END
END search;
PROCEDURE replace* (VAR s: ARRAY OF CHAR; find, repl: CHAR);
VAR
i, strlen: INTEGER;
BEGIN
strlen := LENGTH(s) - 1;
FOR i := 0 TO strlen DO
IF s[i] = find THEN
s[i] := repl
END
END
END replace;
PROCEDURE trim* (source: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
VAR
LenS, start, _end, i, j: INTEGER;
BEGIN
LenS := LENGTH(source) - 1;
j := 0;
IF LenS >= 0 THEN
start := 0;
WHILE (start <= LenS) & (source[start] <= 20X) DO
INC(start)
END;
_end := LenS;
WHILE (_end >= 0) & (source[_end] <= 20X) DO
DEC(_end)
END;
FOR i := start TO _end DO
result[j] := source[i];
INC(j)
END
END;
result[j] := 0X
END trim;
PROCEDURE letter* (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z") OR (c = "_")
END letter;
PROCEDURE digit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9")
END digit;
PROCEDURE hexdigit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR ("A" <= c) & (c <= "F")
END hexdigit;
PROCEDURE space* (c: CHAR): BOOLEAN;
RETURN (0X < c) & (c <= 20X)
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 := LENGTH(str) - 1;
WHILE i >= 0 DO
cap(str[i]);
DEC(i)
END
END UpCase;
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
res := TRUE;
i := 0;
x := 0;
k := LENGTH(str);
WHILE i < k DO
IF digit(str[i]) THEN
x := x * 10 + ORD(str[i]) - ORD("0")
ELSE
i := k;
res := FALSE
END;
INC(i)
END
RETURN res
END StrToInt;
PROCEDURE CheckVer (str: ARRAY OF CHAR): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
k := LENGTH(str);
res := k < LEN(str);
IF res & digit(str[0]) THEN
i := 0;
WHILE (i < k) & digit(str[i]) DO
INC(i)
END;
IF (i < k) & (str[i] = ".") THEN
INC(i);
IF i < k THEN
WHILE (i < k) & digit(str[i]) DO
INC(i)
END
ELSE
res := FALSE
END
ELSE
res := FALSE
END;
res := res & (i = k)
ELSE
res := FALSE
END
RETURN res
END CheckVer;
PROCEDURE StrToVer* (str: ARRAY OF CHAR; VAR major, minor: INTEGER): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := CheckVer(str);
IF res THEN
i := 0;
minor := 0;
major := 0;
WHILE digit(str[i]) DO
major := major * 10 + ORD(str[i]) - ORD("0");
INC(i)
END;
INC(i);
WHILE digit(str[i]) DO
minor := minor * 10 + ORD(str[i]) - ORD("0");
INC(i)
END
END
RETURN res
END StrToVer;
PROCEDURE Utf8To16* (src: ARRAY OF CHAR; VAR dst: ARRAY OF WCHAR): INTEGER;
VAR
i, j, u, srclen, dstlen: INTEGER;
c: CHAR;
BEGIN
srclen := LEN(src);
dstlen := LEN(dst);
i := 0;
j := 0;
WHILE (i < srclen) & (j < dstlen) & (src[i] # 0X) DO
c := src[i];
CASE c OF
|00X..7FX:
u := ORD(c)
|0C1X..0DFX:
u := (ORD(c) - 0C0H) * 64;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(src[i]) MOD 64)
END
|0E1X..0EFX:
u := (ORD(c) - 0E0H) * 4096;
IF i + 1 < srclen THEN
INC(i);
INC(u, (ORD(src[i]) MOD 64) * 64)
END;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(src[i]) MOD 64)
END
(*
|0F1X..0F7X:
|0F9X..0FBX:
|0FDX:
*)
ELSE
END;
INC(i);
dst[j] := WCHR(u);
INC(j)
END;
IF j < dstlen THEN
dst[j] := WCHR(0)
END
RETURN j
END Utf8To16;
PROCEDURE HashStr* (name: ARRAY OF CHAR): INTEGER;
VAR
i, h: INTEGER;
g: SET;
BEGIN
h := 0;
i := 0;
WHILE name[i] # 0X DO
h := h * 16 + ORD(name[i]);
g := BITS(h) * {28..31};
h := ORD(BITS(h) / BITS(LSR(ORD(g), 24)) - g);
INC(i)
END
RETURN h
END HashStr;
END STRINGS.

154
programs/develop/oberon07/source/TARGETS.ob07 Normal file
View File

@@ -0,0 +1,154 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2021, 2023, Anton Krotov
All rights reserved.
*)
MODULE TARGETS;
IMPORT UTILS;
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;
RVM32I* = 14;
RVM64I* = 15;
cpuX86* = 0; cpuAMD64* = 1; cpuMSP430* = 2; cpuTHUMB* = 3;
cpuRVM32I* = 4; cpuRVM64I* = 5;
osNONE* = 0; osWIN32* = 1; osWIN64* = 2;
osLINUX32* = 3; osLINUX64* = 4; osKOS* = 5;
noDISPOSE = {MSP430, STM32CM3, RVM32I, RVM64I};
noRTL = {MSP430};
libRVM32I = "RVMxI" + UTILS.slash + "32";
libRVM64I = "RVMxI" + UTILS.slash + "64";
TYPE
STRING = ARRAY 32 OF CHAR;
TARGET = RECORD
target, CPU, OS, RealSize: INTEGER;
ComLinePar*, LibDir, FileExt: STRING
END;
VAR
Targets*: ARRAY 16 OF TARGET;
CPUs: ARRAY 6 OF
RECORD
BitDepth, InstrSize: INTEGER;
LittleEndian: BOOLEAN
END;
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER;
ComLinePar*, LibDir*, FileExt*: STRING;
Import*, Dispose*, RTL*, Dll*, LittleEndian*, WinLin*: BOOLEAN;
PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
BEGIN
Targets[idx].target := idx;
Targets[idx].CPU := CPU;
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 := CPUs[CPU].BitDepth;
InstrSize := CPUs[CPU].InstrSize;
LittleEndian := CPUs[CPU].LittleEndian;
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 noDISPOSE);
RTL := ~(target IN noRTL);
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WinLin := OS IN {osWIN32, osLINUX32, osWIN64, osLINUX64};
WordSize := BitDepth DIV 8;
AdrSize := WordSize
END
RETURN res
END Select;
PROCEDURE EnterCPU (cpu, BitDepth, InstrSize: INTEGER; LittleEndian: BOOLEAN);
BEGIN
CPUs[cpu].BitDepth := BitDepth;
CPUs[cpu].InstrSize := InstrSize;
CPUs[cpu].LittleEndian := LittleEndian
END EnterCPU;
BEGIN
EnterCPU(cpuX86, 32, 1, TRUE);
EnterCPU(cpuAMD64, 64, 1, TRUE);
EnterCPU(cpuMSP430, 16, 2, TRUE);
EnterCPU(cpuTHUMB, 32, 2, TRUE);
EnterCPU(cpuRVM32I, 32, 4, TRUE);
EnterCPU(cpuRVM64I, 64, 8, TRUE);
Enter( MSP430, cpuMSP430, 0, osNONE, "msp430", "MSP430", ".hex");
Enter( Win32C, cpuX86, 8, osWIN32, "win32con", "Windows", ".exe");
Enter( Win32GUI, cpuX86, 8, osWIN32, "win32gui", "Windows", ".exe");
Enter( Win32DLL, cpuX86, 8, osWIN32, "win32dll", "Windows", ".dll");
Enter( KolibriOS, cpuX86, 8, osKOS, "kosexe", "KolibriOS", "");
Enter( KolibriOSDLL, cpuX86, 8, osKOS, "kosdll", "KolibriOS", ".obj");
Enter( Win64C, cpuAMD64, 8, osWIN64, "win64con", "Windows", ".exe");
Enter( Win64GUI, cpuAMD64, 8, osWIN64, "win64gui", "Windows", ".exe");
Enter( Win64DLL, cpuAMD64, 8, osWIN64, "win64dll", "Windows", ".dll");
Enter( Linux32, cpuX86, 8, osLINUX32, "linux32exe", "Linux", "");
Enter( Linux32SO, cpuX86, 8, osLINUX32, "linux32so", "Linux", ".so");
Enter( Linux64, cpuAMD64, 8, osLINUX64, "linux64exe", "Linux", "");
Enter( Linux64SO, cpuAMD64, 8, osLINUX64, "linux64so", "Linux", ".so");
Enter( STM32CM3, cpuTHUMB, 4, osNONE, "stm32cm3", "STM32CM3", ".hex");
Enter( RVM32I, cpuRVM32I, 4, osNONE, "rvm32i", libRVM32I, ".bin");
Enter( RVM64I, cpuRVM64I, 8, osNONE, "rvm64i", libRVM64I, ".bin");
END TARGETS.

210
programs/develop/oberon07/source/TEXTDRV.ob07 Normal file
View File

@@ -0,0 +1,210 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE TEXTDRV;
IMPORT FILES, C := COLLECTIONS;
CONST
CR = 0DX; LF = 0AX; HT = 9X;
CHUNK = 1024 * 256;
defTabSize* = 4;
TYPE
TEXT* = POINTER TO RECORD (C.ITEM)
chunk: ARRAY CHUNK OF CHAR;
pos, size: INTEGER;
file: FILES.FILE;
utf8: BOOLEAN;
CR: BOOLEAN;
line*, col*: INTEGER;
ifc*: INTEGER;
elsec*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
skip*: BOOLEAN;
peak*: CHAR;
_skip*,
_elsif*,
_else*: ARRAY 100 OF BOOLEAN;
fname*: ARRAY 2048 OF CHAR
END;
VAR
texts: C.COLLECTION;
TabSize: INTEGER;
PROCEDURE load (text: TEXT);
BEGIN
IF ~text.eof THEN
text.size := FILES.read(text.file, text.chunk, LEN(text.chunk));
text.pos := 0;
IF text.size = 0 THEN
text.eof := TRUE;
text.chunk[0] := 0X
END;
text.peak := text.chunk[0]
END
END load;
PROCEDURE next* (text: TEXT);
VAR
c: CHAR;
BEGIN
IF text.pos < text.size - 1 THEN
INC(text.pos);
text.peak := text.chunk[text.pos]
ELSE
load(text)
END;
IF ~text.eof THEN
c := text.peak;
IF c = CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE;
text.CR := TRUE
ELSIF c = LF THEN
IF ~text.CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE
ELSE
text.eol := FALSE
END;
text.CR := FALSE
ELSIF c = HT THEN
text.col := text.col + TabSize - text.col MOD TabSize;
text.eol := FALSE;
text.CR := FALSE
ELSE
IF text.utf8 THEN
IF ORD(c) DIV 64 # 2 THEN
INC(text.col)
END
ELSE
INC(text.col)
END;
text.eol := FALSE;
text.CR := FALSE
END
END
END next;
PROCEDURE init (text: TEXT);
BEGIN
IF (text.pos = 0) & (text.size >= 3) THEN
IF (text.chunk[0] = 0EFX) &
(text.chunk[1] = 0BBX) &
(text.chunk[2] = 0BFX) THEN
text.pos := 3;
text.utf8 := TRUE
END
END;
IF text.size = 0 THEN
text.chunk[0] := 0X;
text.size := 1;
text.eof := FALSE
END;
text.line := 1;
text.col := 1;
text.peak := text.chunk[text.pos]
END init;
PROCEDURE close* (VAR text: TEXT);
BEGIN
IF text # NIL THEN
IF text.file # NIL THEN
FILES.close(text.file)
END;
C.push(texts, text);
text := NIL
END
END close;
PROCEDURE open* (name: ARRAY OF CHAR): TEXT;
VAR
text: TEXT;
citem: C.ITEM;
BEGIN
citem := C.pop(texts);
IF citem = NIL THEN
NEW(text)
ELSE
text := citem(TEXT)
END;
IF text # NIL THEN
text.chunk[0] := 0X;
text.pos := 0;
text.size := 0;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE;
text.skip := FALSE;
text.ifc := 0;
text.elsec := 0;
text._skip[0] := FALSE;
text.peak := 0X;
text.file := FILES.open(name);
COPY(name, text.fname);
IF text.file # NIL THEN
load(text);
init(text)
ELSE
close(text)
END
END
RETURN text
END open;
PROCEDURE setTabSize* (n: INTEGER);
BEGIN
IF (0 < n) & (n <= 64) THEN
TabSize := n
ELSE
TabSize := defTabSize
END
END setTabSize;
BEGIN
TabSize := defTabSize;
texts := C.create()
END TEXTDRV.

2459
programs/develop/oberon07/source/THUMB.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

217
programs/develop/oberon07/source/UTILS.ob07 Normal file
View File

@@ -0,0 +1,217 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2023, Anton Krotov
All rights reserved.
*)
MODULE UTILS;
IMPORT HOST;
CONST
slash* = HOST.slash;
eol* = HOST.eol;
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
min32* = -2147483647-1;
max32* = 2147483647;
vMajor* = 1;
vMinor* = 64;
Date* = "22-jan-2023";
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
VAR
time*: INTEGER;
maxreal*, inf*: REAL;
target*:
RECORD
bit_depth*,
maxInt*,
minInt*,
maxSet*,
maxHex*: INTEGER;
maxReal*: REAL
END;
bit_diff*: INTEGER;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileWrite(F, Buffer, bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileCreate(FName)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
HOST.FileClose(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileOpen(FName)
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
BEGIN
HOST.chmod(FName)
END chmod;
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
HOST.GetArg(i, str)
END GetArg;
PROCEDURE Exit* (code: INTEGER);
BEGIN
HOST.ExitProcess(code)
END Exit;
PROCEDURE GetTickCount* (): INTEGER;
RETURN HOST.GetTickCount()
END GetTickCount;
PROCEDURE OutChar* (c: CHAR);
BEGIN
HOST.OutChar(c)
END OutChar;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
RETURN HOST.splitf(x, a, b)
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;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
HOST.GetCurrentDirectory(path)
END GetCurrentDirectory;
PROCEDURE UnixTime* (): INTEGER;
RETURN HOST.UnixTime()
END UnixTime;
PROCEDURE SetBitDepth* (BitDepth: INTEGER; Double: BOOLEAN);
BEGIN
ASSERT((BitDepth = 16) OR (BitDepth = 32) OR (BitDepth = 64));
bit_diff := bit_depth - BitDepth;
ASSERT(bit_diff >= 0);
target.bit_depth := BitDepth;
target.maxSet := BitDepth - 1;
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, 127)
END
END SetBitDepth;
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE;
RETURN ASR(n, 8 * idx) MOD 256
END Byte;
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN;
BEGIN
INC(bytes, (-bytes) MOD align)
RETURN bytes >= 0
END Align;
PROCEDURE Long* (value: INTEGER): INTEGER;
RETURN ASR(LSL(value, bit_diff), bit_diff)
END Long;
PROCEDURE Short* (value: INTEGER): INTEGER;
RETURN LSR(LSL(value, bit_diff), bit_diff)
END Short;
PROCEDURE Log2* (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 1 THEN
n := -1
END
RETURN n
END Log2;
PROCEDURE hexdgt* (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
INC(n, ORD("0"))
ELSE
INC(n, ORD("A") - 10)
END
RETURN n
END hexdgt;
BEGIN
time := HOST.GetTickCount();
inf := HOST.inf;
maxreal := HOST.maxreal
END UTILS.

104
programs/develop/oberon07/source/WRITER.ob07 Normal file
View File

@@ -0,0 +1,104 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE WRITER;
IMPORT FILES, ERRORS, UTILS;
VAR
counter*: INTEGER;
file: FILES.FILE;
PROCEDURE align* (n, _align: INTEGER): INTEGER;
BEGIN
ASSERT(UTILS.Align(n, _align))
RETURN n
END align;
PROCEDURE WriteByte* (n: BYTE);
BEGIN
IF FILES.WriteByte(file, n) THEN
INC(counter)
ELSE
ERRORS.Error(201)
END
END WriteByte;
PROCEDURE Write* (chunk: ARRAY OF BYTE; bytes: INTEGER);
VAR
n: INTEGER;
BEGIN
n := FILES.write(file, chunk, bytes);
IF n # bytes THEN
ERRORS.Error(201)
END;
INC(counter, n)
END Write;
PROCEDURE Write64LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
WriteByte(UTILS.Byte(n, i))
END
END Write64LE;
PROCEDURE Write32LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
WriteByte(UTILS.Byte(n, i))
END
END Write32LE;
PROCEDURE Write16LE* (n: INTEGER);
BEGIN
WriteByte(UTILS.Byte(n, 0));
WriteByte(UTILS.Byte(n, 1))
END Write16LE;
PROCEDURE Padding* (FileAlignment: INTEGER);
VAR
i: INTEGER;
BEGIN
i := align(counter, FileAlignment) - counter;
WHILE i > 0 DO
WriteByte(0);
DEC(i)
END
END Padding;
PROCEDURE Create* (FileName: ARRAY OF CHAR);
BEGIN
counter := 0;
file := FILES.create(FileName)
END Create;
PROCEDURE Close*;
BEGIN
FILES.close(file)
END Close;
END WRITER.

Some files were not shown because too many files have changed in this diff Show More