├── About.pdf ├── Compile.cmd ├── Elf ├── Errors.txt ├── Lib ├── KolibriOS │ ├── API.ob07 │ ├── Console.ob07 │ ├── ConsoleLib.ob07 │ ├── DateTime.ob07 │ ├── Dir.ob07 │ ├── FSys.ob07 │ ├── File.ob07 │ ├── In.ob07 │ ├── KOSAPI.ob07 │ ├── Math.ob07 │ ├── Out.ob07 │ ├── RTL.ob07 │ ├── Read.ob07 │ ├── Utils.ob07 │ └── Write.ob07 ├── Linux32 │ ├── API.ob07 │ ├── LINAPI.ob07 │ └── RTL.ob07 └── Windows32 │ ├── API.ob07 │ ├── Console.ob07 │ ├── DateTime.ob07 │ ├── Dir.ob07 │ ├── File.ob07 │ ├── In.ob07 │ ├── Math.ob07 │ ├── Out.ob07 │ ├── RTL.ob07 │ ├── Read.ob07 │ ├── Utils.ob07 │ ├── WINAPI.ob07 │ └── Write.ob07 ├── License ├── copying.lesser.txt └── copying.txt ├── Oberon07.Report.pdf ├── Samples ├── KolibriOS │ ├── HW.ob07 │ └── HW_con.ob07 ├── Linux32 │ └── HW.ob07 └── Windows32 │ └── HW.ob07 └── Source ├── Compiler ├── Compiler.ob07 ├── DECL.ob07 ├── SCAN.ob07 ├── UTILS.ob07 └── X86.ob07 └── Editor ├── Dialogs.ob07 ├── Editor.ob07 ├── Lexer.ob07 ├── Line.ob07 ├── List.ob07 ├── Param.ob07 ├── Text.ob07 ├── TextEdit.ob07 └── TextUtils.ob07 /About.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Spirit-of-Oberon/Oberon07akron1/6596c4f2694ca87deb0e7b020d58c6c4815fbf81/About.pdf -------------------------------------------------------------------------------- /Compile.cmd: -------------------------------------------------------------------------------- 1 | @echo off 2 | Compiler.exe %1 %2 %3 3 | @pause -------------------------------------------------------------------------------- /Elf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Spirit-of-Oberon/Oberon07akron1/6596c4f2694ca87deb0e7b020d58c6c4815fbf81/Elf -------------------------------------------------------------------------------- /Errors.txt: -------------------------------------------------------------------------------- 1 |  1 ожидалось 'H' или 'X' 2 | 2 ожидалась цифра 3 | 3 строка не содержит закрывающей кавычки 4 | 4 недопустимый символ 5 | 5 целочисленное переполнение 6 | 6 слишком большое значение символьной константы 7 | 7 вещественное переполнение 8 | 8 переполнение порядка вещественного числа 9 | 9 вещественное антипереполнение 10 | 10 слишком длинный идентификатор 11 | 11 слишком длинная строковая константа 12 | 13 | 21 ожидалось 'MODULE' 14 | 22 ожидался идентификатор 15 | 23 ожидалась ';' 16 | 24 ожидалось 'END' 17 | 25 ожидалась '.' 18 | 26 идентификатор не совпадает с именем модуля 19 | 27 неожиданный конец файла 20 | 28 ожидалась ',', ';' или ':=' 21 | 29 ожидалась ',' или ';' 22 | 30 идентификатор переопределен 23 | 31 циклический импорт 24 | 32 модуль не найден или ошибка доступа 25 | 33 имя модуля не совпадает с именем файла модуля 26 | 34 неправильный формат строки машинных кодов 27 | 35 ожидалось '=' 28 | 36 синтаксическая ошибка в выражении 29 | 37 операция не применима 30 | 38 ожидалась ')' 31 | 39 ожидалoсь 'ARRAY', 'RECORD', 'POINTER' или 'PROCEDURE' 32 | 40 ожидалoсь 'TO' 33 | 41 ожидалoсь 'OF' 34 | 42 неопределенный идентификатор 35 | 43 требуется переменная, процедура или строковая константа 36 | 44 ожидалoсь 'cdecl', 'stdcall' или 'winapi' 37 | 45 флаг вызова недопускается для локальных процедур 38 | 46 деление на нуль 39 | 47 требуется идентификатор типа-записи или типа-указателя 40 | 48 целочисленное деление на нуль 41 | 49 значение левого операнда вне диапазона 0..31 42 | 50 флаг [winapi] доступен только для платформы Windows 43 | 51 ожидалась '}' 44 | 52 требуется выражение типа INTEGER 45 | 53 значение выражения вне диапазона 0..31 46 | 54 левая граница диапазона больше правой 47 | 55 требуется константа типа CHAR 48 | 56 ожидалась '(' 49 | 57 требуется выражение числового типа 50 | 58 не найден файл 'elf' 51 | 59 недостаточно параметров 52 | 60 недопустимый параметр 53 | 61 ожидалась ',' 54 | 62 требуется константное выражение 55 | 63 требуется переменная 56 | 64 файл не найден или ошибка доступа 57 | 65 модуль RTL не найден 58 | 66 требуется выражение типа REAL или LONGREAL 59 | 67 невозможно создать файл, возможно файл открыт или диск защищен от записи 60 | 68 требуется выражение типа CHAR, SET или BOOLEAN 61 | 69 невозможно записать файл 62 | 70 требуется выражение типа LONGREAL 63 | 71 требуется выражение типа REAL 64 | 72 недостаточно памяти для завершения компиляции 65 | 73 процедура не возвращающая результат недопустима в выражениях 66 | 74 значение выражения вне целочисленного диапазона 67 | 75 рекурсивное определение константы 68 | 76 значение выражения вне диапазона 0..255 69 | 77 ожидался идентификатор типа 70 | 78 длина типа-массива должна быть больше нуля 71 | 79 ожидалось 'OF' или ',' 72 | 80 ожидался идентификатор типа-записи 73 | 81 базовый тип типа-указателя должен быть записью 74 | 82 тип результата процедуры не может быть записью или массивом 75 | 83 размер типа слишком велик 76 | 84 ожидался идентификатор или 'VAR' 77 | 85 ожидалась ',' или ':' 78 | 86 ожидалось 'END' или ';' 79 | 87 идентификатор не совпадает с именем процедуры 80 | 88 ошибка чтения файла 'elf' 81 | 89 экспорт локального идентификатора недопустим 82 | 90 экспорт переменных типа ARRAY или RECORD недопустим 83 | 91 экспорт поля записи недопустим вне секции объявления типов 84 | 92 экспорт поля записи недопустим, так как не экспортируется тип записи 85 | 93 размер данных слишком велик 86 | 94 строка длины, отличной от 1 недопустима 87 | 95 значение выражения должно быть в диапазоне 0..127 88 | 96 недопустимое рекурсивное определение типа 89 | 97 недостаточно вещественных регистров, упростите выражение 90 | 98 ожидалось 'THEN' 91 | 99 поле записи не найдено 92 | 100 метка дублирована 93 | 101 идентификатор типа недопустим в выражениях 94 | 102 требуется массив 95 | 103 ожидалoсь 'union' или 'noalign' 96 | 104 требуется указатель 97 | 105 требуется запись 98 | 106 требуется идентификатор типа-записи 99 | 107 требуется идентификатор типа-указателя 100 | 108 недопустимая охрана типа 101 | 109 ожидалась ']' 102 | 110 размерность открытого массива слишком велика 103 | 111 системные флаги требуют импорта модуля SYSTEM 104 | 112 расширение записи не может быть [noalign] или [union] 105 | 113 базовый тип записи не может быть [noalign] или [union] 106 | 114 несовместимый параметр 107 | 115 переменная доступна только для чтения 108 | 116 нельзя использовать локальную процедуру 109 | 117 требуется выражение типа BOOLEAN 110 | 118 ожидалось 'DO' 111 | 119 ожидалось 'UNTIL' 112 | 120 ожидалось ':=' 113 | 121 расширение имени файла главного модуля должно быть "ob07" 114 | 122 значение выражения не должно быть равным нулю 115 | 123 'RETURN' недопустим в процедуре, не возвращающей результат 116 | 124 ожидалось 'RETURN' 117 | 125 тип выражения не соответствует типу результата процедуры 118 | 126 требуется идентификатор переменной 119 | 127 счетчик цикла FOR не должен быть параметром 120 | 128 тип переменной должен быть INTEGER 121 | 129 переменная должна быть локальной 122 | 130 нельзя использовать константу 123 | 131 несовместимость по присваиванию 124 | 132 вызов процедуры-функции допускается только в составе выражения 125 | 133 идентификаторы START и version зарезервированы 126 | 127 | 138 тип переменной должен быть SET 128 | 129 | 141 требуется строка или символьный массив 130 | 131 | 143 требуется символьный массив 132 | 133 | 145 тип переменной должен быть POINTER 134 | 135 | 149 тип переменной должен быть REAL или LONGREAL 136 | 150 требуется строковая константа 137 | 138 | 153 тип выражения должен быть элементарным 139 | 154 тип переменной должен быть элементарным 140 | 155 ожидалось '(' или ':=' 141 | 156 требуется выражение типа INTEGER или CHAR 142 | 157 ожидалось ':' 143 | 158 не найдена процедура в модуле RTL 144 | 159 нарушение границ массива 145 | 160 ожидался идентификатор константы 146 | 161 требуется константа типа INTEGER -------------------------------------------------------------------------------- /Lib/KolibriOS/API.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE API; 19 | 20 | IMPORT sys := SYSTEM; 21 | 22 | CONST 23 | 24 | OS* = "KOS"; 25 | Slash* = "/"; 26 | 27 | MAX_SIZE = 16 * 400H; 28 | HEAP_SIZE = 1 * 100000H; 29 | 30 | TYPE 31 | 32 | FILENAME = ARRAY 2048 OF CHAR; 33 | 34 | OFSTRUCT* = RECORD 35 | subfunc, pos, hpos, bytes, buf: INTEGER; 36 | name: FILENAME 37 | END; 38 | 39 | VAR 40 | 41 | param*, name*, fsize, sec*, dsec*: INTEGER; 42 | 43 | heap, endheap: INTEGER; 44 | pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER; 45 | 46 | CreateFile*: PROCEDURE (p1, p2, p3, p4, p5, p6, p7: INTEGER): INTEGER; 47 | OpenFile*: PROCEDURE (p1: INTEGER; p2: OFSTRUCT; p3: INTEGER): INTEGER; 48 | GetStdHandle*: PROCEDURE (p1: INTEGER): INTEGER; 49 | lnx_CreateFile*: PROCEDURE (FName: ARRAY OF CHAR): INTEGER; 50 | lnx_OpenFile*: PROCEDURE (FName: ARRAY OF CHAR): INTEGER; 51 | 52 | PROCEDURE [stdcall] zeromem*(size, adr: INTEGER); 53 | BEGIN 54 | sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") 55 | END zeromem; 56 | 57 | PROCEDURE strncmp*(a, b, n: INTEGER): INTEGER; 58 | VAR A, B: CHAR; Res: INTEGER; 59 | BEGIN 60 | Res := 0; 61 | WHILE n > 0 DO 62 | sys.GET(a, A); INC(a); 63 | sys.GET(b, B); INC(b); 64 | DEC(n); 65 | IF A # B THEN 66 | Res := ORD(A) - ORD(B); 67 | n := 0 68 | ELSIF A = 0X THEN 69 | n := 0 70 | END 71 | END 72 | RETURN Res 73 | END strncmp; 74 | 75 | PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER; 76 | BEGIN 77 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 78 | sys.CODE("CD40"); (* int 40h *) 79 | sys.CODE("C9"); (* leave *) 80 | sys.CODE("C20400"); (* ret 04h *) 81 | RETURN 0 82 | END sysfunc1; 83 | 84 | PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER; 85 | BEGIN 86 | sys.CODE("53"); (* push ebx *) 87 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 88 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 89 | sys.CODE("CD40"); (* int 40h *) 90 | sys.CODE("5B"); (* pop ebx *) 91 | sys.CODE("C9"); (* leave *) 92 | sys.CODE("C20800"); (* ret 08h *) 93 | RETURN 0 94 | END sysfunc2; 95 | 96 | PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER; 97 | BEGIN 98 | sys.CODE("53"); (* push ebx *) 99 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 100 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 101 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 102 | sys.CODE("CD40"); (* int 40h *) 103 | sys.CODE("5B"); (* pop ebx *) 104 | sys.CODE("C9"); (* leave *) 105 | sys.CODE("C20C00"); (* ret 0Ch *) 106 | RETURN 0 107 | END sysfunc3; 108 | 109 | PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; 110 | BEGIN 111 | sys.CODE("53"); (* push ebx *) 112 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 113 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 114 | sys.CODE("CD40"); (* int 40h *) 115 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 116 | sys.CODE("8919"); (* mov [ecx], ebx *) 117 | sys.CODE("5B"); (* pop ebx *) 118 | sys.CODE("C9"); (* leave *) 119 | sys.CODE("C20C00"); (* ret 0Ch *) 120 | RETURN 0 121 | END sysfunc22; 122 | 123 | PROCEDURE _NEW*(size: INTEGER): INTEGER; 124 | VAR res, idx, temp: INTEGER; 125 | BEGIN 126 | IF size <= MAX_SIZE THEN 127 | idx := ASR(size, 5); 128 | res := pockets[idx]; 129 | IF res # 0 THEN 130 | sys.GET(res, pockets[idx]); 131 | sys.PUT(res, size); 132 | INC(res, 4) 133 | ELSE 134 | IF heap + size >= endheap THEN 135 | IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN 136 | heap := sysfunc3(68, 12, HEAP_SIZE); 137 | endheap := heap + HEAP_SIZE 138 | ELSE 139 | heap := 0 140 | END 141 | END; 142 | IF heap # 0 THEN 143 | sys.PUT(heap, size); 144 | res := heap + 4; 145 | heap := heap + size 146 | ELSE 147 | endheap := 0; 148 | res := 0 149 | END 150 | END 151 | ELSE 152 | IF sysfunc2(18, 16) > ASR(size, 10) THEN 153 | res := sysfunc3(68, 12, size); 154 | sys.PUT(res, size); 155 | INC(res, 4) 156 | ELSE 157 | res := 0 158 | END 159 | END; 160 | IF res # 0 THEN 161 | zeromem(ASR(size, 2) - 1, res) 162 | END 163 | RETURN res 164 | END _NEW; 165 | 166 | PROCEDURE _DISPOSE*(ptr: INTEGER): INTEGER; 167 | VAR size, idx: INTEGER; 168 | BEGIN 169 | DEC(ptr, 4); 170 | sys.GET(ptr, size); 171 | IF size <= MAX_SIZE THEN 172 | idx := ASR(size, 5); 173 | sys.PUT(ptr, pockets[idx]); 174 | pockets[idx] := ptr 175 | ELSE 176 | size := sysfunc3(68, 13, ptr) 177 | END 178 | RETURN 0 179 | END _DISPOSE; 180 | 181 | PROCEDURE Alloc*(flags, size: INTEGER): INTEGER; 182 | RETURN sysfunc3(68, 12, size) 183 | END Alloc; 184 | 185 | PROCEDURE Free*(ptr: INTEGER): INTEGER; 186 | BEGIN 187 | ptr := sysfunc3(68, 13, ptr) 188 | RETURN 0 189 | END Free; 190 | 191 | PROCEDURE OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER; 192 | VAR buf: ARRAY 40 OF CHAR; res: INTEGER; 193 | BEGIN 194 | FS.subfunc := mode; 195 | FS.pos := 0; 196 | FS.hpos := 0; 197 | FS.bytes := 0; 198 | FS.buf := sys.ADR(buf); 199 | COPY(FileName, FS.name); 200 | IF sysfunc22(70, sys.ADR(FS), res) = 0 THEN 201 | res := sys.ADR(FS); 202 | sys.GET(sys.ADR(buf) + 32, fsize) 203 | ELSE 204 | res := 0 205 | END 206 | RETURN res 207 | END OCFile; 208 | 209 | PROCEDURE FileSize*(F: INTEGER): INTEGER; 210 | RETURN fsize 211 | END FileSize; 212 | 213 | PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER; 214 | VAR res1, res: INTEGER; 215 | BEGIN 216 | FS.subfunc := io; 217 | FS.bytes := bytes; 218 | FS.buf := Buffer; 219 | res1 := sysfunc22(70, sys.ADR(FS), res); 220 | IF res = -1 THEN 221 | res := 0 222 | END; 223 | FS.pos := FS.pos + res 224 | RETURN res 225 | END IOFile; 226 | 227 | PROCEDURE kos_OCFile*(FName: ARRAY OF CHAR; mode: INTEGER; VAR memerr: BOOLEAN): INTEGER; 228 | VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER; 229 | BEGIN 230 | memerr := FALSE; 231 | IF OCFile(FName, FS, mode, fsize) # 0 THEN 232 | NEW(pFS); 233 | IF pFS = NIL THEN 234 | memerr := TRUE; 235 | res := 0 236 | ELSE 237 | sys.GET(sys.ADR(pFS), res); 238 | pFS^ := FS 239 | END 240 | ELSE 241 | res := 0 242 | END 243 | RETURN res 244 | END kos_OCFile; 245 | 246 | PROCEDURE ReadFile*(hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER); 247 | VAR pFS: POINTER TO OFSTRUCT; res: INTEGER; 248 | BEGIN 249 | IF hFile # 0 THEN 250 | sys.PUT(sys.ADR(pFS), hFile); 251 | res := IOFile(pFS^, Buffer, nNumberOfBytesToRead, 0) 252 | ELSE 253 | res := 0 254 | END; 255 | sys.PUT(lpNumberOfBytesRead, res) 256 | END ReadFile; 257 | 258 | PROCEDURE WriteFile*(hFile, Buffer, nNumberOfBytesToWrite, lpNumberOfBytesWritten, lpOverlapped: INTEGER); 259 | VAR pFS: POINTER TO OFSTRUCT; res: INTEGER; 260 | BEGIN 261 | IF hFile # 0 THEN 262 | sys.PUT(sys.ADR(pFS), hFile); 263 | res := IOFile(pFS^, Buffer, nNumberOfBytesToWrite, 3) 264 | ELSE 265 | res := 0 266 | END; 267 | sys.PUT(lpNumberOfBytesWritten, res) 268 | END WriteFile; 269 | 270 | PROCEDURE CloseHandle*(hObject: INTEGER); 271 | VAR pFS: POINTER TO OFSTRUCT; 272 | BEGIN 273 | sys.PUT(sys.ADR(pFS), hObject); 274 | DISPOSE(pFS) 275 | END CloseHandle; 276 | 277 | PROCEDURE ExitProcess*(p1: INTEGER); 278 | BEGIN 279 | p1 := sysfunc1(-1) 280 | END ExitProcess; 281 | 282 | PROCEDURE GetCommandLine*(): INTEGER; 283 | RETURN param 284 | END GetCommandLine; 285 | 286 | PROCEDURE GetName*(): INTEGER; 287 | RETURN name 288 | END GetName; 289 | 290 | PROCEDURE OutChar(c: CHAR); 291 | VAR res: INTEGER; 292 | BEGIN 293 | res := sysfunc3(63, 1, ORD(c)) 294 | END OutChar; 295 | 296 | PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER); 297 | VAR c: CHAR; 298 | BEGIN 299 | IF lpCaption # 0 THEN 300 | OutChar(0DX); 301 | OutChar(0AX); 302 | REPEAT 303 | sys.GET(lpCaption, c); 304 | IF c # 0X THEN 305 | OutChar(c) 306 | END; 307 | INC(lpCaption) 308 | UNTIL c = 0X; 309 | OutChar(":"); 310 | OutChar(0DX); 311 | OutChar(0AX) 312 | END; 313 | REPEAT 314 | sys.GET(lpText, c); 315 | IF c # 0X THEN 316 | OutChar(c) 317 | END; 318 | INC(lpText) 319 | UNTIL c = 0X; 320 | IF lpCaption # 0 THEN 321 | OutChar(0DX); 322 | OutChar(0AX) 323 | END 324 | END DebugMsg; 325 | 326 | PROCEDURE Time*(VAR sec, dsec: INTEGER); 327 | VAR t: INTEGER; 328 | BEGIN 329 | t := sysfunc2(26, 9); 330 | sec := t DIV 100; 331 | dsec := t MOD 100 332 | END Time; 333 | 334 | PROCEDURE init* (p1: INTEGER); 335 | VAR p: INTEGER; 336 | BEGIN 337 | p := sysfunc2(68, 11); 338 | Time(sec, dsec); 339 | sys.GET(28, param); 340 | sys.GET(32, name) 341 | END init; 342 | 343 | END API. -------------------------------------------------------------------------------- /Lib/KolibriOS/Console.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Console; 19 | 20 | IMPORT ConsoleLib; 21 | 22 | CONST 23 | 24 | Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3; 25 | Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7; 26 | DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11; 27 | LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15; 28 | 29 | PROCEDURE SetCursor*(X, Y: INTEGER); 30 | BEGIN 31 | ConsoleLib.set_cursor_pos(X, Y) 32 | END SetCursor; 33 | 34 | PROCEDURE GetCursor*(VAR X, Y: INTEGER); 35 | BEGIN 36 | ConsoleLib.get_cursor_pos(X, Y) 37 | END GetCursor; 38 | 39 | PROCEDURE Cls*; 40 | BEGIN 41 | ConsoleLib.cls 42 | END Cls; 43 | 44 | PROCEDURE SetColor*(FColor, BColor: INTEGER); 45 | VAR res: INTEGER; 46 | BEGIN 47 | IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN 48 | res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor) 49 | END 50 | END SetColor; 51 | 52 | PROCEDURE GetCursorX*(): INTEGER; 53 | VAR x, y: INTEGER; 54 | BEGIN 55 | ConsoleLib.get_cursor_pos(x, y) 56 | RETURN x 57 | END GetCursorX; 58 | 59 | PROCEDURE GetCursorY*(): INTEGER; 60 | VAR x, y: INTEGER; 61 | BEGIN 62 | ConsoleLib.get_cursor_pos(x, y) 63 | RETURN y 64 | END GetCursorY; 65 | 66 | END Console. 67 | -------------------------------------------------------------------------------- /Lib/KolibriOS/ConsoleLib.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE ConsoleLib; 19 | 20 | IMPORT sys := SYSTEM, KOSAPI; 21 | 22 | CONST 23 | 24 | COLOR_BLUE* = 001H; 25 | COLOR_GREEN* = 002H; 26 | COLOR_RED* = 004H; 27 | COLOR_BRIGHT* = 008H; 28 | BGR_BLUE* = 010H; 29 | BGR_GREEN* = 020H; 30 | BGR_RED* = 040H; 31 | BGR_BRIGHT* = 080H; 32 | IGNORE_SPECIALS* = 100H; 33 | WINDOW_CLOSED* = 200H; 34 | 35 | TYPE 36 | 37 | gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER); 38 | 39 | VAR 40 | 41 | version* : INTEGER; 42 | init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER); 43 | exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN); 44 | write_asciiz* : PROCEDURE [stdcall] (string: INTEGER); 45 | write_string* : PROCEDURE [stdcall] (string, length: INTEGER); 46 | get_flags* : PROCEDURE [stdcall] (): INTEGER; 47 | set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER; 48 | get_font_height* : PROCEDURE [stdcall] (): INTEGER; 49 | get_cursor_height* : PROCEDURE [stdcall] (): INTEGER; 50 | set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER; 51 | getch* : PROCEDURE [stdcall] (): INTEGER; 52 | getch2* : PROCEDURE [stdcall] (): INTEGER; 53 | kbhit* : PROCEDURE [stdcall] (): INTEGER; 54 | gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER; 55 | gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER; 56 | cls* : PROCEDURE [stdcall] (); 57 | get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER); 58 | set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER); 59 | 60 | PROCEDURE Open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR); 61 | BEGIN 62 | init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0])) 63 | END Open; 64 | 65 | PROCEDURE main; 66 | VAR Lib: INTEGER; 67 | 68 | PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR); 69 | VAR a: INTEGER; 70 | BEGIN 71 | a := KOSAPI.GetProcAdr(name, Lib); 72 | ASSERT(a # 0); 73 | sys.PUT(v, a) 74 | END GetProc; 75 | 76 | BEGIN 77 | Lib := KOSAPI.LoadLib("/rd/1/Lib/Console.obj"); 78 | ASSERT(Lib # 0); 79 | GetProc(sys.ADR(version), "version"); 80 | GetProc(sys.ADR(init), "con_init"); 81 | GetProc(sys.ADR(exit), "con_exit"); 82 | GetProc(sys.ADR(write_asciiz), "con_write_asciiz"); 83 | GetProc(sys.ADR(write_string), "con_write_string"); 84 | GetProc(sys.ADR(get_flags), "con_get_flags"); 85 | GetProc(sys.ADR(set_flags), "con_set_flags"); 86 | GetProc(sys.ADR(get_font_height), "con_get_font_height"); 87 | GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height"); 88 | GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height"); 89 | GetProc(sys.ADR(getch), "con_getch"); 90 | GetProc(sys.ADR(getch2), "con_getch2"); 91 | GetProc(sys.ADR(kbhit), "con_kbhit"); 92 | GetProc(sys.ADR(gets), "con_gets"); 93 | GetProc(sys.ADR(gets2), "con_gets2"); 94 | GetProc(sys.ADR(cls), "con_cls"); 95 | GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos"); 96 | GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos"); 97 | END main; 98 | 99 | BEGIN 100 | main 101 | END ConsoleLib. -------------------------------------------------------------------------------- /Lib/KolibriOS/DateTime.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE DateTime; 19 | 20 | IMPORT sys := SYSTEM, KOSAPI; 21 | 22 | CONST ERR* = -7.0D5; 23 | 24 | PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL; 25 | VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL; 26 | BEGIN 27 | Res := ERR; 28 | IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) & 29 | (Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) & 30 | (Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) THEN 31 | M := "_303232332323"; 32 | IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN 33 | M[2] := "1" 34 | END; 35 | IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN 36 | DEC(Year); 37 | d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594; 38 | FOR i := 1 TO Month - 1 DO 39 | d := d + ORD(M[i]) - ORD("0") + 28 40 | END; 41 | Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0 42 | END 43 | END 44 | RETURN Res 45 | END Encode; 46 | 47 | PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN; 48 | VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR; 49 | 50 | PROCEDURE MonthDay(n: INTEGER): BOOLEAN; 51 | VAR Res: BOOLEAN; 52 | BEGIN 53 | Res := FALSE; 54 | IF d > ORD(M[n]) - ORD("0") + 28 THEN 55 | d := d - ORD(M[n]) + ORD("0") - 28; 56 | INC(Month); 57 | Res := TRUE 58 | END 59 | RETURN Res 60 | END MonthDay; 61 | 62 | BEGIN 63 | IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN 64 | d := FLOOR(Date); 65 | t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0); 66 | d := d + 693593; 67 | Year := 1; 68 | Month := 1; 69 | WHILE d > 0 DO 70 | d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)); 71 | INC(Year) 72 | END; 73 | IF d < 0 THEN 74 | DEC(Year); 75 | d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)) 76 | END; 77 | INC(d); 78 | M := "_303232332323"; 79 | IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN 80 | M[2] := "1" 81 | END; 82 | i := 1; 83 | flag := TRUE; 84 | WHILE flag & (i <= 12) DO 85 | flag := MonthDay(i); 86 | INC(i) 87 | END; 88 | Day := d; 89 | Hour := t DIV 3600000; 90 | t := t MOD 3600000; 91 | Min := t DIV 60000; 92 | t := t MOD 60000; 93 | Sec := t DIV 1000; 94 | Res := TRUE 95 | ELSE 96 | Res := FALSE 97 | END 98 | RETURN Res 99 | END Decode; 100 | 101 | PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER); 102 | VAR date, time: INTEGER; 103 | BEGIN 104 | date := KOSAPI.sysfunc1(29); 105 | time := KOSAPI.sysfunc1(3); 106 | 107 | Year := date MOD 16; 108 | date := date DIV 16; 109 | Year := (date MOD 16) * 10 + Year; 110 | date := date DIV 16; 111 | 112 | Month := date MOD 16; 113 | date := date DIV 16; 114 | Month := (date MOD 16) * 10 + Month; 115 | date := date DIV 16; 116 | 117 | Day := date MOD 16; 118 | date := date DIV 16; 119 | Day := (date MOD 16) * 10 + Day; 120 | date := date DIV 16; 121 | 122 | Hour := time MOD 16; 123 | time := time DIV 16; 124 | Hour := (time MOD 16) * 10 + Hour; 125 | time := time DIV 16; 126 | 127 | Min := time MOD 16; 128 | time := time DIV 16; 129 | Min := (time MOD 16) * 10 + Min; 130 | time := time DIV 16; 131 | 132 | Sec := time MOD 16; 133 | time := time DIV 16; 134 | Sec := (time MOD 16) * 10 + Sec; 135 | time := time DIV 16; 136 | 137 | Year := Year + 2000 138 | END Now; 139 | 140 | END DateTime. -------------------------------------------------------------------------------- /Lib/KolibriOS/Dir.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Dir; 19 | 20 | IMPORT FSys, sys := SYSTEM, KOSAPI; 21 | 22 | VAR fd: FSys.rFD; 23 | 24 | PROCEDURE Exists*(FName: ARRAY OF CHAR): BOOLEAN; 25 | BEGIN 26 | RETURN FSys.GetFileInfo(FName, fd) & (4 IN BITS(fd.attr)) 27 | END Exists; 28 | 29 | PROCEDURE Create*(DirName: ARRAY OF CHAR): BOOLEAN; 30 | VAR F: FSys.FS; res, res2: INTEGER; 31 | BEGIN 32 | NEW(F); 33 | IF F # NIL THEN 34 | F.subfunc := 9; 35 | F.pos := 0; 36 | F.hpos := 0; 37 | F.bytes := 0; 38 | F.buffer := 0; 39 | COPY(DirName, F.name); 40 | res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); 41 | DISPOSE(F) 42 | ELSE 43 | res := -1 44 | END 45 | RETURN res = 0 46 | END Create; 47 | 48 | PROCEDURE Remove*(DirName: ARRAY OF CHAR): BOOLEAN; 49 | VAR F: FSys.FS; res, res2: INTEGER; 50 | BEGIN 51 | IF Exists(DirName) THEN 52 | NEW(F); 53 | IF F # NIL THEN 54 | F.subfunc := 8; 55 | F.pos := 0; 56 | F.hpos := 0; 57 | F.bytes := 0; 58 | F.buffer := 0; 59 | COPY(DirName, F.name); 60 | res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); 61 | DISPOSE(F) 62 | ELSE 63 | res := -1 64 | END 65 | ELSE 66 | res := -1 67 | END 68 | RETURN res = 0 69 | END Remove; 70 | 71 | END Dir. -------------------------------------------------------------------------------- /Lib/KolibriOS/FSys.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE FSys; 19 | 20 | IMPORT sys := SYSTEM, KOSAPI; 21 | 22 | TYPE 23 | 24 | FNAME* = ARRAY 520 OF CHAR; 25 | 26 | FS* = POINTER TO rFS; 27 | 28 | rFS* = RECORD 29 | subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER; 30 | name*: FNAME 31 | END; 32 | 33 | FD* = POINTER TO rFD; 34 | 35 | rFD* = RECORD 36 | attr*: INTEGER; 37 | ntyp*: CHAR; 38 | reserved: ARRAY 3 OF CHAR; 39 | time_create*, date_create*, 40 | time_access*, date_access*, 41 | time_modif*, date_modif*, 42 | size*, hsize*: INTEGER; 43 | name*: FNAME 44 | END; 45 | 46 | VAR fs: rFS; 47 | 48 | PROCEDURE GetFileInfo*(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN; 49 | VAR res2: INTEGER; 50 | BEGIN 51 | fs.subfunc := 5; 52 | fs.pos := 0; 53 | fs.hpos := 0; 54 | fs.bytes := 0; 55 | fs.buffer := sys.ADR(Info); 56 | COPY(FName, fs.name) 57 | RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0 58 | END GetFileInfo; 59 | 60 | END FSys. -------------------------------------------------------------------------------- /Lib/KolibriOS/File.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE File; 19 | 20 | IMPORT FSys, sys := SYSTEM, KOSAPI; 21 | 22 | CONST 23 | 24 | SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2; 25 | 26 | VAR fd: FSys.rFD; fs: FSys.rFS; 27 | 28 | PROCEDURE Exists*(FName: ARRAY OF CHAR): BOOLEAN; 29 | BEGIN 30 | RETURN FSys.GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr)) 31 | END Exists; 32 | 33 | PROCEDURE Close*(VAR F: FSys.FS); 34 | BEGIN 35 | IF F # NIL THEN 36 | DISPOSE(F) 37 | END 38 | END Close; 39 | 40 | PROCEDURE Open*(FName: ARRAY OF CHAR): FSys.FS; 41 | VAR F: FSys.FS; 42 | BEGIN 43 | IF Exists(FName) THEN 44 | NEW(F); 45 | IF F # NIL THEN 46 | F.subfunc := 0; 47 | F.pos := 0; 48 | F.hpos := 0; 49 | F.bytes := 0; 50 | F.buffer := 0; 51 | COPY(FName, F.name) 52 | END 53 | ELSE 54 | F := NIL 55 | END 56 | RETURN F 57 | END Open; 58 | 59 | PROCEDURE Delete*(FName: ARRAY OF CHAR): BOOLEAN; 60 | VAR F: FSys.FS; res, res2: INTEGER; 61 | BEGIN 62 | IF Exists(FName) THEN 63 | NEW(F); 64 | IF F # NIL THEN 65 | F.subfunc := 8; 66 | F.pos := 0; 67 | F.hpos := 0; 68 | F.bytes := 0; 69 | F.buffer := 0; 70 | COPY(FName, F.name); 71 | res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); 72 | DISPOSE(F) 73 | ELSE 74 | res := -1 75 | END 76 | ELSE 77 | res := -1 78 | END 79 | RETURN res = 0 80 | END Delete; 81 | 82 | PROCEDURE Seek*(F: FSys.FS; Offset, Origin: INTEGER): INTEGER; 83 | VAR res: INTEGER; 84 | BEGIN 85 | IF (F # NIL) & FSys.GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN 86 | CASE Origin OF 87 | |SEEK_BEG: F.pos := Offset 88 | |SEEK_CUR: F.pos := F.pos + Offset 89 | |SEEK_END: F.pos := fd.size + Offset 90 | ELSE 91 | END; 92 | res := F.pos 93 | ELSE 94 | res := -1 95 | END 96 | RETURN res 97 | END Seek; 98 | 99 | PROCEDURE Read*(F: FSys.FS; Buffer, Count: INTEGER): INTEGER; 100 | VAR res, res2: INTEGER; 101 | BEGIN 102 | IF F # NIL THEN 103 | F.subfunc := 0; 104 | F.bytes := Count; 105 | F.buffer := Buffer; 106 | res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); 107 | IF res2 > 0 THEN 108 | F.pos := F.pos + res2 109 | END 110 | ELSE 111 | res2 := 0 112 | END 113 | RETURN res2 114 | END Read; 115 | 116 | PROCEDURE Write*(F: FSys.FS; Buffer, Count: INTEGER): INTEGER; 117 | VAR res, res2: INTEGER; 118 | BEGIN 119 | IF F # NIL THEN 120 | F.subfunc := 3; 121 | F.bytes := Count; 122 | F.buffer := Buffer; 123 | res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); 124 | IF res2 > 0 THEN 125 | F.pos := F.pos + res2 126 | END 127 | ELSE 128 | res2 := 0 129 | END 130 | RETURN res2 131 | END Write; 132 | 133 | PROCEDURE Create*(FName: ARRAY OF CHAR): FSys.FS; 134 | VAR F: FSys.FS; res2: INTEGER; 135 | BEGIN 136 | NEW(F); 137 | IF F # NIL THEN 138 | F.subfunc := 2; 139 | F.pos := 0; 140 | F.hpos := 0; 141 | F.bytes := 0; 142 | F.buffer := 0; 143 | COPY(FName, F.name); 144 | IF KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN 145 | DISPOSE(F) 146 | END 147 | END 148 | RETURN F 149 | END Create; 150 | 151 | END File. -------------------------------------------------------------------------------- /Lib/KolibriOS/In.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE In; 19 | 20 | IMPORT sys := SYSTEM, ConsoleLib; 21 | 22 | TYPE 23 | 24 | STRING = ARRAY 260 OF CHAR; 25 | 26 | VAR 27 | 28 | Done* : BOOLEAN; 29 | 30 | PROCEDURE digit(ch: CHAR): BOOLEAN; 31 | RETURN (ch >= "0") & (ch <= "9") 32 | END digit; 33 | 34 | PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN; 35 | VAR i: INTEGER; 36 | BEGIN 37 | i := 0; 38 | neg := FALSE; 39 | WHILE (s[i] <= 20X) & (s[i] # 0X) DO 40 | INC(i) 41 | END; 42 | IF s[i] = "-" THEN 43 | neg := TRUE; 44 | INC(i) 45 | ELSIF s[i] = "+" THEN 46 | INC(i) 47 | END; 48 | first := i; 49 | WHILE digit(s[i]) DO 50 | INC(i) 51 | END; 52 | last := i 53 | RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first]) 54 | END CheckInt; 55 | 56 | PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN; 57 | VAR i: INTEGER; min: STRING; 58 | BEGIN 59 | i := 0; 60 | min := "2147483648"; 61 | WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO 62 | INC(i) 63 | END 64 | RETURN i = 10 65 | END IsMinInt; 66 | 67 | PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER; 68 | CONST maxINT = 7FFFFFFFH; 69 | VAR i, n, res: INTEGER; flag, neg: BOOLEAN; 70 | BEGIN 71 | res := 0; 72 | flag := CheckInt(str, i, n, neg, FALSE); 73 | err := ~flag; 74 | IF flag & neg & IsMinInt(str, i) THEN 75 | flag := FALSE; 76 | neg := FALSE; 77 | res := 80000000H 78 | END; 79 | WHILE flag & digit(str[i]) DO 80 | IF res > maxINT DIV 10 THEN 81 | err := TRUE; 82 | flag := FALSE; 83 | res := 0 84 | ELSE 85 | res := res * 10; 86 | IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN 87 | err := TRUE; 88 | flag := FALSE; 89 | res := 0 90 | ELSE 91 | res := res + (ORD(str[i]) - ORD("0")); 92 | INC(i) 93 | END 94 | END 95 | END; 96 | IF neg THEN 97 | res := -res 98 | END 99 | RETURN res 100 | END StrToInt; 101 | 102 | PROCEDURE Space(s: STRING): BOOLEAN; 103 | VAR i: INTEGER; 104 | BEGIN 105 | i := 0; 106 | WHILE (s[i] # 0X) & (s[i] <= 20X) DO 107 | INC(i) 108 | END 109 | RETURN s[i] = 0X 110 | END Space; 111 | 112 | PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN; 113 | VAR i: INTEGER; Res: BOOLEAN; 114 | BEGIN 115 | Res := CheckInt(s, n, i, neg, TRUE); 116 | IF Res THEN 117 | IF s[i] = "." THEN 118 | INC(i); 119 | WHILE digit(s[i]) DO 120 | INC(i) 121 | END; 122 | IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN 123 | INC(i); 124 | IF (s[i] = "+") OR (s[i] = "-") THEN 125 | INC(i) 126 | END; 127 | Res := digit(s[i]); 128 | WHILE digit(s[i]) DO 129 | INC(i) 130 | END 131 | END 132 | END 133 | END 134 | RETURN Res & (s[i] <= 20X) 135 | END CheckReal; 136 | 137 | PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): LONGREAL; 138 | CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH; 139 | VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN; 140 | 141 | PROCEDURE part1(): BOOLEAN; 142 | BEGIN 143 | res := 0.0D0; 144 | d := 1.0D0; 145 | WHILE digit(str[i]) DO 146 | res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0"))); 147 | INC(i) 148 | END; 149 | IF str[i] = "." THEN 150 | INC(i); 151 | WHILE digit(str[i]) DO 152 | d := d / 10.0D0; 153 | res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d; 154 | INC(i) 155 | END 156 | END 157 | RETURN str[i] # 0X 158 | END part1; 159 | 160 | PROCEDURE part2(): BOOLEAN; 161 | BEGIN 162 | INC(i); 163 | m := 10.0D0; 164 | minus := FALSE; 165 | IF str[i] = "+" THEN 166 | INC(i) 167 | ELSIF str[i] = "-" THEN 168 | minus := TRUE; 169 | INC(i); 170 | m := 0.1D0 171 | END; 172 | scale := 0; 173 | err := FALSE; 174 | WHILE ~err & digit(str[i]) DO 175 | IF scale > maxINT DIV 10 THEN 176 | err := TRUE; 177 | res := 0.0D0 178 | ELSE 179 | scale := scale * 10; 180 | IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN 181 | err := TRUE; 182 | res := 0.0D0 183 | ELSE 184 | scale := scale + (ORD(str[i]) - ORD("0")); 185 | INC(i) 186 | END 187 | END 188 | END 189 | RETURN ~err 190 | END part2; 191 | 192 | PROCEDURE part3; 193 | VAR i: INTEGER; 194 | BEGIN 195 | err := FALSE; 196 | IF scale = maxINT THEN 197 | err := TRUE; 198 | res := 0.0D0 199 | END; 200 | i := 1; 201 | WHILE ~err & (i <= scale) DO 202 | IF ~minus & (res > maxDBL / m) THEN 203 | err := TRUE; 204 | res := 0.0D0 205 | ELSE 206 | res := res * m; 207 | INC(i) 208 | END 209 | END 210 | END part3; 211 | 212 | BEGIN 213 | IF CheckReal(str, i, neg) THEN 214 | IF part1() & part2() THEN 215 | part3 216 | END; 217 | IF neg THEN 218 | res := -res 219 | END 220 | ELSE 221 | res := 0.0D0; 222 | err := TRUE 223 | END 224 | RETURN res 225 | END StrToFloat; 226 | 227 | PROCEDURE String*(VAR s: ARRAY OF CHAR); 228 | VAR res, length: INTEGER; str: STRING; 229 | BEGIN 230 | res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str)); 231 | length := LENGTH(str); 232 | IF length > 0 THEN 233 | str[length - 1] := 0X 234 | END; 235 | COPY(str, s); 236 | Done := TRUE 237 | END String; 238 | 239 | PROCEDURE Char*(VAR x: CHAR); 240 | VAR str: STRING; 241 | BEGIN 242 | String(str); 243 | x := str[0]; 244 | Done := TRUE 245 | END Char; 246 | 247 | PROCEDURE Ln*; 248 | VAR str: STRING; 249 | BEGIN 250 | String(str); 251 | Done := TRUE 252 | END Ln; 253 | 254 | PROCEDURE LongReal*(VAR x: LONGREAL); 255 | VAR str: STRING; err: BOOLEAN; 256 | BEGIN 257 | err := FALSE; 258 | REPEAT 259 | String(str) 260 | UNTIL ~Space(str); 261 | x := StrToFloat(str, err); 262 | Done := ~err 263 | END LongReal; 264 | 265 | PROCEDURE Real*(VAR x: REAL); 266 | CONST maxREAL = 3.39E38; 267 | VAR y: LONGREAL; 268 | BEGIN 269 | LongReal(y); 270 | IF Done THEN 271 | IF ABS(y) > LONG(maxREAL) THEN 272 | x := 0.0; 273 | Done := FALSE 274 | ELSE 275 | x := SHORT(y) 276 | END 277 | END 278 | END Real; 279 | 280 | PROCEDURE Int*(VAR x: INTEGER); 281 | VAR str: STRING; err: BOOLEAN; 282 | BEGIN 283 | err := FALSE; 284 | REPEAT 285 | String(str) 286 | UNTIL ~Space(str); 287 | x := StrToInt(str, err); 288 | Done := ~err 289 | END Int; 290 | 291 | PROCEDURE Open*; 292 | BEGIN 293 | Done := TRUE 294 | END Open; 295 | 296 | END In. 297 | -------------------------------------------------------------------------------- /Lib/KolibriOS/KOSAPI.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE KOSAPI; 19 | 20 | IMPORT sys := SYSTEM, API; 21 | 22 | PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER; 23 | BEGIN 24 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 25 | sys.CODE("CD40"); (* int 40h *) 26 | sys.CODE("C9"); (* leave *) 27 | sys.CODE("C20400"); (* ret 04h *) 28 | RETURN 0 29 | END sysfunc1; 30 | 31 | PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER; 32 | BEGIN 33 | sys.CODE("53"); (* push ebx *) 34 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 35 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 36 | sys.CODE("CD40"); (* int 40h *) 37 | sys.CODE("5B"); (* pop ebx *) 38 | sys.CODE("C9"); (* leave *) 39 | sys.CODE("C20800"); (* ret 08h *) 40 | RETURN 0 41 | END sysfunc2; 42 | 43 | PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER; 44 | BEGIN 45 | sys.CODE("53"); (* push ebx *) 46 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 47 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 48 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 49 | sys.CODE("CD40"); (* int 40h *) 50 | sys.CODE("5B"); (* pop ebx *) 51 | sys.CODE("C9"); (* leave *) 52 | sys.CODE("C20C00"); (* ret 0Ch *) 53 | RETURN 0 54 | END sysfunc3; 55 | 56 | PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER; 57 | BEGIN 58 | sys.CODE("53"); (* push ebx *) 59 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 60 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 61 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 62 | sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) 63 | sys.CODE("CD40"); (* int 40h *) 64 | sys.CODE("5B"); (* pop ebx *) 65 | sys.CODE("C9"); (* leave *) 66 | sys.CODE("C21000"); (* ret 10h *) 67 | RETURN 0 68 | END sysfunc4; 69 | 70 | PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER; 71 | BEGIN 72 | sys.CODE("53"); (* push ebx *) 73 | sys.CODE("56"); (* push esi *) 74 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 75 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 76 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 77 | sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) 78 | sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) 79 | sys.CODE("CD40"); (* int 40h *) 80 | sys.CODE("5E"); (* pop esi *) 81 | sys.CODE("5B"); (* pop ebx *) 82 | sys.CODE("C9"); (* leave *) 83 | sys.CODE("C21400"); (* ret 14h *) 84 | RETURN 0 85 | END sysfunc5; 86 | 87 | PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER; 88 | BEGIN 89 | sys.CODE("53"); (* push ebx *) 90 | sys.CODE("56"); (* push esi *) 91 | sys.CODE("57"); (* push edi *) 92 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 93 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 94 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 95 | sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) 96 | sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) 97 | sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *) 98 | sys.CODE("CD40"); (* int 40h *) 99 | sys.CODE("5F"); (* pop edi *) 100 | sys.CODE("5E"); (* pop esi *) 101 | sys.CODE("5B"); (* pop ebx *) 102 | sys.CODE("C9"); (* leave *) 103 | sys.CODE("C21800"); (* ret 18h *) 104 | RETURN 0 105 | END sysfunc6; 106 | 107 | PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER; 108 | BEGIN 109 | sys.CODE("53"); (* push ebx *) 110 | sys.CODE("56"); (* push esi *) 111 | sys.CODE("57"); (* push edi *) 112 | sys.CODE("55"); (* push ebp *) 113 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 114 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 115 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 116 | sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) 117 | sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) 118 | sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *) 119 | sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *) 120 | sys.CODE("CD40"); (* int 40h *) 121 | sys.CODE("5D"); (* pop ebp *) 122 | sys.CODE("5F"); (* pop edi *) 123 | sys.CODE("5E"); (* pop esi *) 124 | sys.CODE("5B"); (* pop ebx *) 125 | sys.CODE("C9"); (* leave *) 126 | sys.CODE("C21C00"); (* ret 1Ch *) 127 | RETURN 0 128 | END sysfunc7; 129 | 130 | PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; 131 | BEGIN 132 | sys.CODE("53"); (* push ebx *) 133 | sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) 134 | sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) 135 | sys.CODE("CD40"); (* int 40h *) 136 | sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) 137 | sys.CODE("8919"); (* mov [ecx], ebx *) 138 | sys.CODE("5B"); (* pop ebx *) 139 | sys.CODE("C9"); (* leave *) 140 | sys.CODE("C20C00"); (* ret 0Ch *) 141 | RETURN 0 142 | END sysfunc22; 143 | 144 | PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER; 145 | RETURN sysfunc3(68, 19, sys.ADR(name[0])) 146 | END LoadLib; 147 | 148 | PROCEDURE GetProcAdr*(name: ARRAY OF CHAR; lib: INTEGER): INTEGER; 149 | VAR cur, procname, adr: INTEGER; 150 | 151 | PROCEDURE streq(str1, str2: INTEGER): BOOLEAN; 152 | VAR c1, c2: CHAR; 153 | BEGIN 154 | REPEAT 155 | sys.GET(str1, c1); 156 | sys.GET(str2, c2); 157 | INC(str1); 158 | INC(str2) 159 | UNTIL (c1 # c2) OR (c1 = 0X) 160 | RETURN c1 = c2 161 | END streq; 162 | 163 | BEGIN 164 | cur := lib; 165 | REPEAT 166 | sys.GET(cur, procname); 167 | INC(cur, 8) 168 | UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0])); 169 | IF procname # 0 THEN 170 | sys.GET(cur - 4, adr) 171 | ELSE 172 | adr := 0 173 | END 174 | RETURN adr 175 | END GetProcAdr; 176 | 177 | PROCEDURE GetCommandLine*(): INTEGER; 178 | RETURN API.param 179 | END GetCommandLine; 180 | 181 | PROCEDURE GetName*(): INTEGER; 182 | RETURN API.name 183 | END GetName; 184 | 185 | END KOSAPI. -------------------------------------------------------------------------------- /Lib/KolibriOS/Math.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Math; 19 | 20 | IMPORT sys := SYSTEM; 21 | 22 | CONST pi* = 3.141592653589793D+00; 23 | e* = 2.718281828459045D+00; 24 | 25 | VAR INF*, negINF*: LONGREAL; 26 | 27 | PROCEDURE IsNan*(x: LONGREAL): BOOLEAN; 28 | VAR h, l: SET; 29 | BEGIN 30 | sys.GET(sys.ADR(x), l); 31 | sys.GET(sys.ADR(x) + 4, h); 32 | RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) 33 | END IsNan; 34 | 35 | PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; 36 | VAR h, l: SET; 37 | BEGIN 38 | sys.GET(sys.ADR(x), l); 39 | sys.GET(sys.ADR(x) + 4, h); 40 | RETURN (h * {20..30} = {20..30}) & (h * {0..19} = {}) & (l * {0..31} = {}) 41 | END IsInf; 42 | 43 | PROCEDURE Max(A, B: LONGREAL): LONGREAL; 44 | VAR Res: LONGREAL; 45 | BEGIN 46 | IF A > B THEN 47 | Res := A 48 | ELSE 49 | Res := B 50 | END 51 | RETURN Res 52 | END Max; 53 | 54 | PROCEDURE Min(A, B: LONGREAL): LONGREAL; 55 | VAR Res: LONGREAL; 56 | BEGIN 57 | IF A < B THEN 58 | Res := A 59 | ELSE 60 | Res := B 61 | END 62 | RETURN Res 63 | END Min; 64 | 65 | PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN; 66 | VAR Epsilon: LONGREAL; Res: BOOLEAN; 67 | BEGIN 68 | Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12); 69 | IF A > B THEN 70 | Res := (A - B) <= Epsilon 71 | ELSE 72 | Res := (B - A) <= Epsilon 73 | END 74 | RETURN Res 75 | END SameValue; 76 | 77 | PROCEDURE IsZero(x: LONGREAL): BOOLEAN; 78 | RETURN ABS(x) <= 1.0D-12 79 | END IsZero; 80 | 81 | PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL; 82 | BEGIN 83 | sys.CODE("DD4508D9FAC9C20800") 84 | RETURN 0.0D0 85 | END sqrt; 86 | 87 | PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL; 88 | BEGIN 89 | sys.CODE("DD4508D9FEC9C20800") 90 | RETURN 0.0D0 91 | END sin; 92 | 93 | PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL; 94 | BEGIN 95 | sys.CODE("DD4508D9FFC9C20800") 96 | RETURN 0.0D0 97 | END cos; 98 | 99 | PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL; 100 | BEGIN 101 | sys.CODE("DD4508D9F2DEC9C9C20800") 102 | RETURN 0.0D0 103 | END tan; 104 | 105 | PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL; 106 | BEGIN 107 | sys.CODE("DD4508DD4510D9F3C9C21000") 108 | RETURN 0.0D0 109 | END arctan2; 110 | 111 | PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL; 112 | BEGIN 113 | sys.CODE("D9EDDD4508D9F1C9C20800") 114 | RETURN 0.0D0 115 | END ln; 116 | 117 | PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL; 118 | BEGIN 119 | sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000") 120 | RETURN 0.0D0 121 | END log; 122 | 123 | PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL; 124 | BEGIN 125 | sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800") 126 | RETURN 0.0D0 127 | END exp; 128 | 129 | PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL; 130 | BEGIN 131 | sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800") 132 | RETURN 0.0D0 133 | END round; 134 | 135 | PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL; 136 | BEGIN 137 | sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800") 138 | RETURN 0.0D0 139 | END frac; 140 | 141 | PROCEDURE arcsin*(x: LONGREAL): LONGREAL; 142 | RETURN arctan2(x, sqrt(1.0D0 - x * x)) 143 | END arcsin; 144 | 145 | PROCEDURE arccos*(x: LONGREAL): LONGREAL; 146 | RETURN arctan2(sqrt(1.0D0 - x * x), x) 147 | END arccos; 148 | 149 | PROCEDURE arctan*(x: LONGREAL): LONGREAL; 150 | RETURN arctan2(x, 1.0D0) 151 | END arctan; 152 | 153 | PROCEDURE sinh*(x: LONGREAL): LONGREAL; 154 | VAR Res: LONGREAL; 155 | BEGIN 156 | IF IsZero(x) THEN 157 | Res := 0.0D0 158 | ELSE 159 | Res := (exp(x) - exp(-x)) / 2.0D0 160 | END 161 | RETURN Res 162 | END sinh; 163 | 164 | PROCEDURE cosh*(x: LONGREAL): LONGREAL; 165 | VAR Res: LONGREAL; 166 | BEGIN 167 | IF IsZero(x) THEN 168 | Res := 1.0D0 169 | ELSE 170 | Res := (exp(x) + exp(-x)) / 2.0D0 171 | END 172 | RETURN Res 173 | END cosh; 174 | 175 | PROCEDURE tanh*(x: LONGREAL): LONGREAL; 176 | VAR Res: LONGREAL; 177 | BEGIN 178 | IF IsZero(x) THEN 179 | Res := 0.0D0 180 | ELSE 181 | Res := sinh(x) / cosh(x) 182 | END 183 | RETURN Res 184 | END tanh; 185 | 186 | PROCEDURE arcsinh*(x: LONGREAL): LONGREAL; 187 | RETURN ln(x + sqrt((x * x) + 1.0D0)) 188 | END arcsinh; 189 | 190 | PROCEDURE arccosh*(x: LONGREAL): LONGREAL; 191 | RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0)) 192 | END arccosh; 193 | 194 | PROCEDURE arctanh*(x: LONGREAL): LONGREAL; 195 | VAR Res: LONGREAL; 196 | BEGIN 197 | IF SameValue(x, 1.0D0) THEN 198 | Res := INF 199 | ELSIF SameValue(x, -1.0D0) THEN 200 | Res := negINF 201 | ELSE 202 | Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x)) 203 | END 204 | RETURN Res 205 | END arctanh; 206 | 207 | PROCEDURE floor*(x: LONGREAL): LONGREAL; 208 | VAR f: LONGREAL; 209 | BEGIN 210 | f := frac(x); 211 | x := x - f; 212 | IF f < 0.0D0 THEN 213 | x := x - 1.0D0 214 | END 215 | RETURN x 216 | END floor; 217 | 218 | PROCEDURE ceil*(x: LONGREAL): LONGREAL; 219 | VAR f: LONGREAL; 220 | BEGIN 221 | f := frac(x); 222 | x := x - f; 223 | IF f > 0.0D0 THEN 224 | x := x + 1.0D0 225 | END 226 | RETURN x 227 | END ceil; 228 | 229 | PROCEDURE power*(base, exponent: LONGREAL): LONGREAL; 230 | VAR Res: LONGREAL; 231 | BEGIN 232 | IF exponent = 0.0D0 THEN 233 | Res := 1.0D0 234 | ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN 235 | Res := 0.0D0 236 | ELSE 237 | Res := exp(exponent * ln(base)) 238 | END 239 | RETURN Res 240 | END power; 241 | 242 | PROCEDURE sgn*(x: LONGREAL): INTEGER; 243 | VAR Res: INTEGER; 244 | BEGIN 245 | IF x > 0.0D0 THEN 246 | Res := 1 247 | ELSIF x < 0.0D0 THEN 248 | Res := -1 249 | ELSE 250 | Res := 0 251 | END 252 | RETURN Res 253 | END sgn; 254 | 255 | BEGIN 256 | sys.PUT(sys.ADR(INF), 0); 257 | sys.PUT(sys.ADR(INF) + 4, 7FF00000H); 258 | sys.PUT(sys.ADR(negINF), 0); 259 | sys.PUT(sys.ADR(negINF) + 4, 0FFF00000H); 260 | END Math. -------------------------------------------------------------------------------- /Lib/KolibriOS/Out.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Out; 19 | 20 | IMPORT ConsoleLib, sys := SYSTEM; 21 | 22 | CONST 23 | 24 | d = 1.0D0 - 5.0D-12; 25 | 26 | VAR 27 | 28 | Realp: PROCEDURE (x: LONGREAL; width: INTEGER); 29 | 30 | PROCEDURE Char*(c: CHAR); 31 | BEGIN 32 | ConsoleLib.write_string(sys.ADR(c), 1) 33 | END Char; 34 | 35 | PROCEDURE String*(s: ARRAY OF CHAR); 36 | BEGIN 37 | ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s)) 38 | END String; 39 | 40 | PROCEDURE WriteInt(x, n: INTEGER); 41 | VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN; 42 | BEGIN 43 | i := 0; 44 | IF n < 1 THEN 45 | n := 1 46 | END; 47 | IF x < 0 THEN 48 | x := -x; 49 | DEC(n); 50 | neg := TRUE 51 | END; 52 | REPEAT 53 | a[i] := CHR(x MOD 10 + ORD("0")); 54 | x := x DIV 10; 55 | INC(i) 56 | UNTIL x = 0; 57 | WHILE n > i DO 58 | Char(" "); 59 | DEC(n) 60 | END; 61 | IF neg THEN 62 | Char("-") 63 | END; 64 | REPEAT 65 | DEC(i); 66 | Char(a[i]) 67 | UNTIL i = 0 68 | END WriteInt; 69 | 70 | PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN; 71 | VAR h, l: SET; 72 | BEGIN 73 | sys.GET(sys.ADR(AValue), l); 74 | sys.GET(sys.ADR(AValue) + 4, h) 75 | RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) 76 | END IsNan; 77 | 78 | PROCEDURE IsInf(AValue: LONGREAL): BOOLEAN; 79 | VAR h, l: SET; 80 | BEGIN 81 | sys.GET(sys.ADR(AValue), l); 82 | sys.GET(sys.ADR(AValue) + 4, h) 83 | RETURN (h * {20..30} = {20..30}) & (h * {0..19} = {}) & (l * {0..31} = {}) 84 | END IsInf; 85 | 86 | PROCEDURE Int*(x, width: INTEGER); 87 | VAR i: INTEGER; 88 | BEGIN 89 | IF x # 80000000H THEN 90 | WriteInt(x, width) 91 | ELSE 92 | FOR i := 12 TO width DO 93 | Char(20X) 94 | END; 95 | String("-2147483648") 96 | END 97 | END Int; 98 | 99 | PROCEDURE OutInf(x: LONGREAL; width: INTEGER); 100 | VAR s: ARRAY 4 OF CHAR; i: INTEGER; 101 | BEGIN 102 | IF IsNan(x) THEN 103 | s := "Nan"; 104 | INC(width) 105 | ELSIF IsInf(x) & (x > 0.0D0) THEN 106 | s := "+Inf" 107 | ELSIF IsInf(x) & (x < 0.0D0) THEN 108 | s := "-Inf" 109 | END; 110 | FOR i := 1 TO width - 4 DO 111 | Char(" ") 112 | END; 113 | String(s) 114 | END OutInf; 115 | 116 | PROCEDURE Ln*; 117 | BEGIN 118 | Char(0DX); 119 | Char(0AX) 120 | END Ln; 121 | 122 | PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER); 123 | VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN; 124 | BEGIN 125 | IF IsNan(x) OR IsInf(x) THEN 126 | OutInf(x, width) 127 | ELSIF p < 0 THEN 128 | Realp(x, width) 129 | ELSE 130 | len := 0; 131 | minus := FALSE; 132 | IF x < 0.0D0 THEN 133 | minus := TRUE; 134 | INC(len); 135 | x := ABS(x) 136 | END; 137 | e := 0; 138 | WHILE x >= 10.0D0 DO 139 | x := x / 10.0D0; 140 | INC(e) 141 | END; 142 | IF e >= 0 THEN 143 | len := len + e + p + 1; 144 | IF x > 9.0D0 + d THEN 145 | INC(len) 146 | END; 147 | IF p > 0 THEN 148 | INC(len) 149 | END 150 | ELSE 151 | len := len + p + 2 152 | END; 153 | FOR i := 1 TO width - len DO 154 | Char(" ") 155 | END; 156 | IF minus THEN 157 | Char("-") 158 | END; 159 | y := x; 160 | WHILE (y < 1.0D0) & (y # 0.0D0) DO 161 | y := y * 10.0D0; 162 | DEC(e) 163 | END; 164 | IF e < 0 THEN 165 | IF x - LONG(FLT(FLOOR(x))) > d THEN 166 | Char("1"); 167 | x := 0.0D0 168 | ELSE 169 | Char("0"); 170 | x := x * 10.0D0 171 | END 172 | ELSE 173 | WHILE e >= 0 DO 174 | IF x - LONG(FLT(FLOOR(x))) > d THEN 175 | IF x > 9.0D0 THEN 176 | String("10") 177 | ELSE 178 | Char(CHR(FLOOR(x) + ORD("0") + 1)) 179 | END; 180 | x := 0.0D0 181 | ELSE 182 | Char(CHR(FLOOR(x) + ORD("0"))); 183 | x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 184 | END; 185 | DEC(e) 186 | END 187 | END; 188 | IF p > 0 THEN 189 | Char(".") 190 | END; 191 | WHILE p > 0 DO 192 | IF x - LONG(FLT(FLOOR(x))) > d THEN 193 | Char(CHR(FLOOR(x) + ORD("0") + 1)); 194 | x := 0.0D0 195 | ELSE 196 | Char(CHR(FLOOR(x) + ORD("0"))); 197 | x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 198 | END; 199 | DEC(p) 200 | END 201 | END 202 | END FixReal; 203 | 204 | PROCEDURE Real*(x: LONGREAL; width: INTEGER); 205 | VAR e, n, i: INTEGER; minus: BOOLEAN; 206 | BEGIN 207 | IF IsNan(x) OR IsInf(x) THEN 208 | OutInf(x, width) 209 | ELSE 210 | e := 0; 211 | n := 0; 212 | IF width > 23 THEN 213 | n := width - 23; 214 | width := 23 215 | ELSIF width < 9 THEN 216 | width := 9 217 | END; 218 | width := width - 5; 219 | IF x < 0.0D0 THEN 220 | x := -x; 221 | minus := TRUE 222 | ELSE 223 | minus := FALSE 224 | END; 225 | WHILE x >= 10.0D0 DO 226 | x := x / 10.0D0; 227 | INC(e) 228 | END; 229 | WHILE (x < 1.0D0) & (x # 0.0D0) DO 230 | x := x * 10.0D0; 231 | DEC(e) 232 | END; 233 | IF x > 9.0D0 + d THEN 234 | x := 1.0D0; 235 | INC(e) 236 | END; 237 | FOR i := 1 TO n DO 238 | Char(" ") 239 | END; 240 | IF minus THEN 241 | x := -x 242 | END; 243 | FixReal(x, width, width - 3); 244 | Char("E"); 245 | IF e >= 0 THEN 246 | Char("+") 247 | ELSE 248 | Char("-"); 249 | e := ABS(e) 250 | END; 251 | IF e < 100 THEN 252 | Char("0") 253 | END; 254 | IF e < 10 THEN 255 | Char("0") 256 | END; 257 | Int(e, 0) 258 | END 259 | END Real; 260 | 261 | PROCEDURE Open*; 262 | END Open; 263 | 264 | BEGIN 265 | Realp := Real 266 | END Out. 267 | -------------------------------------------------------------------------------- /Lib/KolibriOS/RTL.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE RTL; 19 | 20 | IMPORT sys := SYSTEM, API; 21 | 22 | TYPE 23 | 24 | IntArray = ARRAY 2048 OF INTEGER; 25 | STRING = ARRAY 2048 OF CHAR; 26 | PROC = PROCEDURE; 27 | 28 | VAR 29 | 30 | SelfName, rtab: INTEGER; CloseProc: PROC; 31 | 32 | PROCEDURE [stdcall] _halt*(n: INTEGER); 33 | BEGIN 34 | API.ExitProcess(n) 35 | END _halt; 36 | 37 | PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); 38 | BEGIN 39 | ptr := API._NEW(size); 40 | IF ptr # 0 THEN 41 | sys.PUT(ptr, t); 42 | INC(ptr, 4) 43 | END 44 | END _newrec; 45 | 46 | PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); 47 | BEGIN 48 | IF ptr # 0 THEN 49 | DEC(ptr, 4); 50 | ptr := API._DISPOSE(ptr) 51 | END 52 | END _disprec; 53 | 54 | PROCEDURE [stdcall] _rset*(y, x: INTEGER); 55 | BEGIN 56 | sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") 57 | END _rset; 58 | 59 | PROCEDURE [stdcall] _inset*(y, x: INTEGER); 60 | BEGIN 61 | sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") 62 | END _inset; 63 | 64 | PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); 65 | BEGIN 66 | table := rtab; 67 | sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") 68 | END _checktype; 69 | 70 | PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); 71 | BEGIN 72 | sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") 73 | END _savearr; 74 | 75 | PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; 76 | VAR res: BOOLEAN; 77 | BEGIN 78 | res := dyn = stat; 79 | IF res THEN 80 | _savearr(size, source, dest) 81 | END 82 | RETURN res 83 | END _saverec; 84 | 85 | PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); 86 | VAR i, m: INTEGER; 87 | BEGIN 88 | m := bsize * idx; 89 | FOR i := 4 TO Dim + 2 DO 90 | m := m * Arr[i] 91 | END; 92 | IF (Arr[3] > idx) & (idx >= 0) THEN 93 | Arr[3] := c + m 94 | ELSE 95 | Arr[3] := 0 96 | END 97 | END _arrayidx; 98 | 99 | PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); 100 | BEGIN 101 | IF (Arr[3] > idx) & (idx >= 0) THEN 102 | Arr[3] := bsize * idx + c 103 | ELSE 104 | Arr[3] := 0 105 | END 106 | END _arrayidx1; 107 | 108 | PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); 109 | VAR i, j, t: INTEGER; 110 | BEGIN 111 | FOR i := 1 TO n DO 112 | t := Arr[0]; 113 | FOR j := 0 TO m + n - 1 DO 114 | Arr[j] := Arr[j + 1] 115 | END; 116 | Arr[m + n] := t 117 | END 118 | END _arrayrot; 119 | 120 | PROCEDURE Min(a, b: INTEGER): INTEGER; 121 | VAR res: INTEGER; 122 | BEGIN 123 | IF a < b THEN 124 | res := a 125 | ELSE 126 | res := b 127 | END 128 | RETURN res 129 | END Min; 130 | 131 | PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; 132 | BEGIN 133 | sys.CODE("8B4508"); // mov eax, [ebp + 08h] 134 | sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] 135 | sys.CODE("48"); // dec eax 136 | // L1: 137 | sys.CODE("40"); // inc eax 138 | sys.CODE("803800"); // cmp byte ptr [eax], 0 139 | sys.CODE("7403"); // jz L2 140 | sys.CODE("E2F8"); // loop L1 141 | sys.CODE("40"); // inc eax 142 | // L2: 143 | sys.CODE("2B4508"); // sub eax, [ebp + 08h] 144 | sys.CODE("C9"); // leave 145 | sys.CODE("C20800"); // ret 08h 146 | RETURN 0 147 | END _length; 148 | 149 | PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); 150 | BEGIN 151 | _savearr(Min(alen, blen), a, b); 152 | IF blen > alen THEN 153 | sys.PUT(b + alen, 0X) 154 | END 155 | END _strcopy; 156 | 157 | PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; 158 | VAR i: INTEGER; Res: BOOLEAN; 159 | BEGIN 160 | i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); 161 | IF i = 0 THEN 162 | i := _length(a) - _length(b) 163 | END; 164 | CASE op OF 165 | |0: Res := i = 0 166 | |1: Res := i # 0 167 | |2: Res := i < 0 168 | |3: Res := i > 0 169 | |4: Res := i <= 0 170 | |5: Res := i >= 0 171 | ELSE 172 | END 173 | RETURN Res 174 | END _strcmp; 175 | 176 | PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; 177 | VAR s: ARRAY 2 OF CHAR; 178 | BEGIN 179 | s[0] := b; 180 | s[1] := 0X; 181 | RETURN _strcmp(op, s, a) 182 | END _lstrcmp; 183 | 184 | PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; 185 | VAR s: ARRAY 2 OF CHAR; 186 | BEGIN 187 | s[0] := a; 188 | s[1] := 0X; 189 | RETURN _strcmp(op, b, s) 190 | END _rstrcmp; 191 | 192 | PROCEDURE Int(x: INTEGER; VAR str: STRING); 193 | VAR i, a, b: INTEGER; c: CHAR; 194 | BEGIN 195 | i := 0; 196 | a := 0; 197 | REPEAT 198 | str[i] := CHR(x MOD 10 + ORD("0")); 199 | x := x DIV 10; 200 | INC(i) 201 | UNTIL x = 0; 202 | b := i - 1; 203 | WHILE a < b DO 204 | c := str[a]; 205 | str[a] := str[b]; 206 | str[b] := c; 207 | INC(a); 208 | DEC(b) 209 | END; 210 | str[i] := 0X 211 | END Int; 212 | 213 | PROCEDURE StrAppend(VAR str: STRING; VAR pos: INTEGER; s: ARRAY OF CHAR); 214 | VAR i, n: INTEGER; 215 | BEGIN 216 | n := LEN(s); 217 | i := 0; 218 | WHILE (i < n) & (s[i] # 0X) DO 219 | str[pos] := s[i]; 220 | INC(pos); 221 | INC(i) 222 | END 223 | END StrAppend; 224 | 225 | PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); 226 | VAR msg, int: STRING; pos, n: INTEGER; 227 | BEGIN 228 | pos := 0; 229 | n := line MOD 16; 230 | line := line DIV 16; 231 | CASE n OF 232 | |1: StrAppend(msg, pos, "assertion failure") 233 | |2: StrAppend(msg, pos, "variable of a procedure type have NIL as value") 234 | |3: StrAppend(msg, pos, "typeguard error") 235 | |4: StrAppend(msg, pos, "inadmissible dynamic type") 236 | |5: StrAppend(msg, pos, "index check error") 237 | |6: StrAppend(msg, pos, "NIL pointer dereference") 238 | |7: StrAppend(msg, pos, "invalid value in case statement") 239 | |8: StrAppend(msg, pos, "division by zero") 240 | ELSE 241 | END; 242 | StrAppend(msg, pos, 0DX); 243 | StrAppend(msg, pos, 0AX); 244 | StrAppend(msg, pos, "module "); 245 | StrAppend(msg, pos, modname); 246 | StrAppend(msg, pos, 0DX); 247 | StrAppend(msg, pos, 0AX); 248 | StrAppend(msg, pos, "line "); 249 | Int(line, int); 250 | StrAppend(msg, pos, int); 251 | IF m = 2 THEN 252 | StrAppend(msg, pos, 0DX); 253 | StrAppend(msg, pos, 0AX); 254 | StrAppend(msg, pos, "code "); 255 | Int(code, int); 256 | StrAppend(msg, pos, int) 257 | END; 258 | API.DebugMsg(sys.ADR(msg), SelfName) 259 | END _assrt; 260 | 261 | PROCEDURE [stdcall] _close*; 262 | BEGIN 263 | IF CloseProc # NIL THEN 264 | CloseProc 265 | END 266 | END _close; 267 | 268 | PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); 269 | BEGIN 270 | API.zeromem(gsize, gadr); 271 | API.init(esp); 272 | SelfName := self; 273 | rtab := rec; 274 | CloseProc := NIL; 275 | END _init; 276 | 277 | PROCEDURE SetClose*(proc: PROC); 278 | BEGIN 279 | CloseProc := proc 280 | END SetClose; 281 | 282 | END RTL. -------------------------------------------------------------------------------- /Lib/KolibriOS/Read.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Read; 19 | 20 | IMPORT File, FSys, sys := SYSTEM; 21 | 22 | PROCEDURE Char*(F: FSys.FS; VAR x: CHAR): BOOLEAN; 23 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) 24 | END Char; 25 | 26 | PROCEDURE Int*(F: FSys.FS; VAR x: INTEGER): BOOLEAN; 27 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) 28 | END Int; 29 | 30 | PROCEDURE Real*(F: FSys.FS; VAR x: REAL): BOOLEAN; 31 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) 32 | END Real; 33 | 34 | PROCEDURE LongReal*(F: FSys.FS; VAR x: LONGREAL): BOOLEAN; 35 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) 36 | END LongReal; 37 | 38 | PROCEDURE Boolean*(F: FSys.FS; VAR x: BOOLEAN): BOOLEAN; 39 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) 40 | END Boolean; 41 | 42 | PROCEDURE Set*(F: FSys.FS; VAR x: SET): BOOLEAN; 43 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) 44 | END Set; 45 | 46 | PROCEDURE Card16*(F: FSys.FS; VAR x: sys.CARD16): BOOLEAN; 47 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) 48 | END Card16; 49 | 50 | END Read. -------------------------------------------------------------------------------- /Lib/KolibriOS/Utils.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Utils; 19 | 20 | IMPORT sys := SYSTEM, KOSAPI; 21 | 22 | CONST 23 | 24 | MAX_PARAM = 1024; 25 | 26 | VAR 27 | 28 | Params: ARRAY MAX_PARAM, 2 OF INTEGER; 29 | ParamCount*: INTEGER; 30 | 31 | PROCEDURE GetChar(adr: INTEGER): CHAR; 32 | VAR res: CHAR; 33 | BEGIN 34 | sys.GET(adr, res) 35 | RETURN res 36 | END GetChar; 37 | 38 | PROCEDURE ParamParse; 39 | VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER; 40 | 41 | PROCEDURE ChangeCond(A, B, C: INTEGER); 42 | BEGIN 43 | IF (c <= 20X) & (c # 0X) THEN 44 | cond := A 45 | ELSIF c = 22X THEN 46 | cond := B 47 | ELSIF c = 0X THEN 48 | cond := 6 49 | ELSE 50 | cond := C 51 | END 52 | END ChangeCond; 53 | 54 | BEGIN 55 | p := KOSAPI.GetCommandLine(); 56 | name := KOSAPI.GetName(); 57 | Params[0, 0] := name; 58 | WHILE GetChar(name) # 0X DO 59 | INC(name) 60 | END; 61 | Params[0, 1] := name - 1; 62 | cond := 0; 63 | count := 1; 64 | WHILE (count < MAX_PARAM) & (cond # 6) DO 65 | c := GetChar(p); 66 | CASE cond OF 67 | |0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END 68 | |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END 69 | |3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 70 | |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END 71 | |5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 72 | ELSE 73 | END; 74 | INC(p) 75 | END; 76 | ParamCount := count - 1 77 | END ParamParse; 78 | 79 | PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER); 80 | VAR i, j, len: INTEGER; c: CHAR; 81 | BEGIN 82 | j := 0; 83 | IF n < ParamCount + 1 THEN 84 | len := LEN(str) - 1; 85 | i := Params[n, 0]; 86 | WHILE (j < len) & (i <= Params[n, 1]) DO 87 | c := GetChar(i); 88 | IF c # 22X THEN 89 | str[j] := c; 90 | INC(j) 91 | END; 92 | INC(i); 93 | END; 94 | END; 95 | str[j] := 0X 96 | END ParamStr; 97 | 98 | BEGIN 99 | ParamParse 100 | END Utils. -------------------------------------------------------------------------------- /Lib/KolibriOS/Write.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Write; 19 | 20 | IMPORT File, FSys, sys := SYSTEM; 21 | 22 | PROCEDURE Char*(F: FSys.FS; x: CHAR): BOOLEAN; 23 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) 24 | END Char; 25 | 26 | PROCEDURE Int*(F: FSys.FS; x: INTEGER): BOOLEAN; 27 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) 28 | END Int; 29 | 30 | PROCEDURE Real*(F: FSys.FS; x: REAL): BOOLEAN; 31 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) 32 | END Real; 33 | 34 | PROCEDURE LongReal*(F: FSys.FS; x: LONGREAL): BOOLEAN; 35 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) 36 | END LongReal; 37 | 38 | PROCEDURE Boolean*(F: FSys.FS; x: BOOLEAN): BOOLEAN; 39 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) 40 | END Boolean; 41 | 42 | PROCEDURE Set*(F: FSys.FS; x: SET): BOOLEAN; 43 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) 44 | END Set; 45 | 46 | PROCEDURE Card16*(F: FSys.FS; x: sys.CARD16): BOOLEAN; 47 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) 48 | END Card16; 49 | 50 | END Write. -------------------------------------------------------------------------------- /Lib/Linux32/API.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE API; 19 | 20 | IMPORT sys := SYSTEM; 21 | 22 | CONST 23 | 24 | OS* = "LNX"; 25 | Slash* = "/"; 26 | 27 | TYPE 28 | 29 | OFSTRUCT* = RECORD END; 30 | 31 | TP = ARRAY 2 OF INTEGER; 32 | 33 | VAR 34 | 35 | Param, FSize: INTEGER; 36 | 37 | sec* : INTEGER; 38 | dsec* : INTEGER; 39 | stdin* : INTEGER; 40 | stdout* : INTEGER; 41 | stderr* : INTEGER; 42 | dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER; 43 | dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER; 44 | malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER; 45 | free* : PROCEDURE [cdecl] (ptr: INTEGER); 46 | fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER; 47 | fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER; 48 | fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER; 49 | fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER; 50 | exit* : PROCEDURE [cdecl] (code: INTEGER); 51 | strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER; 52 | strlen : PROCEDURE [cdecl] (str: INTEGER): INTEGER; 53 | clock_gettime : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER; 54 | 55 | CreateFile*: PROCEDURE (p1, p2, p3, p4, p5, p6, p7: INTEGER): INTEGER; 56 | kos_OCFile*: PROCEDURE (FName: ARRAY OF CHAR; mode: INTEGER; VAR memerr: BOOLEAN): INTEGER; 57 | GetName*: PROCEDURE (): INTEGER; 58 | OpenFile*: PROCEDURE (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER; 59 | 60 | PROCEDURE [stdcall] zeromem* (size, adr: INTEGER); 61 | BEGIN 62 | sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") 63 | END zeromem; 64 | 65 | PROCEDURE GetCommandLine* (): INTEGER; 66 | RETURN Param 67 | END GetCommandLine; 68 | 69 | PROCEDURE CloseHandle* (hObject: INTEGER); 70 | BEGIN 71 | hObject := fclose(hObject) 72 | END CloseHandle; 73 | 74 | PROCEDURE WriteFile* (hFile, Buffer, nNumberOfBytesToWrite, lpNumberOfBytesWritten, p1: INTEGER); 75 | BEGIN 76 | sys.PUT(lpNumberOfBytesWritten, fwrite(Buffer, nNumberOfBytesToWrite, 1, hFile) * nNumberOfBytesToWrite) 77 | END WriteFile; 78 | 79 | PROCEDURE ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, p1: INTEGER); 80 | BEGIN 81 | sys.PUT(lpNumberOfBytesRead, fread(Buffer, nNumberOfBytesToRead, 1, hFile) * nNumberOfBytesToRead) 82 | END ReadFile; 83 | 84 | PROCEDURE FileSize* (F: INTEGER): INTEGER; 85 | RETURN FSize 86 | END FileSize; 87 | 88 | PROCEDURE lnx_CreateFile* (FName: ARRAY OF CHAR): INTEGER; 89 | RETURN fopen(sys.ADR(FName), sys.ADR("wb")) 90 | END lnx_CreateFile; 91 | 92 | PROCEDURE lnx_OpenFile* (FName: ARRAY OF CHAR): INTEGER; 93 | VAR F, res: INTEGER; 94 | BEGIN 95 | F := fopen(sys.ADR(FName), sys.ADR("rb")); 96 | IF F # 0 THEN 97 | res := fseek(F, 0, 2); 98 | FSize := ftell(F); 99 | res := fseek(F, 0, 0) 100 | END 101 | RETURN F 102 | END lnx_OpenFile; 103 | 104 | PROCEDURE GetStdHandle* (nStdHandle: INTEGER): INTEGER; 105 | RETURN stdout 106 | END GetStdHandle; 107 | 108 | PROCEDURE Align(n, m: INTEGER): INTEGER; 109 | RETURN n + (m - n MOD m) MOD m 110 | END Align; 111 | 112 | PROCEDURE Alloc* (uFlags, dwBytes: INTEGER): INTEGER; 113 | VAR res: INTEGER; 114 | BEGIN 115 | dwBytes := Align(dwBytes, 4); 116 | res := malloc(dwBytes); 117 | IF res # 0 THEN 118 | zeromem(ASR(dwBytes, 2), res) 119 | END 120 | RETURN res 121 | END Alloc; 122 | 123 | PROCEDURE Free* (hMem: INTEGER): INTEGER; 124 | BEGIN 125 | free(hMem) 126 | RETURN 0 127 | END Free; 128 | 129 | PROCEDURE _NEW*(size: INTEGER): INTEGER; 130 | RETURN Alloc(64, size) 131 | END _NEW; 132 | 133 | PROCEDURE _DISPOSE*(p: INTEGER): INTEGER; 134 | RETURN Free(p) 135 | END _DISPOSE; 136 | 137 | PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); 138 | VAR res: INTEGER; eol: ARRAY 3 OF CHAR; c: CHAR; 139 | BEGIN 140 | c := ":"; 141 | eol[0] := 0DX; 142 | eol[1] := 0AX; 143 | eol[2] := 00X; 144 | WriteFile(stdout, sys.ADR(eol), 2, sys.ADR(res), 0); 145 | WriteFile(stdout, lpCaption, strlen(lpCaption), sys.ADR(res), 0); 146 | WriteFile(stdout, sys.ADR(c), 1, sys.ADR(res), 0); 147 | WriteFile(stdout, sys.ADR(eol), 2, sys.ADR(res), 0); 148 | WriteFile(stdout, lpText, strlen(lpText), sys.ADR(res), 0); 149 | WriteFile(stdout, sys.ADR(eol), 2, sys.ADR(res), 0); 150 | END DebugMsg; 151 | 152 | PROCEDURE ExitProcess* (code: INTEGER); 153 | BEGIN 154 | exit(code) 155 | END ExitProcess; 156 | 157 | PROCEDURE Time*(VAR sec, dsec: INTEGER); 158 | VAR tp: TP; 159 | BEGIN 160 | IF clock_gettime(0, tp) = 0 THEN 161 | sec := tp[0]; 162 | dsec := tp[1] DIV 10000000 163 | ELSE 164 | sec := 0; 165 | dsec := 0 166 | END 167 | END Time; 168 | 169 | PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); 170 | VAR H: INTEGER; 171 | BEGIN 172 | H := dlsym(hMOD, sys.ADR(name[0])); 173 | ASSERT(H # 0); 174 | sys.PUT(adr, H); 175 | END GetProc; 176 | 177 | PROCEDURE init* (esp: INTEGER); 178 | VAR lib, proc: INTEGER; 179 | BEGIN 180 | Param := esp; 181 | sys.MOVE(Param + 12, sys.ADR(dlopen), 4); 182 | sys.MOVE(Param + 16, sys.ADR(dlsym), 4); 183 | sys.MOVE(Param + 20, sys.ADR(exit), 4); 184 | sys.MOVE(Param + 24, sys.ADR(stdin), 4); 185 | sys.MOVE(Param + 28, sys.ADR(stdout), 4); 186 | sys.MOVE(Param + 32, sys.ADR(stderr), 4); 187 | sys.MOVE(Param + 36, sys.ADR(malloc), 4); 188 | sys.MOVE(Param + 40, sys.ADR(free), 4); 189 | sys.MOVE(Param + 44, sys.ADR(fopen), 4); 190 | sys.MOVE(Param + 48, sys.ADR(fclose), 4); 191 | sys.MOVE(Param + 52, sys.ADR(fwrite), 4); 192 | sys.MOVE(Param + 56, sys.ADR(fread), 4); 193 | sys.MOVE(Param + 60, sys.ADR(fseek), 4); 194 | sys.MOVE(Param + 64, sys.ADR(ftell), 4); 195 | lib := dlopen(sys.ADR("libc.so.6"), 1); 196 | ASSERT(lib # 0); 197 | GetProc("strncmp", lib, sys.ADR(strncmp)); 198 | GetProc("strlen", lib, sys.ADR(strlen)); 199 | 200 | lib := dlopen(sys.ADR("librt.so.1"), 1); 201 | ASSERT(lib # 0); 202 | GetProc("clock_gettime", lib, sys.ADR(clock_gettime)); 203 | 204 | Time(sec, dsec) 205 | END init; 206 | 207 | END API. -------------------------------------------------------------------------------- /Lib/Linux32/LINAPI.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE LINAPI; 19 | 20 | IMPORT API, sys := SYSTEM; 21 | 22 | VAR 23 | 24 | ParamCount*, EnvCount*, stdin*, stdout*, stderr*: INTEGER; 25 | 26 | PROCEDURE GetStr(n, offset: INTEGER): INTEGER; 27 | VAR p: INTEGER; 28 | BEGIN 29 | IF n < EnvCount THEN 30 | sys.GET(API.GetCommandLine() + offset, p); 31 | sys.GET(p + 4 * n, p) 32 | ELSE 33 | p := 0 34 | END 35 | RETURN p 36 | END GetStr; 37 | 38 | PROCEDURE EnvStr* (n: INTEGER): INTEGER; 39 | RETURN GetStr(n, 8) 40 | END EnvStr; 41 | 42 | PROCEDURE ParamStr* (n: INTEGER): INTEGER; 43 | RETURN GetStr(n, 4) 44 | END ParamStr; 45 | 46 | PROCEDURE dlopen* (filename: ARRAY OF CHAR; flag: INTEGER): INTEGER; 47 | RETURN API.dlopen(sys.ADR(filename), flag) 48 | END dlopen; 49 | 50 | PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER; 51 | RETURN API.dlsym(handle, sys.ADR(symbol)) 52 | END dlsym; 53 | 54 | PROCEDURE exit* (code: INTEGER); 55 | BEGIN 56 | API.exit(code) 57 | END exit; 58 | 59 | PROCEDURE Init; 60 | VAR p, str: INTEGER; 61 | BEGIN 62 | sys.GET(API.GetCommandLine(), ParamCount); 63 | EnvCount := 0; 64 | sys.GET(API.GetCommandLine() + 8, p); 65 | sys.GET(p, str); 66 | WHILE str # 0 DO 67 | INC(p, 4); 68 | sys.GET(p, str); 69 | INC(EnvCount) 70 | END; 71 | stdin := API.stdin; 72 | stdout := API.stdout; 73 | stderr := API.stderr; 74 | END Init; 75 | 76 | BEGIN 77 | Init 78 | END LINAPI. -------------------------------------------------------------------------------- /Lib/Linux32/RTL.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE RTL; 19 | 20 | IMPORT sys := SYSTEM, API; 21 | 22 | TYPE 23 | 24 | IntArray = ARRAY 2048 OF INTEGER; 25 | STRING = ARRAY 2048 OF CHAR; 26 | PROC = PROCEDURE; 27 | 28 | VAR 29 | 30 | SelfName, rtab: INTEGER; CloseProc: PROC; 31 | 32 | PROCEDURE [stdcall] _halt*(n: INTEGER); 33 | BEGIN 34 | API.ExitProcess(n) 35 | END _halt; 36 | 37 | PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); 38 | BEGIN 39 | ptr := API._NEW(size); 40 | IF ptr # 0 THEN 41 | sys.PUT(ptr, t); 42 | INC(ptr, 4) 43 | END 44 | END _newrec; 45 | 46 | PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); 47 | BEGIN 48 | IF ptr # 0 THEN 49 | DEC(ptr, 4); 50 | ptr := API._DISPOSE(ptr) 51 | END 52 | END _disprec; 53 | 54 | PROCEDURE [stdcall] _rset*(y, x: INTEGER); 55 | BEGIN 56 | sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") 57 | END _rset; 58 | 59 | PROCEDURE [stdcall] _inset*(y, x: INTEGER); 60 | BEGIN 61 | sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") 62 | END _inset; 63 | 64 | PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); 65 | BEGIN 66 | table := rtab; 67 | sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") 68 | END _checktype; 69 | 70 | PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); 71 | BEGIN 72 | sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") 73 | END _savearr; 74 | 75 | PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; 76 | VAR res: BOOLEAN; 77 | BEGIN 78 | res := dyn = stat; 79 | IF res THEN 80 | _savearr(size, source, dest) 81 | END 82 | RETURN res 83 | END _saverec; 84 | 85 | PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); 86 | VAR i, m: INTEGER; 87 | BEGIN 88 | m := bsize * idx; 89 | FOR i := 4 TO Dim + 2 DO 90 | m := m * Arr[i] 91 | END; 92 | IF (Arr[3] > idx) & (idx >= 0) THEN 93 | Arr[3] := c + m 94 | ELSE 95 | Arr[3] := 0 96 | END 97 | END _arrayidx; 98 | 99 | PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); 100 | BEGIN 101 | IF (Arr[3] > idx) & (idx >= 0) THEN 102 | Arr[3] := bsize * idx + c 103 | ELSE 104 | Arr[3] := 0 105 | END 106 | END _arrayidx1; 107 | 108 | PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); 109 | VAR i, j, t: INTEGER; 110 | BEGIN 111 | FOR i := 1 TO n DO 112 | t := Arr[0]; 113 | FOR j := 0 TO m + n - 1 DO 114 | Arr[j] := Arr[j + 1] 115 | END; 116 | Arr[m + n] := t 117 | END 118 | END _arrayrot; 119 | 120 | PROCEDURE Min(a, b: INTEGER): INTEGER; 121 | VAR res: INTEGER; 122 | BEGIN 123 | IF a < b THEN 124 | res := a 125 | ELSE 126 | res := b 127 | END 128 | RETURN res 129 | END Min; 130 | 131 | PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; 132 | BEGIN 133 | sys.CODE("8B4508"); // mov eax, [ebp + 08h] 134 | sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] 135 | sys.CODE("48"); // dec eax 136 | // L1: 137 | sys.CODE("40"); // inc eax 138 | sys.CODE("803800"); // cmp byte ptr [eax], 0 139 | sys.CODE("7403"); // jz L2 140 | sys.CODE("E2F8"); // loop L1 141 | sys.CODE("40"); // inc eax 142 | // L2: 143 | sys.CODE("2B4508"); // sub eax, [ebp + 08h] 144 | sys.CODE("C9"); // leave 145 | sys.CODE("C20800"); // ret 08h 146 | RETURN 0 147 | END _length; 148 | 149 | PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); 150 | BEGIN 151 | _savearr(Min(alen, blen), a, b); 152 | IF blen > alen THEN 153 | sys.PUT(b + alen, 0X) 154 | END 155 | END _strcopy; 156 | 157 | PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; 158 | VAR i: INTEGER; Res: BOOLEAN; 159 | BEGIN 160 | i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); 161 | IF i = 0 THEN 162 | i := _length(a) - _length(b) 163 | END; 164 | CASE op OF 165 | |0: Res := i = 0 166 | |1: Res := i # 0 167 | |2: Res := i < 0 168 | |3: Res := i > 0 169 | |4: Res := i <= 0 170 | |5: Res := i >= 0 171 | ELSE 172 | END 173 | RETURN Res 174 | END _strcmp; 175 | 176 | PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; 177 | VAR s: ARRAY 2 OF CHAR; 178 | BEGIN 179 | s[0] := b; 180 | s[1] := 0X; 181 | RETURN _strcmp(op, s, a) 182 | END _lstrcmp; 183 | 184 | PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; 185 | VAR s: ARRAY 2 OF CHAR; 186 | BEGIN 187 | s[0] := a; 188 | s[1] := 0X; 189 | RETURN _strcmp(op, b, s) 190 | END _rstrcmp; 191 | 192 | PROCEDURE Int(x: INTEGER; VAR str: STRING); 193 | VAR i, a, b: INTEGER; c: CHAR; 194 | BEGIN 195 | i := 0; 196 | a := 0; 197 | REPEAT 198 | str[i] := CHR(x MOD 10 + ORD("0")); 199 | x := x DIV 10; 200 | INC(i) 201 | UNTIL x = 0; 202 | b := i - 1; 203 | WHILE a < b DO 204 | c := str[a]; 205 | str[a] := str[b]; 206 | str[b] := c; 207 | INC(a); 208 | DEC(b) 209 | END; 210 | str[i] := 0X 211 | END Int; 212 | 213 | PROCEDURE StrAppend(VAR str: STRING; VAR pos: INTEGER; s: ARRAY OF CHAR); 214 | VAR i, n: INTEGER; 215 | BEGIN 216 | n := LEN(s); 217 | i := 0; 218 | WHILE (i < n) & (s[i] # 0X) DO 219 | str[pos] := s[i]; 220 | INC(pos); 221 | INC(i) 222 | END 223 | END StrAppend; 224 | 225 | PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); 226 | VAR msg, int: STRING; pos, n: INTEGER; 227 | BEGIN 228 | pos := 0; 229 | n := line MOD 16; 230 | line := line DIV 16; 231 | CASE n OF 232 | |1: StrAppend(msg, pos, "assertion failure") 233 | |2: StrAppend(msg, pos, "variable of a procedure type have NIL as value") 234 | |3: StrAppend(msg, pos, "typeguard error") 235 | |4: StrAppend(msg, pos, "inadmissible dynamic type") 236 | |5: StrAppend(msg, pos, "index check error") 237 | |6: StrAppend(msg, pos, "NIL pointer dereference") 238 | |7: StrAppend(msg, pos, "invalid value in case statement") 239 | |8: StrAppend(msg, pos, "division by zero") 240 | ELSE 241 | END; 242 | StrAppend(msg, pos, 0DX); 243 | StrAppend(msg, pos, 0AX); 244 | StrAppend(msg, pos, "module "); 245 | StrAppend(msg, pos, modname); 246 | StrAppend(msg, pos, 0DX); 247 | StrAppend(msg, pos, 0AX); 248 | StrAppend(msg, pos, "line "); 249 | Int(line, int); 250 | StrAppend(msg, pos, int); 251 | IF m = 2 THEN 252 | StrAppend(msg, pos, 0DX); 253 | StrAppend(msg, pos, 0AX); 254 | StrAppend(msg, pos, "code "); 255 | Int(code, int); 256 | StrAppend(msg, pos, int) 257 | END; 258 | API.DebugMsg(sys.ADR(msg), SelfName) 259 | END _assrt; 260 | 261 | PROCEDURE [stdcall] _close*; 262 | BEGIN 263 | IF CloseProc # NIL THEN 264 | CloseProc 265 | END 266 | END _close; 267 | 268 | PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); 269 | BEGIN 270 | API.zeromem(gsize, gadr); 271 | API.init(esp); 272 | SelfName := self; 273 | rtab := rec; 274 | CloseProc := NIL; 275 | END _init; 276 | 277 | PROCEDURE SetClose*(proc: PROC); 278 | BEGIN 279 | CloseProc := proc 280 | END SetClose; 281 | 282 | END RTL. -------------------------------------------------------------------------------- /Lib/Windows32/API.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE API; 19 | 20 | IMPORT sys := SYSTEM; 21 | 22 | CONST 23 | 24 | OS* = "WIN"; 25 | Slash* = "\"; 26 | 27 | OFS_MAXPATHNAME = 128; 28 | 29 | TYPE 30 | 31 | OFSTRUCT* = RECORD 32 | cBytes: CHAR; 33 | fFixedDisk: CHAR; 34 | nErrCode: sys.CARD16; 35 | Reserved1: sys.CARD16; 36 | Reserved2: sys.CARD16; 37 | szPathName: ARRAY OFS_MAXPATHNAME OF CHAR 38 | END; 39 | 40 | VAR 41 | 42 | sec*, dsec*: INTEGER; 43 | 44 | GetStdHandle*: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER; 45 | CloseHandle*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER; 46 | CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes, 47 | dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER; 48 | OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER; 49 | ReadFile*, WriteFile*: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER; 50 | GetCommandLine*: PROCEDURE [winapi] (): INTEGER; 51 | GetTickCount*: PROCEDURE [winapi] (): INTEGER; 52 | Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER; 53 | Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER; 54 | MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER; 55 | ExitProcess*: PROCEDURE [winapi] (code: INTEGER); 56 | SetFilePointer*: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER; 57 | strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER; 58 | 59 | GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER; 60 | LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER; 61 | 62 | kos_OCFile*: PROCEDURE (FName: ARRAY OF CHAR; mode: INTEGER; VAR memerr: BOOLEAN): INTEGER; 63 | GetName*: PROCEDURE (): INTEGER; 64 | lnx_CreateFile*: PROCEDURE (FName: ARRAY OF CHAR): INTEGER; 65 | lnx_OpenFile*: PROCEDURE (FName: ARRAY OF CHAR): INTEGER; 66 | 67 | PROCEDURE zeromem*(size, adr: INTEGER); 68 | END zeromem; 69 | 70 | PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER); 71 | BEGIN 72 | MessageBoxA(0, lpText, lpCaption, 16) 73 | END DebugMsg; 74 | 75 | PROCEDURE FileSize*(F: INTEGER): INTEGER; 76 | VAR res: INTEGER; 77 | BEGIN 78 | res := SetFilePointer(F, 0, 0, 2); 79 | SetFilePointer(F, 0, 0, 0) 80 | RETURN res 81 | END FileSize; 82 | 83 | PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); 84 | VAR H: INTEGER; 85 | BEGIN 86 | H := GetProcAddress(hMOD, sys.ADR(name[0])); 87 | ASSERT(H # 0); 88 | sys.PUT(adr, H); 89 | END GetProc; 90 | 91 | PROCEDURE Time*(VAR sec, dsec: INTEGER); 92 | VAR t: INTEGER; 93 | BEGIN 94 | t := GetTickCount() DIV 10; 95 | sec := t DIV 100; 96 | dsec := t MOD 100 97 | END Time; 98 | 99 | PROCEDURE _NEW*(size: INTEGER): INTEGER; 100 | RETURN Alloc(64, size) 101 | END _NEW; 102 | 103 | PROCEDURE _DISPOSE*(p: INTEGER): INTEGER; 104 | RETURN Free(p) 105 | END _DISPOSE; 106 | 107 | PROCEDURE init* (esp: INTEGER); 108 | VAR lib, p: INTEGER; 109 | BEGIN 110 | sys.MOVE(esp, sys.ADR(GetProcAddress), 4); 111 | sys.MOVE(esp + 4, sys.ADR(LoadLibraryA), 4); 112 | 113 | lib := LoadLibraryA(sys.ADR("kernel32.dll")); 114 | GetProc("GetTickCount", lib, sys.ADR(GetTickCount)); 115 | 116 | Time(sec, dsec); 117 | 118 | GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle)); 119 | GetProc("CreateFileA", lib, sys.ADR(CreateFile)); 120 | GetProc("CloseHandle", lib, sys.ADR(CloseHandle)); 121 | GetProc("OpenFile", lib, sys.ADR(OpenFile)); 122 | GetProc("ReadFile", lib, sys.ADR(ReadFile)); 123 | GetProc("WriteFile", lib, sys.ADR(WriteFile)); 124 | GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine)); 125 | GetProc("ExitProcess", lib, sys.ADR(ExitProcess)); 126 | GetProc("GlobalAlloc", lib, sys.ADR(Alloc)); 127 | GetProc("GlobalFree", lib, sys.ADR(Free)); 128 | GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer)); 129 | 130 | lib := LoadLibraryA(sys.ADR("msvcrt.dll")); 131 | GetProc("strncmp", lib, sys.ADR(strncmp)); 132 | 133 | lib := LoadLibraryA(sys.ADR("user32.dll")); 134 | GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA)); 135 | END init; 136 | 137 | END API. -------------------------------------------------------------------------------- /Lib/Windows32/Console.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Console; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | CONST 23 | 24 | Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3; 25 | Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7; 26 | DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11; 27 | LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15; 28 | 29 | VAR 30 | 31 | hConsoleOutput: INTEGER; 32 | 33 | PROCEDURE IntToCard16(i: INTEGER): sys.CARD16; 34 | VAR w: sys.CARD16; 35 | BEGIN 36 | sys.GET(sys.ADR(i), w) 37 | RETURN w 38 | END IntToCard16; 39 | 40 | PROCEDURE Card16ToInt(w: sys.CARD16): INTEGER; 41 | VAR i: INTEGER; 42 | BEGIN 43 | sys.PUT(sys.ADR(i), w) 44 | RETURN i 45 | END Card16ToInt; 46 | 47 | PROCEDURE CoordToInt(Coord: WINAPI.TCoord): INTEGER; 48 | VAR res: INTEGER; 49 | BEGIN 50 | sys.GET(sys.ADR(Coord), res) 51 | RETURN res 52 | END CoordToInt; 53 | 54 | PROCEDURE SetCursor*(X, Y: INTEGER); 55 | VAR Coord: WINAPI.TCoord; 56 | BEGIN 57 | Coord.X := IntToCard16(X); 58 | Coord.Y := IntToCard16(Y); 59 | WINAPI.SetConsoleCursorPosition(hConsoleOutput, CoordToInt(Coord)); 60 | END SetCursor; 61 | 62 | PROCEDURE GetCursor*(VAR X, Y: INTEGER); 63 | VAR ScrBufInfo: WINAPI.TConsoleScreenBufferInfo; 64 | BEGIN 65 | WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo); 66 | X := Card16ToInt(ScrBufInfo.dwCursorPosition.X); 67 | Y := Card16ToInt(ScrBufInfo.dwCursorPosition.Y) 68 | END GetCursor; 69 | 70 | PROCEDURE Cls*; 71 | VAR fill: INTEGER; ScrBufInfo: WINAPI.TConsoleScreenBufferInfo; 72 | BEGIN 73 | WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo); 74 | fill := Card16ToInt(ScrBufInfo.dwSize.X) * Card16ToInt(ScrBufInfo.dwSize.Y); 75 | WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, sys.ADR(fill)); 76 | WINAPI.FillConsoleOutputAttribute(hConsoleOutput, Card16ToInt(ScrBufInfo.wAttributes), fill, 0, sys.ADR(fill)); 77 | SetCursor(0, 0); 78 | END Cls; 79 | 80 | PROCEDURE SetColor*(FColor, BColor: INTEGER); 81 | BEGIN 82 | IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN 83 | WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor) 84 | END 85 | END SetColor; 86 | 87 | PROCEDURE GetCursorX*(): INTEGER; 88 | VAR ScrBufInfo: WINAPI.TConsoleScreenBufferInfo; 89 | BEGIN 90 | WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo) 91 | RETURN Card16ToInt(ScrBufInfo.dwCursorPosition.X) 92 | END GetCursorX; 93 | 94 | PROCEDURE GetCursorY*(): INTEGER; 95 | VAR ScrBufInfo: WINAPI.TConsoleScreenBufferInfo; 96 | BEGIN 97 | WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo) 98 | RETURN Card16ToInt(ScrBufInfo.dwCursorPosition.Y) 99 | END GetCursorY; 100 | 101 | BEGIN 102 | hConsoleOutput := WINAPI.GetStdHandle(-11); 103 | END Console. -------------------------------------------------------------------------------- /Lib/Windows32/DateTime.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE DateTime; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | CONST ERR* = -7.0D5; 23 | 24 | PROCEDURE Card16ToInt(w: sys.CARD16): INTEGER; 25 | VAR i: INTEGER; 26 | BEGIN 27 | sys.PUT(sys.ADR(i), w) 28 | RETURN i 29 | END Card16ToInt; 30 | 31 | PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): LONGREAL; 32 | VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL; 33 | BEGIN 34 | Res := ERR; 35 | IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) & 36 | (Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) & 37 | (Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) & 38 | (MSec >= 0) & (MSec <= 999) THEN 39 | M := "_303232332323"; 40 | IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN 41 | M[2] := "1" 42 | END; 43 | IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN 44 | DEC(Year); 45 | d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594; 46 | FOR i := 1 TO Month - 1 DO 47 | d := d + ORD(M[i]) - ORD("0") + 28 48 | END; 49 | Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec)) / 86400000.0D0 50 | END 51 | END 52 | RETURN Res 53 | END Encode; 54 | 55 | PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): BOOLEAN; 56 | VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR; 57 | 58 | PROCEDURE MonthDay(n: INTEGER): BOOLEAN; 59 | VAR Res: BOOLEAN; 60 | BEGIN 61 | Res := FALSE; 62 | IF d > ORD(M[n]) - ORD("0") + 28 THEN 63 | d := d - ORD(M[n]) + ORD("0") - 28; 64 | INC(Month); 65 | Res := TRUE 66 | END 67 | RETURN Res 68 | END MonthDay; 69 | 70 | BEGIN 71 | IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN 72 | d := FLOOR(Date); 73 | t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0); 74 | d := d + 693593; 75 | Year := 1; 76 | Month := 1; 77 | WHILE d > 0 DO 78 | d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)); 79 | INC(Year) 80 | END; 81 | IF d < 0 THEN 82 | DEC(Year); 83 | d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)) 84 | END; 85 | INC(d); 86 | M := "_303232332323"; 87 | IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN 88 | M[2] := "1" 89 | END; 90 | i := 1; 91 | flag := TRUE; 92 | WHILE flag & (i <= 12) DO 93 | flag := MonthDay(i); 94 | INC(i) 95 | END; 96 | Day := d; 97 | Hour := t DIV 3600000; 98 | t := t MOD 3600000; 99 | Min := t DIV 60000; 100 | t := t MOD 60000; 101 | Sec := t DIV 1000; 102 | MSec := t MOD 1000; 103 | Res := TRUE 104 | ELSE 105 | Res := FALSE 106 | END 107 | RETURN Res 108 | END Decode; 109 | 110 | PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER); 111 | VAR T: WINAPI.TSystemTime; 112 | BEGIN 113 | WINAPI.GetLocalTime(T); 114 | Year := Card16ToInt(T.Year); 115 | Month := Card16ToInt(T.Month); 116 | Day := Card16ToInt(T.Day); 117 | Hour := Card16ToInt(T.Hour); 118 | Min := Card16ToInt(T.Min); 119 | Sec := Card16ToInt(T.Sec); 120 | MSec := Card16ToInt(T.MSec) 121 | END Now; 122 | 123 | END DateTime. -------------------------------------------------------------------------------- /Lib/Windows32/Dir.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Dir; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | PROCEDURE Remove*(DirName: ARRAY OF CHAR): BOOLEAN; 23 | RETURN WINAPI.RemoveDirectory(sys.ADR(DirName[0])) # 0 24 | END Remove; 25 | 26 | PROCEDURE Exists*(DirName: ARRAY OF CHAR): BOOLEAN; 27 | VAR Code: SET; 28 | BEGIN 29 | Code := WINAPI.GetFileAttributes(sys.ADR(DirName[0])) 30 | RETURN (Code # {0..31}) & ({4} * Code # {}) 31 | END Exists; 32 | 33 | PROCEDURE Create*(DirName: ARRAY OF CHAR): BOOLEAN; 34 | RETURN WINAPI.CreateDirectory(sys.ADR(DirName[0]), NIL) # 0 35 | END Create; 36 | 37 | END Dir. -------------------------------------------------------------------------------- /Lib/Windows32/File.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE File; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | CONST 23 | 24 | OPEN_R* = 0; OPEN_W* = 1; OPEN_RW* = 2; 25 | SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2; 26 | 27 | PROCEDURE Exists*(FName: ARRAY OF CHAR): BOOLEAN; 28 | VAR FindData: WINAPI.TWin32FindData; Handle: INTEGER; 29 | BEGIN 30 | Handle := WINAPI.FindFirstFile(sys.ADR(FName[0]), FindData); 31 | IF Handle # -1 THEN 32 | WINAPI.FindClose(Handle); 33 | IF FindData.dwFileAttributes >= {4} THEN 34 | Handle := -1 35 | END 36 | END 37 | RETURN Handle # -1 38 | END Exists; 39 | 40 | PROCEDURE Delete*(FName: ARRAY OF CHAR): BOOLEAN; 41 | RETURN WINAPI.DeleteFile(sys.ADR(FName[0])) # 0 42 | END Delete; 43 | 44 | PROCEDURE Create*(FName: ARRAY OF CHAR): INTEGER; 45 | RETURN WINAPI.CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0) 46 | END Create; 47 | 48 | PROCEDURE Close*(F: INTEGER); 49 | BEGIN 50 | WINAPI.CloseHandle(F) 51 | END Close; 52 | 53 | PROCEDURE Open*(FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER; 54 | VAR ofstr: WINAPI.OFSTRUCT; 55 | BEGIN 56 | RETURN WINAPI.OpenFile(sys.ADR(FName[0]), ofstr, Mode) 57 | END Open; 58 | 59 | PROCEDURE Seek*(F, Offset, Origin: INTEGER): INTEGER; 60 | RETURN WINAPI.SetFilePointer(F, Offset, 0, Origin) 61 | END Seek; 62 | 63 | PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER; 64 | VAR res, n: INTEGER; 65 | BEGIN 66 | IF WINAPI.ReadFile(F, Buffer, Count, sys.ADR(n), NIL) = 0 THEN 67 | res := -1 68 | ELSE 69 | res := n 70 | END 71 | RETURN res 72 | END Read; 73 | 74 | PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER; 75 | VAR res, n: INTEGER; 76 | BEGIN 77 | IF WINAPI.WriteFile(F, Buffer, Count, sys.ADR(n), NIL) = 0 THEN 78 | res := -1 79 | ELSE 80 | res := n 81 | END 82 | RETURN res 83 | END Write; 84 | 85 | END File. -------------------------------------------------------------------------------- /Lib/Windows32/In.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE In; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | TYPE 23 | 24 | STRING = ARRAY 260 OF CHAR; 25 | 26 | VAR 27 | 28 | Done*: BOOLEAN; 29 | hConsoleInput: INTEGER; 30 | 31 | PROCEDURE digit(ch: CHAR): BOOLEAN; 32 | RETURN (ch >= "0") & (ch <= "9") 33 | END digit; 34 | 35 | PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN; 36 | VAR i: INTEGER; 37 | BEGIN 38 | i := 0; 39 | neg := FALSE; 40 | WHILE (s[i] <= 20X) & (s[i] # 0X) DO 41 | INC(i) 42 | END; 43 | IF s[i] = "-" THEN 44 | neg := TRUE; 45 | INC(i) 46 | ELSIF s[i] = "+" THEN 47 | INC(i) 48 | END; 49 | first := i; 50 | WHILE digit(s[i]) DO 51 | INC(i) 52 | END; 53 | last := i 54 | RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first]) 55 | END CheckInt; 56 | 57 | PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN; 58 | VAR i: INTEGER; min: STRING; 59 | BEGIN 60 | i := 0; 61 | min := "2147483648"; 62 | WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO 63 | INC(i) 64 | END 65 | RETURN i = 10 66 | END IsMinInt; 67 | 68 | PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER; 69 | CONST maxINT = 7FFFFFFFH; 70 | VAR i, n, res: INTEGER; flag, neg: BOOLEAN; 71 | BEGIN 72 | res := 0; 73 | flag := CheckInt(str, i, n, neg, FALSE); 74 | err := ~flag; 75 | IF flag & neg & IsMinInt(str, i) THEN 76 | flag := FALSE; 77 | neg := FALSE; 78 | res := 80000000H 79 | END; 80 | WHILE flag & digit(str[i]) DO 81 | IF res > maxINT DIV 10 THEN 82 | err := TRUE; 83 | flag := FALSE; 84 | res := 0 85 | ELSE 86 | res := res * 10; 87 | IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN 88 | err := TRUE; 89 | flag := FALSE; 90 | res := 0 91 | ELSE 92 | res := res + (ORD(str[i]) - ORD("0")); 93 | INC(i) 94 | END 95 | END 96 | END; 97 | IF neg THEN 98 | res := -res 99 | END 100 | RETURN res 101 | END StrToInt; 102 | 103 | PROCEDURE Space(s: STRING): BOOLEAN; 104 | VAR i: INTEGER; 105 | BEGIN 106 | i := 0; 107 | WHILE (s[i] # 0X) & (s[i] <= 20X) DO 108 | INC(i) 109 | END 110 | RETURN s[i] = 0X 111 | END Space; 112 | 113 | PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN; 114 | VAR i: INTEGER; Res: BOOLEAN; 115 | BEGIN 116 | Res := CheckInt(s, n, i, neg, TRUE); 117 | IF Res THEN 118 | IF s[i] = "." THEN 119 | INC(i); 120 | WHILE digit(s[i]) DO 121 | INC(i) 122 | END; 123 | IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN 124 | INC(i); 125 | IF (s[i] = "+") OR (s[i] = "-") THEN 126 | INC(i) 127 | END; 128 | Res := digit(s[i]); 129 | WHILE digit(s[i]) DO 130 | INC(i) 131 | END 132 | END 133 | END 134 | END 135 | RETURN Res & (s[i] <= 20X) 136 | END CheckReal; 137 | 138 | PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): LONGREAL; 139 | CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH; 140 | VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN; 141 | 142 | PROCEDURE part1(): BOOLEAN; 143 | BEGIN 144 | res := 0.0D0; 145 | d := 1.0D0; 146 | WHILE digit(str[i]) DO 147 | res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0"))); 148 | INC(i) 149 | END; 150 | IF str[i] = "." THEN 151 | INC(i); 152 | WHILE digit(str[i]) DO 153 | d := d / 10.0D0; 154 | res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d; 155 | INC(i) 156 | END 157 | END 158 | RETURN str[i] # 0X 159 | END part1; 160 | 161 | PROCEDURE part2(): BOOLEAN; 162 | BEGIN 163 | INC(i); 164 | m := 10.0D0; 165 | minus := FALSE; 166 | IF str[i] = "+" THEN 167 | INC(i) 168 | ELSIF str[i] = "-" THEN 169 | minus := TRUE; 170 | INC(i); 171 | m := 0.1D0 172 | END; 173 | scale := 0; 174 | err := FALSE; 175 | WHILE ~err & digit(str[i]) DO 176 | IF scale > maxINT DIV 10 THEN 177 | err := TRUE; 178 | res := 0.0D0 179 | ELSE 180 | scale := scale * 10; 181 | IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN 182 | err := TRUE; 183 | res := 0.0D0 184 | ELSE 185 | scale := scale + (ORD(str[i]) - ORD("0")); 186 | INC(i) 187 | END 188 | END 189 | END 190 | RETURN ~err 191 | END part2; 192 | 193 | PROCEDURE part3; 194 | VAR i: INTEGER; 195 | BEGIN 196 | err := FALSE; 197 | IF scale = maxINT THEN 198 | err := TRUE; 199 | res := 0.0D0 200 | END; 201 | i := 1; 202 | WHILE ~err & (i <= scale) DO 203 | IF ~minus & (res > maxDBL / m) THEN 204 | err := TRUE; 205 | res := 0.0D0 206 | ELSE 207 | res := res * m; 208 | INC(i) 209 | END 210 | END 211 | END part3; 212 | 213 | BEGIN 214 | IF CheckReal(str, i, neg) THEN 215 | IF part1() & part2() THEN 216 | part3 217 | END; 218 | IF neg THEN 219 | res := -res 220 | END 221 | ELSE 222 | res := 0.0D0; 223 | err := TRUE 224 | END 225 | RETURN res 226 | END StrToFloat; 227 | 228 | PROCEDURE String*(VAR s: ARRAY OF CHAR); 229 | VAR count: INTEGER; str: STRING; 230 | BEGIN 231 | WINAPI.ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0); 232 | str[256] := 0X; 233 | str[count] := 0X; 234 | COPY(str, s); 235 | Done := TRUE 236 | END String; 237 | 238 | PROCEDURE Char*(VAR x: CHAR); 239 | VAR str: STRING; 240 | BEGIN 241 | String(str); 242 | x := str[0]; 243 | Done := TRUE 244 | END Char; 245 | 246 | PROCEDURE Ln*; 247 | VAR str: STRING; 248 | BEGIN 249 | String(str); 250 | Done := TRUE 251 | END Ln; 252 | 253 | PROCEDURE LongReal*(VAR x: LONGREAL); 254 | VAR str: STRING; err: BOOLEAN; 255 | BEGIN 256 | err := FALSE; 257 | REPEAT 258 | String(str) 259 | UNTIL ~Space(str); 260 | x := StrToFloat(str, err); 261 | Done := ~err 262 | END LongReal; 263 | 264 | PROCEDURE Real*(VAR x: REAL); 265 | CONST maxREAL = 3.39E38; 266 | VAR y: LONGREAL; 267 | BEGIN 268 | LongReal(y); 269 | IF Done THEN 270 | IF ABS(y) > LONG(maxREAL) THEN 271 | x := 0.0; 272 | Done := FALSE 273 | ELSE 274 | x := SHORT(y) 275 | END 276 | END 277 | END Real; 278 | 279 | PROCEDURE Int*(VAR x: INTEGER); 280 | VAR str: STRING; err: BOOLEAN; 281 | BEGIN 282 | err := FALSE; 283 | REPEAT 284 | String(str) 285 | UNTIL ~Space(str); 286 | x := StrToInt(str, err); 287 | Done := ~err 288 | END Int; 289 | 290 | PROCEDURE Open*; 291 | BEGIN 292 | hConsoleInput := WINAPI.GetStdHandle(-10); 293 | Done := TRUE 294 | END Open; 295 | 296 | END In. -------------------------------------------------------------------------------- /Lib/Windows32/Math.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Math; 19 | 20 | IMPORT sys := SYSTEM; 21 | 22 | CONST pi* = 3.141592653589793D+00; 23 | e* = 2.718281828459045D+00; 24 | 25 | VAR INF*, negINF*: LONGREAL; 26 | 27 | PROCEDURE IsNan*(x: LONGREAL): BOOLEAN; 28 | VAR h, l: SET; 29 | BEGIN 30 | sys.GET(sys.ADR(x), l); 31 | sys.GET(sys.ADR(x) + 4, h); 32 | RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) 33 | END IsNan; 34 | 35 | PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; 36 | VAR h, l: SET; 37 | BEGIN 38 | sys.GET(sys.ADR(x), l); 39 | sys.GET(sys.ADR(x) + 4, h); 40 | RETURN (h * {20..30} = {20..30}) & (h * {0..19} = {}) & (l * {0..31} = {}) 41 | END IsInf; 42 | 43 | PROCEDURE Max(A, B: LONGREAL): LONGREAL; 44 | VAR Res: LONGREAL; 45 | BEGIN 46 | IF A > B THEN 47 | Res := A 48 | ELSE 49 | Res := B 50 | END 51 | RETURN Res 52 | END Max; 53 | 54 | PROCEDURE Min(A, B: LONGREAL): LONGREAL; 55 | VAR Res: LONGREAL; 56 | BEGIN 57 | IF A < B THEN 58 | Res := A 59 | ELSE 60 | Res := B 61 | END 62 | RETURN Res 63 | END Min; 64 | 65 | PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN; 66 | VAR Epsilon: LONGREAL; Res: BOOLEAN; 67 | BEGIN 68 | Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12); 69 | IF A > B THEN 70 | Res := (A - B) <= Epsilon 71 | ELSE 72 | Res := (B - A) <= Epsilon 73 | END 74 | RETURN Res 75 | END SameValue; 76 | 77 | PROCEDURE IsZero(x: LONGREAL): BOOLEAN; 78 | RETURN ABS(x) <= 1.0D-12 79 | END IsZero; 80 | 81 | PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL; 82 | BEGIN 83 | sys.CODE("DD4508D9FAC9C20800") 84 | RETURN 0.0D0 85 | END sqrt; 86 | 87 | PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL; 88 | BEGIN 89 | sys.CODE("DD4508D9FEC9C20800") 90 | RETURN 0.0D0 91 | END sin; 92 | 93 | PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL; 94 | BEGIN 95 | sys.CODE("DD4508D9FFC9C20800") 96 | RETURN 0.0D0 97 | END cos; 98 | 99 | PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL; 100 | BEGIN 101 | sys.CODE("DD4508D9F2DEC9C9C20800") 102 | RETURN 0.0D0 103 | END tan; 104 | 105 | PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL; 106 | BEGIN 107 | sys.CODE("DD4508DD4510D9F3C9C21000") 108 | RETURN 0.0D0 109 | END arctan2; 110 | 111 | PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL; 112 | BEGIN 113 | sys.CODE("D9EDDD4508D9F1C9C20800") 114 | RETURN 0.0D0 115 | END ln; 116 | 117 | PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL; 118 | BEGIN 119 | sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000") 120 | RETURN 0.0D0 121 | END log; 122 | 123 | PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL; 124 | BEGIN 125 | sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800") 126 | RETURN 0.0D0 127 | END exp; 128 | 129 | PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL; 130 | BEGIN 131 | sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800") 132 | RETURN 0.0D0 133 | END round; 134 | 135 | PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL; 136 | BEGIN 137 | sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800") 138 | RETURN 0.0D0 139 | END frac; 140 | 141 | PROCEDURE arcsin*(x: LONGREAL): LONGREAL; 142 | RETURN arctan2(x, sqrt(1.0D0 - x * x)) 143 | END arcsin; 144 | 145 | PROCEDURE arccos*(x: LONGREAL): LONGREAL; 146 | RETURN arctan2(sqrt(1.0D0 - x * x), x) 147 | END arccos; 148 | 149 | PROCEDURE arctan*(x: LONGREAL): LONGREAL; 150 | RETURN arctan2(x, 1.0D0) 151 | END arctan; 152 | 153 | PROCEDURE sinh*(x: LONGREAL): LONGREAL; 154 | VAR Res: LONGREAL; 155 | BEGIN 156 | IF IsZero(x) THEN 157 | Res := 0.0D0 158 | ELSE 159 | Res := (exp(x) - exp(-x)) / 2.0D0 160 | END 161 | RETURN Res 162 | END sinh; 163 | 164 | PROCEDURE cosh*(x: LONGREAL): LONGREAL; 165 | VAR Res: LONGREAL; 166 | BEGIN 167 | IF IsZero(x) THEN 168 | Res := 1.0D0 169 | ELSE 170 | Res := (exp(x) + exp(-x)) / 2.0D0 171 | END 172 | RETURN Res 173 | END cosh; 174 | 175 | PROCEDURE tanh*(x: LONGREAL): LONGREAL; 176 | VAR Res: LONGREAL; 177 | BEGIN 178 | IF IsZero(x) THEN 179 | Res := 0.0D0 180 | ELSE 181 | Res := sinh(x) / cosh(x) 182 | END 183 | RETURN Res 184 | END tanh; 185 | 186 | PROCEDURE arcsinh*(x: LONGREAL): LONGREAL; 187 | RETURN ln(x + sqrt((x * x) + 1.0D0)) 188 | END arcsinh; 189 | 190 | PROCEDURE arccosh*(x: LONGREAL): LONGREAL; 191 | RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0)) 192 | END arccosh; 193 | 194 | PROCEDURE arctanh*(x: LONGREAL): LONGREAL; 195 | VAR Res: LONGREAL; 196 | BEGIN 197 | IF SameValue(x, 1.0D0) THEN 198 | Res := INF 199 | ELSIF SameValue(x, -1.0D0) THEN 200 | Res := negINF 201 | ELSE 202 | Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x)) 203 | END 204 | RETURN Res 205 | END arctanh; 206 | 207 | PROCEDURE floor*(x: LONGREAL): LONGREAL; 208 | VAR f: LONGREAL; 209 | BEGIN 210 | f := frac(x); 211 | x := x - f; 212 | IF f < 0.0D0 THEN 213 | x := x - 1.0D0 214 | END 215 | RETURN x 216 | END floor; 217 | 218 | PROCEDURE ceil*(x: LONGREAL): LONGREAL; 219 | VAR f: LONGREAL; 220 | BEGIN 221 | f := frac(x); 222 | x := x - f; 223 | IF f > 0.0D0 THEN 224 | x := x + 1.0D0 225 | END 226 | RETURN x 227 | END ceil; 228 | 229 | PROCEDURE power*(base, exponent: LONGREAL): LONGREAL; 230 | VAR Res: LONGREAL; 231 | BEGIN 232 | IF exponent = 0.0D0 THEN 233 | Res := 1.0D0 234 | ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN 235 | Res := 0.0D0 236 | ELSE 237 | Res := exp(exponent * ln(base)) 238 | END 239 | RETURN Res 240 | END power; 241 | 242 | PROCEDURE sgn*(x: LONGREAL): INTEGER; 243 | VAR Res: INTEGER; 244 | BEGIN 245 | IF x > 0.0D0 THEN 246 | Res := 1 247 | ELSIF x < 0.0D0 THEN 248 | Res := -1 249 | ELSE 250 | Res := 0 251 | END 252 | RETURN Res 253 | END sgn; 254 | 255 | BEGIN 256 | sys.PUT(sys.ADR(INF), 0); 257 | sys.PUT(sys.ADR(INF) + 4, 7FF00000H); 258 | sys.PUT(sys.ADR(negINF), 0); 259 | sys.PUT(sys.ADR(negINF) + 4, 0FFF00000H); 260 | END Math. -------------------------------------------------------------------------------- /Lib/Windows32/Out.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Out; 19 | 20 | IMPORT sys := SYSTEM, WINAPI, Utils; 21 | 22 | CONST 23 | 24 | d = 1.0D0 - 5.0D-12; 25 | 26 | VAR 27 | 28 | hConsoleOutput: INTEGER; 29 | Realp: PROCEDURE (x: LONGREAL; width: INTEGER); 30 | 31 | PROCEDURE Utf8*(s: ARRAY OF CHAR); 32 | VAR str: ARRAY 512 OF CHAR; n: INTEGER; 33 | BEGIN 34 | COPY(s, str); 35 | WINAPI.WriteConsoleW(hConsoleOutput, sys.ADR(str), Utils.Utf8To16(s, str), sys.ADR(n), 0) 36 | END Utf8; 37 | 38 | PROCEDURE String*(s: ARRAY OF CHAR); 39 | VAR count: INTEGER; 40 | BEGIN 41 | WINAPI.WriteFile(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), NIL) 42 | END String; 43 | 44 | PROCEDURE Char*(x: CHAR); 45 | VAR count: INTEGER; 46 | BEGIN 47 | WINAPI.WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL) 48 | END Char; 49 | 50 | PROCEDURE WriteInt(x, n: INTEGER); 51 | VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN; 52 | BEGIN 53 | i := 0; 54 | IF n < 1 THEN 55 | n := 1 56 | END; 57 | IF x < 0 THEN 58 | x := -x; 59 | DEC(n); 60 | neg := TRUE 61 | END; 62 | REPEAT 63 | a[i] := CHR(x MOD 10 + ORD("0")); 64 | x := x DIV 10; 65 | INC(i) 66 | UNTIL x = 0; 67 | WHILE n > i DO 68 | Char(" "); 69 | DEC(n) 70 | END; 71 | IF neg THEN 72 | Char("-") 73 | END; 74 | REPEAT 75 | DEC(i); 76 | Char(a[i]) 77 | UNTIL i = 0 78 | END WriteInt; 79 | 80 | PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN; 81 | VAR h, l: SET; 82 | BEGIN 83 | sys.GET(sys.ADR(AValue), l); 84 | sys.GET(sys.ADR(AValue) + 4, h) 85 | RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) 86 | END IsNan; 87 | 88 | PROCEDURE IsInf(AValue: LONGREAL): BOOLEAN; 89 | VAR h, l: SET; 90 | BEGIN 91 | sys.GET(sys.ADR(AValue), l); 92 | sys.GET(sys.ADR(AValue) + 4, h) 93 | RETURN (h * {20..30} = {20..30}) & (h * {0..19} = {}) & (l * {0..31} = {}) 94 | END IsInf; 95 | 96 | PROCEDURE Int*(x, width: INTEGER); 97 | VAR i: INTEGER; 98 | BEGIN 99 | IF x # 80000000H THEN 100 | WriteInt(x, width) 101 | ELSE 102 | FOR i := 12 TO width DO 103 | Char(20X) 104 | END; 105 | String("-2147483648") 106 | END 107 | END Int; 108 | 109 | PROCEDURE OutInf(x: LONGREAL; width: INTEGER); 110 | VAR s: ARRAY 4 OF CHAR; i: INTEGER; 111 | BEGIN 112 | IF IsNan(x) THEN 113 | s := "Nan"; 114 | INC(width) 115 | ELSIF IsInf(x) & (x > 0.0D0) THEN 116 | s := "+Inf" 117 | ELSIF IsInf(x) & (x < 0.0D0) THEN 118 | s := "-Inf" 119 | END; 120 | FOR i := 1 TO width - 4 DO 121 | Char(" ") 122 | END; 123 | String(s) 124 | END OutInf; 125 | 126 | PROCEDURE Ln*; 127 | BEGIN 128 | Char(0DX); 129 | Char(0AX) 130 | END Ln; 131 | 132 | PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER); 133 | VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN; 134 | BEGIN 135 | IF IsNan(x) OR IsInf(x) THEN 136 | OutInf(x, width) 137 | ELSIF p < 0 THEN 138 | Realp(x, width) 139 | ELSE 140 | len := 0; 141 | minus := FALSE; 142 | IF x < 0.0D0 THEN 143 | minus := TRUE; 144 | INC(len); 145 | x := ABS(x) 146 | END; 147 | e := 0; 148 | WHILE x >= 10.0D0 DO 149 | x := x / 10.0D0; 150 | INC(e) 151 | END; 152 | IF e >= 0 THEN 153 | len := len + e + p + 1; 154 | IF x > 9.0D0 + d THEN 155 | INC(len) 156 | END; 157 | IF p > 0 THEN 158 | INC(len) 159 | END 160 | ELSE 161 | len := len + p + 2 162 | END; 163 | FOR i := 1 TO width - len DO 164 | Char(" ") 165 | END; 166 | IF minus THEN 167 | Char("-") 168 | END; 169 | y := x; 170 | WHILE (y < 1.0D0) & (y # 0.0D0) DO 171 | y := y * 10.0D0; 172 | DEC(e) 173 | END; 174 | IF e < 0 THEN 175 | IF x - LONG(FLT(FLOOR(x))) > d THEN 176 | Char("1"); 177 | x := 0.0D0 178 | ELSE 179 | Char("0"); 180 | x := x * 10.0D0 181 | END 182 | ELSE 183 | WHILE e >= 0 DO 184 | IF x - LONG(FLT(FLOOR(x))) > d THEN 185 | IF x > 9.0D0 THEN 186 | String("10") 187 | ELSE 188 | Char(CHR(FLOOR(x) + ORD("0") + 1)) 189 | END; 190 | x := 0.0D0 191 | ELSE 192 | Char(CHR(FLOOR(x) + ORD("0"))); 193 | x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 194 | END; 195 | DEC(e) 196 | END 197 | END; 198 | IF p > 0 THEN 199 | Char(".") 200 | END; 201 | WHILE p > 0 DO 202 | IF x - LONG(FLT(FLOOR(x))) > d THEN 203 | Char(CHR(FLOOR(x) + ORD("0") + 1)); 204 | x := 0.0D0 205 | ELSE 206 | Char(CHR(FLOOR(x) + ORD("0"))); 207 | x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 208 | END; 209 | DEC(p) 210 | END 211 | END 212 | END FixReal; 213 | 214 | PROCEDURE Real*(x: LONGREAL; width: INTEGER); 215 | VAR e, n, i: INTEGER; minus: BOOLEAN; 216 | BEGIN 217 | IF IsNan(x) OR IsInf(x) THEN 218 | OutInf(x, width) 219 | ELSE 220 | e := 0; 221 | n := 0; 222 | IF width > 23 THEN 223 | n := width - 23; 224 | width := 23 225 | ELSIF width < 9 THEN 226 | width := 9 227 | END; 228 | width := width - 5; 229 | IF x < 0.0D0 THEN 230 | x := -x; 231 | minus := TRUE 232 | ELSE 233 | minus := FALSE 234 | END; 235 | WHILE x >= 10.0D0 DO 236 | x := x / 10.0D0; 237 | INC(e) 238 | END; 239 | WHILE (x < 1.0D0) & (x # 0.0D0) DO 240 | x := x * 10.0D0; 241 | DEC(e) 242 | END; 243 | IF x > 9.0D0 + d THEN 244 | x := 1.0D0; 245 | INC(e) 246 | END; 247 | FOR i := 1 TO n DO 248 | Char(" ") 249 | END; 250 | IF minus THEN 251 | x := -x 252 | END; 253 | FixReal(x, width, width - 3); 254 | Char("E"); 255 | IF e >= 0 THEN 256 | Char("+") 257 | ELSE 258 | Char("-"); 259 | e := ABS(e) 260 | END; 261 | IF e < 100 THEN 262 | Char("0") 263 | END; 264 | IF e < 10 THEN 265 | Char("0") 266 | END; 267 | Int(e, 0) 268 | END 269 | END Real; 270 | 271 | PROCEDURE Open*; 272 | BEGIN 273 | hConsoleOutput := WINAPI.GetStdHandle(-11) 274 | END Open; 275 | 276 | BEGIN 277 | Realp := Real 278 | END Out. -------------------------------------------------------------------------------- /Lib/Windows32/RTL.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE RTL; 19 | 20 | IMPORT sys := SYSTEM, API; 21 | 22 | TYPE 23 | 24 | IntArray = ARRAY 2048 OF INTEGER; 25 | STRING = ARRAY 2048 OF CHAR; 26 | PROC = PROCEDURE; 27 | 28 | VAR 29 | 30 | SelfName, rtab: INTEGER; CloseProc: PROC; 31 | 32 | PROCEDURE [stdcall] _halt*(n: INTEGER); 33 | BEGIN 34 | API.ExitProcess(n) 35 | END _halt; 36 | 37 | PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); 38 | BEGIN 39 | ptr := API._NEW(size); 40 | IF ptr # 0 THEN 41 | sys.PUT(ptr, t); 42 | INC(ptr, 4) 43 | END 44 | END _newrec; 45 | 46 | PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); 47 | BEGIN 48 | IF ptr # 0 THEN 49 | DEC(ptr, 4); 50 | ptr := API._DISPOSE(ptr) 51 | END 52 | END _disprec; 53 | 54 | PROCEDURE [stdcall] _rset*(y, x: INTEGER); 55 | BEGIN 56 | sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") 57 | END _rset; 58 | 59 | PROCEDURE [stdcall] _inset*(y, x: INTEGER); 60 | BEGIN 61 | sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") 62 | END _inset; 63 | 64 | PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); 65 | BEGIN 66 | table := rtab; 67 | sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") 68 | END _checktype; 69 | 70 | PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); 71 | BEGIN 72 | sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") 73 | END _savearr; 74 | 75 | PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; 76 | VAR res: BOOLEAN; 77 | BEGIN 78 | res := dyn = stat; 79 | IF res THEN 80 | _savearr(size, source, dest) 81 | END 82 | RETURN res 83 | END _saverec; 84 | 85 | PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); 86 | VAR i, m: INTEGER; 87 | BEGIN 88 | m := bsize * idx; 89 | FOR i := 4 TO Dim + 2 DO 90 | m := m * Arr[i] 91 | END; 92 | IF (Arr[3] > idx) & (idx >= 0) THEN 93 | Arr[3] := c + m 94 | ELSE 95 | Arr[3] := 0 96 | END 97 | END _arrayidx; 98 | 99 | PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); 100 | BEGIN 101 | IF (Arr[3] > idx) & (idx >= 0) THEN 102 | Arr[3] := bsize * idx + c 103 | ELSE 104 | Arr[3] := 0 105 | END 106 | END _arrayidx1; 107 | 108 | PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); 109 | VAR i, j, t: INTEGER; 110 | BEGIN 111 | FOR i := 1 TO n DO 112 | t := Arr[0]; 113 | FOR j := 0 TO m + n - 1 DO 114 | Arr[j] := Arr[j + 1] 115 | END; 116 | Arr[m + n] := t 117 | END 118 | END _arrayrot; 119 | 120 | PROCEDURE Min(a, b: INTEGER): INTEGER; 121 | VAR res: INTEGER; 122 | BEGIN 123 | IF a < b THEN 124 | res := a 125 | ELSE 126 | res := b 127 | END 128 | RETURN res 129 | END Min; 130 | 131 | PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; 132 | BEGIN 133 | sys.CODE("8B4508"); // mov eax, [ebp + 08h] 134 | sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] 135 | sys.CODE("48"); // dec eax 136 | // L1: 137 | sys.CODE("40"); // inc eax 138 | sys.CODE("803800"); // cmp byte ptr [eax], 0 139 | sys.CODE("7403"); // jz L2 140 | sys.CODE("E2F8"); // loop L1 141 | sys.CODE("40"); // inc eax 142 | // L2: 143 | sys.CODE("2B4508"); // sub eax, [ebp + 08h] 144 | sys.CODE("C9"); // leave 145 | sys.CODE("C20800"); // ret 08h 146 | RETURN 0 147 | END _length; 148 | 149 | PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); 150 | BEGIN 151 | _savearr(Min(alen, blen), a, b); 152 | IF blen > alen THEN 153 | sys.PUT(b + alen, 0X) 154 | END 155 | END _strcopy; 156 | 157 | PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; 158 | VAR i: INTEGER; Res: BOOLEAN; 159 | BEGIN 160 | i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); 161 | IF i = 0 THEN 162 | i := _length(a) - _length(b) 163 | END; 164 | CASE op OF 165 | |0: Res := i = 0 166 | |1: Res := i # 0 167 | |2: Res := i < 0 168 | |3: Res := i > 0 169 | |4: Res := i <= 0 170 | |5: Res := i >= 0 171 | ELSE 172 | END 173 | RETURN Res 174 | END _strcmp; 175 | 176 | PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; 177 | VAR s: ARRAY 2 OF CHAR; 178 | BEGIN 179 | s[0] := b; 180 | s[1] := 0X; 181 | RETURN _strcmp(op, s, a) 182 | END _lstrcmp; 183 | 184 | PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; 185 | VAR s: ARRAY 2 OF CHAR; 186 | BEGIN 187 | s[0] := a; 188 | s[1] := 0X; 189 | RETURN _strcmp(op, b, s) 190 | END _rstrcmp; 191 | 192 | PROCEDURE Int(x: INTEGER; VAR str: STRING); 193 | VAR i, a, b: INTEGER; c: CHAR; 194 | BEGIN 195 | i := 0; 196 | a := 0; 197 | REPEAT 198 | str[i] := CHR(x MOD 10 + ORD("0")); 199 | x := x DIV 10; 200 | INC(i) 201 | UNTIL x = 0; 202 | b := i - 1; 203 | WHILE a < b DO 204 | c := str[a]; 205 | str[a] := str[b]; 206 | str[b] := c; 207 | INC(a); 208 | DEC(b) 209 | END; 210 | str[i] := 0X 211 | END Int; 212 | 213 | PROCEDURE StrAppend(VAR str: STRING; VAR pos: INTEGER; s: ARRAY OF CHAR); 214 | VAR i, n: INTEGER; 215 | BEGIN 216 | n := LEN(s); 217 | i := 0; 218 | WHILE (i < n) & (s[i] # 0X) DO 219 | str[pos] := s[i]; 220 | INC(pos); 221 | INC(i) 222 | END 223 | END StrAppend; 224 | 225 | PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); 226 | VAR msg, int: STRING; pos, n: INTEGER; 227 | BEGIN 228 | pos := 0; 229 | n := line MOD 16; 230 | line := line DIV 16; 231 | CASE n OF 232 | |1: StrAppend(msg, pos, "assertion failure") 233 | |2: StrAppend(msg, pos, "variable of a procedure type have NIL as value") 234 | |3: StrAppend(msg, pos, "typeguard error") 235 | |4: StrAppend(msg, pos, "inadmissible dynamic type") 236 | |5: StrAppend(msg, pos, "index check error") 237 | |6: StrAppend(msg, pos, "NIL pointer dereference") 238 | |7: StrAppend(msg, pos, "invalid value in case statement") 239 | |8: StrAppend(msg, pos, "division by zero") 240 | ELSE 241 | END; 242 | StrAppend(msg, pos, 0DX); 243 | StrAppend(msg, pos, 0AX); 244 | StrAppend(msg, pos, "module "); 245 | StrAppend(msg, pos, modname); 246 | StrAppend(msg, pos, 0DX); 247 | StrAppend(msg, pos, 0AX); 248 | StrAppend(msg, pos, "line "); 249 | Int(line, int); 250 | StrAppend(msg, pos, int); 251 | IF m = 2 THEN 252 | StrAppend(msg, pos, 0DX); 253 | StrAppend(msg, pos, 0AX); 254 | StrAppend(msg, pos, "code "); 255 | Int(code, int); 256 | StrAppend(msg, pos, int) 257 | END; 258 | API.DebugMsg(sys.ADR(msg), SelfName) 259 | END _assrt; 260 | 261 | PROCEDURE [stdcall] _close*; 262 | BEGIN 263 | IF CloseProc # NIL THEN 264 | CloseProc 265 | END 266 | END _close; 267 | 268 | PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); 269 | BEGIN 270 | API.zeromem(gsize, gadr); 271 | API.init(esp); 272 | SelfName := self; 273 | rtab := rec; 274 | CloseProc := NIL; 275 | END _init; 276 | 277 | PROCEDURE SetClose*(proc: PROC); 278 | BEGIN 279 | CloseProc := proc 280 | END SetClose; 281 | 282 | END RTL. -------------------------------------------------------------------------------- /Lib/Windows32/Read.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Read; 19 | 20 | IMPORT File, sys := SYSTEM; 21 | 22 | PROCEDURE Char*(F: INTEGER; VAR x: CHAR): BOOLEAN; 23 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) 24 | END Char; 25 | 26 | PROCEDURE Int*(F: INTEGER; VAR x: INTEGER): BOOLEAN; 27 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) 28 | END Int; 29 | 30 | PROCEDURE Real*(F: INTEGER; VAR x: REAL): BOOLEAN; 31 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) 32 | END Real; 33 | 34 | PROCEDURE LongReal*(F: INTEGER; VAR x: LONGREAL): BOOLEAN; 35 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) 36 | END LongReal; 37 | 38 | PROCEDURE Boolean*(F: INTEGER; VAR x: BOOLEAN): BOOLEAN; 39 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) 40 | END Boolean; 41 | 42 | PROCEDURE Set*(F: INTEGER; VAR x: SET): BOOLEAN; 43 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) 44 | END Set; 45 | 46 | PROCEDURE Card16*(F: INTEGER; VAR x: sys.CARD16): BOOLEAN; 47 | RETURN File.Read(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) 48 | END Card16; 49 | 50 | END Read. -------------------------------------------------------------------------------- /Lib/Windows32/Utils.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Utils; 19 | 20 | IMPORT sys := SYSTEM, WINAPI; 21 | 22 | CONST 23 | 24 | MAX_PARAM = 1024; 25 | 26 | VAR 27 | 28 | Params: ARRAY MAX_PARAM, 2 OF INTEGER; 29 | ParamCount*: INTEGER; 30 | 31 | PROCEDURE PutSeed*(seed: INTEGER); 32 | BEGIN 33 | WINAPI.srand(seed) 34 | END PutSeed; 35 | 36 | PROCEDURE Rnd*(range : INTEGER): INTEGER; 37 | RETURN WINAPI.rand() MOD range 38 | END Rnd; 39 | 40 | PROCEDURE GetChar(adr: INTEGER): CHAR; 41 | VAR res: CHAR; 42 | BEGIN 43 | sys.GET(adr, res) 44 | RETURN res 45 | END GetChar; 46 | 47 | PROCEDURE ParamParse; 48 | VAR p, count: INTEGER; c: CHAR; cond: INTEGER; 49 | 50 | PROCEDURE ChangeCond(A, B, C: INTEGER); 51 | BEGIN 52 | IF (c <= 20X) & (c # 0X) THEN 53 | cond := A 54 | ELSIF c = 22X THEN 55 | cond := B 56 | ELSIF c = 0X THEN 57 | cond := 6 58 | ELSE 59 | cond := C 60 | END 61 | END ChangeCond; 62 | 63 | BEGIN 64 | p := WINAPI.GetCommandLine(); 65 | cond := 0; 66 | count := 0; 67 | WHILE (count < MAX_PARAM) & (cond # 6) DO 68 | c := GetChar(p); 69 | CASE cond OF 70 | |0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END 71 | |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END 72 | |3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 73 | |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END 74 | |5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 75 | ELSE 76 | END; 77 | INC(p) 78 | END; 79 | ParamCount := count - 1 80 | END ParamParse; 81 | 82 | PROCEDURE Utf8To16*(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR): INTEGER; 83 | VAR i, j, L, u, N: INTEGER; 84 | BEGIN 85 | L := LEN(source); 86 | N := LEN(dest); 87 | N := N - ORD(ODD(N)) - 1; 88 | i := 0; 89 | j := 0; 90 | WHILE (i < L) & (j < N) & (source[i] # 0X) DO 91 | CASE source[i] OF 92 | |00X..7FX: u := ORD(source[i]); 93 | |0C1X..0DFX: 94 | u := LSL(ORD(source[i]) - 0C0H, 6); 95 | IF i + 1 < L THEN 96 | u := u + ROR(LSL(ORD(source[i + 1]), 26), 26); 97 | INC(i) 98 | END 99 | |0E1X..0EFX: 100 | u := LSL(ORD(source[i]) - 0E0H, 12); 101 | IF i + 1 < L THEN 102 | u := u + ROR(LSL(ORD(source[i + 1]), 26), 20); 103 | INC(i) 104 | END; 105 | IF i + 1 < L THEN 106 | u := u + ROR(LSL(ORD(source[i + 1]), 26), 26); 107 | INC(i) 108 | END 109 | (* |0F1X..0F7X: 110 | |0F9X..0FBX: 111 | |0FDX:*) 112 | ELSE 113 | END; 114 | INC(i); 115 | dest[j] := CHR(u MOD 256); 116 | INC(j); 117 | dest[j] := CHR(u DIV 256); 118 | INC(j); 119 | END; 120 | IF j < N THEN 121 | dest[j] := 0X; 122 | dest[j + 1] := 0X 123 | END 124 | RETURN j DIV 2 125 | END Utf8To16; 126 | 127 | PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER); 128 | VAR i, j, len: INTEGER; c: CHAR; 129 | BEGIN 130 | j := 0; 131 | IF n < ParamCount + 1 THEN 132 | len := LEN(str) - 1; 133 | i := Params[n, 0]; 134 | WHILE (j < len) & (i <= Params[n, 1]) DO 135 | c := GetChar(i); 136 | IF c # 22X THEN 137 | str[j] := c; 138 | INC(j) 139 | END; 140 | INC(i); 141 | END; 142 | END; 143 | str[j] := 0X 144 | END ParamStr; 145 | 146 | BEGIN 147 | ParamParse 148 | END Utils. -------------------------------------------------------------------------------- /Lib/Windows32/WINAPI.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE WINAPI; 19 | 20 | IMPORT sys := SYSTEM, API; 21 | 22 | CONST 23 | 24 | OFS_MAXPATHNAME* = 128; 25 | 26 | TYPE 27 | 28 | STRING = ARRAY 260 OF CHAR; 29 | 30 | TCoord* = RECORD 31 | X*, Y*: sys.CARD16 32 | END; 33 | 34 | TSmallRect* = RECORD 35 | Left*, Top*, Right*, Bottom*: sys.CARD16 36 | END; 37 | 38 | TConsoleScreenBufferInfo* = RECORD 39 | dwSize*: TCoord; 40 | dwCursorPosition*: TCoord; 41 | wAttributes*: sys.CARD16; 42 | srWindow*: TSmallRect; 43 | dwMaximumWindowSize*: TCoord 44 | END; 45 | 46 | TSystemTime* = RECORD 47 | Year*: sys.CARD16; 48 | Month*: sys.CARD16; 49 | DayOfWeek*: sys.CARD16; 50 | Day*: sys.CARD16; 51 | Hour*: sys.CARD16; 52 | Min*: sys.CARD16; 53 | Sec*: sys.CARD16; 54 | MSec*: sys.CARD16 55 | END; 56 | 57 | PSecurityAttributes* = POINTER TO TSecurityAttributes; 58 | 59 | TSecurityAttributes* = RECORD 60 | nLength*: INTEGER; 61 | lpSecurityDescriptor*: INTEGER; 62 | bInheritHandle*: INTEGER 63 | END; 64 | 65 | TFileTime* = RECORD 66 | dwLowDateTime*, dwHighDateTime*: INTEGER 67 | END; 68 | 69 | TWin32FindData* = RECORD 70 | dwFileAttributes*: SET; 71 | ftCreationTime*: TFileTime; 72 | ftLastAccessTime*: TFileTime; 73 | ftLastWriteTime*: TFileTime; 74 | nFileSizeHigh*: INTEGER; 75 | nFileSizeLow*: INTEGER; 76 | dwReserved0*: INTEGER; 77 | dwReserved1*: INTEGER; 78 | cFileName*: STRING; 79 | cAlternateFileName*: ARRAY 14 OF CHAR 80 | END; 81 | 82 | OFSTRUCT* = RECORD 83 | cBytes*: CHAR; 84 | fFixedDisk*: CHAR; 85 | nErrCode*: sys.CARD16; 86 | Reserved1*: sys.CARD16; 87 | Reserved2*: sys.CARD16; 88 | szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR 89 | END; 90 | 91 | POverlapped* = POINTER TO OVERLAPPED; 92 | 93 | OVERLAPPED* = RECORD 94 | Internal*: INTEGER; 95 | InternalHigh*: INTEGER; 96 | Offset*: INTEGER; 97 | OffsetHigh*: INTEGER; 98 | hEvent*: INTEGER 99 | END; 100 | 101 | VAR 102 | 103 | SetConsoleCursorPosition*: PROCEDURE [winapi] (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER; 104 | GetConsoleScreenBufferInfo*: PROCEDURE [winapi] (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER; 105 | FillConsoleOutputCharacter*: PROCEDURE [winapi] (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER; 106 | FillConsoleOutputAttribute*: PROCEDURE [winapi] (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER; 107 | SetConsoleTextAttribute*: PROCEDURE [winapi] (hConsoleOutput, wAttributes: INTEGER): INTEGER; 108 | GetStdHandle*: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER; 109 | GetLocalTime*: PROCEDURE [winapi] (T: TSystemTime); 110 | RemoveDirectory*: PROCEDURE [winapi] (lpPathName: INTEGER): INTEGER; 111 | GetFileAttributes*: PROCEDURE [winapi] (lpPathName: INTEGER): SET; 112 | CreateDirectory*: PROCEDURE [winapi] (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER; 113 | FindFirstFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER; 114 | DeleteFile*: PROCEDURE [winapi] (lpFileName: INTEGER): INTEGER; 115 | FindClose*: PROCEDURE [winapi] (hFindFile: INTEGER): INTEGER; 116 | CloseHandle*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER; 117 | CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode: INTEGER; 118 | lpSecurityAttributes: PSecurityAttributes; 119 | dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER; 120 | OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER; 121 | SetFilePointer*: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER; 122 | ReadFile*, WriteFile*: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; 123 | lpOverlapped: POverlapped): INTEGER; 124 | ReadConsole*: PROCEDURE [winapi] (hConsoleInput, lpBuffer, nNumberOfCharsToRead, 125 | lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER; 126 | GetCommandLine*: PROCEDURE [winapi] (): INTEGER; 127 | CreateWindowEx*: PROCEDURE [winapi] (dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y, 128 | nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam: INTEGER): INTEGER; 129 | GlobalAlloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER; 130 | GlobalFree*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER; 131 | MessageBox*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER; 132 | WriteConsoleW*: PROCEDURE [winapi] (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER; 133 | ExitProcess*: PROCEDURE [winapi] (code: INTEGER); 134 | WriteConsole*: PROCEDURE [winapi] (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, 135 | lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER; 136 | GetTickCount*: PROCEDURE [winapi] (): INTEGER; 137 | MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER; 138 | FreeLibrary*: PROCEDURE [winapi] (hLibModule: INTEGER): INTEGER; 139 | GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER; 140 | LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER; 141 | rand*: PROCEDURE [cdecl] (): INTEGER; 142 | srand*: PROCEDURE [cdecl] (seed: INTEGER); 143 | 144 | PROCEDURE GetProc(name: STRING; hMOD, adr: INTEGER); 145 | VAR H: INTEGER; 146 | BEGIN 147 | H := GetProcAddress(hMOD, sys.ADR(name[0])); 148 | ASSERT(H # 0); 149 | sys.PUT(adr, H); 150 | END GetProc; 151 | 152 | PROCEDURE init*; 153 | VAR lib: INTEGER; 154 | BEGIN 155 | LoadLibraryA := API.LoadLibraryA; 156 | GetProcAddress := API.GetProcAddress; 157 | GetTickCount := API.GetTickCount; 158 | MessageBoxA := API.MessageBoxA; 159 | ExitProcess := API.ExitProcess; 160 | CloseHandle := API.CloseHandle; 161 | sys.MOVE(sys.ADR(API.OpenFile), sys.ADR(OpenFile), 4); 162 | sys.MOVE(sys.ADR(API.ReadFile), sys.ADR(ReadFile), 4); 163 | sys.MOVE(sys.ADR(API.WriteFile), sys.ADR(WriteFile), 4); 164 | SetFilePointer := API.SetFilePointer; 165 | GetStdHandle := API.GetStdHandle; 166 | lib := LoadLibraryA(sys.ADR("kernel32.dll")); 167 | GetProc("SetConsoleCursorPosition", lib, sys.ADR(SetConsoleCursorPosition)); 168 | GetProc("GetConsoleScreenBufferInfo", lib, sys.ADR(GetConsoleScreenBufferInfo)); 169 | GetProc("FillConsoleOutputCharacterA", lib, sys.ADR(FillConsoleOutputCharacter)); 170 | GetProc("FillConsoleOutputAttribute", lib, sys.ADR(FillConsoleOutputAttribute)); 171 | GetProc("SetConsoleTextAttribute", lib, sys.ADR(SetConsoleTextAttribute)); 172 | GetProc("GetLocalTime", lib, sys.ADR(GetLocalTime)); 173 | GetProc("RemoveDirectoryA", lib, sys.ADR(RemoveDirectory)); 174 | GetProc("GetFileAttributesA", lib, sys.ADR(GetFileAttributes)); 175 | GetProc("CreateDirectoryA", lib, sys.ADR(CreateDirectory)); 176 | GetProc("FindFirstFileA", lib, sys.ADR(FindFirstFile)); 177 | GetProc("FindClose", lib, sys.ADR(FindClose)); 178 | GetProc("DeleteFileA", lib, sys.ADR(DeleteFile)); 179 | GetProc("CreateFileA", lib, sys.ADR(CreateFile)); 180 | GetProc("ReadConsoleA", lib, sys.ADR(ReadConsole)); 181 | GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine)); 182 | GetProc("WriteConsoleW", lib, sys.ADR(WriteConsoleW)); 183 | GetProc("GlobalAlloc", lib, sys.ADR(GlobalAlloc)); 184 | GetProc("GlobalFree", lib, sys.ADR(GlobalFree)); 185 | GetProc("WriteConsoleA", lib, sys.ADR(WriteConsole)); 186 | GetProc("FreeLibrary", lib, sys.ADR(FreeLibrary)); 187 | 188 | lib := LoadLibraryA(sys.ADR("user32.dll")); 189 | GetProc("CreateWindowExA", lib, sys.ADR(CreateWindowEx)); 190 | 191 | lib := LoadLibraryA(sys.ADR("msvcrt.dll")); 192 | GetProc("rand", lib, sys.ADR(rand)); 193 | GetProc("srand", lib, sys.ADR(srand)); 194 | END init; 195 | 196 | BEGIN 197 | init 198 | END WINAPI. -------------------------------------------------------------------------------- /Lib/Windows32/Write.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public License 15 | along with this program. If not, see . 16 | *) 17 | 18 | MODULE Write; 19 | 20 | IMPORT File, sys := SYSTEM; 21 | 22 | PROCEDURE Char*(F: INTEGER; x: CHAR): BOOLEAN; 23 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) 24 | END Char; 25 | 26 | PROCEDURE Int*(F: INTEGER; x: INTEGER): BOOLEAN; 27 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) 28 | END Int; 29 | 30 | PROCEDURE Real*(F: INTEGER; x: REAL): BOOLEAN; 31 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) 32 | END Real; 33 | 34 | PROCEDURE LongReal*(F: INTEGER; x: LONGREAL): BOOLEAN; 35 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) 36 | END LongReal; 37 | 38 | PROCEDURE Boolean*(F: INTEGER; x: BOOLEAN): BOOLEAN; 39 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) 40 | END Boolean; 41 | 42 | PROCEDURE Set*(F: INTEGER; x: SET): BOOLEAN; 43 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) 44 | END Set; 45 | 46 | PROCEDURE Card16*(F: INTEGER; x: sys.CARD16): BOOLEAN; 47 | RETURN File.Write(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) 48 | END Card16; 49 | 50 | END Write. -------------------------------------------------------------------------------- /License/copying.lesser.txt: -------------------------------------------------------------------------------- 1 |  GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /Oberon07.Report.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Spirit-of-Oberon/Oberon07akron1/6596c4f2694ca87deb0e7b020d58c6c4815fbf81/Oberon07.Report.pdf -------------------------------------------------------------------------------- /Samples/KolibriOS/HW.ob07: -------------------------------------------------------------------------------- 1 | MODULE HW; 2 | 3 | IMPORT sys := SYSTEM, KOSAPI; 4 | 5 | PROCEDURE WindowRedrawStatus(p1: INTEGER); 6 | VAR res: INTEGER; 7 | BEGIN 8 | res := KOSAPI.sysfunc2(0CH, p1) 9 | END WindowRedrawStatus; 10 | 11 | PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); 12 | VAR res: INTEGER; 13 | BEGIN 14 | res := KOSAPI.sysfunc6(0, LSL(x, 16) + w, LSL(y, 16) + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) 15 | END DefineAndDrawWindow; 16 | 17 | PROCEDURE WriteTextToWindow(x, y, color, textflags, text: INTEGER); 18 | VAR res: INTEGER; 19 | BEGIN 20 | res := KOSAPI.sysfunc5(4, LSL(x, 16) + y, color + LSL(textflags, 28), text, 0) 21 | END WriteTextToWindow; 22 | 23 | PROCEDURE WaitForEvent(): INTEGER; 24 | RETURN KOSAPI.sysfunc1(10) 25 | END WaitForEvent; 26 | 27 | PROCEDURE GetKey(VAR keyCode: CHAR); 28 | VAR res: INTEGER; 29 | BEGIN 30 | res := KOSAPI.sysfunc1(2) 31 | END GetKey; 32 | 33 | PROCEDURE ExitApp; 34 | VAR res: INTEGER; 35 | BEGIN 36 | res := KOSAPI.sysfunc1(-1) 37 | END ExitApp; 38 | 39 | PROCEDURE draw_window(header, text: ARRAY OF CHAR); 40 | BEGIN 41 | WindowRedrawStatus(1); 42 | DefineAndDrawWindow(200, 200, 200, 100, 0FFFFFFH, LSL(ORD({0,1}), 4) + 3, 0, 0, sys.ADR(header)); 43 | WriteTextToWindow(10, 10, 0, 8, sys.ADR(text)); 44 | WindowRedrawStatus(2); 45 | END draw_window; 46 | 47 | PROCEDURE Main(header, text: ARRAY OF CHAR); 48 | VAR keyCode: CHAR; 49 | BEGIN 50 | draw_window(header, text); 51 | WHILE TRUE DO 52 | CASE WaitForEvent() OF 53 | |1: draw_window(header, text) 54 | |2: GetKey(keyCode) 55 | |3: ExitApp 56 | ELSE 57 | END 58 | END 59 | END Main; 60 | 61 | BEGIN 62 | Main("HW", "Hello, world!") 63 | END HW. -------------------------------------------------------------------------------- /Samples/KolibriOS/HW_con.ob07: -------------------------------------------------------------------------------- 1 | MODULE HW_con; 2 | 3 | IMPORT Out, In, Console, DateTime, ConsoleLib; 4 | 5 | PROCEDURE OutInt2(n: INTEGER); 6 | BEGIN 7 | ASSERT((0 <= n) & (n <= 99)); 8 | IF n < 10 THEN 9 | Out.Char("0") 10 | END; 11 | Out.Int(n, 0) 12 | END OutInt2; 13 | 14 | PROCEDURE OutMonth(n: INTEGER); 15 | VAR str: ARRAY 4 OF CHAR; 16 | BEGIN 17 | CASE n OF 18 | | 1: str := "jan" 19 | | 2: str := "feb" 20 | | 3: str := "mar" 21 | | 4: str := "apr" 22 | | 5: str := "may" 23 | | 6: str := "jun" 24 | | 7: str := "jul" 25 | | 8: str := "aug" 26 | | 9: str := "sep" 27 | |10: str := "oct" 28 | |11: str := "nov" 29 | |12: str := "dec" 30 | END; 31 | Out.String(str) 32 | END OutMonth; 33 | 34 | PROCEDURE main; 35 | VAR Year, Month, Day, Hour, Min, Sec: INTEGER; 36 | BEGIN 37 | ConsoleLib.Open(-1, -1, -1, -1, "Hello!"); 38 | Out.String("Hello, world!"); Out.Ln; 39 | Console.SetColor(Console.Yellow, Console.Blue); 40 | DateTime.Now(Year, Month, Day, Hour, Min, Sec); 41 | Out.Int(Year, 0); Out.Char("-"); 42 | OutMonth(Month); Out.Char("-"); 43 | OutInt2(Day); Out.Char(" "); 44 | OutInt2(Hour); Out.Char(":"); 45 | OutInt2(Min); Out.Char(":"); 46 | OutInt2(Sec); 47 | In.Ln; 48 | ConsoleLib.exit(TRUE) 49 | END main; 50 | 51 | BEGIN 52 | main 53 | END HW_con. -------------------------------------------------------------------------------- /Samples/Linux32/HW.ob07: -------------------------------------------------------------------------------- 1 | MODULE HW; 2 | 3 | IMPORT sys := SYSTEM, LINAPI; 4 | 5 | VAR puts: PROCEDURE [cdecl] (pchar: INTEGER); 6 | 7 | PROCEDURE main; 8 | VAR dll, p, i: INTEGER; 9 | BEGIN 10 | dll := LINAPI.dlopen("libc.so.6", 1); 11 | ASSERT(dll # 0); 12 | p := LINAPI.dlsym(dll, "puts"); 13 | ASSERT(p # 0); 14 | sys.PUT(sys.ADR(puts), p); 15 | 16 | puts(sys.ADR("Hello, world!")); 17 | 18 | (*вывод параметров программы*) 19 | FOR i := 0 TO LINAPI.ParamCount - 1 DO 20 | puts(LINAPI.ParamStr(i)) 21 | END; 22 | 23 | (*вывод переменных окружения*) 24 | FOR i := 0 TO LINAPI.EnvCount - 1 DO 25 | puts(LINAPI.EnvStr(i)) 26 | END; 27 | 28 | END main; 29 | 30 | BEGIN 31 | main 32 | END HW. -------------------------------------------------------------------------------- /Samples/Windows32/HW.ob07: -------------------------------------------------------------------------------- 1 | MODULE HW; 2 | 3 | IMPORT In, Out; 4 | 5 | BEGIN 6 | In.Open; 7 | Out.Open; 8 | Out.String("Hello, world!"); 9 | In.Ln 10 | END HW. -------------------------------------------------------------------------------- /Source/Compiler/UTILS.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Compiler. 5 | 6 | Compiler is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Compiler is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Compiler. If not, see . 18 | *) 19 | 20 | MODULE UTILS; 21 | 22 | IMPORT sys := SYSTEM, API; 23 | 24 | CONST 25 | 26 | OS* = API.OS; 27 | Slash* = API.Slash; 28 | Ext* = ".ob07"; 29 | MAX_PATH = 1024; 30 | MAX_PARAM = 1024; 31 | Date* = 1385856000; (*2013-12-01*) 32 | 33 | TYPE 34 | 35 | STRING* = ARRAY MAX_PATH OF CHAR; 36 | 37 | ITEM* = POINTER TO rITEM; 38 | 39 | rITEM* = RECORD 40 | Next*, Prev*: ITEM 41 | END; 42 | 43 | LIST* = POINTER TO RECORD 44 | First*, Last*: ITEM; 45 | Count*: INTEGER 46 | END; 47 | 48 | VAR 49 | 50 | Params: ARRAY MAX_PARAM, 2 OF INTEGER; 51 | hConsoleOutput, hConsoleInput, ParamCount*, Line*, Unit*: INTEGER; 52 | win, kos, lnx: BOOLEAN; 53 | FileName: STRING; 54 | 55 | PROCEDURE SetFile*(F: STRING); 56 | BEGIN 57 | FileName := F 58 | END SetFile; 59 | 60 | PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; 61 | VAR h, l: SET; 62 | BEGIN 63 | sys.GET(sys.ADR(x), l); 64 | sys.GET(sys.ADR(x) + 4, h); 65 | RETURN (h * {20..30} = {20..30}) & (h * {0..19} = {}) & (l * {0..31} = {}) 66 | END IsInf; 67 | 68 | PROCEDURE GetChar(adr: INTEGER): CHAR; 69 | VAR res: CHAR; 70 | BEGIN 71 | sys.GET(adr, res) 72 | RETURN res 73 | END GetChar; 74 | 75 | PROCEDURE ParamParse(count: INTEGER); 76 | VAR c: CHAR; cond, p: INTEGER; 77 | 78 | PROCEDURE ChangeCond(A, B, C: INTEGER); 79 | BEGIN 80 | cond := C; 81 | CASE c OF 82 | |0X: cond := 6 83 | |1X..20X: cond := A 84 | |22X: cond := B 85 | ELSE 86 | END 87 | END ChangeCond; 88 | 89 | BEGIN 90 | p := API.GetCommandLine(); 91 | cond := 0; 92 | WHILE (count < MAX_PARAM) & (cond # 6) DO 93 | c := GetChar(p); 94 | CASE cond OF 95 | |0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END 96 | |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END 97 | |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END 98 | |3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 99 | ELSE 100 | END; 101 | INC(p) 102 | END; 103 | ParamCount := count - 1 104 | END ParamParse; 105 | 106 | PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER); 107 | VAR i, j, len: INTEGER; c: CHAR; 108 | BEGIN 109 | j := 0; 110 | IF n <= ParamCount THEN 111 | len := LEN(str) - 1; 112 | i := Params[n, 0]; 113 | WHILE (j < len) & (i <= Params[n, 1]) DO 114 | c := GetChar(i); 115 | IF c # 22X THEN 116 | str[j] := c; 117 | INC(j) 118 | END; 119 | INC(i) 120 | END 121 | END; 122 | str[j] := 0X 123 | END ParamStr; 124 | 125 | PROCEDURE GetMem*(n: INTEGER): INTEGER; 126 | RETURN API.Alloc(64, n) 127 | END GetMem; 128 | 129 | PROCEDURE CloseF*(F: INTEGER); 130 | BEGIN 131 | API.CloseHandle(F) 132 | END CloseF; 133 | 134 | PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER; 135 | VAR res: INTEGER; 136 | BEGIN 137 | API.ReadFile(F, Buffer, Count, sys.ADR(res), 0) 138 | RETURN res 139 | END Read; 140 | 141 | PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER; 142 | VAR res: INTEGER; 143 | BEGIN 144 | API.WriteFile(F, Buffer, Count, sys.ADR(res), 0) 145 | RETURN res 146 | END Write; 147 | 148 | PROCEDURE FileSize*(F: INTEGER): INTEGER; 149 | RETURN API.FileSize(F) 150 | END FileSize; 151 | 152 | PROCEDURE CharC*(x: CHAR); 153 | VAR res: INTEGER; 154 | BEGIN 155 | IF win OR lnx THEN 156 | res := Write(hConsoleOutput, sys.ADR(x), 1) 157 | ELSIF kos THEN 158 | API.DebugMsg(sys.ADR(x), 0) 159 | END 160 | END CharC; 161 | 162 | PROCEDURE Int*(x: INTEGER); 163 | VAR i: INTEGER; buf: ARRAY 11 OF INTEGER; 164 | BEGIN 165 | i := 0; 166 | REPEAT 167 | buf[i] := x MOD 10; 168 | x := x DIV 10; 169 | INC(i) 170 | UNTIL x = 0; 171 | REPEAT 172 | DEC(i); 173 | CharC(CHR(buf[i] + ORD("0"))) 174 | UNTIL i = 0 175 | END Int; 176 | 177 | PROCEDURE Ln*; 178 | BEGIN 179 | CharC(0DX); 180 | CharC(0AX) 181 | END Ln; 182 | 183 | PROCEDURE OutString*(str: ARRAY OF CHAR); 184 | VAR s: STRING; n: INTEGER; 185 | BEGIN 186 | IF win OR lnx THEN 187 | n := Write(hConsoleOutput, sys.ADR(str), LENGTH(str)) 188 | ELSIF kos THEN 189 | API.DebugMsg(sys.ADR(str), 0) 190 | END 191 | END OutString; 192 | 193 | PROCEDURE ErrMsg*(code: INTEGER); 194 | BEGIN 195 | OutString("error: "); Int(code); Ln; 196 | END ErrMsg; 197 | 198 | PROCEDURE ErrMsgPos*(line, col, code: INTEGER); 199 | VAR s: UTILS.STRING; 200 | BEGIN 201 | OutString("error: "); Int(code); Ln; 202 | OutString("file: "); OutString(FileName); Ln; 203 | OutString("line: "); Int(line); Ln; 204 | OutString("pos: "); Int(col); Ln; 205 | END ErrMsgPos; 206 | 207 | PROCEDURE UnitLine*(newUnit, newLine: INTEGER); 208 | BEGIN 209 | Unit := newUnit; 210 | Line := newLine 211 | END UnitLine; 212 | 213 | PROCEDURE min*(a, b: INTEGER): INTEGER; 214 | VAR Res: INTEGER; 215 | BEGIN 216 | IF a < b THEN 217 | Res := a 218 | ELSE 219 | Res := b 220 | END 221 | RETURN Res 222 | END min; 223 | 224 | PROCEDURE Align*(n: INTEGER): INTEGER; 225 | RETURN (4 - n MOD 4) MOD 4 226 | END Align; 227 | 228 | PROCEDURE CAP(x: CHAR): CHAR; 229 | BEGIN 230 | IF (x >= "a") & (x <= "z") THEN 231 | x := CHR(ORD(x) - 32) 232 | END 233 | RETURN x 234 | END CAP; 235 | 236 | PROCEDURE streq*(a, b: ARRAY OF CHAR): BOOLEAN; 237 | VAR i: INTEGER; 238 | BEGIN 239 | i := -1; 240 | REPEAT 241 | INC(i) 242 | UNTIL (CAP(a[i]) # CAP(b[i])) OR (a[i] = 0X) OR (b[i] = 0X) 243 | RETURN a[i] = b[i] 244 | END streq; 245 | 246 | PROCEDURE concat*(L, R: ARRAY OF CHAR; VAR Res: ARRAY OF CHAR); 247 | VAR i, j: INTEGER; 248 | BEGIN 249 | i := 0; 250 | WHILE (L[i] # 0X) & (i - 1 < LEN(Res)) DO 251 | Res[i] := L[i]; 252 | INC(i) 253 | END; 254 | j := 0; 255 | WHILE (R[j] # 0X) & (j + i - 1 < LEN(Res)) DO 256 | Res[j + i] := R[j]; 257 | INC(j) 258 | END; 259 | Res[j + i] := 0X 260 | END concat; 261 | 262 | PROCEDURE Push*(this: LIST; item: ITEM); 263 | BEGIN 264 | IF this.Count = 0 THEN 265 | this.First := item; 266 | item.Prev := NIL 267 | ELSE 268 | this.Last.Next := item; 269 | item.Prev := this.Last 270 | END; 271 | INC(this.Count); 272 | this.Last := item; 273 | item.Next := NIL 274 | END Push; 275 | 276 | PROCEDURE Insert*(this: LIST; item, prev: ITEM); 277 | BEGIN 278 | IF prev # this.Last THEN 279 | item.Next := prev.Next; 280 | item.Prev := prev; 281 | prev.Next := item; 282 | item.Next.Prev := item; 283 | INC(this.Count) 284 | ELSE 285 | Push(this, item) 286 | END 287 | END Insert; 288 | 289 | PROCEDURE Clear*(this: LIST); 290 | BEGIN 291 | this.First := NIL; 292 | this.Last := NIL; 293 | this.Count := 0 294 | END Clear; 295 | 296 | PROCEDURE CreateList*(): LIST; 297 | VAR nov: LIST; 298 | BEGIN 299 | NEW(nov) 300 | RETURN nov 301 | END CreateList; 302 | 303 | PROCEDURE Revers(VAR str: STRING); 304 | VAR a, b: INTEGER; c: CHAR; 305 | BEGIN 306 | a := 0; 307 | b := LENGTH(str) - 1; 308 | WHILE a < b DO 309 | c := str[a]; 310 | str[a] := str[b]; 311 | str[b] := c; 312 | INC(a); 313 | DEC(b) 314 | END 315 | END Revers; 316 | 317 | PROCEDURE Split*(FName: STRING; VAR Path, Name, Ext: STRING); 318 | VAR i, j, k: INTEGER; 319 | BEGIN 320 | i := LENGTH(FName) - 1; 321 | j := 0; 322 | WHILE (i >= 0) & (FName[i] # API.Slash) DO 323 | Name[j] := FName[i]; 324 | DEC(i); 325 | INC(j) 326 | END; 327 | Name[j] := 0X; 328 | Revers(Name); 329 | j := 0; 330 | k := LENGTH(Name) - 1; 331 | WHILE (k >= 0) & (Name[k] # ".") DO 332 | Ext[j] := Name[k]; 333 | DEC(k); 334 | INC(j) 335 | END; 336 | IF k >= 0 THEN 337 | Name[k] := 0X; 338 | Ext[j] := "."; 339 | INC(j) 340 | ELSE 341 | j := 0 342 | END; 343 | Ext[j] := 0X; 344 | Revers(Ext); 345 | j := i; 346 | FOR i := 0 TO j DO 347 | Path[i] := FName[i] 348 | END; 349 | Path[j + 1] := 0X 350 | END Split; 351 | 352 | PROCEDURE PChar*(s: ARRAY OF CHAR): INTEGER; 353 | RETURN sys.ADR(s) 354 | END PChar; 355 | 356 | PROCEDURE LinuxParam; 357 | VAR p, i, str: INTEGER; c: CHAR; 358 | BEGIN 359 | p := API.GetCommandLine(); 360 | sys.GET(p, ParamCount); 361 | sys.GET(p + 4, p); 362 | FOR i := 0 TO ParamCount - 1 DO 363 | sys.GET(p + i * 4, str); 364 | Params[i, 0] := str; 365 | REPEAT 366 | sys.GET(str, c); 367 | INC(str) 368 | UNTIL c = 0X; 369 | Params[i, 1] := str - 1 370 | END; 371 | DEC(ParamCount) 372 | END LinuxParam; 373 | 374 | PROCEDURE Time*; 375 | VAR sec, dsec: INTEGER; 376 | BEGIN 377 | OutString("elapsed time "); 378 | API.Time(sec, dsec); 379 | sec := sec - API.sec; 380 | dsec := dsec - API.dsec; 381 | dsec := dsec + sec * 100; 382 | Int(dsec DIV 100); CharC("."); 383 | dsec := dsec MOD 100; 384 | IF dsec < 10 THEN 385 | Int(0) 386 | END; 387 | Int(dsec); OutString(" sec"); UTILS.Ln 388 | END Time; 389 | 390 | PROCEDURE HALT*(n: INTEGER); 391 | BEGIN 392 | Time; 393 | API.ExitProcess(n) 394 | END HALT; 395 | 396 | PROCEDURE MemErr*(err: BOOLEAN); 397 | BEGIN 398 | IF err THEN 399 | ErrMsg(72); 400 | HALT(1) 401 | END 402 | END MemErr; 403 | 404 | PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER; 405 | VAR res: INTEGER; memerr: BOOLEAN; 406 | BEGIN 407 | IF win THEN 408 | res := API.CreateFile(sys.ADR(FName), 0C0000000H, 0, 0, 2, 80H, 0); 409 | IF res = -1 THEN 410 | res := 0 411 | END 412 | ELSIF kos THEN 413 | res := API.kos_OCFile(FName, 2, memerr); 414 | MemErr(memerr) 415 | ELSIF lnx THEN 416 | res := API.lnx_CreateFile(FName) 417 | END 418 | RETURN res 419 | END CreateF; 420 | 421 | PROCEDURE OpenF*(FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER; 422 | VAR ofstr: API.OFSTRUCT; res: INTEGER; memerr: BOOLEAN; 423 | BEGIN 424 | IF win THEN 425 | res := API.OpenFile(sys.ADR(FName), ofstr, Mode); 426 | IF res = -1 THEN 427 | res := 0 428 | END 429 | ELSIF kos THEN 430 | res := API.kos_OCFile(FName, 5, memerr); 431 | MemErr(memerr) 432 | ELSIF lnx THEN 433 | res := API.lnx_OpenFile(FName) 434 | END 435 | RETURN res 436 | END OpenF; 437 | 438 | PROCEDURE Init; 439 | VAR p, count: INTEGER; 440 | 441 | PROCEDURE last(VAR p: INTEGER); 442 | BEGIN 443 | WHILE GetChar(p) # 0X DO INC(p) END; 444 | DEC(p) 445 | END last; 446 | 447 | BEGIN 448 | IF win THEN 449 | hConsoleOutput := API.GetStdHandle(-11); 450 | ParamParse(0) 451 | ELSIF kos THEN 452 | ParamParse(1); 453 | Params[0, 0] := API.GetName(); 454 | Params[0, 1] := Params[0, 0]; 455 | last(Params[0, 1]) 456 | ELSIF lnx THEN 457 | hConsoleOutput := API.GetStdHandle(-11); 458 | LinuxParam 459 | END 460 | END Init; 461 | 462 | BEGIN 463 | win := API.OS = "WIN"; 464 | kos := API.OS = "KOS"; 465 | lnx := API.OS = "LNX"; 466 | Init 467 | END UTILS. -------------------------------------------------------------------------------- /Source/Editor/Dialogs.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE Dialogs; 21 | 22 | IMPORT sys := SYSTEM, TU := TextUtils, TE := TextEdit, Line, Text; 23 | 24 | CONST 25 | 26 | frDown = 0; 27 | frWholeWord = 1; 28 | frMatchCase = 2; 29 | 30 | TYPE 31 | 32 | STRING = ARRAY 2048 OF CHAR; 33 | 34 | OPENFILENAME = RECORD 35 | lStructSize, 36 | hwndOwner, 37 | hInstance, 38 | lpstrFilter, 39 | lpstrCustomFilter, 40 | nMaxCustFilter, 41 | nFilterIndex, 42 | lpstrFile, 43 | nMaxFile, 44 | lpstrFileTitle, 45 | nMaxFileTitle, 46 | lpstrInitialDir, 47 | lpstrTitle, 48 | flags: INTEGER; 49 | nFileOffset, 50 | nFileExtension: sys.CARD16; 51 | lpstrDefExt, 52 | lCustData, 53 | lpfnHook, 54 | lpTemplateName: INTEGER 55 | END; 56 | 57 | PGetOpenSaveFileName* = PROCEDURE [winapi] (Open: OPENFILENAME): INTEGER; 58 | 59 | LPCHOOSECOLOR = RECORD 60 | lStructSize, 61 | hwndOwner, 62 | hInstance, 63 | rgbResult, 64 | lpCustColors, 65 | Flags, 66 | lCustData, 67 | lpfnHook, 68 | lpTemplateName: INTEGER 69 | END; 70 | 71 | PChooseColor* = PROCEDURE [winapi] (lpcc: LPCHOOSECOLOR): BOOLEAN; 72 | 73 | LPFINDREPLACE* = POINTER TO FINDREPLACE; 74 | 75 | FINDREPLACE* = RECORD 76 | lStructSize, 77 | hwndOwner, 78 | hInstance: INTEGER; 79 | Flags: SET; 80 | lpstrFindWhat, 81 | lpstrReplaceWith: INTEGER; 82 | wFindWhatLen, 83 | wReplaceWithLen: sys.CARD16; 84 | lCustData: INTEGER; 85 | lpfnHook: INTEGER; 86 | lpTemplateName: INTEGER 87 | END; 88 | 89 | TFile = ARRAY 10240 OF Line.WCHAR; 90 | TFileName = ARRAY 1024 OF Line.WCHAR; 91 | 92 | TOpenSave = RECORD 93 | Filter: STRING; 94 | File: TFile; 95 | FileName, InitDir: TFileName 96 | END; 97 | 98 | TFindReplace = RECORD 99 | sFind, sReplace: Line.TEXTSTR 100 | END; 101 | 102 | PFindText* = PROCEDURE [winapi] (lpfr: LPFINDREPLACE): INTEGER; 103 | 104 | PGetCurrentDirectory* = PROCEDURE [winapi] (nBufferLength, lpBuffer: INTEGER): INTEGER; 105 | 106 | PRedraw = PROCEDURE; 107 | 108 | VAR 109 | 110 | OpenProc, SaveProc: PGetOpenSaveFileName; 111 | Open, Save: OPENFILENAME; 112 | rOpen, rSave: TOpenSave; 113 | 114 | Color: LPCHOOSECOLOR; 115 | ColorProc: PChooseColor; 116 | CustColors: ARRAY 16 OF INTEGER; 117 | 118 | Find*, Replace: LPFINDREPLACE; 119 | FindProc, ReplaceProc: PFindText; 120 | rFind, rReplace: TFindReplace; 121 | 122 | Redraw: PROCEDURE; 123 | GetCurrentDirectory: PGetCurrentDirectory; 124 | Window, hInstance: INTEGER; 125 | 126 | PROCEDURE Files*(): INTEGER; 127 | VAR i, length, a, n: INTEGER; 128 | BEGIN 129 | i := 0; 130 | a := 0; 131 | n := -1; 132 | length := LEN(rOpen.File); 133 | WHILE (i < length) & (a < 2) DO 134 | IF Line.iszero(rOpen.File[i]) THEN 135 | IF a = 0 THEN 136 | INC(n) 137 | END; 138 | INC(a) 139 | ELSE 140 | a := 0 141 | END; 142 | INC(i) 143 | END 144 | RETURN n 145 | END Files; 146 | 147 | PROCEDURE FileIdx2(VAR FileName: TFileName; File: TFile; idx: INTEGER): INTEGER; 148 | VAR i, length, n, dirlen: INTEGER; 149 | BEGIN 150 | dirlen := GetCurrentDirectory(LEN(FileName), sys.ADR(FileName)); 151 | FileName[dirlen][0] := "\"; 152 | FileName[dirlen][1] := 0X; 153 | INC(dirlen); 154 | FileName[dirlen][0] := 0X; 155 | FileName[dirlen][1] := 0X; 156 | i := 0; 157 | n := -1; 158 | length := LEN(File); 159 | WHILE (i < length) & (n < idx) DO 160 | IF Line.iszero(File[i]) THEN 161 | INC(n) 162 | END; 163 | INC(i) 164 | END; 165 | WHILE Line.notzero(File[i]) DO 166 | FileName[dirlen] := File[i]; 167 | INC(i); INC(dirlen); 168 | END; 169 | FileName[dirlen] := File[i] 170 | RETURN sys.ADR(FileName) 171 | END FileIdx2; 172 | 173 | PROCEDURE FileIdx*(open: BOOLEAN; idx: INTEGER): INTEGER; 174 | VAR res: INTEGER; 175 | BEGIN 176 | IF open THEN 177 | res := FileIdx2(rOpen.FileName, rOpen.File, idx) 178 | ELSE 179 | res := FileIdx2(rSave.FileName, rSave.File, idx) 180 | END 181 | RETURN res 182 | END FileIdx; 183 | 184 | PROCEDURE ClearFile(VAR F: TFile); 185 | VAR i: INTEGER; 186 | BEGIN 187 | FOR i := 0 TO LEN(F) - 1 DO 188 | F[i][0] := 0X; F[i][1] := 0X 189 | END 190 | END ClearFile; 191 | 192 | PROCEDURE SaveAsFile*(): INTEGER; 193 | VAR i, res: INTEGER; 194 | BEGIN 195 | res := 0; 196 | ClearFile(rSave.File); 197 | IF SaveProc(Save) # 0 THEN 198 | res := FileIdx(FALSE, -1) 199 | END 200 | RETURN res 201 | END SaveAsFile; 202 | 203 | PROCEDURE ExecuteOpen*(): BOOLEAN; 204 | VAR i: INTEGER; 205 | BEGIN 206 | ClearFile(rOpen.File) 207 | RETURN OpenProc(Open) # 0 208 | END ExecuteOpen; 209 | 210 | PROCEDURE InitOpenSave(VAR r: OPENFILENAME; VAR r2: TOpenSave); 211 | VAR tempFilter: STRING; n, i: INTEGER; 212 | BEGIN 213 | r.lpstrFilter := sys.ADR(r2.Filter); 214 | r.lpstrFile := sys.ADR(r2.File); 215 | r.nMaxFile := LEN(r2.File); 216 | r.lpstrInitialDir := sys.ADR(r2.InitDir); 217 | r.lStructSize := sys.SIZE(OPENFILENAME); 218 | r.hwndOwner := Window; 219 | r.hInstance := hInstance; 220 | tempFilter := "Oberon Module (*.ob07)"; TU.concat(tempFilter, 1X, tempFilter); 221 | TU.concat(tempFilter, "*.ob07", tempFilter); TU.concat(tempFilter, 1X, tempFilter); 222 | TU.concat(tempFilter, "Все файлы (*.*)", tempFilter); TU.concat(tempFilter, 1X, tempFilter); 223 | TU.concat(tempFilter, "*.*", tempFilter); TU.concat(tempFilter, 1X, tempFilter); TU.concat(tempFilter, 1X, tempFilter); 224 | n := TU.Utf8To16(tempFilter, r2.Filter); 225 | FOR i := 0 TO n * 2 - 1 BY 2 DO 226 | IF (r2.Filter[i] = 1X) & (r2.Filter[i + 1] = 0X) THEN 227 | r2.Filter[i] := 0X 228 | END 229 | END; 230 | r.nFilterIndex := 1; 231 | r.lpstrFileTitle := r.lpstrFile; 232 | r.nMaxFileTitle := r.nMaxFile; 233 | r.lpstrTitle := 0 234 | END InitOpenSave; 235 | 236 | PROCEDURE InitOpen*(proc: PGetOpenSaveFileName); 237 | BEGIN 238 | OpenProc := proc; 239 | Open.flags := ORD({2, 9, 19}); 240 | InitOpenSave(Open, rOpen) 241 | END InitOpen; 242 | 243 | PROCEDURE InitSave*(proc: PGetOpenSaveFileName); 244 | VAR tempFilter: STRING; n, i: INTEGER; 245 | BEGIN 246 | SaveProc := proc; 247 | Save.flags := ORD({1, 2, 19}); 248 | InitOpenSave(Save, rSave) 249 | END InitSave; 250 | 251 | PROCEDURE ExecuteColor*(color: INTEGER): INTEGER; 252 | BEGIN 253 | Color.rgbResult := color; 254 | ColorProc(Color) 255 | RETURN Color.rgbResult 256 | END ExecuteColor; 257 | 258 | PROCEDURE InitColor*(proc: PChooseColor); 259 | BEGIN 260 | ColorProc := proc; 261 | Color.lStructSize := sys.SIZE(LPCHOOSECOLOR); 262 | Color.hwndOwner := Window; 263 | Color.hInstance := hInstance; 264 | Color.lpCustColors := sys.ADR(CustColors); 265 | Color.lCustData := sys.ADR(Color); 266 | Color.lpfnHook := 0; 267 | Color.lpTemplateName := 0; 268 | Color.Flags := 1 269 | END InitColor; 270 | 271 | PROCEDURE ExecuteFind*; 272 | BEGIN 273 | FindProc(Find) 274 | END ExecuteFind; 275 | 276 | PROCEDURE ExecuteReplace*; 277 | BEGIN 278 | ReplaceProc(Replace) 279 | END ExecuteReplace; 280 | 281 | PROCEDURE FindText(str: ARRAY OF Line.WCHAR; VAR pos: INTEGER; Case, Whole, Frw: BOOLEAN): Line.LINE; 282 | VAR res: Line.LINE; 283 | BEGIN 284 | IF (TE.f # NIL) & (TE.f.txt # NIL) THEN 285 | res := Text.Find(TE.f.txt, str, pos, Case, Whole, Frw) 286 | END; 287 | Redraw 288 | RETURN res 289 | END FindText; 290 | 291 | PROCEDURE ReplaceText(find, repl: ARRAY OF Line.WCHAR; All, Case, Whole: BOOLEAN): INTEGER; 292 | VAR res: INTEGER; 293 | BEGIN 294 | IF (TE.f # NIL) & (TE.f.txt # NIL) THEN 295 | res := Text.Replace(TE.f.txt, find, repl, All, Case, Whole) 296 | END; 297 | Redraw 298 | RETURN res 299 | END ReplaceText; 300 | 301 | PROCEDURE FindFail(pFind: INTEGER); 302 | VAR str1, str2, str3: TU.STRING8; n: INTEGER; 303 | BEGIN 304 | TE.Utf16To8(str3, pFind); 305 | n := TU.Utf8To16("Oberon-07", str1); 306 | str2 := "не удается найти "; 307 | TU.concat(str2, 22X, str2); 308 | TU.concat(str2, str3, str2); 309 | TU.concat(str2, 22X, str2); 310 | n := TU.Utf8To16(str2, str3); 311 | TU.MessageBox(Window, sys.ADR(str3), sys.ADR(str1), 64) 312 | END FindFail; 313 | 314 | PROCEDURE FindNext*(lpf: LPFINDREPLACE); 315 | VAR pos: INTEGER; res: Line.LINE; sFind: Line.TEXTSTR; 316 | BEGIN 317 | sys.MOVE(lpf.lpstrFindWhat, sys.ADR(sFind), sys.SIZE(Line.TEXTSTR) DIV 2); 318 | res := FindText(sFind, pos, frMatchCase IN lpf.Flags, frWholeWord IN lpf.Flags, frDown IN lpf.Flags); 319 | IF res = NIL THEN 320 | FindFail(lpf.lpstrFindWhat) 321 | END 322 | END FindNext; 323 | 324 | PROCEDURE FRProc*(lpfr: LPFINDREPLACE); 325 | VAR n: INTEGER; all: BOOLEAN; int: ARRAY 11 OF CHAR; str1, str2: TU.STRING8; 326 | BEGIN 327 | n := -1; 328 | all := FALSE; 329 | IF 3 IN lpfr.Flags THEN 330 | FindNext(lpfr) 331 | ELSIF 4 IN lpfr.Flags THEN 332 | n := ReplaceText(rReplace.sFind, rReplace.sReplace, FALSE, frMatchCase IN Replace.Flags, frWholeWord IN Replace.Flags) 333 | ELSIF 5 IN lpfr.Flags THEN 334 | n := ReplaceText(rReplace.sFind, rReplace.sReplace, TRUE, frMatchCase IN Replace.Flags, frWholeWord IN Replace.Flags); 335 | all := TRUE 336 | END; 337 | IF n = 0 THEN 338 | FindFail(sys.ADR(rReplace.sFind)) 339 | ELSIF all THEN 340 | TU.IntToStr(n, int); 341 | str1 := "сделано замен: "; 342 | TU.concat(str1, int, str1); 343 | n := TU.Utf8To16(str1, str2); 344 | n := TU.Utf8To16("Oberon-07", str1); 345 | TU.MessageBox(Window, sys.ADR(str2), sys.ADR(str1), 64) 346 | END 347 | END FRProc; 348 | 349 | PROCEDURE InitFR(r: LPFINDREPLACE; r2: TFindReplace); 350 | BEGIN 351 | r.lStructSize := sys.SIZE(FINDREPLACE); 352 | r.hwndOwner := Window; 353 | r.hInstance := hInstance; 354 | r.Flags := {frDown}; 355 | r.lpstrFindWhat := sys.ADR(r2.sFind); 356 | r.lpstrReplaceWith := sys.ADR(r2.sReplace); 357 | sys.PUT(sys.ADR(r.wFindWhatLen), LEN(r2.sFind)); 358 | r.wReplaceWithLen := r.wFindWhatLen; 359 | r.lCustData := 0; 360 | r.lpfnHook := 0; 361 | r.lpTemplateName := 0 362 | END InitFR; 363 | 364 | PROCEDURE InitFind*(proc: PFindText); 365 | BEGIN 366 | InitFR(Find, rFind); 367 | FindProc := proc 368 | END InitFind; 369 | 370 | PROCEDURE InitReplace*(proc: PFindText); 371 | BEGIN 372 | InitFR(Replace, rReplace); 373 | ReplaceProc := proc 374 | END InitReplace; 375 | 376 | PROCEDURE Init*(pRedraw: PRedraw; GetCurDir: PGetCurrentDirectory; wnd, hinst: INTEGER); 377 | BEGIN 378 | NEW(Find); NEW(Replace); 379 | Redraw := pRedraw; 380 | GetCurrentDirectory := GetCurDir; 381 | Window := wnd; 382 | hInstance := hinst 383 | END Init; 384 | 385 | END Dialogs. -------------------------------------------------------------------------------- /Source/Editor/Lexer.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE Lexer; 21 | 22 | IMPORT Line, TU := TextUtils, List; 23 | 24 | VAR 25 | 26 | Colors: TU.TColors; TextColor: INTEGER; 27 | str: Line.TEXTSTR; pos, length, comin: INTEGER; kw: ARRAY 64, 20 OF Line.WCHAR; kwcount, stpos: INTEGER; 28 | CurLine: Line.LINE; comstr: BOOLEAN; 29 | 30 | PROCEDURE SetLine*(L: Line.LINE); 31 | BEGIN 32 | CurLine := L; 33 | str := L.str; 34 | length := L.length; 35 | pos := -1; 36 | comin := L.comin; 37 | L.comout := 0; 38 | END SetLine; 39 | 40 | PROCEDURE EnterKW(key: ARRAY OF CHAR); 41 | VAR i: INTEGER; 42 | BEGIN 43 | WHILE key[i] # 0X DO 44 | kw[kwcount][i][0] := key[i]; 45 | kw[kwcount][i][1] := 0X; 46 | INC(i) 47 | END; 48 | kw[kwcount][i][0] := 0X; 49 | kw[kwcount][i][1] := 0X; 50 | INC(kwcount) 51 | END EnterKW; 52 | 53 | PROCEDURE Cap(ch: CHAR; reg: BOOLEAN): CHAR; 54 | BEGIN 55 | IF ~reg & (ch >= "a") & (ch <= "z") THEN 56 | ch := CHR(ORD(ch) - 32) 57 | END 58 | RETURN ch 59 | END Cap; 60 | 61 | PROCEDURE CheckKW(pos, len, a, b: INTEGER; reg: BOOLEAN): BOOLEAN; 62 | VAR i, j: INTEGER; res: BOOLEAN; 63 | BEGIN 64 | i := a; 65 | res := FALSE; 66 | WHILE (i <= b) & ~res DO 67 | j := 0; 68 | WHILE (j <= len) & (kw[i][j][0] = Cap(str[j + pos][0], reg)) & (kw[i][j][1] = str[j + pos][1]) DO 69 | INC(j) 70 | END; 71 | res := (j > len) & (kw[i][j][0] = 0X) & (kw[i][j][1] = 0X); 72 | INC(i) 73 | END 74 | RETURN res 75 | END CheckKW; 76 | 77 | PROCEDURE GetChar(): INTEGER; 78 | BEGIN 79 | INC(pos) 80 | RETURN ORD(str[pos][0]) + LSL(ORD(str[pos][1]), 8) 81 | END GetChar; 82 | 83 | PROCEDURE Ident; 84 | VAR flag: BOOLEAN; 85 | BEGIN 86 | DEC(pos); 87 | REPEAT 88 | CASE GetChar() OF 89 | |41H..5AH, 61H..7AH, 5FH, 30H..39H: flag := FALSE 90 | ELSE 91 | flag := TRUE 92 | END 93 | UNTIL flag 94 | END Ident; 95 | 96 | PROCEDURE Num(): BOOLEAN; 97 | VAR flag, hexchar, hex, r, scale: BOOLEAN; 98 | BEGIN 99 | r := FALSE; 100 | hex := FALSE; 101 | hexchar := FALSE; 102 | DEC(pos); 103 | REPEAT 104 | flag := TRUE; 105 | CASE GetChar() OF 106 | |30H..39H: flag := FALSE 107 | |41H..46H: hex := TRUE; flag := FALSE 108 | |48H: INC(pos) 109 | |58H: INC(pos); hexchar := TRUE 110 | |2EH: r := GetChar() # 2EH; DEC(pos) 111 | ELSE 112 | END 113 | UNTIL flag; 114 | IF r THEN 115 | scale := FALSE; 116 | REPEAT 117 | flag := TRUE; 118 | CASE GetChar() OF 119 | |30H..39H: flag := FALSE 120 | |44H, 45H: scale := TRUE; IF ~((GetChar() - 20H) IN {0BH, 0DH}) THEN DEC(pos) END; 121 | ELSE 122 | END 123 | UNTIL flag 124 | END; 125 | IF scale THEN 126 | REPEAT 127 | CASE GetChar() OF 128 | |30H..39H: flag := FALSE 129 | ELSE 130 | flag := TRUE 131 | END 132 | UNTIL flag 133 | END 134 | RETURN hexchar 135 | END Num; 136 | 137 | PROCEDURE String(): BOOLEAN; 138 | VAR flag, eol: BOOLEAN; 139 | BEGIN 140 | eol := FALSE; 141 | flag := FALSE; 142 | REPEAT 143 | CASE GetChar() OF 144 | | 0H: flag := TRUE; eol := TRUE 145 | |22H: flag := TRUE 146 | ELSE 147 | END 148 | UNTIL flag 149 | RETURN eol 150 | END String; 151 | 152 | PROCEDURE Comment(VAR deep: INTEGER): BOOLEAN; 153 | VAR flag, eol: BOOLEAN; 154 | BEGIN 155 | eol := FALSE; 156 | flag := FALSE; 157 | REPEAT 158 | CASE GetChar() OF 159 | | 0H: flag := TRUE; eol := TRUE 160 | |2AH: 161 | IF GetChar() = 29H THEN 162 | DEC(deep); 163 | flag := deep = 0 164 | ELSE 165 | DEC(pos) 166 | END 167 | |28H: 168 | IF GetChar() = 2AH THEN 169 | INC(deep) 170 | ELSE 171 | DEC(pos) 172 | END 173 | ELSE 174 | END 175 | UNTIL flag 176 | RETURN eol 177 | END Comment; 178 | 179 | PROCEDURE GetLex*(VAR col, len: INTEGER): INTEGER; 180 | VAR c, color, deep: INTEGER; flag, s, eol: BOOLEAN; 181 | BEGIN 182 | IF comin = 0 THEN 183 | flag := FALSE; 184 | color := TextColor; 185 | col := pos; 186 | len := 0; 187 | c := GetChar(); 188 | ELSE 189 | col := 0; 190 | eol := Comment(comin); 191 | len := pos - col; 192 | color := Colors[TU.cCom]; 193 | IF ~eol THEN 194 | INC(len); 195 | INC(pos) 196 | ELSE 197 | CurLine.comout := comin; 198 | comstr := TRUE 199 | END; 200 | c := -1 201 | END; 202 | flag := TRUE; 203 | CASE c OF 204 | |0FFFFFFFFH: comin := 0; 205 | |41H..5AH, 61H..7AH, 5FH: 206 | col := pos; 207 | Ident; 208 | len := pos - col; 209 | IF CheckKW(col, len - 1, 0, stpos - 1, TRUE) THEN 210 | color := Colors[TU.cKey] 211 | ELSIF CheckKW(col, len - 1, stpos, kwcount - 1, TRUE) THEN 212 | color := Colors[TU.cStId] 213 | END; 214 | |0H: color := -1; 215 | |22H: 216 | col := pos; 217 | eol := String(); 218 | len := pos - col; 219 | color := Colors[TU.cStr]; 220 | IF ~eol THEN 221 | INC(len); 222 | INC(pos) 223 | ELSE 224 | comstr := TRUE 225 | END 226 | |28H: 227 | IF GetChar() = 2AH THEN 228 | col := pos - 1; 229 | deep := 1; 230 | eol := Comment(deep); 231 | len := pos - col; 232 | color := Colors[TU.cCom]; 233 | IF ~eol THEN 234 | INC(len); 235 | INC(pos) 236 | ELSE 237 | CurLine.comout := deep; 238 | comstr := TRUE 239 | END 240 | ELSE 241 | flag := FALSE; 242 | DEC(pos) 243 | END 244 | |30H..39H: 245 | col := pos; 246 | s := Num(); 247 | len := pos - col; 248 | IF s THEN 249 | color := Colors[TU.cStr] 250 | ELSE 251 | color := Colors[TU.cNum] 252 | END; 253 | |2FH: 254 | IF GetChar() = 2FH THEN 255 | col := pos - 1; 256 | len := 1; 257 | REPEAT 258 | INC(len) 259 | UNTIL GetChar() = 0H; 260 | color := Colors[TU.cCom]; 261 | comstr := TRUE 262 | ELSE 263 | flag := FALSE; 264 | DEC(pos) 265 | END 266 | ELSE 267 | flag := FALSE 268 | END; 269 | IF ~flag THEN len := 1; col := pos ELSE DEC(pos) END 270 | RETURN color 271 | END GetLex; 272 | 273 | PROCEDURE CommentTable*(L: Line.LINE); 274 | VAR lexcol, lexlen, i, dif1, dif2, n, m: INTEGER; nov: Line.ComItem; 275 | BEGIN 276 | n := L.comin; 277 | m := L.comout; 278 | List.Clear(L.ComTab); 279 | i := -1; 280 | REPEAT 281 | INC(i); 282 | L.comin := i; 283 | SetLine(L); 284 | WHILE GetLex(lexcol, lexlen) # -1 DO END; 285 | NEW(nov); 286 | nov.comout := L.comout; 287 | nov.comin := L.comin; 288 | List.Push(L.ComTab, nov); 289 | IF i > 0 THEN 290 | dif2 := dif1 291 | END; 292 | dif1 := nov.comout - nov.comin; 293 | UNTIL (i > 0) & (dif1 = dif2); 294 | List.Pop(L.ComTab); 295 | List.Pop(L.ComTab); 296 | L.dif := dif1; 297 | L.comin := n; 298 | L.comout := m 299 | END CommentTable; 300 | 301 | PROCEDURE Upper(this: Line.LINE; pos: INTEGER); 302 | VAR n, i: INTEGER; 303 | BEGIN 304 | n := pos; 305 | WHILE (n >= 0) & TU.Small(this.str[n]) DO 306 | DEC(n); 307 | END; 308 | IF (n < 0) OR ~TU.IdentChar(this.str[n]) THEN 309 | INC(n); 310 | str := this.str; 311 | IF CheckKW(n, pos - n, 0, 63, FALSE) THEN 312 | FOR i := n TO pos DO 313 | TU.CAP(this.str[i]) 314 | END 315 | END 316 | END 317 | END Upper; 318 | 319 | PROCEDURE autocaps(ch: Line.WCHAR): BOOLEAN; 320 | RETURN (ch[1] = 0X) & ( 321 | (ch[0] = " ") OR (ch[0] = "(") OR (ch[0] = ")") OR 322 | (ch[0] = ",") OR (ch[0] = ";") OR (ch[0] = "|") ) 323 | END autocaps; 324 | 325 | PROCEDURE incomstr(pos: INTEGER): BOOLEAN; 326 | VAR line, col: INTEGER; 327 | BEGIN 328 | str[pos][0] := 0X; 329 | str[pos][1] := 0X; 330 | line := 0; 331 | col := 0; 332 | comstr := FALSE; 333 | WHILE GetLex(line, col) # -1 DO END; 334 | RETURN comstr 335 | END incomstr; 336 | 337 | PROCEDURE Caps*(this: Line.LINE; pos: INTEGER; ch: Line.WCHAR); 338 | BEGIN 339 | SetLine(this); 340 | IF (pos > 0) & (pos <= this.length) & autocaps(ch) & ~incomstr(pos - 1) THEN 341 | Upper(this, pos - 1) 342 | END 343 | END Caps; 344 | 345 | PROCEDURE GetColors*; 346 | BEGIN 347 | TU.GetColors(Colors); 348 | TextColor := Colors[TU.cText]; 349 | END GetColors; 350 | 351 | BEGIN 352 | EnterKW("MOD"); 353 | EnterKW("ELSE"); 354 | EnterKW("RETURN"); 355 | EnterKW("CASE"); 356 | EnterKW("IF"); 357 | EnterKW("POINTER"); 358 | EnterKW("TYPE"); 359 | EnterKW("BEGIN"); 360 | EnterKW("DIV"); 361 | EnterKW("FALSE"); 362 | EnterKW("IN"); 363 | EnterKW("NIL"); 364 | EnterKW("RECORD"); 365 | EnterKW("TO"); 366 | EnterKW("VAR"); 367 | EnterKW("ARRAY"); 368 | EnterKW("DO"); 369 | EnterKW("END"); 370 | EnterKW("IS"); 371 | EnterKW("OF"); 372 | EnterKW("PROCEDURE"); 373 | EnterKW("THEN"); 374 | EnterKW("WHILE"); 375 | EnterKW("BY"); 376 | EnterKW("CONST"); 377 | EnterKW("ELSIF"); 378 | EnterKW("IMPORT"); 379 | EnterKW("MODULE"); 380 | EnterKW("OR"); 381 | EnterKW("REPEAT"); 382 | EnterKW("TRUE"); 383 | EnterKW("UNTIL"); 384 | EnterKW("FOR"); 385 | 386 | stpos := kwcount; 387 | 388 | EnterKW("ABS"); 389 | EnterKW("ASR"); 390 | EnterKW("ASSERT"); 391 | EnterKW("BITS"); 392 | EnterKW("BOOLEAN"); 393 | EnterKW("CHAR"); 394 | EnterKW("CHR"); 395 | EnterKW("COPY"); 396 | EnterKW("DEC"); 397 | EnterKW("DISPOSE"); 398 | EnterKW("EXCL"); 399 | EnterKW("FLOOR"); 400 | EnterKW("FLT"); 401 | EnterKW("INC"); 402 | EnterKW("INCL"); 403 | EnterKW("INTEGER"); 404 | EnterKW("LEN"); 405 | EnterKW("LENGTH"); 406 | EnterKW("LSL"); 407 | EnterKW("LSR"); 408 | EnterKW("LONG"); 409 | EnterKW("LONGREAL"); 410 | EnterKW("NEW"); 411 | EnterKW("ODD"); 412 | EnterKW("ORD"); 413 | EnterKW("PACK"); 414 | EnterKW("REAL"); 415 | EnterKW("ROR"); 416 | EnterKW("SET"); 417 | EnterKW("SHORT"); 418 | EnterKW("UNPK"); 419 | 420 | GetColors; 421 | Line.Init(CommentTable) 422 | END Lexer. -------------------------------------------------------------------------------- /Source/Editor/Line.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE Line; 21 | 22 | IMPORT List; 23 | 24 | CONST MAXLEN* = 512; 25 | 26 | TYPE 27 | 28 | WCHAR* = ARRAY 2 OF CHAR; 29 | 30 | TEXTSTR* = ARRAY MAXLEN OF WCHAR; 31 | 32 | LINE* = POINTER TO rLINE; 33 | 34 | ComItem* = POINTER TO RECORD (List.rITEM) comin*, comout*: INTEGER END; 35 | 36 | rLINE* = RECORD (List.rITEM) 37 | str*: TEXTSTR; 38 | length*, comin*, comout*, dif*: INTEGER; 39 | Modified*: BOOLEAN; 40 | ComTab*: List.LIST 41 | END; 42 | 43 | PROC = PROCEDURE (L: LINE); 44 | 45 | VAR zero: WCHAR; Lst: List.LIST; CommentTable: PROC; 46 | 47 | PROCEDURE SetList*(L: List.LIST); 48 | BEGIN 49 | Lst := L 50 | END SetList; 51 | 52 | PROCEDURE Init*(p: PROC); 53 | BEGIN 54 | CommentTable := p 55 | END Init; 56 | 57 | PROCEDURE iszero*(ch: WCHAR): BOOLEAN; 58 | RETURN (ch[0] = 0X) & (ch[1] = 0X) 59 | END iszero; 60 | 61 | PROCEDURE notzero*(ch: WCHAR): BOOLEAN; 62 | RETURN (ch[0] # 0X) OR (ch[1] # 0X) 63 | END notzero; 64 | 65 | PROCEDURE concat(L, R: ARRAY OF WCHAR; VAR Res: ARRAY OF WCHAR); 66 | VAR i, j: INTEGER; 67 | BEGIN 68 | i := 0; 69 | WHILE notzero(L[i]) & (i < LEN(Res) - 1) DO 70 | Res[i] := L[i]; 71 | INC(i) 72 | END; 73 | j := 0; 74 | WHILE notzero(R[j]) & (j + i < LEN(Res) - 1) DO 75 | Res[j + i] := R[j]; 76 | INC(j) 77 | END; 78 | Res[j + i] := zero 79 | END concat; 80 | 81 | PROCEDURE Clear*(this: LINE); 82 | BEGIN 83 | this.str[0] := zero; 84 | this.length := 0; 85 | this.Modified := TRUE 86 | END Clear; 87 | 88 | PROCEDURE ShiftRight1(VAR str: TEXTSTR; pos, count: INTEGER); 89 | VAR i: INTEGER; 90 | BEGIN 91 | FOR i := pos + count - 1 TO pos BY -1 DO 92 | str[i + 1] := str[i] 93 | END 94 | END ShiftRight1; 95 | 96 | PROCEDURE ShiftRight*(VAR str: TEXTSTR; pos, count, shift: INTEGER); 97 | VAR i: INTEGER; 98 | BEGIN 99 | FOR i := pos + count - 1 TO pos BY -1 DO 100 | str[i + shift] := str[i] 101 | END 102 | END ShiftRight; 103 | 104 | PROCEDURE ShiftLeft*(VAR str: TEXTSTR; pos, count, shift: INTEGER); 105 | VAR i: INTEGER; 106 | BEGIN 107 | FOR i := pos TO pos + count - 1 DO 108 | str[i - shift] := str[i] 109 | END 110 | END ShiftLeft; 111 | 112 | PROCEDURE TrimRight*(this: LINE); 113 | VAR i: INTEGER; 114 | BEGIN 115 | i := this.length - 1; 116 | WHILE (i >= 0) & (this.str[i][0] = 20X) & (this.str[i][1] = 0X) DO 117 | DEC(i) 118 | END; 119 | INC(i); 120 | this.str[i] := zero; 121 | this.length := i; 122 | CommentTable(this); 123 | this.Modified := FALSE 124 | END TrimRight; 125 | 126 | PROCEDURE Concat*(this, next: LINE): BOOLEAN; 127 | VAR Len, t: INTEGER; res: BOOLEAN; 128 | BEGIN 129 | concat(this.str, next.str, this.str); 130 | t := this.length + next.length; 131 | IF t > (MAXLEN - 1) THEN 132 | Len := MAXLEN - 1 - this.length; 133 | ShiftLeft(next.str, Len, next.length - Len, Len); 134 | next.length := next.length - Len; 135 | next.str[next.length] := zero; 136 | next.Modified := TRUE; 137 | this.length := MAXLEN - 1; 138 | res := FALSE 139 | ELSE 140 | this.length := t; 141 | res := TRUE 142 | END; 143 | this.Modified := TRUE 144 | RETURN res 145 | END Concat; 146 | 147 | PROCEDURE Spaces*(this: LINE; n: INTEGER); 148 | VAR i: INTEGER; 149 | BEGIN 150 | FOR i := this.length TO this.length + n - 1 DO 151 | this.str[i][0] := 20X; 152 | this.str[i][1] := 0X 153 | END; 154 | this.length := this.length + n; 155 | IF n > 0 THEN 156 | this.Modified := TRUE 157 | END; 158 | this.str[this.length] := zero 159 | END Spaces; 160 | 161 | PROCEDURE DestroyLine(this: List.ITEM); 162 | BEGIN 163 | List.DestroyList(this(LINE).ComTab) 164 | END DestroyLine; 165 | 166 | PROCEDURE CreateLine*(str: TEXTSTR; length: INTEGER): LINE; 167 | VAR nov: LINE; 168 | BEGIN 169 | NEW(nov); 170 | IF nov # NIL THEN 171 | nov.Destroy := DestroyLine; 172 | NEW(nov.ComTab); 173 | List.CreateList(nov.ComTab); 174 | nov.str := str; 175 | nov.length := length; 176 | TrimRight(nov) 177 | END 178 | RETURN nov 179 | END CreateLine; 180 | 181 | PROCEDURE FrwInput(this: LINE; ch: WCHAR; VAR last: WCHAR; VAR next: LINE): BOOLEAN; 182 | VAR str: TEXTSTR; res: BOOLEAN; 183 | BEGIN 184 | res := FALSE; 185 | IF this = NIL THEN 186 | str[0] := zero; 187 | this := CreateLine(str, 0); 188 | List.Push(Lst, this) 189 | END; 190 | IF this.length = MAXLEN - 1 THEN 191 | last := this.str[MAXLEN - 2]; 192 | DEC(this.length); 193 | this.str[MAXLEN - 2] := zero; 194 | res := TRUE; 195 | next := this.Next(LINE) 196 | END; 197 | ShiftRight1(this.str, 0, this.length + 1); 198 | this.str[0] := ch; 199 | INC(this.length); 200 | this.Modified := TRUE 201 | RETURN res 202 | END FrwInput; 203 | 204 | PROCEDURE Input*(this: LINE; pos: INTEGER; ch: WCHAR): BOOLEAN; 205 | VAR res: BOOLEAN; 206 | 207 | PROCEDURE proc1(this: LINE; ch: WCHAR); 208 | VAR res: BOOLEAN; last, first: WCHAR; next, line: LINE; 209 | BEGIN 210 | first := ch; 211 | line := this; 212 | REPEAT 213 | res := FrwInput(line, first, last, next); 214 | line := next; 215 | first := last 216 | UNTIL ~res 217 | END proc1; 218 | 219 | BEGIN 220 | res := FALSE; 221 | IF pos <= this.length THEN 222 | IF this.length = MAXLEN - 1 THEN 223 | IF pos = this.length THEN 224 | proc1(this.Next(LINE), ch); 225 | res := TRUE 226 | ELSE 227 | proc1(this.Next(LINE), this.str[MAXLEN - 2]) 228 | END; 229 | DEC(this.length) 230 | END; 231 | ShiftRight1(this.str, pos, this.length - pos + 1); 232 | INC(this.length); 233 | this.Modified := TRUE; 234 | IF pos # MAXLEN - 1 THEN 235 | this.str[pos] := ch 236 | END 237 | ELSE 238 | IF pos < MAXLEN - 1 THEN 239 | Spaces(this, pos - this.length); 240 | this.length := pos + 1; 241 | this.str[this.length] := zero; 242 | this.Modified := TRUE; 243 | this.str[pos] := ch 244 | ELSE 245 | proc1(this.Next(LINE), ch); 246 | res := TRUE 247 | END 248 | END 249 | RETURN res 250 | END Input; 251 | 252 | PROCEDURE Delete*(this: LINE; pos: INTEGER): BOOLEAN; 253 | VAR Res: BOOLEAN; 254 | BEGIN 255 | Res := pos >= this.length; 256 | IF Res THEN 257 | Spaces(this, pos - this.length); 258 | this.length := pos 259 | ELSE 260 | ShiftLeft(this.str, pos + 1, this.length - pos, 1); 261 | DEC(this.length) 262 | END; 263 | this.Modified := TRUE 264 | RETURN Res 265 | END Delete; 266 | 267 | PROCEDURE FirstSymbol*(this: LINE): INTEGER; 268 | VAR i: INTEGER; 269 | BEGIN 270 | i := 0; 271 | IF this # NIL THEN 272 | WHILE (this.str[i][0] = 20X) & (this.str[i][1] = 0X) DO 273 | INC(i) 274 | END; 275 | IF iszero(this.str[i]) THEN 276 | i := -1 277 | END 278 | END 279 | RETURN i 280 | END FirstSymbol; 281 | 282 | PROCEDURE BkSpace*(this: LINE; pos: INTEGER): INTEGER; 283 | VAR n, m: INTEGER; cur: LINE; 284 | BEGIN 285 | n := 0; 286 | IF pos > 0 THEN 287 | n := FirstSymbol(this); 288 | IF n = -1 THEN 289 | n := pos; 290 | TrimRight(this) 291 | END; 292 | IF (n = 0) OR (n # pos) THEN 293 | n := 1 294 | ELSE 295 | cur := this.Prev(LINE); 296 | m := FirstSymbol(cur); 297 | WHILE (cur # NIL) & ((m = -1) OR (m >= n)) DO 298 | cur := cur.Prev(LINE); 299 | m := FirstSymbol(cur) 300 | END; 301 | IF cur # NIL THEN 302 | n := n - m 303 | END 304 | END; 305 | IF pos <= this.length THEN 306 | ShiftLeft(this.str, pos, this.length - pos + 1, n); 307 | this.length := this.length - n; 308 | this.Modified := TRUE 309 | END 310 | END 311 | RETURN n 312 | END BkSpace; 313 | 314 | PROCEDURE FrwSpaces*(this: LINE; n: INTEGER); 315 | VAR space: WCHAR; 316 | BEGIN 317 | space[0] := 20X; 318 | space[1] := 0X; 319 | WHILE n > 0 DO 320 | IF Input(this, 0, space) THEN END; 321 | DEC(n) 322 | END 323 | END FrwSpaces; 324 | 325 | PROCEDURE Enter*(this: LINE; pos: INTEGER): LINE; 326 | VAR str: TEXTSTR; i, length: INTEGER; 327 | BEGIN 328 | IF pos > this.length THEN 329 | Spaces(this, pos - this.length) 330 | END; 331 | FOR i := pos TO this.length DO 332 | str[i - pos] := this.str[i] 333 | END; 334 | length := this.length - pos; 335 | IF length < 0 THEN 336 | length := 0 337 | END; 338 | this.str[pos] := zero; 339 | this.length := pos; 340 | this.Modified := TRUE 341 | RETURN CreateLine(str, length) 342 | END Enter; 343 | 344 | BEGIN 345 | zero[0] := 0X; 346 | zero[1] := 0X 347 | END Line. -------------------------------------------------------------------------------- /Source/Editor/List.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE List; 21 | 22 | TYPE 23 | 24 | ITEM* = POINTER TO rITEM; 25 | 26 | rITEM* = RECORD 27 | Next*, Prev*: ITEM; 28 | Destroy*: PROCEDURE (this: ITEM) 29 | END; 30 | 31 | LIST* = POINTER TO rLIST; 32 | 33 | rLIST* = RECORD 34 | First*, Last*: ITEM; 35 | Count*: INTEGER 36 | END; 37 | 38 | PROCEDURE Index*(this: LIST; idx: INTEGER): ITEM; 39 | VAR cur: ITEM; 40 | BEGIN 41 | IF idx > this.Count - 1 THEN 42 | cur := NIL 43 | ELSE 44 | cur := this.First; 45 | WHILE idx > 0 DO 46 | cur := cur.Next; 47 | DEC(idx) 48 | END 49 | END 50 | RETURN cur 51 | END Index; 52 | 53 | PROCEDURE Push*(this: LIST; item: ITEM); 54 | BEGIN 55 | IF this.Count = 0 THEN 56 | this.First := item; 57 | item.Prev := NIL 58 | ELSE 59 | this.Last.Next := item; 60 | item.Prev := this.Last 61 | END; 62 | INC(this.Count); 63 | this.Last := item; 64 | item.Next := NIL 65 | END Push; 66 | 67 | PROCEDURE Destroy(this: ITEM); 68 | BEGIN 69 | IF this.Destroy # NIL THEN 70 | this.Destroy(this) 71 | END; 72 | DISPOSE(this) 73 | END Destroy; 74 | 75 | PROCEDURE Pop*(this: LIST); 76 | BEGIN 77 | IF this.Count # 0 THEN 78 | this.Last := this.Last.Prev; 79 | IF this.Count = 1 THEN 80 | Destroy(this.First); 81 | this.Last := NIL; 82 | this.First := NIL 83 | ELSE 84 | Destroy(this.Last.Next) 85 | END; 86 | DEC(this.Count); 87 | IF this.Last # NIL THEN 88 | this.Last.Next := NIL 89 | END 90 | END 91 | END Pop; 92 | 93 | PROCEDURE DelItem*(this: LIST; item: ITEM); 94 | BEGIN 95 | IF (item # this.First) & (item # this.Last) THEN 96 | item.Prev.Next := item.Next; 97 | item.Next.Prev := item.Prev; 98 | DEC(this.Count); 99 | Destroy(item) 100 | ELSIF this.Count = 1 THEN 101 | 102 | ELSIF item = this.Last THEN 103 | Pop(this) 104 | ELSIF item = this.First THEN 105 | item.Next.Prev := NIL; 106 | this.First := item.Next; 107 | DEC(this.Count); 108 | Destroy(item) 109 | END 110 | END DelItem; 111 | 112 | PROCEDURE Insert*(this: LIST; item, prev: ITEM); 113 | BEGIN 114 | IF prev # this.Last THEN 115 | item.Next := prev.Next; 116 | item.Prev := prev; 117 | prev.Next := item; 118 | item.Next.Prev := item; 119 | INC(this.Count) 120 | ELSE 121 | Push(this, item) 122 | END 123 | END Insert; 124 | 125 | PROCEDURE CreateList*(nov: LIST); 126 | BEGIN 127 | IF nov # NIL THEN 128 | nov.First := NIL; 129 | nov.Last := NIL; 130 | nov.Count := 0 131 | END 132 | END CreateList; 133 | 134 | PROCEDURE Clear*(this: LIST); 135 | BEGIN 136 | WHILE this.Count > 0 DO Pop(this) END 137 | END Clear; 138 | 139 | PROCEDURE DestroyList*(this: LIST); 140 | BEGIN 141 | Clear(this); 142 | DISPOSE(this) 143 | END DestroyList; 144 | 145 | END List. -------------------------------------------------------------------------------- /Source/Editor/Param.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE Param; 21 | 22 | IMPORT sys := SYSTEM, TextUtils; 23 | 24 | CONST 25 | 26 | MAX_PARAM = 1024; 27 | 28 | VAR 29 | 30 | Params: ARRAY MAX_PARAM, 2 OF INTEGER; 31 | ParamCount*: INTEGER; 32 | 33 | PROCEDURE GetChar(adr: INTEGER): CHAR; 34 | VAR res: CHAR; 35 | BEGIN 36 | sys.GET(adr, res) 37 | RETURN res 38 | END GetChar; 39 | 40 | PROCEDURE ParamParse; 41 | VAR p, count: INTEGER; c: CHAR; cond: INTEGER; 42 | 43 | PROCEDURE ChangeCond(A, B, C: INTEGER); 44 | BEGIN 45 | IF (c <= 20X) & (c # 0X) THEN 46 | cond := A 47 | ELSIF c = 22X THEN 48 | cond := B 49 | ELSIF c = 0X THEN 50 | cond := 6 51 | ELSE 52 | cond := C 53 | END 54 | END ChangeCond; 55 | 56 | BEGIN 57 | p := TextUtils.GetCommandLine(); 58 | cond := 0; 59 | count := 0; 60 | WHILE (count < MAX_PARAM) & (cond # 6) DO 61 | c := GetChar(p); 62 | CASE cond OF 63 | |0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END 64 | |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END 65 | |3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 66 | |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END 67 | |5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END 68 | ELSE 69 | END; 70 | INC(p) 71 | END; 72 | ParamCount := count - 1 73 | END ParamParse; 74 | 75 | PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER); 76 | VAR i, j, len: INTEGER; c: CHAR; 77 | BEGIN 78 | j := 0; 79 | IF n < ParamCount + 1 THEN 80 | len := LEN(str) - 1; 81 | i := Params[n, 0]; 82 | WHILE (j < len) & (i <= Params[n, 1]) DO 83 | c := GetChar(i); 84 | IF c # 22X THEN 85 | str[j] := c; 86 | INC(j) 87 | END; 88 | INC(i); 89 | END; 90 | END; 91 | str[j] := 0X 92 | END ParamStr; 93 | 94 | BEGIN 95 | ParamParse 96 | END Param. -------------------------------------------------------------------------------- /Source/Editor/TextEdit.ob07: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2013 Krotov Anton 3 | 4 | This file is part of Editor. 5 | 6 | Editor is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Editor is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Editor. If not, see . 18 | *) 19 | 20 | MODULE TextEdit; 21 | 22 | IMPORT Text, List, Line, SYSTEM, TU := TextUtils; 23 | 24 | TYPE 25 | 26 | STRING* = ARRAY 2048 OF Line.WCHAR; 27 | 28 | EditFile* = POINTER TO RECORD (List.rITEM) 29 | txt*: Text.TEXT; 30 | name*: STRING; 31 | syntax*, numbers*, Saved*: BOOLEAN 32 | END; 33 | 34 | VAR 35 | 36 | f*, main*: EditFile; FList*: List.LIST; 37 | textW, textH, stksize, pen: INTEGER; 38 | Params, platf: STRING; 39 | 40 | PROCEDURE Assigned(): BOOLEAN; 41 | RETURN (f # NIL) & (f.txt # NIL) 42 | END Assigned; 43 | 44 | PROCEDURE CurModified*(): BOOLEAN; 45 | VAR res: BOOLEAN; 46 | BEGIN 47 | IF Assigned() THEN 48 | res := f.txt.Modified 49 | ELSE 50 | res := FALSE 51 | END 52 | RETURN res 53 | END CurModified; 54 | 55 | PROCEDURE Selected*(): BOOLEAN; 56 | VAR res: BOOLEAN; 57 | BEGIN 58 | IF Assigned() THEN 59 | res := Text.Select(f.txt) 60 | ELSE 61 | res := FALSE 62 | END 63 | RETURN res 64 | END Selected; 65 | 66 | PROCEDURE Syntax*(syn: BOOLEAN); 67 | BEGIN 68 | IF Assigned() THEN 69 | f.syntax := syn; 70 | Text.SetMode(f.txt, f.syntax, f.numbers) 71 | END 72 | END Syntax; 73 | 74 | PROCEDURE Numbers*(num: BOOLEAN); 75 | BEGIN 76 | IF Assigned() THEN 77 | f.numbers := num; 78 | Text.SetMode(f.txt, f.syntax, f.numbers) 79 | END 80 | END Numbers; 81 | 82 | PROCEDURE GetCursor*(VAR line, col: INTEGER); 83 | BEGIN 84 | IF Assigned() THEN 85 | Text.GetCursor(f.txt, col, line) 86 | END 87 | END GetCursor; 88 | 89 | PROCEDURE TextLeft*(): INTEGER; 90 | VAR res: INTEGER; 91 | BEGIN 92 | IF Assigned() THEN 93 | res := f.txt.TextLeft 94 | ELSE 95 | res := 0 96 | END 97 | RETURN res 98 | END TextLeft; 99 | 100 | PROCEDURE WordSel*; 101 | BEGIN 102 | IF Assigned() THEN 103 | Text.WordSelect(f.txt) 104 | END 105 | END WordSel; 106 | 107 | PROCEDURE Index*(file: EditFile): INTEGER; 108 | VAR cur: EditFile; res: INTEGER; 109 | BEGIN 110 | res := 0; 111 | cur := FList.First(EditFile); 112 | WHILE cur # file DO 113 | cur := cur.Next(EditFile); 114 | INC(res) 115 | END 116 | RETURN res 117 | END Index; 118 | 119 | PROCEDURE Utf16To8*(VAR str: ARRAY OF CHAR; name: INTEGER); 120 | VAR a, n, c: INTEGER; w: Line.WCHAR; 121 | BEGIN 122 | a := SYSTEM.ADR(str); 123 | REPEAT 124 | SYSTEM.MOVE(name, SYSTEM.ADR(w), 2); 125 | INC(name, 2); 126 | c := TU.Utf16To8(w, n); 127 | SYSTEM.MOVE(SYSTEM.ADR(c), a, n); 128 | a := a + n 129 | UNTIL c = 0 130 | END Utf16To8; 131 | 132 | PROCEDURE ExtractFileName*(str: INTEGER; ch: CHAR): INTEGER; 133 | VAR w: Line.WCHAR; res: INTEGER; 134 | BEGIN 135 | res := str; 136 | REPEAT 137 | SYSTEM.GET(str, w[0]); 138 | SYSTEM.GET(str + 1, w[1]); 139 | INC(str, 2); 140 | IF (w[0] = ch) & (w[1] = 0X) THEN 141 | res := str 142 | END 143 | UNTIL (w[0] = 0X) & (w[1] = 0X) 144 | RETURN res 145 | END ExtractFileName; 146 | 147 | PROCEDURE WStrEQ(a, b: INTEGER): BOOLEAN; 148 | VAR i, Len, n: INTEGER; c, d: ARRAY 2048 OF CHAR; 149 | BEGIN 150 | Utf16To8(c, a); 151 | Utf16To8(d, b) 152 | RETURN c = d 153 | END WStrEQ; 154 | 155 | PROCEDURE IndexName*(name: INTEGER; extr: BOOLEAN): INTEGER; 156 | VAR cur: EditFile; cont: BOOLEAN; res, curname: INTEGER; 157 | BEGIN 158 | cont := TRUE; 159 | res := -1; 160 | cur := FList.First(EditFile); 161 | WHILE (cur # NIL) & cont DO 162 | IF extr THEN 163 | curname := ExtractFileName(SYSTEM.ADR(cur.name), "\") 164 | ELSE 165 | curname := SYSTEM.ADR(cur.name) 166 | END; 167 | cont := ~WStrEQ(name, curname); 168 | cur := cur.Next(EditFile); 169 | INC(res) 170 | END; 171 | IF cont THEN 172 | res := -1 173 | END 174 | RETURN res 175 | END IndexName; 176 | 177 | PROCEDURE Modified*(): BOOLEAN; 178 | VAR cur: EditFile; res: BOOLEAN; 179 | BEGIN 180 | res := FALSE; 181 | cur := FList.First(EditFile); 182 | WHILE ~res & (cur # NIL) DO 183 | res := cur.txt.Modified; 184 | cur := cur.Next(EditFile) 185 | END 186 | RETURN res 187 | END Modified; 188 | 189 | PROCEDURE Add*(str: Line.TEXTSTR; length: INTEGER); 190 | BEGIN 191 | IF Assigned() THEN 192 | Text.Add(f.txt, str, length) 193 | END 194 | END Add; 195 | 196 | PROCEDURE Close*(): BOOLEAN; 197 | VAR f1: EditFile; res: BOOLEAN; 198 | BEGIN 199 | res := FALSE; 200 | IF Assigned() THEN 201 | Text.Close(f.txt); 202 | IF main = f THEN 203 | main := NIL 204 | END; 205 | f1 := f; 206 | IF f1.Prev # NIL THEN 207 | f := f1.Prev(EditFile) 208 | ELSE 209 | f := f1.Next(EditFile) 210 | END; 211 | IF FList.Count = 1 THEN 212 | List.Pop(FList) 213 | ELSE 214 | List.DelItem(FList, f1) 215 | END; 216 | IF f # NIL THEN 217 | Line.SetList(f.txt) 218 | ELSE 219 | Line.SetList(NIL) 220 | END; 221 | res := TRUE 222 | END 223 | RETURN res 224 | END Close; 225 | 226 | PROCEDURE ChangePage*(index: INTEGER); 227 | VAR item: List.ITEM; 228 | BEGIN 229 | item := List.Index(FList, index); 230 | f := item(EditFile); 231 | IF f # NIL THEN 232 | Line.SetList(f.txt) 233 | ELSE 234 | Line.SetList(NIL) 235 | END 236 | END ChangePage; 237 | 238 | PROCEDURE SetFont*(H, W: INTEGER); 239 | VAR cur: EditFile; 240 | BEGIN 241 | textH := H; 242 | textW := W; 243 | cur := FList.First(EditFile); 244 | WHILE cur # NIL DO 245 | Text.SetFont(cur.txt, H, W); 246 | cur := cur.Next(EditFile) 247 | END 248 | END SetFont; 249 | 250 | PROCEDURE SetMain*; 251 | BEGIN 252 | main := f 253 | END SetMain; 254 | 255 | PROCEDURE SetName*(str: INTEGER); 256 | VAR w: Line.WCHAR; i: INTEGER; 257 | BEGIN 258 | i := 0; 259 | REPEAT 260 | SYSTEM.GET(str, w[0]); 261 | SYSTEM.GET(str + 1, w[1]); 262 | f.name[i] := w; 263 | INC(i); 264 | INC(str, 2); 265 | f.Saved := TRUE 266 | UNTIL (w[0] = 0X) & (w[1] = 0X) 267 | END SetName; 268 | 269 | PROCEDURE Save*(file: EditFile): BOOLEAN; 270 | RETURN (file # NIL) & (file.txt # NIL) & Text.Save(file.txt, file.name) 271 | END Save; 272 | 273 | PROCEDURE Mouse_Move*(X, Y: INTEGER); 274 | VAR line, col: INTEGER; 275 | BEGIN 276 | IF Assigned() THEN 277 | Text.GetLineCol(f.txt, line, col); 278 | Text.Mouse_Move(f.txt, (X - f.txt.TextLeft + textW DIV 2) DIV textW + col, Y DIV textH + line) 279 | END 280 | END Mouse_Move; 281 | 282 | PROCEDURE Mouse_Down*(Shift: BOOLEAN; X, Y: INTEGER); 283 | VAR line, col: INTEGER; 284 | BEGIN 285 | IF Assigned() THEN 286 | Text.GetLineCol(f.txt, line, col); 287 | IF Shift THEN 288 | Text.Mouse_Move(f.txt, (X - f.txt.TextLeft + textW DIV 2) DIV textW + col, Y DIV textH + line) 289 | ELSE 290 | Text.CancelSelect(f.txt, (X - f.txt.TextLeft + textW DIV 2) DIV textW + col, Y DIV textH + line) 291 | END 292 | END 293 | END Mouse_Down; 294 | 295 | PROCEDURE NewFile*; 296 | VAR wline: Line.TEXTSTR; 297 | BEGIN 298 | wline[0][0] := 0X; 299 | wline[0][1] := 0X; 300 | NEW(f); 301 | f.Saved := FALSE; 302 | f.name[0] := wline[0]; 303 | List.Push(FList, f); 304 | f.txt := Text.CreateText(textW, textH); 305 | Text.SetMode(f.txt, TRUE, TRUE); 306 | Text.Add(f.txt, wline, 0); 307 | f.syntax := TRUE; 308 | f.numbers := TRUE; 309 | Line.SetList(f.txt) 310 | END NewFile; 311 | 312 | PROCEDURE Redraw*(hdc, Width, Height: INTEGER; Cursor: BOOLEAN); 313 | BEGIN 314 | IF Assigned() THEN 315 | Text.Print(f.txt, hdc, Height DIV textH + 1, (Width - f.txt.TextLeft) DIV textW + 2, Cursor); 316 | TU.SelectObject(hdc, pen); 317 | DEC(Width, 3); 318 | DEC(Height, 3); 319 | Text.DrawLine(hdc, 0, 0, Width, 0); 320 | Text.DrawLine(hdc, 0, 0, 0, Height); 321 | Text.DrawLine(hdc, Width, 0, Width, Height); 322 | Text.DrawLine(hdc, 0, Height, Width, Height); 323 | END 324 | END Redraw; 325 | 326 | PROCEDURE KeyDown*(key: INTEGER; Shift: SET); 327 | BEGIN 328 | IF Assigned() THEN 329 | Text.KeyDown(f.txt, key, Shift) 330 | END 331 | END KeyDown; 332 | 333 | PROCEDURE Copy*; 334 | BEGIN 335 | IF Assigned() THEN 336 | Text.Copy(f.txt) 337 | END 338 | END Copy; 339 | 340 | PROCEDURE Paste*; 341 | BEGIN 342 | IF Assigned() THEN 343 | Text.Paste(f.txt) 344 | END 345 | END Paste; 346 | 347 | PROCEDURE DelSelect*; 348 | BEGIN 349 | IF Assigned() & Text.DelSelect(f.txt) THEN END 350 | END DelSelect; 351 | 352 | PROCEDURE ChCase*(up: BOOLEAN); 353 | BEGIN 354 | IF Assigned() THEN 355 | Text.ChCase(f.txt, up) 356 | END 357 | END ChCase; 358 | 359 | PROCEDURE Input*(key: INTEGER); 360 | VAR w: Line.WCHAR; 361 | BEGIN 362 | IF Assigned() & ((key > 31) & (key # 127) OR (key = 9)) THEN 363 | w[0] := CHR(key MOD 256); 364 | w[1] := CHR(key DIV 256); 365 | Text.Input(f.txt, w) 366 | END 367 | END Input; 368 | 369 | PROCEDURE SetLineCol*(line, col: INTEGER); 370 | BEGIN 371 | IF Assigned() THEN 372 | Text.SetLineCol(f.txt, line, col) 373 | END 374 | END SetLineCol; 375 | 376 | PROCEDURE GetLineCol*(VAR line, col: INTEGER); 377 | BEGIN 378 | IF Assigned() THEN 379 | Text.GetLineCol(f.txt, line, col) 380 | END 381 | END GetLineCol; 382 | 383 | PROCEDURE GetLinesCols*(VAR lines, cols: INTEGER); 384 | BEGIN 385 | IF Assigned() THEN 386 | Text.GetLinesCols(f.txt, lines, cols) 387 | END 388 | END GetLinesCols; 389 | 390 | PROCEDURE Count*(): INTEGER; 391 | VAR res: INTEGER; 392 | BEGIN 393 | res := 0; 394 | IF Assigned() THEN 395 | res := f.txt.Count 396 | END 397 | RETURN res 398 | END Count; 399 | 400 | PROCEDURE DelFirst*; 401 | BEGIN 402 | IF Assigned() THEN 403 | List.DelItem(f.txt, f.txt.First) 404 | END 405 | END DelFirst; 406 | 407 | BEGIN 408 | NEW(FList); 409 | List.CreateList(FList); 410 | pen := TU.CreatePen(0, 1, TU.RGB(128, 128, 128)) 411 | END TextEdit. --------------------------------------------------------------------------------