KolibriOS/kolibrios
13
4
Fork 12
Code Issues 78 Pull Requests 5 Projects Releases Activity

oberon07: update to the latest version from https://github.com/AntKrotov/oberon-07-compiler

Browse Source 
git-svn-id: svn://kolibrios.org@7983 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Kirill Lipatov (Leency) 2020-05-25 20:48:33 +00:00
parent 559d0cc062
commit 65c332bd36
109 changed files with 16414 additions and 7600 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

Binary file not shown.

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

Binary file not shown.

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

Binary file not shown.

390
programs/develop/oberon07/Docs/About1251.txt
View File

@ -1,390 +0,0 @@
Компилятор языка программирования Oberon-07/16 для i486
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32, ELF или MENUET01/MSCOFF.
Параметры:
1) имя главного модуля
2) тип приложения
"console" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"kos" - KolibriOS
"obj" - KolibriOS DLL
"elfexe" - Linux ELF-EXEC
"elfso" - Linux ELF-SO
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-ver <major.minor> версия программы (только для obj)
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" console -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" dll -out "C:\example.dll"
Compiler.exe "C:\example.ob07" gui -out "C:\example.exe" -stk 4
Compiler.exe "C:\example.ob07" console -out "C:\example.exe" -nochk pti
Compiler.kex "/tmp0/1/example.ob07" kos -out "/tmp0/1/example.kex" -stk 4
Compiler.kex "/tmp0/1/example.ob07" obj -out "/tmp0/1/example.obj" -ver 2.7
Compiler.exe "C:\example.ob07" elfexe -out "C:\example" -stk 1 -nochk a
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
При работе компилятора в KolibriOS, код завершения не передается.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Добавлены системные флаги
4. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
5. Расширен набор стандартных процедур
6. Семантика охраны/проверки типа уточнена для нулевого указателя
7. Семантика DIV и MOD уточнена для отрицательных чисел
8. Добавлены однострочные комментарии (начинаются с пары символов "//")
9. Разрешено наследование от типа-указателя
10. Добавлен синтаксис для импорта процедур из внешних библиотек
11. "Строки" можно заключать также в одиночные кавычки: 'строка'
12. Добавлен тип WCHAR
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -2147483648 .. 2147483647 4
REAL 4.94E-324 .. 1.70E+308 8
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
- ASSERT(x), при x = FALSE
- разыменование нулевого указателя
- целочисленное деление на 0
- вызов процедуры через процедурную переменную с нулевым значением
- ошибка охраны типа
- нарушение границ массива
- непредусмотренное значение выражения в операторе CASE
- ошибка копирования массивов v := x, если LEN(v) < LEN(x)
- неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
- CHR(x), если (x < 0) OR (x > 255)
- WCHR(x), если (x < 0) OR (x > 65535)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 16 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : INTEGER)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall],
[ccall], [ccall16], [windows], [linux]. Например:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
Если указан флаг [ccall16], то принимается соглашение ccall, но перед
вызовом указатель стэка будет выравнен по границе 16 байт.
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall16].
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
DISPOSE (VAR v: любой_указатель)
Освобождает память, выделенную процедурой NEW для
динамической переменной v^, и присваивает переменной v
значение NIL.
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
DIV и MOD
x y x DIV y x MOD y
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- "library" -- имя файла динамической библиотеки
- "function" -- имя импортируемой процедуры
например:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
В KolibriOS импортировать процедуры можно только из библиотек, размещенных
в /rd/1/lib. Импортировать и вызывать функции инициализации библиотек
(lib_init, START) при этом не нужно.
Для Linux, импортированные процедуры не реализованы.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
------------------------------------------------------------------------------
Модуль RTL
Все программы неявно используют модуль RTL. Компилятор транслирует
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не
следует явно вызывать эти процедуры, за исключением процедур SetDll и SetFini
если приложение компилируется как Windows DLL или Linux SO, соответственно:
PROCEDURE SetDll
(process_detach, thread_detach, thread_attach: DLL_ENTRY);
где TYPE DLL_ENTRY =
PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
SetDll назначает процедуры process_detach, thread_detach, thread_attach
вызываемыми при
- выгрузке dll-библиотеки (process_detach)
- создании нового потока (thread_attach)
- уничтожении потока (thread_detach)
PROCEDURE SetFini (ProcFini: PROC);
где TYPE PROC = PROCEDURE (* без параметров *)
SetFini назначает процедуру ProcFini вызываемой при выгрузке so-библиотеки.
Для прочих типов приложений, вызов процедур SetDll и SetFini не влияет на
поведение программы.
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах
(Windows), в терминал (Linux), на доску отладки (KolibriOS).
------------------------------------------------------------------------------
Модуль API
Существуют несколько реализаций модуля API (для различных ОС).
Как и модуль RTL, модуль API не предназначен для прямого использования.
Он обеспечивает связь RTL с ОС.
------------------------------------------------------------------------------
Генерация исполняемых файлов DLL
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, и ее имя должно быть отмечено символом
экспорта ("*"). KolibriOS DLL всегда экспортируют идентификаторы "version"
(версия программы) и "lib_init" - адрес процедуры инициализации DLL:
PROCEDURE [stdcall] lib_init (): INTEGER
Эта процедура должна быть вызвана перед использованием DLL.
Процедура всегда возвращает 1.

390
programs/develop/oberon07/Docs/About866.txt
View File

@ -1,390 +0,0 @@
Š®¬¯¨«ïâ®à ï§ëª  ¯à®£à ¬¬¨à®¢ ­¨ï Oberon-07/16 ¤«ï i486
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
<20> à ¬¥âàë ª®¬ ­¤­®© áâப¨
‚室 - ⥪áâ®¢ë¥ ä ©«ë ¬®¤ã«¥© á à áè¨à¥­¨¥¬ ".ob07", ª®¤¨à®¢ª  ANSI ¨«¨
UTF-8 á BOM-ᨣ­ âãன.
‚ë室 - ¨á¯®­ï¥¬ë© ä ©« ä®à¬ â  PE32, ELF ¨«¨ MENUET01/MSCOFF.
<20> à ¬¥âàë:
1) ¨¬ï £« ¢­®£® ¬®¤ã«ï
2) ⨯ ¯à¨«®¦¥­¨ï
"console" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"kos" - KolibriOS
"obj" - KolibriOS DLL
"elfexe" - Linux ELF-EXEC
"elfso" - Linux ELF-SO
3) ­¥®¡ï§ â¥«ì­ë¥ ¯ à ¬¥âàë-ª«îç¨
-out <file_name> ¨¬ï १ã«ìâ¨àãî饣® ä ©« ; ¯® 㬮«ç ­¨î,
ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ £« ¢­®£® ¬®¤ã«ï, ­® á ¤à㣨¬ à áè¨à¥­¨¥¬
(ᮮ⢥âáâ¢ã¥â ⨯㠨ᯮ«­ï¥¬®£® ä ©« )
-stk <size> à §¬¥à áâíª  ¢ ¬¥£ ¡ ©â å (¯® 㬮«ç ­¨î 2 Œ¡,
¤®¯ãá⨬® ®â 1 ¤® 32 Œ¡)
-nochk <"ptibcwra"> ®âª«îç¨âì ¯à®¢¥àª¨ ¯à¨ ¢ë¯®«­¥­¨¨ (á¬. ­¨¦¥)
-ver <major.minor> ¢¥àá¨ï ¯à®£à ¬¬ë (⮫쪮 ¤«ï obj)
¯ à ¬¥âà -nochk § ¤ ¥âáï ¢ ¢¨¤¥ áâப¨ ¨§ ᨬ¢®«®¢:
"p" - 㪠§ â¥«¨
"t" - ⨯ë
"i" - ¨­¤¥ªáë
"b" - ­¥ï¢­®¥ ¯à¨¢¥¤¥­¨¥ INTEGER ª BYTE
"c" - ¤¨ ¯ §®­  à£ã¬¥­â  ä㭪樨 CHR
"w" - ¤¨ ¯ §®­  à£ã¬¥­â  ä㭪樨 WCHR
"r" - íª¢¨¢ «¥­â­® "bcw"
"a" - ¢á¥ ¯à®¢¥àª¨
<20>®à冷ª ᨬ¢®«®¢ ¬®¦¥â ¡ëâì «î¡ë¬. <20> «¨ç¨¥ ¢ áâப¥ ⮣® ¨«¨ ¨­®£®
ᨬ¢®«  ®âª«îç ¥â ᮮ⢥âáâ¢ãîéãî ¯à®¢¥àªã.
<20> ¯à¨¬¥à: -nochk it - ®âª«îç¨âì ¯à®¢¥àªã ¨­¤¥ªá®¢ ¨ ®åà ­ã ⨯ .
-nochk a - ®âª«îç¨âì ¢á¥ ®âª«îç ¥¬ë¥ ¯à®¢¥àª¨.
<20> ¯à¨¬¥à:
Compiler.exe "C:\example.ob07" console -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" dll -out "C:\example.dll"
Compiler.exe "C:\example.ob07" gui -out "C:\example.exe" -stk 4
Compiler.exe "C:\example.ob07" console -out "C:\example.exe" -nochk pti
Compiler.kex "/tmp0/1/example.ob07" kos -out "/tmp0/1/example.kex" -stk 4
Compiler.kex "/tmp0/1/example.ob07" obj -out "/tmp0/1/example.obj" -ver 2.7
Compiler.exe "C:\example.ob07" elfexe -out "C:\example" -stk 1 -nochk a
‚ á«ãç ¥ ãᯥ譮© ª®¬¯¨«ï樨, ª®¬¯¨«ïâ®à ¯¥à¥¤ ¥â ª®¤ § ¢¥à襭¨ï 0, ¨­ ç¥ 1.
<EFBFBD>ਠࠡ®â¥ ª®¬¯¨«ïâ®à  ¢ KolibriOS, ª®¤ § ¢¥à襭¨ï ­¥ ¯¥à¥¤ ¥âáï.
------------------------------------------------------------------------------
Žâ«¨ç¨ï ®â ®à¨£¨­ « 
1. <20> áè¨à¥­ ¯á¥¢¤®¬®¤ã«ì SYSTEM
2. ‚ ¨¤¥­â¨ä¨ª â®à å ¤®¯ã᪠¥âáï ᨬ¢®« "_"
3. „®¡ ¢«¥­ë á¨á⥬­ë¥ ä« £¨
4. “ᮢ¥à襭á⢮¢ ­ ®¯¥à â®à CASE (¤®¡ ¢«¥­ë ª®­áâ ­â­ë¥ ¢ëà ¦¥­¨ï ¢
¬¥âª å ¢ à¨ ­â®¢ ¨ ­¥®¡ï§ â¥«ì­ ï ¢¥âª  ELSE)
5. <20> áè¨à¥­ ­ ¡®à áâ ­¤ àâ­ëå ¯à®æ¥¤ãà
6. ‘¥¬ ­â¨ª  ®åà ­ë/¯à®¢¥àª¨ ⨯  ãâ®ç­¥­  ¤«ï ­ã«¥¢®£® 㪠§ â¥«ï
7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥«
8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//")
9. <20> §à¥è¥­® ­ á«¥¤®¢ ­¨¥ ®â ⨯ -㪠§ â¥«ï
10. „®¡ ¢«¥­ ᨭ⠪á¨á ¤«ï ¨¬¯®àâ  ¯à®æ¥¤ãà ¨§ ¢­¥è­¨å ¡¨¡«¨®â¥ª
11. "‘âப¨" ¬®¦­® § ª«îç âì â ª¦¥ ¢ ®¤¨­®ç­ë¥ ª ¢ë窨: 'áâப '
12. „®¡ ¢«¥­ ⨯ WCHAR
------------------------------------------------------------------------------
Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨
1. Žá­®¢­ë¥ ⨯ë
’¨¯ „¨ ¯ §®­ §­ ç¥­¨© <20> §¬¥à, ¡ ©â
INTEGER -2147483648 .. 2147483647 4
REAL 4.94E-324 .. 1.70E+308 8
CHAR ᨬ¢®« ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET ¬­®¦¥á⢮ ¨§ 楫ëå ç¨á¥« {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR ᨬ¢®« î­¨ª®¤  (0X .. 0FFFFX) 2
2. Œ ªá¨¬ «ì­ ï ¤«¨­  ¨¤¥­â¨ä¨ª â®à®¢ - 1024 ᨬ¢®«®¢
3. Œ ªá¨¬ «ì­ ï ¤«¨­  áâப®¢ëå ª®­áâ ­â - 1024 ᨬ¢®«®¢ (UTF-8)
4. Œ ªá¨¬ «ì­ ï à §¬¥à­®áâì ®âªàëâëå ¬ áᨢ®¢ - 5
5. <20>à®æ¥¤ãà  NEW § ¯®«­ï¥â ­ã«ï¬¨ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨
6. ƒ«®¡ «ì­ë¥ ¨ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¨­¨æ¨ «¨§¨àãîâáï ­ã«ï¬¨
7. ‚ ®â«¨ç¨¥ ®â ¬­®£¨å Oberon-ॠ«¨§ æ¨©, á¡®à騪 ¬ãá®à  ¨ ¤¨­ ¬¨ç¥áª ï
¬®¤ã«ì­®áâì ®âáãâáâ¢ãîâ
8. ’¨¯ BYTE ¢ ¢ëà ¦¥­¨ïå ¢á¥£¤  ¯à¨¢®¤¨âáï ª INTEGER
9. Š®­âà®«ì ¯¥à¥¯®«­¥­¨ï §­ ç¥­¨© ¢ëà ¦¥­¨© ­¥ ¯à®¨§¢®¤¨âáï
10. Žè¨¡ª¨ ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï:
- ASSERT(x), ¯à¨ x = FALSE
- ࠧ묥­®¢ ­¨¥ ­ã«¥¢®£® 㪠§ â¥«ï
- 楫®ç¨á«¥­­®¥ ¤¥«¥­¨¥ ­  0
- ¢ë§®¢ ¯à®æ¥¤ãàë ç¥à¥§ ¯à®æ¥¤ãà­ãî ¯¥à¥¬¥­­ãî á ­ã«¥¢ë¬ §­ ç¥­¨¥¬
- ®è¨¡ª  ®åà ­ë ⨯ 
- ­ àã襭¨¥ £à ­¨æ ¬ áᨢ 
- ­¥¯à¥¤ãᬮâ७­®¥ §­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢ ®¯¥à â®à¥ CASE
- ®è¨¡ª  ª®¯¨à®¢ ­¨ï ¬ áᨢ®¢ v := x, ¥á«¨ LEN(v) < LEN(x)
- ­¥ï¢­®¥ ¯à¨¢¥¤¥­¨¥ x:INTEGER ª v:BYTE, ¥á«¨ (x < 0) OR (x > 255)
- CHR(x), ¥á«¨ (x < 0) OR (x > 255)
- WCHR(x), ¥á«¨ (x < 0) OR (x > 65535)
------------------------------------------------------------------------------
<20>ᥢ¤®¬®¤ã«ì SYSTEM
<20>ᥢ¤®¬®¤ã«ì SYSTEM ᮤ¥à¦¨â ­¨§ª®ã஢­¥¢ë¥ ¨ ­¥¡¥§®¯ á­ë¥ ¯à®æ¥¤ãàë,
®è¨¡ª¨ ¯à¨ ¨á¯®«ì§®¢ ­¨¨ ¯à®æ¥¤ãà ¯á¥¢¤®¬®¤ã«ï SYSTEM ¬®£ã⠯ਢ¥á⨠ª
¯®¢à¥¦¤¥­¨î ¤ ­­ëå ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨  ¢ à¨©­®¬ã § ¢¥à襭¨î ¯à®£à ¬¬ë.
PROCEDURE ADR(v: «î¡®© ⨯): INTEGER
v - ¯¥à¥¬¥­­ ï ¨«¨ ¯à®æ¥¤ãà ;
¢®§¢à é ¥â  ¤à¥á v
PROCEDURE SADR(x: áâப®¢ ï ª®­áâ ­â  (CHAR UTF-8)): INTEGER
¢®§¢à é ¥â  ¤à¥á x
PROCEDURE WSADR(x: áâப®¢ ï ª®­áâ ­â  (WCHAR)): INTEGER
¢®§¢à é ¥â  ¤à¥á x
PROCEDURE SIZE(T): INTEGER
¢®§¢à é ¥â à §¬¥à ⨯  T
PROCEDURE TYPEID(T): INTEGER
T - ⨯-§ ¯¨áì ¨«¨ ⨯-㪠§ â¥«ì,
¢®§¢à é ¥â ­®¬¥à ⨯  ¢ â ¡«¨æ¥ ⨯®¢-§ ¯¨á¥©
PROCEDURE INF(): REAL
¢®§¢à é ¥â ᯥ樠«ì­®¥ ¢¥é¥á⢥­­®¥ §­ ç¥­¨¥ "¡¥áª®­¥ç­®áâì"
PROCEDURE GET(a: INTEGER;
VAR v: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
v := <20> ¬ïâì[a]
PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
<20> ¬ïâì[a] := x;
…᫨ x: BYTE ¨«¨ x: WCHAR, â® §­ ç¥­¨¥ x ¡ã¤¥â à áè¨à¥­®
¤® 32 ¡¨â, ¤«ï § ¯¨á¨ ¡ ©â®¢ ¨á¯®«ì§®¢ âì SYSTEM.PUT8,
¤«ï WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
<20> ¬ïâì[a] := ¬« ¤è¨¥ 8 ¡¨â (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
<20> ¬ïâì[a] := ¬« ¤è¨¥ 16 ¡¨â (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest,
®¡« á⨠Source ¨ Dest ­¥ ¬®£ãâ ¯¥à¥ªà뢠âìáï
PROCEDURE COPY(VAR Source: «î¡®© ⨯; VAR Dest: «î¡®© ⨯; n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest.
<20>ª¢¨¢ «¥­â­®
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 ­¥«ì§ï ¨á¯®«ì§®¢ âì ¢ ª®­áâ ­â­ëå ¢ëà ¦¥­¨ïå.
------------------------------------------------------------------------------
‘¨á⥬­ë¥ ä« £¨
<20>ਠ®¡ê¥­¨¨ ¯à®æ¥¤ãà­ëå ⨯®¢ ¨ £«®¡ «ì­ëå ¯à®æ¥¤ãà, ¯®á«¥ ª«î祢®£®
á«®¢  PROCEDURE ¬®¦¥â ¡ëâì 㪠§ ­ ä« £ ᮣ« è¥­¨ï ® ¢ë§®¢¥: [stdcall],
[ccall], [ccall16], [windows], [linux]. <20> ¯à¨¬¥à:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
…᫨ 㪠§ ­ ä« £ [ccall16], â® ¯à¨­¨¬ ¥âáï ᮣ« è¥­¨¥ ccall, ­® ¯¥à¥¤
¢ë§®¢®¬ 㪠§ â¥«ì áâíª  ¡ã¤¥â ¢ëà ¢­¥­ ¯® £à ­¨æ¥ 16 ¡ ©â.
”« £ [windows] - ᨭ®­¨¬ ¤«ï [stdcall], [linux] - ᨭ®­¨¬ ¤«ï [ccall16].
‡­ ª "-" ¯®á«¥ ¨¬¥­¨ ä« £  ([stdcall-], [linux-], ...) ®§­ ç ¥â, çâ®
१ã«ìâ â ¯à®æ¥¤ãàë ¬®¦­® ¨£­®à¨à®¢ âì (­¥ ¤®¯ã᪠¥âáï ¤«ï ⨯  REAL).
<20>ਠ®¡ê¥­¨¨ ⨯®¢-§ ¯¨á¥©, ¯®á«¥ ª«î祢®£® á«®¢  RECORD ¬®¦¥â ¡ëâì
㪠§ ­ ä« £ [noalign]. ”« £ [noalign] ®§­ ç ¥â ®âáãâá⢨¥ ¢ëà ¢­¨¢ ­¨ï ¯®«¥©
§ ¯¨á¨. ‡ ¯¨á¨ á á¨á⥬­ë¬ ä« £®¬ ­¥ ¬®£ãâ ¨¬¥âì ¡ §®¢ë© ⨯ ¨ ­¥ ¬®£ãâ ¡ëâì
¡ §®¢ë¬¨ ⨯ ¬¨ ¤«ï ¤àã£¨å § ¯¨á¥©.
„«ï ¨á¯®«ì§®¢ ­¨ï á¨á⥬­ëå ä« £®¢, âॡã¥âáï ¨¬¯®àâ¨à®¢ âì SYSTEM.
------------------------------------------------------------------------------
Ž¯¥à â®à CASE
‘¨­â ªá¨á ®¯¥à â®à  CASE:
CaseStatement =
CASE Expression OF ‘ase {"|" ‘ase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
<20> ¯à¨¬¥à:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
‚ ¬¥âª å ¢ à¨ ­â®¢ ¬®¦­® ¨á¯®«ì§®¢ âì ª®­áâ ­â­ë¥ ¢ëà ¦¥­¨ï, ¢¥âª  ELSE
­¥®¡ï§ â¥«ì­ . …᫨ §­ ç¥­¨¥ x ­¥ ᮮ⢥âáâ¢ã¥â ­¨ ®¤­®¬ã ¢ à¨ ­âã ¨ ELSE
®âáãâáâ¢ã¥â, â® ¯à®£à ¬¬  ¯à¥à뢠¥âáï á ®è¨¡ª®© ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï.
------------------------------------------------------------------------------
’¨¯ WCHAR
’¨¯ WCHAR ¤®¡ ¢«¥­ ¢ ï§ëª ¤«ï 㤮¡­®© ¯®¤¤¥¦ª¨ î­¨ª®¤ . „«ï ⨯®¢ WCHAR ¨
ARRAY OF WCHAR ¤®¯ã᪠îâáï ¢á¥ â¥ ¦¥ ®¯¥à æ¨¨, ª ª ¤«ï ⨯®¢ CHAR ¨
ARRAY OF CHAR, §  ¨áª«î祭¨¥¬ ¢áâ஥­­®© ¯à®æ¥¤ãàë CHR, ª®â®à ï ¢®§¢à é ¥â
⮫쪮 ⨯ CHAR. „«ï ¯®«ã祭¨ï §­ ç¥­¨ï ⨯  WCHAR, á«¥¤ã¥â ¨á¯®«ì§®¢ âì
¯à®æ¥¤ãàã WCHR ¢¬¥áâ® CHR. „«ï ¯à ¢¨«ì­®© à ¡®âë á ⨯®¬, ­¥®¡å®¤¨¬® á®åà ­ïâì
¨á室­ë© ª®¤ ¢ ª®¤¨à®¢ª¥ UTF-8 c BOM.
------------------------------------------------------------------------------
<20>஢¥àª  ¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï
Žà¨£¨­ «ì­®¥ á®®¡é¥­¨¥ ® ï§ëª¥ ­¥ ®¯à¥¤¥«ï¥â ¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë ¯à¨
¢ë¯®«­¥­¨¨ ®åà ­ë 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
<20>८¡à §®¢ ­¨¥ ⨯ ,  ­ «®£¨ç­® CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
DIV ¨ MOD
x y x DIV y x MOD y
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
------------------------------------------------------------------------------
ˆ¬¯®àâ¨à®¢ ­­ë¥ ¯à®æ¥¤ãàë
‘¨­â ªá¨á ¨¬¯®àâ :
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
- callconv -- ᮣ« è¥­¨¥ ® ¢ë§®¢¥
- "library" -- ¨¬ï ä ©«  ¤¨­ ¬¨ç¥áª®© ¡¨¡«¨®â¥ª¨
- "function" -- ¨¬ï ¨¬¯®àâ¨à㥬®© ¯à®æ¥¤ãàë
­ ¯à¨¬¥à:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
‚ ª®­æ¥ ®¡ê¥­¨ï ¬®¦¥â ¡ëâì ¤®¡ ¢«¥­® (­¥®¡ï§ â¥«ì­®) "END proc_name;"
Ž¡ê¥­¨ï ¨¬¯®àâ¨à®¢ ­­ëå ¯à®æ¥¤ãà ¤®«¦­ë à á¯®« £ âìáï ¢ £«®¡ «ì­®©
®¡« á⨠¢¨¤¨¬®á⨠¬®¤ã«ï ¯®á«¥ ®¡ê¥­¨ï ¯¥à¥¬¥­­ëå, ¢¬¥áâ¥ á ®¡ê¥­¨¥¬
"®¡ëç­ëå" ¯à®æ¥¤ãà, ®â ª®â®àëå ¨¬¯®àâ¨à®¢ ­­ë¥ ®â«¨ç îâáï ⮫쪮 ®âáãâá⢨¥¬
⥫  ¯à®æ¥¤ãàë. ‚ ®áâ «ì­®¬, ª â ª¨¬ ¯à®æ¥¤ãà ¬ ¯à¨¬¥­¨¬ë ⥠¦¥ ¯à ¢¨« :
¨å ¬®¦­® ¢ë§¢ âì, ¯à¨á¢®¨âì ¯à®æ¥¤ãà­®© ¯¥à¥¬¥­­®© ¨«¨ ¯®«ãç¨âì  ¤à¥á.
’ ª ª ª ¨¬¯®àâ¨à®¢ ­­ ï ¯à®æ¥¤ãà  ¢á¥£¤  ¨¬¥¥â ®¥ 㪠§ ­¨¥ ᮣ« è¥­¨ï ®
¢ë§®¢¥, ⮠ᮢ¬¥áâ¨¬ë© ¯à®æ¥¤ãà­ë© ⨯ ⮦¥ ¤®«¦¥­ ¡ëâì ®¡ê¥­ á 㪠§ ­¨¥¬
ᮣ« è¥­¨ï ® ¢ë§®¢¥:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
‚ KolibriOS ¨¬¯®àâ¨à®¢ âì ¯à®æ¥¤ãàë ¬®¦­® ⮫쪮 ¨§ ¡¨¡«¨®â¥ª, à §¬¥é¥­­ëå
¢ /rd/1/lib. ˆ¬¯®àâ¨à®¢ âì ¨ ¢ë§ë¢ âì ä㭪樨 ¨­¨æ¨ «¨§ æ¨¨ ¡¨¡«¨®â¥ª
(lib_init, START) ¯à¨ í⮬ ­¥ ­ã¦­®.
„«ï Linux, ¨¬¯®àâ¨à®¢ ­­ë¥ ¯à®æ¥¤ãàë ­¥ ॠ«¨§®¢ ­ë.
------------------------------------------------------------------------------
‘ªàëâë¥ ¯ à ¬¥âàë ¯à®æ¥¤ãà
<20>¥ª®â®àë¥ ¯à®æ¥¤ãàë ¬®£ãâ ¨¬¥âì áªàëâë¥ ¯ à ¬¥âàë, ®­¨ ®âáãâáâ¢ãîâ ¢ ᯨ᪥
ä®à¬ «ì­ëå ¯ à ¬¥â஢, ­® ãç¨â뢠îâáï ª®¬¯¨«ïâ®à®¬ ¯à¨ âà ­á«ï樨 ¢ë§®¢®¢.
<EFBFBD>â® ¢®§¬®¦­® ¢ á«¥¤ãîé¨å á«ãç ïå:
1. <20>à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà ®âªàëâë© ¬ áᨢ:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. <20>à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà-¯¥à¥¬¥­­ãî ⨯  RECORD:
PROCEDURE Proc (VAR x: Rec);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
------------------------------------------------------------------------------
Œ®¤ã«ì RTL
‚ᥠ¯à®£à ¬¬ë ­¥ï¢­® ¨á¯®«ì§ãîâ ¬®¤ã«ì RTL. Š®¬¯¨«ïâ®à â࠭᫨àã¥â
­¥ª®â®àë¥ ®¯¥à æ¨¨ (¯à®¢¥àª  ¨ ®åà ­  ⨯ , áà ¢­¥­¨¥ áâப, á®®¡é¥­¨ï ®¡
®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨ ¤à.) ª ª ¢ë§®¢ë ¯à®æ¥¤ãà í⮣® ¬®¤ã«ï. <20>¥
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãà SetDll ¨ SetFini
¥á«¨ ¯à¨«®¦¥­¨¥ ª®¬¯¨«¨àã¥âáï ª ª Windows DLL ¨«¨ Linux SO, ᮮ⢥âá⢥­­®:
PROCEDURE SetDll
(process_detach, thread_detach, thread_attach: DLL_ENTRY);
£¤¥ TYPE DLL_ENTRY =
PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
SetDll ­ §­ ç ¥â ¯à®æ¥¤ãàë process_detach, thread_detach, thread_attach
¢ë§ë¢ ¥¬ë¬¨ ¯à¨
- ¢ë£à㧪¥ dll-¡¨¡«¨®â¥ª¨ (process_detach)
- ᮧ¤ ­¨¨ ­®¢®£® ¯®â®ª  (thread_attach)
- ã­¨ç⮦¥­¨¨ ¯®â®ª  (thread_detach)
PROCEDURE SetFini (ProcFini: PROC);
£¤¥ TYPE PROC = PROCEDURE (* ¡¥§ ¯ à ¬¥â஢ *)
SetFini ­ §­ ç ¥â ¯à®æ¥¤ãàã ProcFini ¢ë§ë¢ ¥¬®© ¯à¨ ¢ë£à㧪¥ so-¡¨¡«¨®â¥ª¨.
„«ï ¯à®ç¨å ⨯®¢ ¯à¨«®¦¥­¨©, ¢ë§®¢ ¯à®æ¥¤ãà SetDll ¨ SetFini ­¥ ¢«¨ï¥â ­ 
¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë.
‘®®¡é¥­¨ï ®¡ ®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¢ë¢®¤ïâáï ¢ ¤¨ «®£®¢ëå ®ª­ å
(Windows), ¢ â¥à¬¨­ « (Linux), ­  ¤®áªã ®â« ¤ª¨ (KolibriOS).
------------------------------------------------------------------------------
Œ®¤ã«ì API
‘ãé¥áâ¢ãîâ ­¥áª®«ìª® ॠ«¨§ æ¨© ¬®¤ã«ï API (¤«ï à §«¨ç­ëå Ž‘).
Š ª ¨ ¬®¤ã«ì RTL, ¬®¤ã«ì API ­¥ ¯à¥¤­ §­ ç¥­ ¤«ï ¯àאַ£® ¨á¯®«ì§®¢ ­¨ï.
Ž­ ®¡¥á¯¥ç¨¢ ¥â á¢ï§ì RTL á Ž‘.
------------------------------------------------------------------------------
ƒ¥­¥à æ¨ï ¨á¯®«­ï¥¬ëå ä ©«®¢ DLL
<20> §à¥è ¥âáï íªá¯®àâ¨à®¢ âì ⮫쪮 ¯à®æ¥¤ãàë. „«ï í⮣®, ¯à®æ¥¤ãà  ¤®«¦­ 
­ å®¤¨âìáï ¢ £« ¢­®¬ ¬®¤ã«¥ ¯à®£à ¬¬ë, ¨ ¥¥ ¨¬ï ¤®«¦­® ¡ëâì ®â¬¥ç¥­® ᨬ¢®«®¬
íªá¯®àâ  ("*"). KolibriOS DLL ¢á¥£¤  íªá¯®àâ¨àãîâ ¨¤¥­â¨ä¨ª â®àë "version"
(¢¥àá¨ï ¯à®£à ¬¬ë) ¨ "lib_init" -  ¤à¥á ¯à®æ¥¤ãàë ¨­¨æ¨ «¨§ æ¨¨ DLL:
PROCEDURE [stdcall] lib_init (): INTEGER
<EFBFBD>â  ¯à®æ¥¤ãà  ¤®«¦­  ¡ëâì ¢ë§¢ ­  ¯¥à¥¤ ¨á¯®«ì§®¢ ­¨¥¬ DLL.
<EFBFBD>à®æ¥¤ãà  ¢á¥£¤  ¢®§¢à é ¥â 1.

566
programs/develop/oberon07/Docs/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
------------------------------------------------------------------------------

566
programs/develop/oberon07/Docs/KOSLib1251.txt
View File

@ -1,566 +0,0 @@
==============================================================================
Áèáëèîòåêà (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
------------------------------------------------------------------------------

566
programs/develop/oberon07/Docs/KOSLib866.txt
View File

@ -1,566 +0,0 @@
==============================================================================
<20>¨¡«¨®â¥ª  (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 (®è¨¡ª ). <20>ਠ­¥®¡å®¤¨¬®áâ¨, à á¯ ª®¢ë¢ ¥â
ä ©« (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
‡ ¯¨á뢠¥â áâàãªâãàã ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  ¤«ï ä ©« 
¨«¨ ¯ ¯ª¨ á ¨¬¥­¥¬ FName ¢ ¯ à ¬¥âà Info.
<20>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 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
<20>à®æ¥¤ãàë ¢®§¢à é îâ 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
<20>à®æ¥¤ãàë ¢®§¢à é îâ 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
<20>¥à¥à á¯à¥¤¥«ï¥â ¡«®ª ¯ ¬ïâ¨,
ptr -  ¤à¥á à ­¥¥ ¢ë¤¥«¥­­®£® ¡«®ª ,
size - ­®¢ë© à §¬¥à,
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¯¥à¥à á¯à¥¤¥«¥­­ë© ¡«®ª,
0 ¯à¨ ®è¨¡ª¥
PROCEDURE GetCommandLine(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ ¯ à ¬¥â஢
PROCEDURE GetName(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ á ¨¬¥­¥¬ ¯à®£à ¬¬ë
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
‡ £à㦠¥â DLL á ¯®«­ë¬ ¨¬¥­¥¬ name. ‚®§¢à é ¥â  ¤à¥á â ¡«¨æë
íªá¯®àâ . <20>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - ¨¬ï ¯à®æ¥¤ãàë
lib -  ¤à¥á â ¡«¨æë íªá¯®àâ  DLL
‚®§¢à é ¥â  ¤à¥á ¯à®æ¥¤ãàë. <20>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 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 㪠§ â¥«ì ­  èà¨äâ
<20>à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© 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
------------------------------------------------------------------------------

312
programs/develop/oberon07/Docs/WinLib.txt Normal file
View File

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

358
programs/develop/oberon07/Docs/x86.txt Normal file
View File

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

346
programs/develop/oberon07/Docs/x86_64.txt Normal file
View File

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

2
programs/develop/oberon07/GitHub.url Normal file
View File

@ -0,0 +1,2 @@
[InternetShortcut]
URL=https://github.com/AntKrotov/oberon-07-compiler

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

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

15
programs/develop/oberon07/Lib/KolibriOS/API.ob07
View File

@ -1,7 +1,7 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2020, Anton Krotov
All rights reserved.
*)
@ -318,4 +318,13 @@ PROCEDURE GetTickCount* (): INTEGER;
END GetTickCount;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
END sofinit;
END API.

4
programs/develop/oberon07/Lib/KolibriOS/Args.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -97,4 +97,4 @@ END GetArg;
BEGIN
ParamParse
END Args.
END Args.

4
programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -102,4 +102,4 @@ END Load;
BEGIN
Load
END ColorDlg.
END ColorDlg.

2
programs/develop/oberon07/Lib/KolibriOS/Console.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

4
programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -100,4 +100,4 @@ END main;
BEGIN
main
END ConsoleLib.
END ConsoleLib.

4
programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -138,4 +138,4 @@ BEGIN
Msec := 0
END Now;
END DateTime.
END DateTime.

4
programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -289,4 +289,4 @@ BEGIN
res := KOSAPI.sysfunc2(70, sys.ADR(info))
END Open;
END Debug.
END Debug.

4
programs/develop/oberon07/Lib/KolibriOS/File.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -313,4 +313,4 @@ BEGIN
END DeleteDir;
END File.
END File.

46
programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
View File

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

2
programs/develop/oberon07/Lib/KolibriOS/In.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

4
programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -427,4 +427,4 @@ BEGIN
END _init;
END KOSAPI.
END KOSAPI.

4
programs/develop/oberon07/Lib/KolibriOS/Math.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -381,4 +381,4 @@ BEGIN
END fact;
END Math.
END Math.

4
programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -104,4 +104,4 @@ PROCEDURE LinkStatus* (num: INTEGER): INTEGER;
END LinkStatus;
END NetDevices.
END NetDevices.

4
programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -150,4 +150,4 @@ END Load;
BEGIN
Load
END OpenDlg.
END OpenDlg.

4
programs/develop/oberon07/Lib/KolibriOS/Out.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -264,4 +264,4 @@ END FixReal;
PROCEDURE Open*;
END Open;
END Out.
END Out.

143
programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
View File

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

4
programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify
@ -121,4 +121,4 @@ END main;
BEGIN
main
END RasterWorks.
END RasterWorks.

4
programs/develop/oberon07/Lib/KolibriOS/Read.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -43,4 +43,4 @@ 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.
END Read.

128
programs/develop/oberon07/Lib/KolibriOS/UnixTime.ob07
View File

@ -1,64 +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.
(*
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.

4
programs/develop/oberon07/Lib/KolibriOS/Vector.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -118,4 +118,4 @@ BEGIN
END destroy;
END Vector.
END Vector.

4
programs/develop/oberon07/Lib/KolibriOS/Write.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -43,4 +43,4 @@ 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.
END Write.

4
programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
@ -489,4 +489,4 @@ BEGIN
RETURN Font
END LoadFont;
END kfonts.
END kfonts.

4
programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify
@ -432,4 +432,4 @@ END main;
BEGIN
main
END libimg.
END libimg.

30
programs/develop/oberon07/Lib/Linux32/API.ob07
View File

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

46
programs/develop/oberon07/Lib/Linux32/HOST.ob07
View File

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

14
programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
View File

@ -1,7 +1,7 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -13,6 +13,7 @@ IMPORT SYSTEM, API;
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
VAR
@ -69,12 +70,17 @@ BEGIN
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
@ -134,4 +140,4 @@ END syscall;
BEGIN
init
END LINAPI.
END LINAPI.

65
programs/develop/oberon07/Lib/Linux32/Libdl.ob07 Normal file
View File

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

384
programs/develop/oberon07/Lib/Linux32/Math.ob07 Normal file
View File

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

277
programs/develop/oberon07/Lib/Linux32/Out.ob07 Normal file
View File

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

143
programs/develop/oberon07/Lib/Linux32/RTL.ob07
View File

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

169
programs/develop/oberon07/Lib/Linux64/API.ob07 Normal file
View File

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

208
programs/develop/oberon07/Lib/Linux64/HOST.ob07 Normal file
View File

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

138
programs/develop/oberon07/Lib/Linux64/LINAPI.ob07 Normal file
View File

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

65
programs/develop/oberon07/Lib/Linux64/Libdl.ob07 Normal file
View File

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

311
programs/develop/oberon07/Lib/Linux64/Math.ob07 Normal file
View File

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

276
programs/develop/oberon07/Lib/Linux64/Out.ob07 Normal file
View File

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

516
programs/develop/oberon07/Lib/Linux64/RTL.ob07 Normal file
View File

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

64
programs/develop/oberon07/Lib/Windows32/API.ob07
View File

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

101
programs/develop/oberon07/Lib/Windows32/Args.ob07 Normal file
View File

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

100
programs/develop/oberon07/Lib/Windows32/Console.ob07 Normal file
View File

@ -0,0 +1,100 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7;
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

174
programs/develop/oberon07/Lib/Windows32/DateTime.ob07 Normal file
View File

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

142
programs/develop/oberon07/Lib/Windows32/File.ob07 Normal file
View File

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

46
programs/develop/oberon07/Lib/Windows32/HOST.ob07
View File

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

289
programs/develop/oberon07/Lib/Windows32/In.ob07 Normal file
View File

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

384
programs/develop/oberon07/Lib/Windows32/Math.ob07 Normal file
View File

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

280
programs/develop/oberon07/Lib/Windows32/Out.ob07 Normal file
View File

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

143
programs/develop/oberon07/Lib/Windows32/RTL.ob07
View File

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

64
programs/develop/oberon07/Lib/Windows32/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.

76
programs/develop/oberon07/Lib/Windows32/Utils.ob07 Normal file
View File

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

241
programs/develop/oberon07/Lib/Windows32/WINAPI.ob07 Normal file
View File

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

130
programs/develop/oberon07/Lib/Windows64/API.ob07 Normal file
View File

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

100
programs/develop/oberon07/Lib/Windows64/Console.ob07 Normal file
View File

@ -0,0 +1,100 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7;
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

174
programs/develop/oberon07/Lib/Windows64/DateTime.ob07 Normal file
View File

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

371
programs/develop/oberon07/Lib/Windows64/HOST.ob07 Normal file
View File

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

295
programs/develop/oberon07/Lib/Windows64/In.ob07 Normal file
View File

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

311
programs/develop/oberon07/Lib/Windows64/Math.ob07 Normal file
View File

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

308
programs/develop/oberon07/Lib/Windows64/Out.ob07 Normal file
View File

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

516
programs/develop/oberon07/Lib/Windows64/RTL.ob07 Normal file
View File

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

64
programs/develop/oberon07/Lib/Windows64/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.

170
programs/develop/oberon07/Lib/Windows64/WINAPI.ob07 Normal file
View File

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

4
programs/develop/oberon07/Samples/Dialogs.ob07
View File

@ -1,4 +1,4 @@
MODULE Dialogs;
MODULE Dialogs;
IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg;
@ -107,4 +107,4 @@ END main;
BEGIN
main
END Dialogs.
END Dialogs.

4
programs/develop/oberon07/Samples/HW.ob07
View File

@ -1,4 +1,4 @@
MODULE HW;
MODULE HW;
IMPORT sys := SYSTEM, KOSAPI;
@ -47,4 +47,4 @@ END Main;
BEGIN
Main("HW", "Hello, world!")
END HW.
END HW.

4
programs/develop/oberon07/Samples/HW_con.ob07
View File

@ -1,4 +1,4 @@
MODULE HW_con;
MODULE HW_con;
IMPORT Out, In, Console, DateTime;
@ -60,4 +60,4 @@ BEGIN
main;
In.Ln;
Console.exit(TRUE)
END HW_con.
END HW_con.

732
programs/develop/oberon07/Source/AMD64.ob07
View File

File diff suppressed because it is too large Load Diff

89
programs/develop/oberon07/Source/ARITH.ob07
View File

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

4
programs/develop/oberon07/Source/AVLTREES.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -194,4 +194,4 @@ END destroy;
BEGIN
nodes := C.create()
END AVLTREES.
END AVLTREES.

26
programs/develop/oberon07/Source/BIN.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -12,17 +12,12 @@ IMPORT LISTS, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
RCODE* = 1;
RDATA* = 2;
RBSS* = 3;
RIMP* = 4;
RCODE* = 0; PICCODE* = RCODE + 1;
RDATA* = 2; PICDATA* = RDATA + 1;
RBSS* = 4; PICBSS* = RBSS + 1;
RIMP* = 6; PICIMP* = RIMP + 1;
PICCODE* = 5;
PICDATA* = 6;
PICBSS* = 7;
PICIMP* = 8;
IMPTAB* = 9;
IMPTAB* = 8;
TYPE
@ -211,6 +206,13 @@ BEGIN
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)
@ -380,4 +382,4 @@ BEGIN
END InitArray;
END BIN.
END BIN.

10
programs/develop/oberon07/Source/CHUNKLISTS.ob07
View File

@ -1,7 +1,7 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
@ -12,8 +12,8 @@ IMPORT LISTS, WR := WRITER;
CONST
LENOFBYTECHUNK = 64000;
LENOFINTCHUNK = 16000;
LENOFBYTECHUNK = 65536;
LENOFINTCHUNK = 16384;
TYPE
@ -283,4 +283,4 @@ PROCEDURE Length* (list: ANYLIST): INTEGER;
END Length;
END CHUNKLISTS.
END CHUNKLISTS.

4
programs/develop/oberon07/Source/COLLECTIONS.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -56,4 +56,4 @@ BEGIN
END create;
END COLLECTIONS.
END COLLECTIONS.

4
programs/develop/oberon07/Source/CONSOLE.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -79,4 +79,4 @@ BEGIN
END Int2Ln;
END CONSOLE.
END CONSOLE.

49
programs/develop/oberon07/Source/CONSTANTS.ob07
View File

@ -1,49 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE CONSTANTS;
CONST
vMajor* = 1;
vMinor* = 13;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
Target_iConsole* = 1;
Target_iGUI* = 2;
Target_iDLL* = 3;
Target_iKolibri* = 4;
Target_iObject* = 5;
Target_iConsole64* = 6;
Target_iGUI64* = 7;
Target_iDLL64* = 8;
Target_iELF32* = 9;
Target_iELFSO32* = 10;
Target_iELF64* = 11;
Target_iELFSO64* = 12;
Target_iMSP430* = 13;
Target_sConsole* = "console";
Target_sGUI* = "gui";
Target_sDLL* = "dll";
Target_sKolibri* = "kos";
Target_sObject* = "obj";
Target_sConsole64* = "console64";
Target_sGUI64* = "gui64";
Target_sDLL64* = "dll64";
Target_sELF32* = "elfexe";
Target_sELFSO32* = "elfso";
Target_sELF64* = "elfexe64";
Target_sELFSO64* = "elfso64";
Target_sMSP430* = "msp430";
END CONSTANTS.

176
programs/develop/oberon07/Source/Compiler.ob07
View File

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

22
programs/develop/oberon07/Source/ELF.ob07
View File

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

20
programs/develop/oberon07/Source/ERRORS.ob07
View File

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

35
programs/develop/oberon07/Source/FILES.ob07
View File

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

127
programs/develop/oberon07/Source/HEX.ob07 Normal file
View File

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

2394
programs/develop/oberon07/Source/IL.ob07
View File

File diff suppressed because it is too large Load Diff

29
programs/develop/oberon07/Source/KOS.ob07
View File

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

4
programs/develop/oberon07/Source/LISTS.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -199,4 +199,4 @@ BEGIN
END create;
END LISTS.
END LISTS.

42
programs/develop/oberon07/Source/MSCOFF.ob07
View File

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

3552
programs/develop/oberon07/Source/MSP430.ob07
View File

File diff suppressed because it is too large Load Diff

1352
programs/develop/oberon07/Source/MSP430RTL.ob07
View File

File diff suppressed because it is too large Load Diff

105
programs/develop/oberon07/Source/PARS.ob07
View File

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

4
programs/develop/oberon07/Source/PATHS.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -106,4 +106,4 @@ BEGIN
END GetCurrentDirectory;
END PATHS.
END PATHS.

91
programs/develop/oberon07/Source/PE32.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -7,7 +7,7 @@
MODULE PE32;
IMPORT BIN, LISTS, UTILS, WR := WRITER, mConst := CONSTANTS, CHL := CHUNKLISTS;
IMPORT BIN, LISTS, UTILS, WR := WRITER, CHL := CHUNKLISTS;
CONST
@ -165,11 +165,7 @@ VAR
Relocations: LISTS.LIST;
bit64: BOOLEAN;
libcnt: INTEGER;
PROCEDURE SIZE (): INTEGER;
RETURN SIZE_OF_DWORD * (ORD(bit64) + 1)
END SIZE;
SizeOfWord: INTEGER;
PROCEDURE Export (program: BIN.PROGRAM; DataRVA: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
@ -258,41 +254,42 @@ BEGIN
import := import.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SIZE()
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord
END GetImportSize;
PROCEDURE fixup (program: BIN.PROGRAM; Address: VIRTUAL_ADDR);
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
AdrImp: INTEGER;
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
code: CHL.BYTELIST;
L, delta, delta0, AdrImp: INTEGER;
BEGIN
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
delta0 := 3 - 7 * ORD(bit64);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - Address.Code - 7 * ORD(bit64);
L := BIN.get32le(code, reloc.offset);
delta := delta0 - reloc.offset - Address.Code;
CASE reloc.opcode OF
|BIN.PICDATA:
BIN.put32le(program.code, reloc.offset, L + Address.Data + delta)
BIN.put32le(code, reloc.offset, L + Address.Data + delta)
|BIN.PICCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
|BIN.PICBSS:
BIN.put32le(program.code, reloc.offset, L + Address.Bss + delta)
BIN.put32le(code, reloc.offset, L + Address.Bss + delta)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.FirstThunk * SIZE() + AdrImp + delta)
BIN.put32le(code, reloc.offset, iproc.FirstThunk * SizeOfWord + AdrImp + delta)
END;
@ -418,7 +415,6 @@ VAR
i: INTEGER;
BEGIN
WriteWord(file, h.Magic);
WR.WriteByte(file, h.MajorLinkerVersion);
@ -499,6 +495,7 @@ VAR
BEGIN
bit64 := amd64;
SizeOfWord := SIZE_OF_DWORD * (ORD(bit64) + 1);
Relocations := LISTS.create(NIL);
Size.Code := CHL.Length(program.code);
@ -532,8 +529,8 @@ BEGIN
PEHeader.FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
PEHeader.OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
PEHeader.OptionalHeader.MajorLinkerVersion := mConst.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := mConst.vMinor;
PEHeader.OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
PEHeader.OptionalHeader.SizeOfCode := align(Size.Code, FileAlignment);
PEHeader.OptionalHeader.SizeOfInitializedData := 0;
PEHeader.OptionalHeader.SizeOfUninitializedData := 0;
@ -563,30 +560,30 @@ BEGIN
PEHeader.OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
InitSection(SectionHeaders[0], ".text", SHC_text);
SectionHeaders[0].VirtualSize := Size.Code;
SectionHeaders[0].VirtualAddress := SectionAlignment;
SectionHeaders[0].SizeOfRawData := align(Size.Code, FileAlignment);
SectionHeaders[0].PointerToRawData := PEHeader.OptionalHeader.SizeOfHeaders;
SectionHeaders[0].VirtualSize := Size.Code;
SectionHeaders[0].VirtualAddress := SectionAlignment;
SectionHeaders[0].SizeOfRawData := align(Size.Code, FileAlignment);
SectionHeaders[0].PointerToRawData := PEHeader.OptionalHeader.SizeOfHeaders;
InitSection(SectionHeaders[1], ".data", SHC_data);
SectionHeaders[1].VirtualSize := Size.Data;
SectionHeaders[1].VirtualAddress := align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].SizeOfRawData := align(Size.Data, FileAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
SectionHeaders[1].VirtualSize := Size.Data;
SectionHeaders[1].VirtualAddress := align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].SizeOfRawData := align(Size.Data, FileAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
InitSection(SectionHeaders[2], ".bss", SHC_bss);
SectionHeaders[2].VirtualSize := Size.Bss;
SectionHeaders[2].VirtualAddress := align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].SizeOfRawData := 0;
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
SectionHeaders[2].VirtualSize := Size.Bss;
SectionHeaders[2].VirtualAddress := align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].SizeOfRawData := 0;
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
Size.Import := GetImportSize(program.imp_list);
InitSection(SectionHeaders[3], ".idata", SHC_data);
SectionHeaders[3].VirtualSize := Size.Import + CHL.Length(program.import);
SectionHeaders[3].VirtualAddress := align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].SizeOfRawData := align(SectionHeaders[3].VirtualSize, FileAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
SectionHeaders[3].VirtualSize := Size.Import + CHL.Length(program.import);
SectionHeaders[3].VirtualAddress := align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].SizeOfRawData := align(SectionHeaders[3].VirtualSize, FileAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
Address.Code := SectionHeaders[0].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
@ -599,10 +596,10 @@ BEGIN
Size.Export := Export(program, SectionHeaders[1].VirtualAddress, ExportDir);
InitSection(SectionHeaders[4], ".edata", SHC_data);
SectionHeaders[4].VirtualSize := Size.Export + CHL.Length(program.export);
SectionHeaders[4].VirtualAddress := align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].SizeOfRawData := align(SectionHeaders[4].VirtualSize, FileAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
SectionHeaders[4].VirtualSize := Size.Export + CHL.Length(program.export);
SectionHeaders[4].VirtualAddress := align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].SizeOfRawData := align(SectionHeaders[4].VirtualSize, FileAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
END;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
@ -658,7 +655,7 @@ BEGIN
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SIZE() + n - 1 DO
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SizeOfWord + n - 1 DO
CHL.PushInt(ImportTable, 0)
END;
@ -666,11 +663,11 @@ BEGIN
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
i := i + 5
END;
import := import.next(BIN.IMPRT)
@ -738,4 +735,4 @@ BEGIN
END write;
END PE32.
END PE32.

156
programs/develop/oberon07/Source/PROG.ob07
View File

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

4
programs/develop/oberon07/Source/REG.ob07
View File

@ -1,4 +1,4 @@
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
@ -435,4 +435,4 @@ BEGIN
END Init;
END REG.
END REG.

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