/programs/develop/cedit/CEDIT |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
/programs/develop/cedit/SRC/CEdit.ob07 |
---|
28,7 → 28,7 |
RW, Ini, box_lib, Icons; |
CONST |
header = "CEdit (14-jun-2021)"; |
header = "CEdit (15-jun-2021)"; |
ShellFilter = ""; |
EditFilter = "SH|ASM|TXT|INC|OB07|C|CPP|H|PAS|PP|LUA|INI"; |
78,15 → 78,16 |
btnTop = MainMenuHeight + 3; |
toolBtnSize = 24; |
toolbarDelim = 7; |
iconPad = (toolBtnSize - Icons.SIZE) DIV 2; |
TOP = btnTop + toolBtnSize + 7; |
RIGHT = scrollWidth - 2; |
BOTTOM = scrollWidth + 25; |
BOTTOM = scrollWidth + 18; |
minWinWidth = 635; minWinHeight = 542; |
SEARCH_PADDING = 10; |
searchLeft = 10; |
searchLeft = 0; |
EditBox_Width = 180; |
EDITBOX_MAXCHARS = 500; |
270,8 → 271,6 |
PROCEDURE toolbarIcons; |
CONST |
iconPad = (toolBtnSize - Icons.SIZE) DIV 2; |
VAR |
x, color: INTEGER; |
BEGIN |
329,7 → 328,7 |
PROCEDURE WriteModified (x, y: INTEGER); |
BEGIN |
modified := text.modified; |
K.DrawRect(x, TOP + canvas.height + scrollWidth - 1, 9*fontWidth, BOTTOM - scrollWidth + 1, K.winColor); |
K.DrawRect(x, TOP + canvas.height + scrollWidth - 1, 8*fontWidth, BOTTOM - scrollWidth + 1, K.winColor); |
IF modified THEN |
K.DrawText866(x, y, K.textColor, "modified") |
END |
353,7 → 352,7 |
WritePos(y); |
IF modified # text.modified THEN |
WriteModified(width - 9*fontWidth, y) |
WriteModified(width - 8*fontWidth, y) |
END; |
T.getScroll(text, scrollX, scrollY); |
445,8 → 444,6 |
PROCEDURE draw_window; |
CONST |
iconPad = (toolBtnSize - Icons.SIZE) DIV 2; |
VAR |
width, height, x, y: INTEGER; |
527,13 → 524,13 |
INC(x, toolBtnSize + 5 + toolbarDelim); |
drawToolbarBtn(btnBuild, x); |
Icons.draw(icons, 54, x + iconPad, btnTop + iconPad); |
INC(x, toolBtnSize + 5); |
drawToolbarBtn(btnRun, x); |
Icons.draw(icons, 53, x + iconPad, btnTop + iconPad); |
INC(x, toolBtnSize + 5); |
toolbarIcons; |
K.CreateButton(btnUp, LEFT + canvas.width - 1, TOP, scrollWidth - 1, scrollWidth, K.btnColor, 0X); |
K.DrawText69(LEFT + canvas.width - 1 + (scrollWidth - 6) DIV 2, TOP + (scrollWidth - 9) DIV 2, K.btnTextColor, 18X); |
K.CreateButton(btnDown, LEFT + canvas.width - 1, TOP + canvas.height - scrollWidth - 1, scrollWidth - 1, scrollWidth, K.btnColor, 0X); |
549,10 → 546,10 |
y := (btnHeight - fontHeight) DIV 2 + btnTop; |
CASE text.enc OF |
|E.UTF8: K.DrawText866(width - 6*fontWidth, y, K.textColor, "UTF-8") |
|E.UTF8BOM: K.DrawText866(width - 10*fontWidth, y, K.textColor, "UTF-8-BOM") |
|E.CP866: K.DrawText866(width - 6*fontWidth, y, K.textColor, "CP866") |
|E.W1251: K.DrawText866(width - 13*fontWidth, y, K.textColor, "Windows-1251") |
|E.UTF8: K.DrawText866(width - 5*fontWidth, y, K.textColor, "UTF-8") |
|E.UTF8BOM: K.DrawText866(width - 9*fontWidth, y, K.textColor, "UTF-8-BOM") |
|E.CP866: K.DrawText866(width - 5*fontWidth, y, K.textColor, "CP866") |
|E.W1251: K.DrawText866(width - 12*fontWidth, y, K.textColor, "Windows-1251") |
END; |
IF search THEN |
SearchPanel(searchLeft, TOP) |
559,9 → 556,9 |
END; |
y := height - (BOTTOM - scrollWidth) + (BOTTOM - scrollWidth - 16) DIV 2; |
K.DrawRect(LEFT + 16*fontWidth, TOP + canvas.height + scrollWidth - 1, width - LEFT - 25*fontWidth, BOTTOM - scrollWidth + 1, K.winColor); |
K.DrawRect(LEFT + 16*fontWidth, TOP + canvas.height + scrollWidth - 1, width - LEFT - 24*fontWidth, BOTTOM - scrollWidth + 1, K.winColor); |
K.DrawText866(LEFT + 16*fontWidth, y, K.textColor, text.fileName); |
WriteModified(width - 9*fontWidth, y); |
WriteModified(width - 8*fontWidth, y); |
repaint |
END; |
K.EndDraw |
753,7 → 750,7 |
BEGIN |
search := ~search; |
IF search THEN |
LEFT := searchLeft + EditBox_Width + SEARCH_PADDING*3; |
LEFT := searchLeft + EditBox_Width + SEARCH_PADDING*2 + 5; |
IF T.search(text, searchText, cs, whole) THEN END |
ELSE |
LEFT := searchLeft; |
1245,7 → 1242,7 |
winHeight := MAX(winHeight, minWinHeight); |
cliWidth := winWidth; |
cliHeight := winHeight; |
LEFT := 10; |
LEFT := searchLeft; |
canvas := G.CreateCanvas(winWidth - (LEFT + RIGHT + 10), winHeight - (TOP + BOTTOM + 4) - K.SkinHeight()); |
font1 := G.CreateFont(1, "", {}); |
font2 := G.CreateFont(2, "", {}); |
/programs/develop/cedit/SRC/Icons.ob07 |
---|
0,0 → 1,127 |
(* |
Copyright 2021 Anton Krotov |
This file is part of CEdit. |
CEdit is free software: you can redistribute it and/or modify |
it under the terms of the GNU General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
CEdit is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU General Public License for more details. |
You should have received a copy of the GNU General Public License |
along with CEdit. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Icons; |
IMPORT |
LibImg, K := KolibriOS, SYSTEM; |
CONST |
fileName = "/rd/1/Icons16.png"; |
SIZE* = 18; |
VAR |
source: INTEGER; |
PROCEDURE copy (src, dst: INTEGER); |
VAR |
src_sizeX, src_sizeY, dst_sizeX, dst_sizeY, |
src_data, dst_data: INTEGER; |
BEGIN |
LibImg.GetInf(src, src_sizeX, src_sizeY, src_data); |
LibImg.GetInf(dst, dst_sizeX, dst_sizeY, dst_data); |
ASSERT(src_sizeX = dst_sizeX); |
ASSERT(src_sizeY = dst_sizeY); |
SYSTEM.MOVE(src_data, dst_data, src_sizeX*src_sizeY*3) |
END copy; |
PROCEDURE load (): INTEGER; |
VAR |
y: INTEGER; |
BEGIN |
RETURN LibImg.LoadFromFile(fileName, SIZE, y) |
END load; |
PROCEDURE draw* (icons, n, x, y: INTEGER); |
VAR |
sizeX, sizeY, data: INTEGER; |
BEGIN |
LibImg.GetInf(icons, sizeX, sizeY, data); |
K.DrawImage(data + SIZE*SIZE*3*n, SIZE, SIZE, x, y) |
END draw; |
PROCEDURE gray (icons: INTEGER); |
VAR |
sizeX, sizeY, data, x, y: INTEGER; |
b, g, r, gr: BYTE; |
BEGIN |
LibImg.GetInf(icons, sizeX, sizeY, data); |
FOR y := 0 TO sizeY - 1 DO |
FOR x := 0 TO sizeX - 1 DO |
SYSTEM.GET8(data, b); |
SYSTEM.GET8(data + 1, g); |
SYSTEM.GET8(data + 2, r); |
gr := (r + g + b) DIV 3; |
SYSTEM.PUT8(data, gr); |
SYSTEM.PUT8(data + 1, gr); |
SYSTEM.PUT8(data + 2, gr); |
INC(data, 3); |
END |
END |
END gray; |
PROCEDURE iconsBackColor (icons: INTEGER); |
VAR |
sizeX, sizeY, data, x, y: INTEGER; |
b, g, r: BYTE; |
BEGIN |
LibImg.GetInf(icons, sizeX, sizeY, data); |
FOR y := 0 TO sizeY - 1 DO |
FOR x := 0 TO sizeX - 1 DO |
SYSTEM.GET8(data, b); |
SYSTEM.GET8(data + 1, g); |
SYSTEM.GET8(data + 2, r); |
IF b + g + r = 765 THEN |
b := K.toolbarColor MOD 256; |
g := K.toolbarColor DIV 256 MOD 256; |
r := K.toolbarColor DIV 65536 MOD 256 |
END; |
SYSTEM.PUT8(data, b); |
SYSTEM.PUT8(data + 1, g); |
SYSTEM.PUT8(data + 2, r); |
INC(data, 3); |
END |
END |
END iconsBackColor; |
PROCEDURE get* (VAR icons, grayIcons: INTEGER); |
BEGIN |
IF source = 0 THEN |
source := load(); |
icons := load(); |
grayIcons := load() |
ELSE |
copy(source, icons); |
copy(source, grayIcons) |
END; |
gray(grayIcons); |
iconsBackColor(icons); |
iconsBackColor(grayIcons) |
END get; |
BEGIN |
source := 0 |
END Icons. |
/programs/develop/oberon07/Docs/KOSLib.txt |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Docs/WinLib.txt |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Docs/x86.txt |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Deleted: svn:mime-type |
-application/octet-stream |
\ No newline at end of property |
/programs/develop/oberon07/Docs/x86_64.txt |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/SCAN.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/X86.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/CHUNKLISTS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/STATEMENTS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/LISTS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/FILES.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/IL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/PROG.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/BIN.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/TARGETS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/PE32.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/Compiler.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/AMD64.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/WRITER.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/ERRORS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/PATHS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/THUMB.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/RVM32I.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/HEX.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/AVLTREES.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/MSP430.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/STRINGS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/KOS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/TEXTDRV.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/UTILS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/CONSOLE.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/PARS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/ELF.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/ARITH.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/MSP430RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/REG.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/MSCOFF.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/COLLECTIONS.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/File.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/Console.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/In.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/WINAPI.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/API.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/Math.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/Args.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows32/DateTime.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/RVM32I/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/RVM32I/Trap.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/RVM32I/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/RVM32I/FPU.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/RVM32I/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/File.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/Libdl.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/In.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/API.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/Math.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/Args.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux32/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/In.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/WINAPI.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/API.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/Math.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/Args.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/DateTime.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/File.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Windows64/Console.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/MSP430/MSP430.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/File.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/Libdl.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/In.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/API.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/Math.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/LINAPI.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/Args.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Linux64/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Math/MathRound.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Math/Rand.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Math/MathStat.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/Math/RandExt.ob07 |
---|
File deleted |
/programs/develop/oberon07/Lib/Math/MathBits.ob07 |
---|
File deleted |
/programs/develop/oberon07/Lib/Math/CMath.ob07 |
---|
File deleted |
/programs/develop/oberon07/Lib/STM32CM3/FPU.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/STM32CM3/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Args.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Vector.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/UnixTime.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Console.ob07 |
---|
File deleted |
/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/In.ob07 |
---|
File deleted |
/programs/develop/oberon07/Lib/KolibriOS/Out.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/API.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Read.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/File.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Math.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Lib/KolibriOS/Write.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/MSP430/Button.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/MSP430/TwoTimers.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/MSP430/Flash.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/MSP430/Blink.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/MSP430/TimerA.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/MSP430/Restart.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Windows/Console/hailst.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/MagicSquares.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/HeapSort.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/Doors.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/MultiplicationTables.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/TempConv.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/sequence012.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/postfix.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/exp.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/HelloRus.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/Hello.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Windows/Console/SierpinskiTriangle.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/Sieve.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/fact.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/SierpinskiCarpet.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Windows/Console/SpiralMatrix.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/STM32CM3/Button.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/STM32CM3/Blink.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/STM32CM3/LCD.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/STM32CM3/TIM67.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/STM32CM3/SysTick.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/KolibriOS/Dialogs.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/KolibriOS/HW_con.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/KolibriOS/HW.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Linux/HW.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/filler.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/_unix.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/unix.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/filler.txt |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/out.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/filler/gr.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/animation/animation.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/animation/_unix.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/animation/unix.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/animation/out.ob07 |
---|
File deleted |
/programs/develop/oberon07/Samples/Linux/X11/animation/gr.ob07 |
---|
File deleted |
/programs/develop/oberon07/Compiler |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
/programs/develop/oberon07/Compiler.exe |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
/programs/develop/oberon07/LICENSE |
---|
1,6 → 1,6 |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
Redistribution and use in source and binary forms, with or without |
/programs/develop/oberon07/README.md |
---|
0,0 → 1,6 |
Oberon-07 compiler for x64 (Windows, Linux), x86 (Windows, Linux, KolibriOS), MSP430x{1,2}xx, STM32 Cortex-M3 |
============================================ |
**Links:** |
https://github.com/prospero78/obGraph (Тест графических возможностей компилятора Оберона-07) |
https://github.com/VadimAnIsaev/Oberon-07-additional-modules (Additional modules / Дополнительные модули) |
/programs/develop/oberon07/SelfKolibriOS.cmd |
---|
0,0 → 1,2 |
Compiler.exe source\Compiler.ob07 kosexe -out source\Compiler.kex -stk 2 |
@pause |
/programs/develop/oberon07/doc/CC.txt |
---|
0,0 → 1,61 |
Условная компиляция |
синтаксис: |
$IF "(" ident {"|" ident} ")" |
<...> |
{$ELSIF "(" ident {"|" ident} ")"} |
<...> |
[$ELSE] |
<...> |
$END |
где ident: |
- одно из возможных значений параметра <target> в командной строке |
- пользовательский идентификатор, переданный с ключом -def при компиляции |
- один из возможных предопределенных идентификаторов: |
WINDOWS - приложение Windows |
LINUX - приложение Linux |
KOLIBRIOS - приложение KolibriOS |
CPU_X86 - приложение для процессора x86 (32-бит) |
CPU_X8664 - приложение для процессора x86_64 |
примеры: |
$IF (win64con | win64gui | win64dll) |
OS := "WIN64"; |
$ELSIF (win32con | win32gui | win32dll) |
OS := "WIN32"; |
$ELSIF (linux64exe | linux64so) |
OS := "LINUX64"; |
$ELSIF (linux32exe | linux32so) |
OS := "LINUX32"; |
$ELSE |
OS := "UNKNOWN"; |
$END |
$IF (debug) (* -def debug *) |
print("debug"); |
$END |
$IF (WINDOWS) |
$IF (CPU_X86) |
(*windows 32*) |
$ELSIF (CPU_X8664) |
(*windows 64*) |
$END |
$ELSIF (LINUX) |
$IF (CPU_X86) |
(*linux 32*) |
$ELSIF (CPU_X8664) |
(*linux 64*) |
$END |
$END |
/programs/develop/oberon07/doc/KOSLib.txt |
---|
0,0 → 1,566 |
============================================================================== |
Библиотека (KolibriOS) |
------------------------------------------------------------------------------ |
MODULE Out - консольный вывод |
PROCEDURE Open |
формально открывает консольный вывод |
PROCEDURE Int(x, width: INTEGER) |
вывод целого числа x; |
width - количество знакомест, используемых для вывода |
PROCEDURE Real(x: REAL; width: INTEGER) |
вывод вещественного числа x в плавающем формате; |
width - количество знакомест, используемых для вывода |
PROCEDURE Char(x: CHAR) |
вывод символа x |
PROCEDURE FixReal(x: REAL; width, p: INTEGER) |
вывод вещественного числа x в фиксированном формате; |
width - количество знакомест, используемых для вывода; |
p - количество знаков после десятичной точки |
PROCEDURE Ln |
переход на следующую строку |
PROCEDURE String(s: ARRAY OF CHAR) |
вывод строки s |
------------------------------------------------------------------------------ |
MODULE In - консольный ввод |
VAR Done: BOOLEAN |
принимает значение TRUE в случае успешного выполнения |
операции ввода, иначе FALSE |
PROCEDURE Open |
формально открывает консольный ввод, |
также присваивает переменной Done значение TRUE |
PROCEDURE Int(VAR x: INTEGER) |
ввод числа типа INTEGER |
PROCEDURE Char(VAR x: CHAR) |
ввод символа |
PROCEDURE Real(VAR x: REAL) |
ввод числа типа REAL |
PROCEDURE String(VAR s: ARRAY OF CHAR) |
ввод строки |
PROCEDURE Ln |
ожидание нажатия ENTER |
------------------------------------------------------------------------------ |
MODULE Console - дополнительные процедуры консольного вывода |
CONST |
Следующие константы определяют цвет консольного вывода |
Black = 0 Blue = 1 Green = 2 |
Cyan = 3 Red = 4 Magenta = 5 |
Brown = 6 LightGray = 7 DarkGray = 8 |
LightBlue = 9 LightGreen = 10 LightCyan = 11 |
LightRed = 12 LightMagenta = 13 Yellow = 14 |
White = 15 |
PROCEDURE Cls |
очистка окна консоли |
PROCEDURE SetColor(FColor, BColor: INTEGER) |
установка цвета консольного вывода: FColor - цвет текста, |
BColor - цвет фона, возможные значения - вышеперечисленные |
константы |
PROCEDURE SetCursor(x, y: INTEGER) |
установка курсора консоли в позицию (x, y) |
PROCEDURE GetCursor(VAR x, y: INTEGER) |
записывает в параметры текущие координаты курсора консоли |
PROCEDURE GetCursorX(): INTEGER |
возвращает текущую x-координату курсора консоли |
PROCEDURE GetCursorY(): INTEGER |
возвращает текущую y-координату курсора консоли |
------------------------------------------------------------------------------ |
MODULE ConsoleLib - обертка библиотеки console.obj |
------------------------------------------------------------------------------ |
MODULE Math - математические функции |
CONST |
pi = 3.141592653589793E+00 |
e = 2.718281828459045E+00 |
PROCEDURE IsNan(x: REAL): BOOLEAN |
возвращает TRUE, если x - не число |
PROCEDURE IsInf(x: REAL): BOOLEAN |
возвращает TRUE, если x - бесконечность |
PROCEDURE sqrt(x: REAL): REAL |
квадратный корень x |
PROCEDURE exp(x: REAL): REAL |
экспонента x |
PROCEDURE ln(x: REAL): REAL |
натуральный логарифм x |
PROCEDURE sin(x: REAL): REAL |
синус x |
PROCEDURE cos(x: REAL): REAL |
косинус x |
PROCEDURE tan(x: REAL): REAL |
тангенс x |
PROCEDURE arcsin(x: REAL): REAL |
арксинус x |
PROCEDURE arccos(x: REAL): REAL |
арккосинус x |
PROCEDURE arctan(x: REAL): REAL |
арктангенс x |
PROCEDURE arctan2(y, x: REAL): REAL |
арктангенс y/x |
PROCEDURE power(base, exponent: REAL): REAL |
возведение числа base в степень exponent |
PROCEDURE log(base, x: REAL): REAL |
логарифм x по основанию base |
PROCEDURE sinh(x: REAL): REAL |
гиперболический синус x |
PROCEDURE cosh(x: REAL): REAL |
гиперболический косинус x |
PROCEDURE tanh(x: REAL): REAL |
гиперболический тангенс x |
PROCEDURE arsinh(x: REAL): REAL |
обратный гиперболический синус x |
PROCEDURE arcosh(x: REAL): REAL |
обратный гиперболический косинус x |
PROCEDURE artanh(x: REAL): REAL |
обратный гиперболический тангенс x |
PROCEDURE round(x: REAL): REAL |
округление x до ближайшего целого |
PROCEDURE frac(x: REAL): REAL; |
дробная часть числа x |
PROCEDURE floor(x: REAL): REAL |
наибольшее целое число (представление как REAL), |
не больше x: floor(1.2) = 1.0 |
PROCEDURE ceil(x: REAL): REAL |
наименьшее целое число (представление как REAL), |
не меньше x: ceil(1.2) = 2.0 |
PROCEDURE sgn(x: REAL): INTEGER |
если x > 0 возвращает 1 |
если x < 0 возвращает -1 |
если x = 0 возвращает 0 |
PROCEDURE fact(n: INTEGER): REAL |
факториал n |
------------------------------------------------------------------------------ |
MODULE Debug - вывод на доску отладки |
Интерфейс как модуль Out |
PROCEDURE Open |
открывает доску отладки |
------------------------------------------------------------------------------ |
MODULE File - работа с файловой системой |
TYPE |
FNAME = ARRAY 520 OF CHAR |
FS = POINTER TO rFS |
rFS = RECORD (* информационная структура файла *) |
subfunc, pos, hpos, bytes, buffer: INTEGER; |
name: FNAME |
END |
FD = POINTER TO rFD |
rFD = RECORD (* структура блока данных входа каталога *) |
attr: INTEGER; |
ntyp: CHAR; |
reserved: ARRAY 3 OF CHAR; |
time_create, date_create, |
time_access, date_access, |
time_modif, date_modif, |
size, hsize: INTEGER; |
name: FNAME |
END |
CONST |
SEEK_BEG = 0 |
SEEK_CUR = 1 |
SEEK_END = 2 |
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER; |
Загружает в память файл с именем FName, записывает в параметр |
size размер файла, возвращает адрес загруженного файла |
или 0 (ошибка). При необходимости, распаковывает |
файл (kunpack). |
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN |
Записывает структуру блока данных входа каталога для файла |
или папки с именем FName в параметр Info. |
При ошибке возвращает FALSE. |
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN |
возвращает TRUE, если файл с именем FName существует |
PROCEDURE Close(VAR F: FS) |
освобождает память, выделенную для информационной структуры |
файла F и присваивает F значение NIL |
PROCEDURE Open(FName: ARRAY OF CHAR): FS |
возвращает указатель на информационную структуру файла с |
именем FName, при ошибке возвращает NIL |
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN |
удаляет файл с именем FName, при ошибке возвращает FALSE |
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER |
устанавливает позицию чтения-записи файла F на Offset, |
относительно Origin = (SEEK_BEG - начало файла, |
SEEK_CUR - текущая позиция, SEEK_END - конец файла), |
возвращает позицию относительно начала файла, например: |
Seek(F, 0, SEEK_END) |
устанавливает позицию на конец файла и возвращает длину |
файла; при ошибке возвращает -1 |
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER |
Читает данные из файла в память. F - указатель на |
информационную структуру файла, Buffer - адрес области |
памяти, Count - количество байт, которое требуется прочитать |
из файла; возвращает количество байт, которое было прочитано |
и соответствующим образом изменяет позицию чтения/записи в |
информационной структуре F. |
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER |
Записывает данные из памяти в файл. F - указатель на |
информационную структуру файла, Buffer - адрес области |
памяти, Count - количество байт, которое требуется записать |
в файл; возвращает количество байт, которое было записано и |
соответствующим образом изменяет позицию чтения/записи в |
информационной структуре F. |
PROCEDURE Create(FName: ARRAY OF CHAR): FS |
создает новый файл с именем FName (полное имя), возвращает |
указатель на информационную структуру файла, |
при ошибке возвращает NIL |
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN |
создает папку с именем DirName, все промежуточные папки |
должны существовать, при ошибке возвращает FALSE |
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN |
удаляет пустую папку с именем DirName, |
при ошибке возвращает FALSE |
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN |
возвращает TRUE, если папка с именем DirName существует |
------------------------------------------------------------------------------ |
MODULE Read - чтение основных типов данных из файла F |
Процедуры возвращают TRUE в случае успешной операции чтения и |
соответствующим образом изменяют позицию чтения/записи в |
информационной структуре F |
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN |
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN |
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN |
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN |
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN |
PROCEDURE WChar(F: File.FS; VAR x: WCHAR): BOOLEAN |
------------------------------------------------------------------------------ |
MODULE Write - запись основных типов данных в файл F |
Процедуры возвращают TRUE в случае успешной операции записи и |
соответствующим образом изменяют позицию чтения/записи в |
информационной структуре F |
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN |
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN |
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN |
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN |
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN |
PROCEDURE WChar(F: File.FS; x: WCHAR): BOOLEAN |
------------------------------------------------------------------------------ |
MODULE DateTime - дата, время |
CONST ERR = -7.0E5 |
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER) |
записывает в параметры компоненты текущей системной даты и |
времени |
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL |
возвращает дату, полученную из компонентов |
Year, Month, Day, Hour, Min, Sec; |
при ошибке возвращает константу ERR = -7.0E5 |
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day, |
Hour, Min, Sec: INTEGER): BOOLEAN |
извлекает компоненты |
Year, Month, Day, Hour, Min, Sec из даты Date; |
при ошибке возвращает FALSE |
------------------------------------------------------------------------------ |
MODULE Args - параметры программы |
VAR argc: INTEGER |
количество параметров программы, включая имя |
исполняемого файла |
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR) |
записывает в строку s n-й параметр программы, |
нумерация параметров от 0 до argc - 1, |
нулевой параметр -- имя исполняемого файла |
------------------------------------------------------------------------------ |
MODULE KOSAPI |
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER |
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER |
... |
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER |
Обертки для функций API ядра KolibriOS. |
arg1 .. arg7 соответствуют регистрам |
eax, ebx, ecx, edx, esi, edi, ebp; |
возвращают значение регистра eax после системного вызова. |
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER |
Обертка для функций API ядра KolibriOS. |
arg1 - регистр eax, arg2 - регистр ebx, |
res2 - значение регистра ebx после системного вызова; |
возвращает значение регистра eax после системного вызова. |
PROCEDURE malloc(size: INTEGER): INTEGER |
Выделяет блок памяти. |
size - размер блока в байтах, |
возвращает адрес выделенного блока |
PROCEDURE free(ptr: INTEGER): INTEGER |
Освобождает ранее выделенный блок памяти с адресом ptr, |
возвращает 0 |
PROCEDURE realloc(ptr, size: INTEGER): INTEGER |
Перераспределяет блок памяти, |
ptr - адрес ранее выделенного блока, |
size - новый размер, |
возвращает указатель на перераспределенный блок, |
0 при ошибке |
PROCEDURE GetCommandLine(): INTEGER |
Возвращает адрес строки параметров |
PROCEDURE GetName(): INTEGER |
Возвращает адрес строки с именем программы |
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER |
Загружает DLL с полным именем name. Возвращает адрес таблицы |
экспорта. При ошибке возвращает 0. |
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER |
name - имя процедуры |
lib - адрес таблицы экспорта DLL |
Возвращает адрес процедуры. При ошибке возвращает 0. |
------------------------------------------------------------------------------ |
MODULE ColorDlg - работа с диалогом "Color Dialog" |
TYPE |
Dialog = POINTER TO RECORD (* структура диалога *) |
status: INTEGER (* состояние диалога: |
0 - пользователь нажал Cancel |
1 - пользователь нажал OK |
2 - диалог открыт *) |
color: INTEGER (* выбранный цвет *) |
END |
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog |
создать диалог |
draw_window - процедура перерисовки основного окна |
(TYPE DRAW_WINDOW = PROCEDURE); |
процедура возвращает указатель на структуру диалога |
PROCEDURE Show(cd: Dialog) |
показать диалог |
cd - указатель на структуру диалога, который был создан ранее |
процедурой Create |
PROCEDURE Destroy(VAR cd: Dialog) |
уничтожить диалог |
cd - указатель на структуру диалога |
------------------------------------------------------------------------------ |
MODULE OpenDlg - работа с диалогом "Open Dialog" |
TYPE |
Dialog = POINTER TO RECORD (* структура диалога *) |
status: INTEGER (* состояние диалога: |
0 - пользователь нажал Cancel |
1 - пользователь нажал OK |
2 - диалог открыт *) |
FileName: ARRAY 4096 OF CHAR (* имя выбранного файла *) |
FilePath: ARRAY 4096 OF CHAR (* полное имя выбранного |
файла *) |
END |
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path, |
filter: ARRAY OF CHAR): Dialog |
создать диалог |
draw_window - процедура перерисовки основного окна |
(TYPE DRAW_WINDOW = PROCEDURE) |
type - тип диалога |
0 - открыть |
1 - сохранить |
2 - выбрать папку |
def_path - путь по умолчанию, папка def_path будет открыта |
при первом запуске диалога |
filter - в строке записано перечисление расширений файлов, |
которые будут показаны в диалоговом окне, расширения |
разделяются символом "|", например: "ASM|TXT|INI" |
процедура возвращает указатель на структуру диалога |
PROCEDURE Show(od: Dialog; Width, Height: INTEGER) |
показать диалог |
od - указатель на структуру диалога, который был создан ранее |
процедурой Create |
Width и Height - ширина и высота диалогового окна |
PROCEDURE Destroy(VAR od: Dialog) |
уничтожить диалог |
od - указатель на структуру диалога |
------------------------------------------------------------------------------ |
MODULE kfonts - работа с kf-шрифтами |
CONST |
bold = 1 |
italic = 2 |
underline = 4 |
strike_through = 8 |
smoothing = 16 |
bpp32 = 32 |
TYPE |
TFont = POINTER TO TFont_desc (* указатель на шрифт *) |
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont |
загрузить шрифт из файла |
file_name имя kf-файла |
рез-т: указатель на шрифт/NIL (ошибка) |
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN |
установить размер шрифта |
Font указатель на шрифт |
font_size размер шрифта |
рез-т: TRUE/FALSE (ошибка) |
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN |
проверить, есть ли шрифт, заданного размера |
Font указатель на шрифт |
font_size размер шрифта |
рез-т: TRUE/FALSE (шрифта нет) |
PROCEDURE Destroy(VAR Font: TFont) |
выгрузить шрифт, освободить динамическую память |
Font указатель на шрифт |
Присваивает переменной Font значение NIL |
PROCEDURE TextHeight(Font: TFont): INTEGER |
получить высоту строки текста |
Font указатель на шрифт |
рез-т: высота строки текста в пикселях |
PROCEDURE TextWidth(Font: TFont; |
str, length, params: INTEGER): INTEGER |
получить ширину строки текста |
Font указатель на шрифт |
str адрес строки текста в кодировке Win-1251 |
length количество символов в строке или -1, если строка |
завершается нулем |
params параметры-флаги см. ниже |
рез-т: ширина строки текста в пикселях |
PROCEDURE TextOut(Font: TFont; |
canvas, x, y, str, length, color, params: INTEGER) |
вывести текст в буфер |
для вывода буфера в окно, использовать ф.65 или |
ф.7 (если буфер 24-битный) |
Font указатель на шрифт |
canvas адрес графического буфера |
структура буфера: |
Xsize dd |
Ysize dd |
picture rb Xsize * Ysize * 4 (32 бита) |
или Xsize * Ysize * 3 (24 бита) |
x, y координаты текста относительно левого верхнего |
угла буфера |
str адрес строки текста в кодировке Win-1251 |
length количество символов в строке или -1, если строка |
завершается нулем |
color цвет текста 0x00RRGGBB |
params параметры-флаги: |
1 жирный |
2 курсив |
4 подчеркнутый |
8 перечеркнутый |
16 применить сглаживание |
32 вывод в 32-битный буфер |
возможно использование флагов в любых сочетаниях |
------------------------------------------------------------------------------ |
MODULE RasterWorks - обертка библиотеки Rasterworks.obj |
------------------------------------------------------------------------------ |
MODULE libimg - обертка библиотеки libimg.obj |
------------------------------------------------------------------------------ |
/programs/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/programs/develop/oberon07/doc/WinLib.txt |
---|
0,0 → 1,312 |
============================================================================== |
Библиотека (Windows) |
------------------------------------------------------------------------------ |
MODULE Out - консольный вывод |
PROCEDURE Open |
открывает консольный вывод |
PROCEDURE Int(x, width: INTEGER) |
вывод целого числа x; |
width - количество знакомест, используемых для вывода |
PROCEDURE Real(x: REAL; width: INTEGER) |
вывод вещественного числа x в плавающем формате; |
width - количество знакомест, используемых для вывода |
PROCEDURE Char(x: CHAR) |
вывод символа x |
PROCEDURE FixReal(x: REAL; width, p: INTEGER) |
вывод вещественного числа x в фиксированном формате; |
width - количество знакомест, используемых для вывода; |
p - количество знаков после десятичной точки |
PROCEDURE Ln |
переход на следующую строку |
PROCEDURE String(s: ARRAY OF CHAR) |
вывод строки s (ASCII) |
PROCEDURE StringW(s: ARRAY OF WCHAR) |
вывод строки s (UTF-16) |
------------------------------------------------------------------------------ |
MODULE In - консольный ввод |
VAR Done: BOOLEAN |
принимает значение TRUE в случае успешного выполнения |
операции ввода и FALSE в противном случае |
PROCEDURE Open |
открывает консольный ввод, |
также присваивает переменной Done значение TRUE |
PROCEDURE Int(VAR x: INTEGER) |
ввод числа типа INTEGER |
PROCEDURE Char(VAR x: CHAR) |
ввод символа |
PROCEDURE Real(VAR x: REAL) |
ввод числа типа REAL |
PROCEDURE String(VAR s: ARRAY OF CHAR) |
ввод строки |
PROCEDURE Ln |
ожидание нажатия ENTER |
------------------------------------------------------------------------------ |
MODULE Console - дополнительные процедуры консольного вывода |
CONST |
Следующие константы определяют цвет консольного вывода |
Black = 0 Blue = 1 Green = 2 |
Cyan = 3 Red = 4 Magenta = 5 |
Brown = 6 LightGray = 7 DarkGray = 8 |
LightBlue = 9 LightGreen = 10 LightCyan = 11 |
LightRed = 12 LightMagenta = 13 Yellow = 14 |
White = 15 |
PROCEDURE Cls |
очистка окна консоли |
PROCEDURE SetColor(FColor, BColor: INTEGER) |
установка цвета консольного вывода: FColor - цвет текста, |
BColor - цвет фона, возможные значения - вышеперечисленные |
константы |
PROCEDURE SetCursor(x, y: INTEGER) |
установка курсора консоли в позицию (x, y) |
PROCEDURE GetCursor(VAR x, y: INTEGER) |
записывает в параметры текущие координаты курсора консоли |
PROCEDURE GetCursorX(): INTEGER |
возвращает текущую x-координату курсора консоли |
PROCEDURE GetCursorY(): INTEGER |
возвращает текущую y-координату курсора консоли |
------------------------------------------------------------------------------ |
MODULE Math - математические функции |
CONST |
pi = 3.141592653589793E+00 |
e = 2.718281828459045E+00 |
PROCEDURE IsNan(x: REAL): BOOLEAN |
возвращает TRUE, если x - не число |
PROCEDURE IsInf(x: REAL): BOOLEAN |
возвращает TRUE, если x - бесконечность |
PROCEDURE sqrt(x: REAL): REAL |
квадратный корень x |
PROCEDURE exp(x: REAL): REAL |
экспонента x |
PROCEDURE ln(x: REAL): REAL |
натуральный логарифм x |
PROCEDURE sin(x: REAL): REAL |
синус x |
PROCEDURE cos(x: REAL): REAL |
косинус x |
PROCEDURE tan(x: REAL): REAL |
тангенс x |
PROCEDURE arcsin(x: REAL): REAL |
арксинус x |
PROCEDURE arccos(x: REAL): REAL |
арккосинус x |
PROCEDURE arctan(x: REAL): REAL |
арктангенс x |
PROCEDURE arctan2(y, x: REAL): REAL |
арктангенс y/x |
PROCEDURE power(base, exponent: REAL): REAL |
возведение числа base в степень exponent |
PROCEDURE log(base, x: REAL): REAL |
логарифм x по основанию base |
PROCEDURE sinh(x: REAL): REAL |
гиперболический синус x |
PROCEDURE cosh(x: REAL): REAL |
гиперболический косинус x |
PROCEDURE tanh(x: REAL): REAL |
гиперболический тангенс x |
PROCEDURE arsinh(x: REAL): REAL |
обратный гиперболический синус x |
PROCEDURE arcosh(x: REAL): REAL |
обратный гиперболический косинус x |
PROCEDURE artanh(x: REAL): REAL |
обратный гиперболический тангенс x |
PROCEDURE round(x: REAL): REAL |
округление x до ближайшего целого |
PROCEDURE frac(x: REAL): REAL; |
дробная часть числа x |
PROCEDURE floor(x: REAL): REAL |
наибольшее целое число (представление как REAL), |
не больше x: floor(1.2) = 1.0 |
PROCEDURE ceil(x: REAL): REAL |
наименьшее целое число (представление как REAL), |
не меньше x: ceil(1.2) = 2.0 |
PROCEDURE sgn(x: REAL): INTEGER |
если x > 0 возвращает 1 |
если x < 0 возвращает -1 |
если x = 0 возвращает 0 |
PROCEDURE fact(n: INTEGER): REAL |
факториал n |
------------------------------------------------------------------------------ |
MODULE File - работа с файловой системой |
CONST |
OPEN_R = 0 |
OPEN_W = 1 |
OPEN_RW = 2 |
SEEK_BEG = 0 |
SEEK_CUR = 1 |
SEEK_END = 2 |
PROCEDURE Create(FName: ARRAY OF CHAR): INTEGER |
создает новый файл с именем FName (полное имя с путем), |
открывет файл для записи и возвращает идентификатор файла |
(целое число), в случае ошибки, возвращает -1 |
PROCEDURE Open(FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER |
открывает существующий файл с именем FName (полное имя с |
путем) в режиме Mode = (OPEN_R (только чтение), OPEN_W |
(только запись), OPEN_RW (чтение и запись)), возвращает |
идентификатор файла (целое число), в случае ошибки, |
возвращает -1 |
PROCEDURE Read(F, Buffer, Count: INTEGER): INTEGER |
Читает данные из файла в память. F - числовой идентификатор |
файла, Buffer - адрес области памяти, Count - количество байт, |
которое требуется прочитать из файла; возвращает количество |
байт, которое было прочитано из файла |
PROCEDURE Write(F, Buffer, Count: INTEGER): INTEGER |
Записывает данные из памяти в файл. F - числовой идентификатор |
файла, Buffer - адрес области памяти, Count - количество байт, |
которое требуется записать в файл; возвращает количество байт, |
которое было записано в файл |
PROCEDURE Seek(F, Offset, Origin: INTEGER): INTEGER |
устанавливает позицию чтения-записи файла с идентификатором F |
на Offset, относительно Origin = (SEEK_BEG - начало файла, |
SEEK_CUR - текущая позиция, SEEK_END - конец файла), |
возвращает позицию относительно начала файла, например: |
Seek(F, 0, 2) - устанавливает позицию на конец файла и |
возвращает длину файла; при ошибке возвращает -1 |
PROCEDURE Close(F: INTEGER) |
закрывает ранее открытый файл с идентификатором F |
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN |
удаляет файл с именем FName (полное имя с путем), |
возвращает TRUE, если файл успешно удален |
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN |
возвращает TRUE, если файл с именем FName (полное имя) |
существует |
PROCEDURE Load(FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER |
загружает в память существующий файл с именем FName (полное имя с |
путем), возвращает адрес памяти, куда был загружен файл, |
записывает размер файла в параметр Size; |
при ошибке возвращает 0 |
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN |
создает папку с именем DirName, все промежуточные папки |
должны существовать. В случае ошибки, возвращает FALSE |
PROCEDURE RemoveDir(DirName: ARRAY OF CHAR): BOOLEAN |
удаляет пустую папку с именем DirName. В случае ошибки, |
возвращает FALSE |
PROCEDURE ExistsDir(DirName: ARRAY OF CHAR): BOOLEAN |
возвращает TRUE, если папка с именем DirName существует |
------------------------------------------------------------------------------ |
MODULE DateTime - дата, время |
CONST ERR = -7.0E5 |
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER) |
возвращает в параметрах компоненты текущей системной даты и |
времени |
PROCEDURE NowEncode(): REAL; |
возвращает текущую системную дату и |
время (представление REAL) |
PROCEDURE Encode(Year, Month, Day, |
Hour, Min, Sec, MSec: INTEGER): REAL |
возвращает дату, полученную из компонентов |
Year, Month, Day, Hour, Min, Sec, MSec; |
при ошибке возвращает константу ERR = -7.0E5 |
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day, |
Hour, Min, Sec, MSec: INTEGER): BOOLEAN |
извлекает компоненты |
Year, Month, Day, Hour, Min, Sec, MSec из даты Date; |
при ошибке возвращает FALSE |
------------------------------------------------------------------------------ |
MODULE Args - параметры программы |
VAR argc: INTEGER |
количество параметров программы, включая имя |
исполняемого файла |
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR) |
записывает в строку s n-й параметр программы, |
нумерация параметров от 0 до argc - 1, |
нулевой параметр -- имя исполняемого файла |
------------------------------------------------------------------------------ |
MODULE Utils - разное |
PROCEDURE Utf8To16(source: ARRAY OF CHAR; |
VAR dest: ARRAY OF CHAR): INTEGER; |
преобразует символы строки source из кодировки UTF-8 в |
кодировку UTF-16, результат записывает в строку dest, |
возвращает количество 16-битных символов, записанных в dest |
PROCEDURE PutSeed(seed: INTEGER) |
Инициализация генератора случайных чисел целым числом seed |
PROCEDURE Rnd(range: INTEGER): INTEGER |
Целые случайные числа в диапазоне 0 <= x < range |
------------------------------------------------------------------------------ |
MODULE WINAPI - привязки к некоторым API-функциям Windows |
/programs/develop/oberon07/doc/x86.txt |
---|
0,0 → 1,413 |
Компилятор языка программирования Oberon-07/16 для i486 |
Windows/Linux/KolibriOS. |
------------------------------------------------------------------------------ |
Параметры командной строки |
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или |
UTF-8 с BOM-сигнатурой. |
Выход - испоняемый файл формата PE32, ELF или MENUET01/MSCOFF. |
Параметры: |
1) имя главного модуля |
2) тип приложения |
"win32con" - Windows console |
"win32gui" - Windows GUI |
"win32dll" - Windows DLL |
"linux32exe" - Linux ELF-EXEC |
"linux32so" - Linux ELF-SO |
"kosexe" - KolibriOS |
"kosdll" - KolibriOS DLL |
3) необязательные параметры-ключи |
-out <file_name> имя результирующего файла; по умолчанию, |
совпадает с именем главного модуля, но с другим расширением |
(соответствует типу исполняемого файла) |
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб, |
допустимо от 1 до 32 Мб) |
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже) |
-lower разрешить ключевые слова и встроенные идентификаторы в |
нижнем регистре |
-def <имя> задать символ условной компиляции |
-ver <major.minor> версия программы (только для kosdll) |
параметр -nochk задается в виде строки из символов: |
"p" - указатели |
"t" - типы |
"i" - индексы |
"b" - неявное приведение INTEGER к BYTE |
"c" - диапазон аргумента функции CHR |
"w" - диапазон аргумента функции WCHR |
"r" - эквивалентно "bcw" |
"a" - все проверки |
Порядок символов может быть любым. Наличие в строке того или иного |
символа отключает соответствующую проверку. |
Например: -nochk it - отключить проверку индексов и охрану типа. |
-nochk a - отключить все отключаемые проверки. |
Например: |
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -stk 1 |
Compiler.exe "C:\example.ob07" win32dll -out "C:\example.dll" |
Compiler.exe "C:\example.ob07" win32gui -out "C:\example.exe" -stk 4 |
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -nochk pti |
Compiler.kex "/tmp0/1/example.ob07" kosexe -out "/tmp0/1/example.kex" -stk 4 |
Compiler.kex "/tmp0/1/example.ob07" kosdll -out "/tmp0/1/mydll.obj" -ver 2.7 |
Compiler.exe "C:\example.ob07" linux32exe -out "C:\example" -stk 1 -nochk a |
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1. |
При работе компилятора в KolibriOS, код завершения не передается. |
------------------------------------------------------------------------------ |
Отличия от оригинала |
1. Расширен псевдомодуль SYSTEM |
2. В идентификаторах допускается символ "_" |
3. Добавлены системные флаги |
4. Усовершенствован оператор CASE (добавлены константные выражения в |
метках вариантов и необязательная ветка ELSE) |
5. Расширен набор стандартных процедур |
6. Семантика охраны/проверки типа уточнена для нулевого указателя |
7. Добавлены однострочные комментарии (начинаются с пары символов "//") |
8. Разрешено наследование от типа-указателя |
9. Добавлен синтаксис для импорта процедур из внешних библиотек |
10. "Строки" можно заключать также в одиночные кавычки: 'строка' |
11. Добавлен тип WCHAR |
12. Добавлена операция конкатенации строковых и символьных констант |
13. Возможен импорт модулей с указанием пути и имени файла |
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt) |
15. Имя процедуры в конце объявления (после END) необязательно |
------------------------------------------------------------------------------ |
Особенности реализации |
1. Основные типы |
Тип Диапазон значений Размер, байт |
INTEGER -2147483648 .. 2147483647 4 |
REAL 4.94E-324 .. 1.70E+308 8 |
CHAR символ ASCII (0X .. 0FFX) 1 |
BOOLEAN FALSE, TRUE 1 |
SET множество из целых чисел {0 .. 31} 4 |
BYTE 0 .. 255 1 |
WCHAR символ юникода (0X .. 0FFFFX) 2 |
2. Максимальная длина идентификаторов - 255 символов |
3. Максимальная длина строковых констант - 511 символов (UTF-8) |
4. Максимальная размерность открытых массивов - 5 |
5. Процедура NEW заполняет нулями выделенный блок памяти |
6. Глобальные и локальные переменные инициализируются нулями |
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая |
модульность отсутствуют |
8. Тип BYTE в выражениях всегда приводится к INTEGER |
9. Контроль переполнения значений выражений не производится |
10. Ошибки времени выполнения: |
1 ASSERT(x), при x = FALSE |
2 разыменование нулевого указателя |
3 целочисленное деление на неположительное число |
4 вызов процедуры через процедурную переменную с нулевым значением |
5 ошибка охраны типа |
6 нарушение границ массива |
7 непредусмотренное значение выражения в операторе CASE |
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x) |
9 CHR(x), если (x < 0) OR (x > 255) |
10 WCHR(x), если (x < 0) OR (x > 65535) |
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255) |
------------------------------------------------------------------------------ |
Псевдомодуль SYSTEM |
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры, |
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к |
повреждению данных времени выполнения и аварийному завершению программы. |
PROCEDURE ADR(v: любой тип): INTEGER |
v - переменная или процедура; |
возвращает адрес v |
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER |
возвращает адрес x |
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER |
возвращает адрес x |
PROCEDURE SIZE(T): INTEGER |
возвращает размер типа T |
PROCEDURE TYPEID(T): INTEGER |
T - тип-запись или тип-указатель, |
возвращает номер типа в таблице типов-записей |
PROCEDURE INF(): REAL |
возвращает специальное вещественное значение "бесконечность" |
PROCEDURE MOVE(Source, Dest, n: INTEGER) |
Копирует n байт памяти из Source в Dest, |
области Source и Dest не могут перекрываться |
PROCEDURE GET(a: INTEGER; |
VAR v: любой основной тип, PROCEDURE, POINTER) |
v := Память[a] |
PROCEDURE GET8(a: INTEGER; |
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1) |
PROCEDURE GET16(a: INTEGER; |
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2) |
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4) |
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER) |
Память[a] := x; |
Если x: BYTE или x: WCHAR, то значение x будет расширено |
до 32 бит, для записи байтов использовать SYSTEM.PUT8, |
для WCHAR -- SYSTEM.PUT16 |
PROCEDURE PUT8(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 8 бит (x) |
PROCEDURE PUT16(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 16 бит (x) |
PROCEDURE PUT32(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 32 бит (x) |
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER) |
Копирует n байт памяти из Source в Dest. |
Эквивалентно |
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n) |
PROCEDURE CODE(byte1, byte2,... : INTEGER) |
Вставка машинного кода, |
byte1, byte2 ... - константы в диапазоне 0..255, |
например: |
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *) |
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не |
допускаются никакие явные операции, за исключением присваивания. |
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях. |
------------------------------------------------------------------------------ |
Системные флаги |
При объявлении процедурных типов и глобальных процедур, после ключевого |
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall], |
[cdecl], [ccall], [windows], [linux], [oberon]. Например: |
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER; |
Если указан флаг [ccall], то принимается соглашение cdecl, но перед |
вызовом указатель стэка будет выравнен по границе 16 байт. |
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall]. |
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что |
результат процедуры можно игнорировать (не допускается для типа REAL). |
Если флаг не указан или указан флаг [oberon], то принимается внутреннее |
соглашение о вызове. |
При объявлении типов-записей, после ключевого слова RECORD может быть |
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей |
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть |
базовыми типами для других записей. |
Для использования системных флагов, требуется импортировать SYSTEM. |
------------------------------------------------------------------------------ |
Оператор CASE |
Синтаксис оператора CASE: |
CaseStatement = |
CASE Expression OF Case {"|" Case} |
[ELSE StatementSequence] END. |
Case = [CaseLabelList ":" StatementSequence]. |
CaseLabelList = CaseLabels {"," CaseLabels}. |
CaseLabels = ConstExpression [".." ConstExpression]. |
Например: |
CASE x OF |
|-1: DoSomething1 |
| 1: DoSomething2 |
| 0: DoSomething3 |
ELSE |
DoSomething4 |
END |
В метках вариантов можно использовать константные выражения, ветка ELSE |
необязательна. Если значение x не соответствует ни одному варианту и ELSE |
отсутствует, то программа прерывается с ошибкой времени выполнения. |
------------------------------------------------------------------------------ |
Тип WCHAR |
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и |
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и |
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает |
только тип CHAR. Для получения значения типа WCHAR, следует использовать |
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять |
исходный код в кодировке UTF-8 с BOM. |
------------------------------------------------------------------------------ |
Конкатенация строковых и символьных констант |
Допускается конкатенация ("+") константных строк и символов типа CHAR: |
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *) |
newline = 0DX + 0AX; |
------------------------------------------------------------------------------ |
Проверка и охрана типа нулевого указателя |
Оригинальное сообщение о языке не определяет поведение программы при |
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих |
Oberon-реализациях выполнение такой операции приводит к ошибке времени |
выполнения. В данной реализации охрана типа нулевого указателя не приводит к |
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет |
значительно сократить частоту применения охраны типа. |
------------------------------------------------------------------------------ |
Дополнительные стандартные процедуры |
DISPOSE (VAR v: любой_указатель) |
Освобождает память, выделенную процедурой NEW для |
динамической переменной v^, и присваивает переменной v |
значение NIL. |
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR); |
v := x; |
Если LEN(v) < LEN(x), то строка x будет скопирована |
не полностью |
LSR (x, n: INTEGER): INTEGER |
Логический сдвиг x на n бит вправо. |
MIN (a, b: INTEGER): INTEGER |
Минимум из двух значений. |
MAX (a, b: INTEGER): INTEGER |
Максимум из двух значений. |
BITS (x: INTEGER): SET |
Интерпретирует x как значение типа SET. |
Выполняется на этапе компиляции. |
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER |
Длина 0X-завершенной строки s, без учета символа 0X. |
Если символ 0X отсутствует, функция возвращает длину |
массива s. s не может быть константой. |
WCHR (n: INTEGER): WCHAR |
Преобразование типа, аналогично CHR(n: INTEGER): CHAR |
------------------------------------------------------------------------------ |
Импорт модулей с указанием пути и имени файла |
Примеры: |
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *) |
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *) |
------------------------------------------------------------------------------ |
Импортированные процедуры |
Синтаксис импорта: |
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type; |
- callconv -- соглашение о вызове |
- library -- имя файла динамической библиотеки (строковая константа) |
- function -- имя импортируемой процедуры (строковая константа), если |
указана пустая строка, то имя процедуры = proc_name |
например: |
PROCEDURE [windows, "kernel32.dll", ""] ExitProcess (code: INTEGER); |
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN); |
В конце объявления может быть добавлено (необязательно) "END proc_name;" |
Объявления импортированных процедур должны располагаться в глобальной |
области видимости модуля после объявления переменных, вместе с объявлением |
"обычных" процедур, от которых импортированные отличаются только отсутствием |
тела процедуры. В остальном, к таким процедурам применимы те же правила: |
их можно вызвать, присвоить процедурной переменной или получить адрес. |
Так как импортированная процедура всегда имеет явное указание соглашения о |
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием |
соглашения о вызове: |
VAR |
ExitProcess: PROCEDURE [windows] (code: INTEGER); |
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN); |
В KolibriOS импортировать процедуры можно только из библиотек, размещенных |
в /rd/1/lib. Импортировать и вызывать функции инициализации библиотек |
(lib_init, START) при этом не нужно. |
Для Linux, импортированные процедуры не реализованы. |
------------------------------------------------------------------------------ |
Скрытые параметры процедур |
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке |
формальных параметров, но учитываются компилятором при трансляции вызовов. |
Это возможно в следующих случаях: |
1. Процедура имеет формальный параметр открытый массив: |
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL); |
Вызов транслируется так: |
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x)) |
2. Процедура имеет формальный параметр-переменную типа RECORD: |
PROCEDURE Proc (VAR x: Rec); |
Вызов транслируется так: |
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x)) |
Скрытые параметры необходимо учитывать при связи с внешними приложениями. |
------------------------------------------------------------------------------ |
Модуль RTL |
Все программы неявно используют модуль RTL. Компилятор транслирует |
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об |
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не |
следует вызывать эти процедуры явно. |
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах |
(Windows), в терминал (Linux), на доску отладки (KolibriOS). |
------------------------------------------------------------------------------ |
Модуль API |
Существуют несколько реализаций модуля API (для различных ОС). |
Как и модуль RTL, модуль API не предназначен для прямого использования. |
Он обеспечивает связь RTL с ОС. |
------------------------------------------------------------------------------ |
Генерация исполняемых файлов DLL |
Разрешается экспортировать только процедуры. Для этого, процедура должна |
находиться в главном модуле программы, и ее имя должно быть отмечено символом |
экспорта ("*"). Нельзя экспортировать процедуры, которые импортированы из |
других dll-библиотек. |
KolibriOS DLL всегда экспортируют идентификаторы "version" (версия |
программы) и "lib_init" - адрес процедуры инициализации DLL: |
PROCEDURE [stdcall] lib_init (): INTEGER |
Эта процедура должна быть вызвана перед использованием DLL. |
Процедура всегда возвращает 1. |
/programs/develop/oberon07/doc/x86_64.txt |
---|
0,0 → 1,394 |
Компилятор языка программирования Oberon-07/16 для x86_64 |
Windows/Linux |
------------------------------------------------------------------------------ |
Параметры командной строки |
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или |
UTF-8 с BOM-сигнатурой. |
Выход - испоняемый файл формата PE32+ или ELF64. |
Параметры: |
1) имя главного модуля |
2) тип приложения |
"win64con" - Windows64 console |
"win64gui" - Windows64 GUI |
"win64dll" - Windows64 DLL |
"linux64exe" - Linux ELF64-EXEC |
"linux64so" - Linux ELF64-SO |
3) необязательные параметры-ключи |
-out <file_name> имя результирующего файла; по умолчанию, |
совпадает с именем главного модуля, но с другим расширением |
(соответствует типу исполняемого файла) |
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб, |
допустимо от 1 до 32 Мб) |
-nochk <"ptibcwra"> отключить проверки при выполнении |
-lower разрешить ключевые слова и встроенные идентификаторы в |
нижнем регистре |
-def <имя> задать символ условной компиляции |
параметр -nochk задается в виде строки из символов: |
"p" - указатели |
"t" - типы |
"i" - индексы |
"b" - неявное приведение INTEGER к BYTE |
"c" - диапазон аргумента функции CHR |
"w" - диапазон аргумента функции WCHR |
"r" - эквивалентно "bcw" |
"a" - все проверки |
Порядок символов может быть любым. Наличие в строке того или иного |
символа отключает соответствующую проверку. |
Например: -nochk it - отключить проверку индексов и охрану типа. |
-nochk a - отключить все отключаемые проверки. |
Например: |
Compiler.exe "C:\example.ob07" win64con -out "C:\example.exe" -stk 1 |
Compiler.exe "C:\example.ob07" win64dll -out "C:\example.dll" -nochk pti |
Compiler "source/Compiler.ob07" linux64exe -out "source/Compiler" -nochk a |
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1. |
------------------------------------------------------------------------------ |
Отличия от оригинала |
1. Расширен псевдомодуль SYSTEM |
2. В идентификаторах допускается символ "_" |
3. Добавлены системные флаги |
4. Усовершенствован оператор CASE (добавлены константные выражения в |
метках вариантов и необязательная ветка ELSE) |
5. Расширен набор стандартных процедур |
6. Семантика охраны/проверки типа уточнена для нулевого указателя |
7. Добавлены однострочные комментарии (начинаются с пары символов "//") |
8. Разрешено наследование от типа-указателя |
9. Добавлен синтаксис для импорта процедур из внешних библиотек |
10. "Строки" можно заключать также в одиночные кавычки: 'строка' |
11. Добавлен тип WCHAR |
12. Добавлена операция конкатенации строковых и символьных констант |
13. Возможен импорт модулей с указанием пути и имени файла |
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt) |
15. Имя процедуры в конце объявления (после END) необязательно |
------------------------------------------------------------------------------ |
Особенности реализации |
1. Основные типы |
Тип Диапазон значений Размер, байт |
INTEGER -9223372036854775808 .. 9223372036854775807 8 |
REAL 4.94E-324 .. 1.70E+308 8 |
CHAR символ ASCII (0X .. 0FFX) 1 |
BOOLEAN FALSE, TRUE 1 |
SET множество из целых чисел {0 .. 63} 8 |
BYTE 0 .. 255 1 |
WCHAR символ юникода (0X .. 0FFFFX) 2 |
2. Максимальная длина идентификаторов - 255 символов |
3. Максимальная длина строковых констант - 511 символов (UTF-8) |
4. Максимальная размерность открытых массивов - 5 |
5. Процедура NEW заполняет нулями выделенный блок памяти |
6. Глобальные и локальные переменные инициализируются нулями |
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая |
модульность отсутствуют |
8. Тип BYTE в выражениях всегда приводится к INTEGER |
9. Контроль переполнения значений выражений не производится |
10. Ошибки времени выполнения: |
1 ASSERT(x), при x = FALSE |
2 разыменование нулевого указателя |
3 целочисленное деление на неположительное число |
4 вызов процедуры через процедурную переменную с нулевым значением |
5 ошибка охраны типа |
6 нарушение границ массива |
7 непредусмотренное значение выражения в операторе CASE |
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x) |
9 CHR(x), если (x < 0) OR (x > 255) |
10 WCHR(x), если (x < 0) OR (x > 65535) |
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255) |
------------------------------------------------------------------------------ |
Псевдомодуль SYSTEM |
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры, |
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к |
повреждению данных времени выполнения и аварийному завершению программы. |
PROCEDURE ADR(v: любой тип): INTEGER |
v - переменная или процедура; |
возвращает адрес v |
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER |
возвращает адрес x |
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER |
возвращает адрес x |
PROCEDURE SIZE(T): INTEGER |
возвращает размер типа T |
PROCEDURE TYPEID(T): INTEGER |
T - тип-запись или тип-указатель, |
возвращает номер типа в таблице типов-записей |
PROCEDURE INF(): REAL |
возвращает специальное вещественное значение "бесконечность" |
PROCEDURE MOVE(Source, Dest, n: INTEGER) |
Копирует n байт памяти из Source в Dest, |
области Source и Dest не могут перекрываться |
PROCEDURE GET(a: INTEGER; |
VAR v: любой основной тип, PROCEDURE, POINTER) |
v := Память[a] |
PROCEDURE GET8(a: INTEGER; |
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1) |
PROCEDURE GET16(a: INTEGER; |
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2) |
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32) |
Эквивалентно |
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4) |
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER) |
Память[a] := x; |
Если x: BYTE или x: WCHAR, то значение x будет расширено |
до 64 бит, для записи байтов использовать SYSTEM.PUT8, |
для WCHAR -- SYSTEM.PUT16 |
PROCEDURE PUT8(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 8 бит (x) |
PROCEDURE PUT16(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 16 бит (x) |
PROCEDURE PUT32(a: INTEGER; |
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32) |
Память[a] := младшие 32 бит (x) |
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER) |
Копирует n байт памяти из Source в Dest. |
Эквивалентно |
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n) |
PROCEDURE CODE(byte1, byte2,... : BYTE) |
Вставка машинного кода, |
byte1, byte2 ... - константы в диапазоне 0..255, |
например: |
SYSTEM.CODE(048H,08BH,045H,010H) (* mov rax,qword[rbp+16] *) |
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не |
допускаются никакие явные операции, за исключением присваивания. |
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях. |
------------------------------------------------------------------------------ |
Системные флаги |
При объявлении процедурных типов и глобальных процедур, после ключевого |
слова PROCEDURE может быть указан флаг соглашения о вызове: |
[win64], [systemv], [windows], [linux], [oberon], [ccall]. |
Например: |
PROCEDURE [win64] MyProc (x, y, z: INTEGER): INTEGER; |
Флаг [windows] - синоним для [win64], [linux] - синоним для [systemv]. |
Флаг [ccall] - синоним для [win64] или [systemv] (зависит от целевой ОС). |
Знак "-" после имени флага ([win64-], [linux-], ...) означает, что |
результат процедуры можно игнорировать (не допускается для типа REAL). |
Если флаг не указан или указан флаг [oberon], то принимается внутреннее |
соглашение о вызове. [win64] и [systemv] используются для связи с |
операционной системой и внешними приложениями. |
При объявлении типов-записей, после ключевого слова RECORD может быть |
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей |
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть |
базовыми типами для других записей. |
Для использования системных флагов, требуется импортировать SYSTEM. |
------------------------------------------------------------------------------ |
Оператор CASE |
Синтаксис оператора CASE: |
CaseStatement = |
CASE Expression OF Case {"|" Case} |
[ELSE StatementSequence] END. |
Case = [CaseLabelList ":" StatementSequence]. |
CaseLabelList = CaseLabels {"," CaseLabels}. |
CaseLabels = ConstExpression [".." ConstExpression]. |
Например: |
CASE x OF |
|-1: DoSomething1 |
| 1: DoSomething2 |
| 0: DoSomething3 |
ELSE |
DoSomething4 |
END |
В метках вариантов можно использовать константные выражения, ветка ELSE |
необязательна. Если значение x не соответствует ни одному варианту и ELSE |
отсутствует, то программа прерывается с ошибкой времени выполнения. |
------------------------------------------------------------------------------ |
Тип WCHAR |
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и |
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и |
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает |
только тип CHAR. Для получения значения типа WCHAR, следует использовать |
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять |
исходный код в кодировке UTF-8 с BOM. |
------------------------------------------------------------------------------ |
Конкатенация строковых и символьных констант |
Допускается конкатенация ("+") константных строк и символов типа CHAR: |
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *) |
newline = 0DX + 0AX; |
------------------------------------------------------------------------------ |
Проверка и охрана типа нулевого указателя |
Оригинальное сообщение о языке не определяет поведение программы при |
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих |
Oberon-реализациях выполнение такой операции приводит к ошибке времени |
выполнения. В данной реализации охрана типа нулевого указателя не приводит к |
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет |
значительно сократить частоту применения охраны типа. |
------------------------------------------------------------------------------ |
Дополнительные стандартные процедуры |
DISPOSE (VAR v: любой_указатель) |
Освобождает память, выделенную процедурой NEW для |
динамической переменной v^, и присваивает переменной v |
значение NIL. |
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR); |
v := x; |
Если LEN(v) < LEN(x), то строка x будет скопирована |
не полностью |
LSR (x, n: INTEGER): INTEGER |
Логический сдвиг x на n бит вправо. |
MIN (a, b: INTEGER): INTEGER |
Минимум из двух значений. |
MAX (a, b: INTEGER): INTEGER |
Максимум из двух значений. |
BITS (x: INTEGER): SET |
Интерпретирует x как значение типа SET. |
Выполняется на этапе компиляции. |
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER |
Длина 0X-завершенной строки s, без учета символа 0X. |
Если символ 0X отсутствует, функция возвращает длину |
массива s. s не может быть константой. |
WCHR (n: INTEGER): WCHAR |
Преобразование типа, аналогично CHR(n: INTEGER): CHAR |
------------------------------------------------------------------------------ |
Импорт модулей с указанием пути и имени файла |
Примеры: |
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *) |
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *) |
------------------------------------------------------------------------------ |
Импортированные процедуры |
Синтаксис импорта: |
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type; |
- callconv -- соглашение о вызове |
- library -- имя файла динамической библиотеки (строковая константа) |
- function -- имя импортируемой процедуры (строковая константа), если |
указана пустая строка, то имя процедуры = proc_name |
например: |
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER); |
PROCEDURE [windows, "kernel32.dll", ""] GetTickCount (): INTEGER; |
В конце объявления может быть добавлено (необязательно) "END proc_name;" |
Объявления импортированных процедур должны располагаться в глобальной |
области видимости модуля после объявления переменных, вместе с объявлением |
"обычных" процедур, от которых импортированные отличаются только отсутствием |
тела процедуры. В остальном, к таким процедурам применимы те же правила: |
их можно вызвать, присвоить процедурной переменной или получить адрес. |
Так как импортированная процедура всегда имеет явное указание соглашения о |
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием |
соглашения о вызове: |
VAR |
ExitProcess: PROCEDURE [windows] (code: INTEGER); |
Для Linux, импортированные процедуры не реализованы. |
------------------------------------------------------------------------------ |
Скрытые параметры процедур |
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке |
формальных параметров, но учитываются компилятором при трансляции вызовов. |
Это возможно в следующих случаях: |
1. Процедура имеет формальный параметр открытый массив: |
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL); |
Вызов транслируется так: |
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x)) |
2. Процедура имеет формальный параметр-переменную типа RECORD: |
PROCEDURE Proc (VAR x: Rec); |
Вызов транслируется так: |
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x)) |
Скрытые параметры необходимо учитывать при связи с внешними приложениями. |
------------------------------------------------------------------------------ |
Модуль RTL |
Все программы неявно используют модуль RTL. Компилятор транслирует |
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об |
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не |
следует вызывать эти процедуры явно. |
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах |
(Windows), в терминал (Linux). |
------------------------------------------------------------------------------ |
Модуль API |
Существуют несколько реализаций модуля API (для различных ОС). |
Как и модуль RTL, модуль API не предназначен для прямого использования. |
Он обеспечивает связь RTL с ОС. |
------------------------------------------------------------------------------ |
Генерация исполняемых файлов DLL |
Разрешается экспортировать только процедуры. Для этого, процедура должна |
находиться в главном модуле программы, ее имя должно быть отмечено символом |
экспорта ("*") и должно быть указано соглашение о вызове. Нельзя |
экспортировать процедуры, которые импортированы из других dll-библиотек. |
/programs/develop/oberon07/lib/KolibriOS/API.ob07 |
---|
0,0 → 1,332 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE API; |
IMPORT SYSTEM, K := KOSAPI; |
CONST |
eol* = 0DX + 0AX; |
BIT_DEPTH* = 32; |
MAX_SIZE = 16 * 400H; |
HEAP_SIZE = 1 * 100000H; |
_new = 1; |
_dispose = 2; |
SizeOfHeader = 36; |
TYPE |
CRITICAL_SECTION = ARRAY 2 OF INTEGER; |
VAR |
heap, endheap: INTEGER; |
pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER; |
CriticalSection: CRITICAL_SECTION; |
_import*, multi: BOOLEAN; |
base*: INTEGER; |
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER); |
BEGIN |
SYSTEM.CODE( |
0FCH, (* cld *) |
031H, 0C0H, (* xor eax, eax *) |
057H, (* push edi *) |
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) |
0F3H, 0ABH, (* rep stosd *) |
05FH (* pop edi *) |
) |
END zeromem; |
PROCEDURE mem_commit* (adr, size: INTEGER); |
VAR |
tmp: INTEGER; |
BEGIN |
FOR tmp := adr TO adr + size - 1 BY 4096 DO |
SYSTEM.PUT(tmp, 0) |
END |
END mem_commit; |
PROCEDURE switch_task; |
BEGIN |
K.sysfunc2(68, 1) |
END switch_task; |
PROCEDURE futex_create (ptr: INTEGER): INTEGER; |
RETURN K.sysfunc3(77, 0, ptr) |
END futex_create; |
PROCEDURE futex_wait (futex, value, timeout: INTEGER); |
BEGIN |
K.sysfunc5(77, 2, futex, value, timeout) |
END futex_wait; |
PROCEDURE futex_wake (futex, number: INTEGER); |
BEGIN |
K.sysfunc4(77, 3, futex, number) |
END futex_wake; |
PROCEDURE EnterCriticalSection* (VAR CriticalSection: CRITICAL_SECTION); |
BEGIN |
switch_task; |
futex_wait(CriticalSection[0], 1, 10000); |
CriticalSection[1] := 1 |
END EnterCriticalSection; |
PROCEDURE LeaveCriticalSection* (VAR CriticalSection: CRITICAL_SECTION); |
BEGIN |
CriticalSection[1] := 0; |
futex_wake(CriticalSection[0], 1) |
END LeaveCriticalSection; |
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION); |
BEGIN |
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1])); |
CriticalSection[1] := 0 |
END InitializeCriticalSection; |
PROCEDURE __NEW (size: INTEGER): INTEGER; |
VAR |
res, idx, temp: INTEGER; |
BEGIN |
IF size <= MAX_SIZE THEN |
idx := ASR(size, 5); |
res := pockets[idx]; |
IF res # 0 THEN |
SYSTEM.GET(res, pockets[idx]); |
SYSTEM.PUT(res, size); |
INC(res, 4) |
ELSE |
temp := 0; |
IF heap + size >= endheap THEN |
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN |
temp := K.sysfunc3(68, 12, HEAP_SIZE) |
ELSE |
temp := 0 |
END; |
IF temp # 0 THEN |
mem_commit(temp, HEAP_SIZE); |
heap := temp; |
endheap := heap + HEAP_SIZE |
ELSE |
temp := -1 |
END |
END; |
IF (heap # 0) & (temp # -1) THEN |
SYSTEM.PUT(heap, size); |
res := heap + 4; |
heap := heap + size |
ELSE |
res := 0 |
END |
END |
ELSE |
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN |
res := K.sysfunc3(68, 12, size); |
IF res # 0 THEN |
mem_commit(res, size); |
SYSTEM.PUT(res, size); |
INC(res, 4) |
END |
ELSE |
res := 0 |
END |
END; |
IF (res # 0) & (size <= MAX_SIZE) THEN |
zeromem(ASR(size, 2) - 1, res) |
END |
RETURN res |
END __NEW; |
PROCEDURE __DISPOSE (ptr: INTEGER): INTEGER; |
VAR |
size, idx: INTEGER; |
BEGIN |
DEC(ptr, 4); |
SYSTEM.GET(ptr, size); |
IF size <= MAX_SIZE THEN |
idx := ASR(size, 5); |
SYSTEM.PUT(ptr, pockets[idx]); |
pockets[idx] := ptr |
ELSE |
size := K.sysfunc3(68, 13, ptr) |
END |
RETURN 0 |
END __DISPOSE; |
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF multi THEN |
EnterCriticalSection(CriticalSection) |
END; |
IF func = _new THEN |
res := __NEW(arg) |
ELSIF func = _dispose THEN |
res := __DISPOSE(arg) |
END; |
IF multi THEN |
LeaveCriticalSection(CriticalSection) |
END |
RETURN res |
END NEW_DISPOSE; |
PROCEDURE _NEW* (size: INTEGER): INTEGER; |
RETURN NEW_DISPOSE(_new, size) |
END _NEW; |
PROCEDURE _DISPOSE* (ptr: INTEGER): INTEGER; |
RETURN NEW_DISPOSE(_dispose, ptr) |
END _DISPOSE; |
PROCEDURE exit* (p1: INTEGER); |
BEGIN |
K.sysfunc1(-1) |
END exit; |
PROCEDURE exit_thread* (p1: INTEGER); |
BEGIN |
K.sysfunc1(-1) |
END exit_thread; |
PROCEDURE OutChar (c: CHAR); |
BEGIN |
K.sysfunc3(63, 1, ORD(c)) |
END OutChar; |
PROCEDURE OutLn; |
BEGIN |
OutChar(0DX); |
OutChar(0AX) |
END OutLn; |
PROCEDURE OutStr (pchar: INTEGER); |
VAR |
c: CHAR; |
BEGIN |
IF pchar # 0 THEN |
REPEAT |
SYSTEM.GET(pchar, c); |
IF c # 0X THEN |
OutChar(c) |
END; |
INC(pchar) |
UNTIL c = 0X |
END |
END OutStr; |
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); |
BEGIN |
IF lpCaption # 0 THEN |
OutLn; |
OutStr(lpCaption); |
OutChar(":"); |
OutLn |
END; |
OutStr(lpText); |
IF lpCaption # 0 THEN |
OutLn |
END |
END DebugMsg; |
PROCEDURE OutString (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i < LEN(s)) & (s[i] # 0X) DO |
OutChar(s[i]); |
INC(i) |
END |
END OutString; |
PROCEDURE imp_error; |
BEGIN |
OutString("import error: "); |
IF K.imp_error.error = 1 THEN |
OutString("can't load '"); OutString(K.imp_error.lib) |
ELSIF K.imp_error.error = 2 THEN |
OutString("not found '"); OutString(K.imp_error.proc); OutString("' in '"); OutString(K.imp_error.lib) |
END; |
OutString("'"); |
OutLn |
END imp_error; |
PROCEDURE init* (import_, code: INTEGER); |
BEGIN |
multi := FALSE; |
base := code - SizeOfHeader; |
K.sysfunc2(68, 11); |
InitializeCriticalSection(CriticalSection); |
K._init; |
_import := (K.dll_Load(import_) = 0) & (K.imp_error.error = 0); |
IF ~_import THEN |
imp_error |
END |
END init; |
PROCEDURE SetMultiThr* (value: BOOLEAN); |
BEGIN |
multi := value |
END SetMultiThr; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN K.sysfunc2(26, 9) * 10 |
END GetTickCount; |
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
RETURN 0 |
END dllentry; |
PROCEDURE sofinit*; |
END sofinit; |
END API. |
/programs/develop/oberon07/lib/KolibriOS/File.ob07 |
---|
0,0 → 1,330 |
(* |
Copyright 2016, 2018, 2021 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE File; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2; |
TYPE |
FNAME* = ARRAY 520 OF CHAR; |
FS* = POINTER TO rFS; |
rFS* = RECORD |
subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER; |
name*: FNAME |
END; |
FD* = POINTER TO rFD; |
rFD* = RECORD |
attr*: INTEGER; |
ntyp*: CHAR; |
reserved: ARRAY 3 OF CHAR; |
time_create*, date_create*, |
time_access*, date_access*, |
time_modif*, date_modif*, |
size*, hsize*: INTEGER; |
name*: FNAME |
END; |
PROCEDURE [stdcall] f_68_27 (file_name: INTEGER; VAR size: INTEGER): INTEGER; |
BEGIN |
sys.CODE( |
053H, (* push ebx *) |
06AH, 044H, (* push 68 *) |
058H, (* pop eax *) |
06AH, 01BH, (* push 27 *) |
05BH, (* pop ebx *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) |
0CDH, 040H, (* int 64 *) |
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *) |
089H, 011H, (* mov dword [ecx], edx *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 8 *) |
) |
RETURN 0 |
END f_68_27; |
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER; |
RETURN f_68_27(sys.ADR(FName[0]), size) |
END Load; |
PROCEDURE GetFileInfo* (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN; |
VAR |
res2: INTEGER; fs: rFS; |
BEGIN |
fs.subfunc := 5; |
fs.pos := 0; |
fs.hpos := 0; |
fs.bytes := 0; |
fs.buffer := sys.ADR(Info); |
COPY(FName, fs.name) |
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0 |
END GetFileInfo; |
PROCEDURE FileSize* (FName: ARRAY OF CHAR): INTEGER; |
VAR |
Info: rFD; |
res: INTEGER; |
BEGIN |
IF GetFileInfo(FName, Info) THEN |
res := Info.size |
ELSE |
res := -1 |
END |
RETURN res |
END FileSize; |
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN; |
VAR |
fd: rFD; |
BEGIN |
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr)) |
END Exists; |
PROCEDURE Close* (VAR F: FS); |
BEGIN |
IF F # NIL THEN |
DISPOSE(F) |
END |
END Close; |
PROCEDURE Open* (FName: ARRAY OF CHAR): FS; |
VAR |
F: FS; |
BEGIN |
IF Exists(FName) THEN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 0; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(FName, F.name) |
END |
ELSE |
F := NIL |
END |
RETURN F |
END Open; |
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN; |
VAR |
F: FS; |
res, res2: INTEGER; |
BEGIN |
IF Exists(FName) THEN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 8; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(FName, F.name); |
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); |
DISPOSE(F) |
ELSE |
res := -1 |
END |
ELSE |
res := -1 |
END |
RETURN res = 0 |
END Delete; |
PROCEDURE Seek* (F: FS; Offset, Origin: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
fd: rFD; |
BEGIN |
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN |
CASE Origin OF |
|SEEK_BEG: F.pos := Offset |
|SEEK_CUR: F.pos := F.pos + Offset |
|SEEK_END: F.pos := fd.size + Offset |
ELSE |
END; |
res := F.pos |
ELSE |
res := -1 |
END |
RETURN res |
END Seek; |
PROCEDURE Read* (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
IF F # NIL THEN |
F.subfunc := 0; |
F.bytes := Count; |
F.buffer := Buffer; |
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); |
IF res2 > 0 THEN |
F.pos := F.pos + res2 |
END |
ELSE |
res2 := 0 |
END |
RETURN res2 |
END Read; |
PROCEDURE Write* (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
IF F # NIL THEN |
F.subfunc := 3; |
F.bytes := Count; |
F.buffer := Buffer; |
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); |
IF res2 > 0 THEN |
F.pos := F.pos + res2 |
END |
ELSE |
res2 := 0 |
END |
RETURN res2 |
END Write; |
PROCEDURE Create* (FName: ARRAY OF CHAR): FS; |
VAR |
F: FS; |
res2: INTEGER; |
BEGIN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 2; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(FName, F.name); |
IF KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN |
DISPOSE(F) |
END |
END |
RETURN F |
END Create; |
PROCEDURE DirExists* (FName: ARRAY OF CHAR): BOOLEAN; |
VAR |
fd: rFD; |
BEGIN |
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr)) |
END DirExists; |
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN; |
VAR |
F: FS; |
res, res2: INTEGER; |
BEGIN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 9; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(DirName, F.name); |
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); |
DISPOSE(F) |
ELSE |
res := -1 |
END |
RETURN res = 0 |
END CreateDir; |
PROCEDURE DeleteDir* (DirName: ARRAY OF CHAR): BOOLEAN; |
VAR |
F: FS; |
res, res2: INTEGER; |
BEGIN |
IF DirExists(DirName) THEN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 8; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(DirName, F.name); |
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2); |
DISPOSE(F) |
ELSE |
res := -1 |
END |
ELSE |
res := -1 |
END |
RETURN res = 0 |
END DeleteDir; |
END File. |
/programs/develop/oberon07/lib/KolibriOS/HOST.ob07 |
---|
0,0 → 1,552 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT SYSTEM, K := KOSAPI, API; |
CONST |
slash* = "/"; |
eol* = 0DX + 0AX; |
bit_depth* = API.BIT_DEPTH; |
maxint* = ROR(-2, 1); |
minint* = ROR(1, 1); |
MAX_PARAM = 1024; |
TYPE |
DAYS = ARRAY 12, 31, 2 OF INTEGER; |
FNAME = ARRAY 520 OF CHAR; |
FS = POINTER TO rFS; |
rFS = RECORD |
subfunc, pos, hpos, bytes, buffer: INTEGER; |
name: FNAME |
END; |
FD = POINTER TO rFD; |
rFD = RECORD |
attr: INTEGER; |
ntyp: CHAR; |
reserved: ARRAY 3 OF CHAR; |
time_create, date_create, |
time_access, date_access, |
time_modif, date_modif, |
size, hsize: INTEGER; |
name: FNAME |
END; |
VAR |
Console: BOOLEAN; |
days: DAYS; |
Params: ARRAY MAX_PARAM, 2 OF INTEGER; |
argc*: INTEGER; |
maxreal*: REAL; |
PROCEDURE [stdcall, "Console.obj", "con_init"] con_init (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER); |
PROCEDURE [stdcall, "Console.obj", "con_exit"] con_exit (bCloseWindow: BOOLEAN); |
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER); |
PROCEDURE ExitProcess* (p1: INTEGER); |
BEGIN |
IF Console THEN |
con_exit(FALSE) |
END; |
K.sysfunc1(-1) |
END ExitProcess; |
PROCEDURE OutChar* (c: CHAR); |
BEGIN |
IF Console THEN |
con_write_string(SYSTEM.ADR(c), 1) |
ELSE |
K.sysfunc3(63, 1, ORD(c)) |
END |
END OutChar; |
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN; |
VAR |
res2: INTEGER; |
fs: rFS; |
BEGIN |
fs.subfunc := 5; |
fs.pos := 0; |
fs.hpos := 0; |
fs.bytes := 0; |
fs.buffer := SYSTEM.ADR(Info); |
COPY(FName, fs.name) |
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0 |
END GetFileInfo; |
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN; |
VAR |
fd: rFD; |
BEGIN |
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr)) |
END Exists; |
PROCEDURE Close (VAR F: FS); |
BEGIN |
IF F # NIL THEN |
DISPOSE(F) |
END |
END Close; |
PROCEDURE Open (FName: ARRAY OF CHAR): FS; |
VAR |
F: FS; |
BEGIN |
IF Exists(FName) THEN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 0; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(FName, F.name) |
END |
ELSE |
F := NIL |
END |
RETURN F |
END Open; |
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
IF F # NIL THEN |
F.subfunc := 0; |
F.bytes := Count; |
F.buffer := Buffer; |
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2); |
IF res2 > 0 THEN |
F.pos := F.pos + res2 |
END |
ELSE |
res2 := 0 |
END |
RETURN res2 |
END Read; |
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
IF F # NIL THEN |
F.subfunc := 3; |
F.bytes := Count; |
F.buffer := Buffer; |
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2); |
IF res2 > 0 THEN |
F.pos := F.pos + res2 |
END |
ELSE |
res2 := 0 |
END |
RETURN res2 |
END Write; |
PROCEDURE Create (FName: ARRAY OF CHAR): FS; |
VAR |
F: FS; |
res2: INTEGER; |
BEGIN |
NEW(F); |
IF F # NIL THEN |
F.subfunc := 2; |
F.pos := 0; |
F.hpos := 0; |
F.bytes := 0; |
F.buffer := 0; |
COPY(FName, F.name); |
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN |
DISPOSE(F) |
END |
END |
RETURN F |
END Create; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
fs: FS; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(F), fs); |
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes); |
IF n = 0 THEN |
n := -1 |
END |
RETURN n |
END FileRead; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
fs: FS; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(F), fs); |
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes); |
IF n = 0 THEN |
n := -1 |
END |
RETURN n |
END FileWrite; |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
VAR |
fs: FS; |
res: INTEGER; |
BEGIN |
fs := Create(FName); |
SYSTEM.GET(SYSTEM.ADR(fs), res) |
RETURN res |
END FileCreate; |
PROCEDURE FileClose* (F: INTEGER); |
VAR |
fs: FS; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(F), fs); |
Close(fs) |
END FileClose; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
VAR |
fs: FS; |
res: INTEGER; |
BEGIN |
fs := Open(FName); |
SYSTEM.GET(SYSTEM.ADR(fs), res) |
RETURN res |
END FileOpen; |
PROCEDURE chmod* (FName: ARRAY OF CHAR); |
END chmod; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN K.sysfunc2(26, 9) |
END GetTickCount; |
PROCEDURE AppAdr (): INTEGER; |
VAR |
buf: ARRAY 1024 OF CHAR; |
a: INTEGER; |
BEGIN |
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1); |
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a) |
RETURN a |
END AppAdr; |
PROCEDURE GetCommandLine (): INTEGER; |
VAR |
param: INTEGER; |
BEGIN |
SYSTEM.GET(28 + AppAdr(), param) |
RETURN param |
END GetCommandLine; |
PROCEDURE GetName (): INTEGER; |
VAR |
name: INTEGER; |
BEGIN |
SYSTEM.GET(32 + AppAdr(), name) |
RETURN name |
END GetName; |
PROCEDURE GetChar (adr: INTEGER): CHAR; |
VAR |
res: CHAR; |
BEGIN |
SYSTEM.GET(adr, res) |
RETURN res |
END GetChar; |
PROCEDURE ParamParse; |
VAR |
p, count, name, cond: INTEGER; |
c: CHAR; |
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER); |
BEGIN |
IF (c <= 20X) & (c # 0X) THEN |
cond := A |
ELSIF c = 22X THEN |
cond := B |
ELSIF c = 0X THEN |
cond := 6 |
ELSE |
cond := C |
END |
END ChangeCond; |
BEGIN |
p := GetCommandLine(); |
name := GetName(); |
Params[0, 0] := name; |
WHILE GetChar(name) # 0X DO |
INC(name) |
END; |
Params[0, 1] := name - 1; |
cond := 0; |
count := 1; |
WHILE (argc < MAX_PARAM) & (cond # 6) DO |
c := GetChar(p); |
CASE cond OF |
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END |
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END |
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END |
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END |
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END |
|6: |
END; |
INC(p) |
END; |
argc := count |
END ParamParse; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
i, j, len: INTEGER; |
c: CHAR; |
BEGIN |
j := 0; |
IF n < argc THEN |
len := LEN(s) - 1; |
i := Params[n, 0]; |
WHILE (j < len) & (i <= Params[n, 1]) DO |
c := GetChar(i); |
IF c # 22X THEN |
s[j] := c; |
INC(j) |
END; |
INC(i) |
END |
END; |
s[j] := 0X |
END GetArg; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
n: INTEGER; |
BEGIN |
n := K.sysfunc4(30, 2, SYSTEM.ADR(path[0]), LEN(path) - 2); |
path[n - 1] := slash; |
path[n] := 0X |
END GetCurrentDirectory; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN path[0] # slash |
END isRelative; |
PROCEDURE UnixTime* (): INTEGER; |
VAR |
date, time, year, month, day, hour, min, sec: INTEGER; |
BEGIN |
date := K.sysfunc1(29); |
time := K.sysfunc1(3); |
year := date MOD 16; |
date := date DIV 16; |
year := (date MOD 16) * 10 + year; |
date := date DIV 16; |
month := date MOD 16; |
date := date DIV 16; |
month := (date MOD 16) * 10 + month; |
date := date DIV 16; |
day := date MOD 16; |
date := date DIV 16; |
day := (date MOD 16) * 10 + day; |
date := date DIV 16; |
hour := time MOD 16; |
time := time DIV 16; |
hour := (time MOD 16) * 10 + hour; |
time := time DIV 16; |
min := time MOD 16; |
time := time DIV 16; |
min := (time MOD 16) * 10 + min; |
time := time DIV 16; |
sec := time MOD 16; |
time := time DIV 16; |
sec := (time MOD 16) * 10 + sec; |
time := time DIV 16; |
INC(year, 2000) |
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec |
END UnixTime; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
BEGIN |
SYSTEM.GET32(SYSTEM.ADR(x), a); |
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b) |
RETURN a |
END splitf; |
PROCEDURE d2s* (x: REAL): INTEGER; |
VAR |
h, l, s, e: INTEGER; |
BEGIN |
e := splitf(x, l, h); |
s := ASR(h, 31) MOD 2; |
e := (h DIV 100000H) MOD 2048; |
IF e <= 896 THEN |
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H; |
REPEAT |
h := h DIV 2; |
INC(e) |
UNTIL e = 897; |
e := 896; |
l := (h MOD 8) * 20000000H; |
h := h DIV 8 |
ELSIF (1151 <= e) & (e < 2047) THEN |
e := 1151; |
h := 0; |
l := 0 |
ELSIF e = 2047 THEN |
e := 1151; |
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN |
h := 80000H; |
l := 0 |
END |
END; |
DEC(e, 896) |
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 |
END d2s; |
PROCEDURE init (VAR days: DAYS); |
VAR |
i, j, n0, n1: INTEGER; |
BEGIN |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
days[i, j, 0] := 0; |
days[i, j, 1] := 0; |
END |
END; |
days[ 1, 28, 0] := -1; |
FOR i := 0 TO 1 DO |
days[ 1, 29, i] := -1; |
days[ 1, 30, i] := -1; |
days[ 3, 30, i] := -1; |
days[ 5, 30, i] := -1; |
days[ 8, 30, i] := -1; |
days[10, 30, i] := -1; |
END; |
n0 := 0; |
n1 := 0; |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
IF days[i, j, 0] = 0 THEN |
days[i, j, 0] := n0; |
INC(n0) |
END; |
IF days[i, j, 1] = 0 THEN |
days[i, j, 1] := n1; |
INC(n1) |
END |
END |
END; |
maxreal := 1.9; |
PACK(maxreal, 1023); |
Console := API._import; |
IF Console THEN |
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS")) |
END; |
ParamParse |
END init; |
BEGIN |
init(days) |
END HOST. |
/programs/develop/oberon07/lib/KolibriOS/OpenDlg.ob07 |
---|
0,0 → 1,158 |
(* |
Copyright 2016, 2018, 2020, 2021 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE OpenDlg; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
topen* = 0; |
tsave* = 1; |
tdir* = 2; |
TYPE |
DRAW_WINDOW = PROCEDURE; |
TDialog = RECORD |
_type*, |
procinfo, |
com_area_name, |
com_area, |
opendir_path, |
dir_default_path, |
start_path: INTEGER; |
draw_window: DRAW_WINDOW; |
status*, |
openfile_path, |
filename_area: INTEGER; |
filter_area: |
POINTER TO RECORD |
size: INTEGER; |
filter: ARRAY 4096 OF CHAR |
END; |
X, Y: INTEGER; |
procinf: ARRAY 1024 OF CHAR; |
s_com_area_name: ARRAY 32 OF CHAR; |
s_opendir_path, |
s_dir_default_path, |
FilePath*, |
FileName*: ARRAY 4096 OF CHAR |
END; |
Dialog* = POINTER TO TDialog; |
VAR |
Dialog_start, Dialog_init: PROCEDURE [stdcall] (od: Dialog); |
PROCEDURE Show*(od: Dialog; Width, Height: INTEGER); |
BEGIN |
IF od # NIL THEN |
od.X := Width; |
od.Y := Height; |
Dialog_start(od) |
END |
END Show; |
PROCEDURE Create*(draw_window: DRAW_WINDOW; _type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog; |
VAR res: Dialog; n, i: INTEGER; |
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR); |
VAR i: INTEGER; |
BEGIN |
i := LENGTH(str) - 1; |
WHILE i >= 0 DO |
IF str[i] = c1 THEN |
str[i] := c2 |
END; |
DEC(i) |
END |
END replace; |
BEGIN |
NEW(res); |
IF res # NIL THEN |
NEW(res.filter_area); |
IF res.filter_area # NIL THEN |
res.s_com_area_name := "FFFFFFFF_open_dialog"; |
res.com_area := 0; |
res._type := _type; |
res.draw_window := draw_window; |
COPY(def_path, res.s_dir_default_path); |
COPY(filter, res.filter_area.filter); |
n := LENGTH(res.filter_area.filter); |
FOR i := 0 TO 3 DO |
res.filter_area.filter[n + i] := "|" |
END; |
res.filter_area.filter[n + 4] := 0X; |
res.X := 0; |
res.Y := 0; |
res.s_opendir_path := res.s_dir_default_path; |
res.FilePath := ""; |
res.FileName := ""; |
res.status := 0; |
res.filter_area.size := LENGTH(res.filter_area.filter); |
res.procinfo := sys.ADR(res.procinf[0]); |
res.com_area_name := sys.ADR(res.s_com_area_name[0]); |
res.start_path := sys.SADR("/rd/1/File managers/opendial"); |
res.opendir_path := sys.ADR(res.s_opendir_path[0]); |
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]); |
res.openfile_path := sys.ADR(res.FilePath[0]); |
res.filename_area := sys.ADR(res.FileName[0]); |
replace(res.filter_area.filter, "|", 0X); |
Dialog_init(res) |
ELSE |
DISPOSE(res) |
END |
END |
RETURN res |
END Create; |
PROCEDURE Destroy*(VAR od: Dialog); |
BEGIN |
IF od # NIL THEN |
DISPOSE(od.filter_area); |
DISPOSE(od) |
END |
END Destroy; |
PROCEDURE Load; |
VAR Lib: INTEGER; |
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
BEGIN |
a := KOSAPI.GetProcAdr(name, Lib); |
ASSERT(a # 0); |
sys.PUT(v, a) |
END GetProc; |
BEGIN |
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj"); |
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init"); |
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start"); |
END Load; |
BEGIN |
Load |
END OpenDlg. |
/programs/develop/oberon07/lib/KolibriOS/RTL.ob07 |
---|
0,0 → 1,543 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT SYSTEM, API; |
CONST |
minint = ROR(1, 1); |
WORD = API.BIT_DEPTH DIV 8; |
VAR |
name: INTEGER; |
types: INTEGER; |
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER); |
BEGIN |
SYSTEM.CODE( |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
085H, 0C0H, (* test eax, eax *) |
07EH, 019H, (* jle L *) |
0FCH, (* cld *) |
057H, (* push edi *) |
056H, (* push esi *) |
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *) |
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *) |
089H, 0C1H, (* mov ecx, eax *) |
0C1H, 0E9H, 002H, (* shr ecx, 2 *) |
0F3H, 0A5H, (* rep movsd *) |
089H, 0C1H, (* mov ecx, eax *) |
083H, 0E1H, 003H, (* and ecx, 3 *) |
0F3H, 0A4H, (* rep movsb *) |
05EH, (* pop esi *) |
05FH (* pop edi *) |
(* L: *) |
) |
END _move; |
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, dst, src); |
res := TRUE |
END |
RETURN res |
END _arrcpy; |
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
_move(MIN(len_dst, len_src) * chr_size, dst, src) |
END _strcpy; |
PROCEDURE [stdcall] _rot* (Len, Ptr: INTEGER); |
BEGIN |
SYSTEM.CODE( |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- Len *) |
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- Ptr *) |
049H, (* dec ecx *) |
053H, (* push ebx *) |
08BH, 018H, (* mov ebx, dword [eax] *) |
(* L: *) |
08BH, 050H, 004H, (* mov edx, dword [eax + 4] *) |
089H, 010H, (* mov dword [eax], edx *) |
083H, 0C0H, 004H, (* add eax, 4 *) |
049H, (* dec ecx *) |
075H, 0F5H, (* jnz L *) |
089H, 018H, (* mov dword [eax], ebx *) |
05BH, (* pop ebx *) |
05DH, (* pop ebp *) |
0C2H, 008H, 000H (* ret 8 *) |
) |
END _rot; |
PROCEDURE [stdcall] _set* (b, a: INTEGER); (* {a..b} -> eax *) |
BEGIN |
SYSTEM.CODE( |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- b *) |
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- a *) |
039H, 0C8H, (* cmp eax, ecx *) |
07FH, 033H, (* jg L1 *) |
083H, 0F8H, 01FH, (* cmp eax, 31 *) |
07FH, 02EH, (* jg L1 *) |
085H, 0C9H, (* test ecx, ecx *) |
07CH, 02AH, (* jl L1 *) |
083H, 0F9H, 01FH, (* cmp ecx, 31 *) |
07EH, 005H, (* jle L3 *) |
0B9H, 01FH, 000H, 000H, 000H, (* mov ecx, 31 *) |
(* L3: *) |
085H, 0C0H, (* test eax, eax *) |
07DH, 002H, (* jge L2 *) |
031H, 0C0H, (* xor eax, eax *) |
(* L2: *) |
089H, 0CAH, (* mov edx, ecx *) |
029H, 0C2H, (* sub edx, eax *) |
0B8H, 000H, 000H, 000H, 080H, (* mov eax, 0x80000000 *) |
087H, 0CAH, (* xchg edx, ecx *) |
0D3H, 0F8H, (* sar eax, cl *) |
087H, 0CAH, (* xchg edx, ecx *) |
083H, 0E9H, 01FH, (* sub ecx, 31 *) |
0F7H, 0D9H, (* neg ecx *) |
0D3H, 0E8H, (* shr eax, cl *) |
05DH, (* pop ebp *) |
0C2H, 008H, 000H, (* ret 8 *) |
(* L1: *) |
031H, 0C0H, (* xor eax, eax *) |
05DH, (* pop ebp *) |
0C2H, 008H, 000H (* ret 8 *) |
) |
END _set; |
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *) |
BEGIN |
SYSTEM.CODE( |
031H, 0C0H, (* xor eax, eax *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *) |
083H, 0F9H, 01FH, (* cmp ecx, 31 *) |
077H, 003H, (* ja L *) |
00FH, 0ABH, 0C8H (* bts eax, ecx *) |
(* L: *) |
) |
END _set1; |
PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *) |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- x *) |
031H, 0D2H, (* xor edx, edx *) |
085H, 0C0H, (* test eax, eax *) |
074H, 018H, (* je L2 *) |
07FH, 002H, (* jg L1 *) |
0F7H, 0D2H, (* not edx *) |
(* L1: *) |
089H, 0C3H, (* mov ebx, eax *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- y *) |
0F7H, 0F9H, (* idiv ecx *) |
085H, 0D2H, (* test edx, edx *) |
074H, 009H, (* je L2 *) |
031H, 0CBH, (* xor ebx, ecx *) |
085H, 0DBH, (* test ebx, ebx *) |
07DH, 003H, (* jge L2 *) |
048H, (* dec eax *) |
001H, 0CAH, (* add edx, ecx *) |
(* L2: *) |
05BH (* pop ebx *) |
) |
END _divmod; |
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER); |
BEGIN |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
SYSTEM.PUT(ptr, t); |
INC(ptr, WORD) |
END |
END _new; |
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER); |
BEGIN |
IF ptr # 0 THEN |
ptr := API._DISPOSE(ptr - WORD) |
END |
END _dispose; |
PROCEDURE [stdcall] _length* (len, str: INTEGER); |
BEGIN |
SYSTEM.CODE( |
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *) |
048H, (* dec eax *) |
(* L1: *) |
040H, (* inc eax *) |
080H, 038H, 000H, (* cmp byte [eax], 0 *) |
074H, 003H, (* jz L2 *) |
0E2H, 0F8H, (* loop L1 *) |
040H, (* inc eax *) |
(* L2: *) |
02BH, 045H, 00CH (* sub eax, dword [ebp + 0Ch] *) |
) |
END _length; |
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER); |
BEGIN |
SYSTEM.CODE( |
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *) |
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *) |
048H, (* dec eax *) |
048H, (* dec eax *) |
(* L1: *) |
040H, (* inc eax *) |
040H, (* inc eax *) |
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *) |
074H, 004H, (* jz L2 *) |
0E2H, 0F6H, (* loop L1 *) |
040H, (* inc eax *) |
040H, (* inc eax *) |
(* L2: *) |
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *) |
0D1H, 0E8H (* shr eax, 1 *) |
) |
END _lengthw; |
PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
056H, (* push esi *) |
057H, (* push edi *) |
053H, (* push ebx *) |
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *) |
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *) |
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *) |
031H, 0C9H, (* xor ecx, ecx *) |
031H, 0D2H, (* xor edx, edx *) |
0B8H, |
000H, 000H, 000H, 080H, (* mov eax, minint *) |
(* L1: *) |
085H, 0DBH, (* test ebx, ebx *) |
07EH, 017H, (* jle L3 *) |
08AH, 00EH, (* mov cl, byte[esi] *) |
08AH, 017H, (* mov dl, byte[edi] *) |
046H, (* inc esi *) |
047H, (* inc edi *) |
04BH, (* dec ebx *) |
039H, 0D1H, (* cmp ecx, edx *) |
074H, 006H, (* je L2 *) |
089H, 0C8H, (* mov eax, ecx *) |
029H, 0D0H, (* sub eax, edx *) |
0EBH, 006H, (* jmp L3 *) |
(* L2: *) |
085H, 0C9H, (* test ecx, ecx *) |
075H, 0E7H, (* jne L1 *) |
031H, 0C0H, (* xor eax, eax *) |
(* L3: *) |
05BH, (* pop ebx *) |
05FH, (* pop edi *) |
05EH, (* pop esi *) |
05DH, (* pop ebp *) |
0C2H, 00CH, 000H (* ret 12 *) |
) |
RETURN 0 |
END strncmp; |
PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
056H, (* push esi *) |
057H, (* push edi *) |
053H, (* push ebx *) |
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *) |
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *) |
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *) |
031H, 0C9H, (* xor ecx, ecx *) |
031H, 0D2H, (* xor edx, edx *) |
0B8H, |
000H, 000H, 000H, 080H, (* mov eax, minint *) |
(* L1: *) |
085H, 0DBH, (* test ebx, ebx *) |
07EH, 01BH, (* jle L3 *) |
066H, 08BH, 00EH, (* mov cx, word[esi] *) |
066H, 08BH, 017H, (* mov dx, word[edi] *) |
046H, (* inc esi *) |
046H, (* inc esi *) |
047H, (* inc edi *) |
047H, (* inc edi *) |
04BH, (* dec ebx *) |
039H, 0D1H, (* cmp ecx, edx *) |
074H, 006H, (* je L2 *) |
089H, 0C8H, (* mov eax, ecx *) |
029H, 0D0H, (* sub eax, edx *) |
0EBH, 006H, (* jmp L3 *) |
(* L2: *) |
085H, 0C9H, (* test ecx, ecx *) |
075H, 0E3H, (* jne L1 *) |
031H, 0C0H, (* xor eax, eax *) |
(* L3: *) |
05BH, (* pop ebx *) |
05FH, (* pop edi *) |
05EH, (* pop esi *) |
05DH, (* pop ebp *) |
0C2H, 00CH, 000H (* ret 12 *) |
) |
RETURN 0 |
END strncmpw; |
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: CHAR; |
BEGIN |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmp; |
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: WCHAR; |
BEGIN |
res := strncmpw(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2 * 2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1 * 2, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmpw; |
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
c: CHAR; |
i: INTEGER; |
BEGIN |
i := 0; |
REPEAT |
SYSTEM.GET(pchar, c); |
s[i] := c; |
INC(pchar); |
INC(i) |
UNTIL c = 0X |
END PCharToStr; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
BEGIN |
i := 0; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END IntToStr; |
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2: INTEGER; |
BEGIN |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2); |
s1[n1 + n2] := 0X |
END append; |
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER); |
VAR |
s, temp: ARRAY 1024 OF CHAR; |
BEGIN |
CASE err OF |
| 1: s := "assertion failure" |
| 2: s := "NIL dereference" |
| 3: s := "bad divisor" |
| 4: s := "NIL procedure call" |
| 5: s := "type guard error" |
| 6: s := "index out of range" |
| 7: s := "invalid CASE" |
| 8: s := "array assignment error" |
| 9: s := "CHR out of range" |
|10: s := "WCHR out of range" |
|11: s := "BYTE out of range" |
END; |
append(s, API.eol + "module: "); PCharToStr(_module, temp); append(s, temp); |
append(s, API.eol + "line: "); IntToStr(line, temp); append(s, temp); |
API.DebugMsg(SYSTEM.ADR(s[0]), name); |
API.exit_thread(0) |
END _error; |
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER; |
BEGIN |
SYSTEM.GET(t0 + t1 + types, t0) |
RETURN t0 MOD 2 |
END _isrec; |
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER; |
BEGIN |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, p); |
SYSTEM.GET(t0 + p + types, p) |
END |
RETURN p MOD 2 |
END _is; |
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER; |
BEGIN |
SYSTEM.GET(t0 + t1 + types, t0) |
RETURN t0 MOD 2 |
END _guardrec; |
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER; |
BEGIN |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, p); |
SYSTEM.GET(t0 + p + types, p) |
ELSE |
p := 1 |
END |
RETURN p MOD 2 |
END _guard; |
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved) |
END _dllentry; |
PROCEDURE [stdcall] _sofinit*; |
BEGIN |
API.sofinit |
END _sofinit; |
PROCEDURE [stdcall] _exit* (code: INTEGER); |
BEGIN |
API.exit(code) |
END _exit; |
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER); |
VAR |
t0, t1, i, j: INTEGER; |
BEGIN |
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *) |
API.init(param, code); |
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER)); |
ASSERT(types # 0); |
FOR i := 0 TO tcount - 1 DO |
FOR j := 0 TO tcount - 1 DO |
t0 := i; t1 := j; |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(_types + t1 * WORD, t1) |
END; |
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1)) |
END |
END; |
name := modname |
END _init; |
END RTL. |
/programs/develop/oberon07/lib/KolibriOS/ColorDlg.ob07 |
---|
0,0 → 1,105 |
(* |
Copyright 2016, 2018, 2020 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE ColorDlg; |
IMPORT sys := SYSTEM, KOSAPI; |
TYPE |
DRAW_WINDOW = PROCEDURE; |
TDialog = RECORD |
_type, |
procinfo, |
com_area_name, |
com_area, |
start_path: INTEGER; |
draw_window: DRAW_WINDOW; |
status*, |
X, Y, |
color_type, |
color*: INTEGER; |
procinf: ARRAY 1024 OF CHAR; |
s_com_area_name: ARRAY 32 OF CHAR |
END; |
Dialog* = POINTER TO TDialog; |
VAR |
Dialog_start, Dialog_init: PROCEDURE [stdcall] (cd: Dialog); |
PROCEDURE Show*(cd: Dialog); |
BEGIN |
IF cd # NIL THEN |
cd.X := 0; |
cd.Y := 0; |
Dialog_start(cd) |
END |
END Show; |
PROCEDURE Create*(draw_window: DRAW_WINDOW): Dialog; |
VAR res: Dialog; |
BEGIN |
NEW(res); |
IF res # NIL THEN |
res.s_com_area_name := "FFFFFFFF_color_dlg"; |
res.com_area := 0; |
res._type := 0; |
res.color_type := 0; |
res.procinfo := sys.ADR(res.procinf[0]); |
res.com_area_name := sys.ADR(res.s_com_area_name[0]); |
res.start_path := sys.SADR("/rd/1/colrdial"); |
res.draw_window := draw_window; |
res.status := 0; |
res.X := 0; |
res.Y := 0; |
res.color := 0; |
Dialog_init(res) |
END |
RETURN res |
END Create; |
PROCEDURE Destroy*(VAR cd: Dialog); |
BEGIN |
IF cd # NIL THEN |
DISPOSE(cd) |
END |
END Destroy; |
PROCEDURE Load; |
VAR Lib: INTEGER; |
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
BEGIN |
a := KOSAPI.GetProcAdr(name, Lib); |
ASSERT(a # 0); |
sys.PUT(v, a) |
END GetProc; |
BEGIN |
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj"); |
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init"); |
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start"); |
END Load; |
BEGIN |
Load |
END ColorDlg. |
/programs/develop/oberon07/lib/KolibriOS/Math.ob07 |
---|
0,0 → 1,450 |
(* |
BSD 2-Clause License |
Copyright (c) 2013-2014, 2018-2020 Anton Krotov |
All rights reserved. |
*) |
MODULE Math; |
IMPORT SYSTEM; |
CONST |
pi* = 3.141592653589793; |
e* = 2.718281828459045; |
PROCEDURE IsNan* (x: REAL): BOOLEAN; |
VAR |
h, l: SET; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(x), l); |
SYSTEM.GET(SYSTEM.ADR(x) + 4, h) |
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) |
END IsNan; |
PROCEDURE IsInf* (x: REAL): BOOLEAN; |
RETURN ABS(x) = SYSTEM.INF() |
END IsInf; |
PROCEDURE Max (a, b: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF a > b THEN |
res := a |
ELSE |
res := b |
END |
RETURN res |
END Max; |
PROCEDURE Min (a, b: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF a < b THEN |
res := a |
ELSE |
res := b |
END |
RETURN res |
END Min; |
PROCEDURE SameValue (a, b: REAL): BOOLEAN; |
VAR |
eps: REAL; |
res: BOOLEAN; |
BEGIN |
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12); |
IF a > b THEN |
res := (a - b) <= eps |
ELSE |
res := (b - a) <= eps |
END |
RETURN res |
END SameValue; |
PROCEDURE IsZero (x: REAL): BOOLEAN; |
RETURN ABS(x) <= 1.0E-12 |
END IsZero; |
PROCEDURE [stdcall] sqrt* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FAH, (* fsqrt *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END sqrt; |
PROCEDURE [stdcall] sin* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FEH, (* fsin *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END sin; |
PROCEDURE [stdcall] cos* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FFH, (* fcos *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END cos; |
PROCEDURE [stdcall] tan* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FBH, (* fsincos *) |
0DEH, 0F9H, (* fdivp st1, st *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END tan; |
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *) |
0D9H, 0F3H, (* fpatan *) |
0C9H, (* leave *) |
0C2H, 010H, 000H (* ret 10h *) |
) |
RETURN 0.0 |
END arctan2; |
PROCEDURE [stdcall] ln* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0D9H, 0EDH, (* fldln2 *) |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0F1H, (* fyl2x *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END ln; |
PROCEDURE [stdcall] log* (base, x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0D9H, 0E8H, (* fld1 *) |
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *) |
0D9H, 0F1H, (* fyl2x *) |
0D9H, 0E8H, (* fld1 *) |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0F1H, (* fyl2x *) |
0DEH, 0F9H, (* fdivp st1, st *) |
0C9H, (* leave *) |
0C2H, 010H, 000H (* ret 10h *) |
) |
RETURN 0.0 |
END log; |
PROCEDURE [stdcall] exp* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0EAH, (* fldl2e *) |
0DEH, 0C9H, 0D9H, 0C0H, |
0D9H, 0FCH, 0DCH, 0E9H, |
0D9H, 0C9H, 0D9H, 0F0H, |
0D9H, 0E8H, 0DEH, 0C1H, |
0D9H, 0FDH, 0DDH, 0D9H, |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END exp; |
PROCEDURE [stdcall] round* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 07DH, 0F4H, 0D9H, |
07DH, 0F6H, 066H, 081H, |
04DH, 0F6H, 000H, 003H, |
0D9H, 06DH, 0F6H, 0D9H, |
0FCH, 0D9H, 06DH, 0F4H, |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END round; |
PROCEDURE [stdcall] frac* (x: REAL): REAL; |
BEGIN |
SYSTEM.CODE( |
050H, |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0C0H, 0D9H, 03CH, |
024H, 0D9H, 07CH, 024H, |
002H, 066H, 081H, 04CH, |
024H, 002H, 000H, 00FH, |
0D9H, 06CH, 024H, 002H, |
0D9H, 0FCH, 0D9H, 02CH, |
024H, 0DEH, 0E9H, |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END frac; |
PROCEDURE sqri* (x: INTEGER): INTEGER; |
RETURN x * x |
END sqri; |
PROCEDURE sqrr* (x: REAL): REAL; |
RETURN x * x |
END sqrr; |
PROCEDURE arcsin* (x: REAL): REAL; |
RETURN arctan2(x, sqrt(1.0 - x * x)) |
END arcsin; |
PROCEDURE arccos* (x: REAL): REAL; |
RETURN arctan2(sqrt(1.0 - x * x), x) |
END arccos; |
PROCEDURE arctan* (x: REAL): REAL; |
RETURN arctan2(x, 1.0) |
END arctan; |
PROCEDURE sinh* (x: REAL): REAL; |
BEGIN |
x := exp(x) |
RETURN (x - 1.0 / x) * 0.5 |
END sinh; |
PROCEDURE cosh* (x: REAL): REAL; |
BEGIN |
x := exp(x) |
RETURN (x + 1.0 / x) * 0.5 |
END cosh; |
PROCEDURE tanh* (x: REAL): REAL; |
BEGIN |
IF x > 15.0 THEN |
x := 1.0 |
ELSIF x < -15.0 THEN |
x := -1.0 |
ELSE |
x := exp(2.0 * x); |
x := (x - 1.0) / (x + 1.0) |
END |
RETURN x |
END tanh; |
PROCEDURE arsinh* (x: REAL): REAL; |
RETURN ln(x + sqrt(x * x + 1.0)) |
END arsinh; |
PROCEDURE arcosh* (x: REAL): REAL; |
RETURN ln(x + sqrt(x * x - 1.0)) |
END arcosh; |
PROCEDURE artanh* (x: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF SameValue(x, 1.0) THEN |
res := SYSTEM.INF() |
ELSIF SameValue(x, -1.0) THEN |
res := -SYSTEM.INF() |
ELSE |
res := 0.5 * ln((1.0 + x) / (1.0 - x)) |
END |
RETURN res |
END artanh; |
PROCEDURE floor* (x: REAL): REAL; |
VAR |
f: REAL; |
BEGIN |
f := frac(x); |
x := x - f; |
IF f < 0.0 THEN |
x := x - 1.0 |
END |
RETURN x |
END floor; |
PROCEDURE ceil* (x: REAL): REAL; |
VAR |
f: REAL; |
BEGIN |
f := frac(x); |
x := x - f; |
IF f > 0.0 THEN |
x := x + 1.0 |
END |
RETURN x |
END ceil; |
PROCEDURE power* (base, exponent: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF exponent = 0.0 THEN |
res := 1.0 |
ELSIF (base = 0.0) & (exponent > 0.0) THEN |
res := 0.0 |
ELSE |
res := exp(exponent * ln(base)) |
END |
RETURN res |
END power; |
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL; |
VAR |
i: INTEGER; |
a: REAL; |
BEGIN |
a := 1.0; |
IF base # 0.0 THEN |
IF exponent # 0 THEN |
IF exponent < 0 THEN |
base := 1.0 / base |
END; |
i := ABS(exponent); |
WHILE i > 0 DO |
WHILE ~ODD(i) DO |
i := LSR(i, 1); |
base := sqrr(base) |
END; |
DEC(i); |
a := a * base |
END |
ELSE |
a := 1.0 |
END |
ELSE |
ASSERT(exponent > 0); |
a := 0.0 |
END |
RETURN a |
END ipower; |
PROCEDURE sgn* (x: REAL): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF x > 0.0 THEN |
res := 1 |
ELSIF x < 0.0 THEN |
res := -1 |
ELSE |
res := 0 |
END |
RETURN res |
END sgn; |
PROCEDURE fact* (n: INTEGER): REAL; |
VAR |
res: REAL; |
BEGIN |
res := 1.0; |
WHILE n > 1 DO |
res := res * FLT(n); |
DEC(n) |
END |
RETURN res |
END fact; |
PROCEDURE DegToRad* (x: REAL): REAL; |
RETURN x * (pi / 180.0) |
END DegToRad; |
PROCEDURE RadToDeg* (x: REAL): REAL; |
RETURN x * (180.0 / pi) |
END RadToDeg; |
(* Return hypotenuse of triangle *) |
PROCEDURE hypot* (x, y: REAL): REAL; |
VAR |
a: REAL; |
BEGIN |
x := ABS(x); |
y := ABS(y); |
IF x > y THEN |
a := x * sqrt(1.0 + sqrr(y / x)) |
ELSE |
IF x > 0.0 THEN |
a := y * sqrt(1.0 + sqrr(x / y)) |
ELSE |
a := y |
END |
END |
RETURN a |
END hypot; |
END Math. |
/programs/develop/oberon07/lib/KolibriOS/libimg.ob07 |
---|
0,0 → 1,435 |
(* |
Copyright 2016, 2018, 2020 KolibriOS team |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE libimg; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
FLIP_VERTICAL *= 1; |
FLIP_HORIZONTAL *= 2; |
ROTATE_90_CW *= 1; |
ROTATE_180 *= 2; |
ROTATE_270_CW *= 3; |
ROTATE_90_CCW *= ROTATE_270_CW; |
ROTATE_270_CCW *= ROTATE_90_CW; |
// scale type corresponding img_scale params |
LIBIMG_SCALE_INTEGER *= 1; // scale factor ; reserved 0 |
LIBIMG_SCALE_TILE *= 2; // new width ; new height |
LIBIMG_SCALE_STRETCH *= 3; // new width ; new height |
LIBIMG_SCALE_FIT_RECT *= 4; // new width ; new height |
LIBIMG_SCALE_FIT_WIDTH *= 5; // new width ; new height |
LIBIMG_SCALE_FIT_HEIGHT *= 6; // new width ; new height |
LIBIMG_SCALE_FIT_MAX *= 7; // new width ; new height |
// interpolation algorithm |
LIBIMG_INTER_NONE *= 0; // use it with LIBIMG_SCALE_INTEGER, LIBIMG_SCALE_TILE, etc |
LIBIMG_INTER_BILINEAR *= 1; |
LIBIMG_INTER_DEFAULT *= LIBIMG_INTER_BILINEAR; |
// list of format id's |
LIBIMG_FORMAT_BMP *= 1; |
LIBIMG_FORMAT_ICO *= 2; |
LIBIMG_FORMAT_CUR *= 3; |
LIBIMG_FORMAT_GIF *= 4; |
LIBIMG_FORMAT_PNG *= 5; |
LIBIMG_FORMAT_JPEG *= 6; |
LIBIMG_FORMAT_TGA *= 7; |
LIBIMG_FORMAT_PCX *= 8; |
LIBIMG_FORMAT_XCF *= 9; |
LIBIMG_FORMAT_TIFF *= 10; |
LIBIMG_FORMAT_PNM *= 11; |
LIBIMG_FORMAT_WBMP *= 12; |
LIBIMG_FORMAT_XBM *= 13; |
LIBIMG_FORMAT_Z80 *= 14; |
// encode flags (byte 0x02 of common option) |
LIBIMG_ENCODE_STRICT_SPECIFIC *= 01H; |
LIBIMG_ENCODE_STRICT_BIT_DEPTH *= 02H; |
LIBIMG_ENCODE_DELETE_ALPHA *= 08H; |
LIBIMG_ENCODE_FLUSH_ALPHA *= 10H; |
// values for Image.Type |
// must be consecutive to allow fast switch on Image.Type in support functions |
bpp8i *= 1; // indexed |
bpp24 *= 2; |
bpp32 *= 3; |
bpp15 *= 4; |
bpp16 *= 5; |
bpp1 *= 6; |
bpp8g *= 7; // grayscale |
bpp2i *= 8; |
bpp4i *= 9; |
bpp8a *= 10; // grayscale with alpha channel; application layer only!!! kernel doesn't handle this image type, libimg can only create and destroy such images |
// bits in Image.Flags |
IsAnimated *= 1; |
TYPE |
Image* = RECORD |
Checksum *: INTEGER; |
Width *: INTEGER; |
Height *: INTEGER; |
Next *: INTEGER; |
Previous *: INTEGER; |
Type *: INTEGER; // one of bppN |
Data *: INTEGER; |
Palette *: INTEGER; // used iff Type eq bpp1, bpp2, bpp4 or bpp8i |
Extended *: INTEGER; |
Flags *: INTEGER; // bitfield |
Delay *: INTEGER // used iff IsAnimated is set in Flags |
END; |
ImageDecodeOptions* = RECORD |
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on |
BackgroundColor *: INTEGER // used for transparent images as background |
END; |
FormatsTableEntry* = RECORD |
Format_id *: INTEGER; |
Is *: INTEGER; |
Decode *: INTEGER; |
Encode *: INTEGER; |
Capabilities *: INTEGER |
END; |
VAR |
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER; |
img_to_rgb2 *: PROCEDURE (img: INTEGER; out: INTEGER); |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? decodes image data into RGB triplets and stores them where out points to ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to source image ;; |
;> out = where to store RGB triplets ;; |
;;================================================================================================;; |
*) |
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? decodes image data into RGB triplets and returns pointer to memory area containing them ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to source image ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to rgb_data (array of [rgb] triplets) ;; |
;;================================================================================================;; |
*) |
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? decodes loaded into memory graphic file ;; |
;;------------------------------------------------------------------------------------------------;; |
;> data = pointer to file in memory ;; |
;> length = size in bytes of memory area pointed to by data ;; |
;> options = 0 / pointer to the structure of additional options ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to image ;; |
;;================================================================================================;; |
*) |
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? encode image to some format ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to input image ;; |
;> common = some most important options ;; |
; 0x00 : byte : format id ;; |
; 0x01 : byte : fast encoding (0) / best compression ratio (255) ;; |
; 0 : store uncompressed data (if supported both by the format and libimg) ;; |
; 1 - 255 : use compression, if supported ;; |
; this option may be ignored if any format specific options are defined ;; |
; i.e. the 0 here will be ignored if some compression algorithm is specified ;; |
; 0x02 : byte : flags (bitfield) ;; |
; 0x01 : return an error if format specific conditions cannot be met ;; |
; 0x02 : preserve current bit depth. means 8bpp/16bpp/24bpp and so on ;; |
; 0x04 : delete alpha channel, if any ;; |
; 0x08 : flush alpha channel with 0xff, if any; add it if none ;; |
; 0x03 : byte : reserved, must be 0 ;; |
;> specific = 0 / pointer to the structure of format specific options ;; |
; see <format_name>.inc for description ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to encoded data ;; |
;;================================================================================================;; |
*) |
img_create *: PROCEDURE (width, height, _type: INTEGER): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? creates an Image structure and initializes some its fields ;; |
;;------------------------------------------------------------------------------------------------;; |
;> width = width of an image in pixels ;; |
;> height = height of an image in pixels ;; |
;> type = one of the bppN constants ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to image ;; |
;;================================================================================================;; |
*) |
img_destroy *: PROCEDURE (img: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? frees memory occupied by an image and all the memory regions its fields point to ;; |
;? follows Previous/Next pointers and deletes all the images in sequence ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE (fail) / TRUE (success) ;; |
;;================================================================================================;; |
*) |
img_destroy_layer *: PROCEDURE (img: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? frees memory occupied by an image and all the memory regions its fields point to ;; |
;? for image sequences deletes only one frame and fixes Previous/Next pointers ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE (fail) / TRUE (success) ;; |
;;================================================================================================;; |
*) |
img_count *: PROCEDURE (img: INTEGER): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Get number of images in the list (e.g. in animated GIF file) ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;;------------------------------------------------------------------------------------------------;; |
;< -1 (fail) / >0 (ok) ;; |
;;================================================================================================;; |
*) |
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Flip all layers of image ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;> flip_kind = one of FLIP_* constants ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE / TRUE ;; |
;;================================================================================================;; |
*) |
img_flip_layer *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Flip image layer ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;> flip_kind = one of FLIP_* constants ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE / TRUE ;; |
;;================================================================================================;; |
*) |
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Rotate all layers of image ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;> rotate_kind = one of ROTATE_* constants ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE / TRUE ;; |
;;================================================================================================;; |
*) |
img_rotate_layer *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Rotate image layer ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;> rotate_kind = one of ROTATE_* constants ;; |
;;------------------------------------------------------------------------------------------------;; |
;< FALSE / TRUE ;; |
;;================================================================================================;; |
*) |
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER); |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? Draw image in the window ;; |
;;------------------------------------------------------------------------------------------------;; |
;> img = pointer to image ;; |
;> x = x-coordinate in the window ;; |
;> y = y-coordinate in the window ;; |
;> width = maximum width to draw ;; |
;> height = maximum height to draw ;; |
;> xpos = offset in image by x-axis ;; |
;> ypos = offset in image by y-axis ;; |
;;================================================================================================;; |
*) |
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER; |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? scale _image ;; |
;;------------------------------------------------------------------------------------------------;; |
;> src = pointer to source image ;; |
;> crop_x = left coord of cropping rect ;; |
;> crop_y = top coord of cropping rect ;; |
;> crop_width = width of cropping rect ;; |
;> crop_height = height of cropping rect ;; |
;> dst = pointer to resulting image / 0 ;; |
;> scale = how to change width and height. see libimg.inc ;; |
;> inter = interpolation algorithm ;; |
;> param1 = see libimg.inc ;; |
;> param2 = see libimg.inc ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to scaled image ;; |
;;================================================================================================;; |
*) |
img_convert *: PROCEDURE (src, dst: INTEGER; dst_type, flags, param: INTEGER); |
(* |
;;------------------------------------------------------------------------------------------------;; |
;? scale _image ;; |
;;------------------------------------------------------------------------------------------------;; |
;> src = pointer to source image ;; |
;> flags = see libimg.inc ;; |
;> dst_type = the Image.Type of converted image ;; |
;> dst = pointer to destination image, if any ;; |
;;------------------------------------------------------------------------------------------------;; |
;< 0 / pointer to converted image ;; |
;;================================================================================================;; |
*) |
img_formats_table *: ARRAY 20 OF FormatsTableEntry; |
PROCEDURE GetImageStruct* (img: INTEGER; VAR ImageStruct: Image): BOOLEAN; |
BEGIN |
IF img # 0 THEN |
sys.MOVE(img, sys.ADR(ImageStruct), sys.SIZE(Image)) |
END |
RETURN img # 0 |
END GetImageStruct; |
PROCEDURE GetFormatsTable(ptr: INTEGER); |
VAR i: INTEGER; eot: BOOLEAN; |
BEGIN |
i := 0; |
REPEAT |
sys.MOVE(ptr, sys.ADR(img_formats_table[i]), sys.SIZE(FormatsTableEntry)); |
ptr := ptr + sys.SIZE(FormatsTableEntry); |
eot := img_formats_table[i].Format_id = 0; |
INC(i) |
UNTIL eot OR (i = LEN(img_formats_table)) |
END GetFormatsTable; |
PROCEDURE main; |
VAR Lib, formats_table_ptr: INTEGER; |
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
BEGIN |
a := KOSAPI.GetProcAdr(name, Lib); |
ASSERT(a # 0); |
sys.PUT(v, a) |
END GetProc; |
BEGIN |
Lib := KOSAPI.LoadLib("/rd/1/lib/libimg.obj"); |
ASSERT(Lib # 0); |
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img"); |
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb"); |
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2"); |
GetProc(Lib, sys.ADR(img_decode) , "img_decode"); |
GetProc(Lib, sys.ADR(img_encode) , "img_encode"); |
GetProc(Lib, sys.ADR(img_create) , "img_create"); |
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy"); |
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer"); |
GetProc(Lib, sys.ADR(img_count) , "img_count"); |
GetProc(Lib, sys.ADR(img_flip) , "img_flip"); |
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer"); |
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate"); |
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer"); |
GetProc(Lib, sys.ADR(img_draw) , "img_draw"); |
GetProc(Lib, sys.ADR(img_scale) , "img_scale"); |
GetProc(Lib, sys.ADR(img_convert) , "img_convert"); |
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table"); |
GetFormatsTable(formats_table_ptr) |
END main; |
BEGIN |
main |
END libimg. |
/programs/develop/oberon07/lib/KolibriOS/Args.ob07 |
---|
0,0 → 1,100 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Args; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
MAX_PARAM = 1024; |
VAR |
Params: ARRAY MAX_PARAM, 2 OF INTEGER; |
argc*: INTEGER; |
PROCEDURE GetChar(adr: INTEGER): CHAR; |
VAR res: CHAR; |
BEGIN |
sys.GET(adr, res) |
RETURN res |
END GetChar; |
PROCEDURE ParamParse; |
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER; |
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER); |
BEGIN |
IF (c <= 20X) & (c # 0X) THEN |
cond := A |
ELSIF c = 22X THEN |
cond := B |
ELSIF c = 0X THEN |
cond := 6 |
ELSE |
cond := C |
END |
END ChangeCond; |
BEGIN |
p := KOSAPI.GetCommandLine(); |
name := KOSAPI.GetName(); |
Params[0, 0] := name; |
WHILE GetChar(name) # 0X DO |
INC(name) |
END; |
Params[0, 1] := name - 1; |
cond := 0; |
count := 1; |
WHILE (argc < MAX_PARAM) & (cond # 6) DO |
c := GetChar(p); |
CASE cond OF |
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END |
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END |
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END |
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END |
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END |
ELSE |
END; |
INC(p) |
END; |
argc := count |
END ParamParse; |
PROCEDURE GetArg*(n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR i, j, len: INTEGER; c: CHAR; |
BEGIN |
j := 0; |
IF n < argc THEN |
len := LEN(s) - 1; |
i := Params[n, 0]; |
WHILE (j < len) & (i <= Params[n, 1]) DO |
c := GetChar(i); |
IF c # 22X THEN |
s[j] := c; |
INC(j) |
END; |
INC(i); |
END; |
END; |
s[j] := 0X |
END GetArg; |
BEGIN |
ParamParse |
END Args. |
/programs/develop/oberon07/lib/KolibriOS/Console.ob07 |
---|
0,0 → 1,94 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Console; |
IMPORT ConsoleLib, In, Out; |
CONST |
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3; |
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7; |
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11; |
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15; |
PROCEDURE SetCursor* (X, Y: INTEGER); |
BEGIN |
ConsoleLib.set_cursor_pos(X, Y) |
END SetCursor; |
PROCEDURE GetCursor* (VAR X, Y: INTEGER); |
BEGIN |
ConsoleLib.get_cursor_pos(X, Y) |
END GetCursor; |
PROCEDURE Cls*; |
BEGIN |
ConsoleLib.cls |
END Cls; |
PROCEDURE SetColor* (FColor, BColor: INTEGER); |
VAR |
res: INTEGER; |
BEGIN |
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN |
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor) |
END |
END SetColor; |
PROCEDURE GetCursorX* (): INTEGER; |
VAR |
x, y: INTEGER; |
BEGIN |
ConsoleLib.get_cursor_pos(x, y) |
RETURN x |
END GetCursorX; |
PROCEDURE GetCursorY* (): INTEGER; |
VAR |
x, y: INTEGER; |
BEGIN |
ConsoleLib.get_cursor_pos(x, y) |
RETURN y |
END GetCursorY; |
PROCEDURE open*; |
BEGIN |
ConsoleLib.open(-1, -1, -1, -1, ""); |
In.Open; |
Out.Open |
END open; |
PROCEDURE exit* (bCloseWindow: BOOLEAN); |
BEGIN |
ConsoleLib.exit(bCloseWindow) |
END exit; |
END Console. |
/programs/develop/oberon07/lib/KolibriOS/ConsoleLib.ob07 |
---|
0,0 → 1,103 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE ConsoleLib; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
COLOR_BLUE* = 001H; |
COLOR_GREEN* = 002H; |
COLOR_RED* = 004H; |
COLOR_BRIGHT* = 008H; |
BGR_BLUE* = 010H; |
BGR_GREEN* = 020H; |
BGR_RED* = 040H; |
BGR_BRIGHT* = 080H; |
IGNORE_SPECIALS* = 100H; |
WINDOW_CLOSED* = 200H; |
TYPE |
gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER); |
VAR |
version* : INTEGER; |
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER); |
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN); |
write_asciiz* : PROCEDURE [stdcall] (string: INTEGER); |
write_string* : PROCEDURE [stdcall] (string, length: INTEGER); |
get_flags* : PROCEDURE [stdcall] (): INTEGER; |
set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER; |
get_font_height* : PROCEDURE [stdcall] (): INTEGER; |
get_cursor_height* : PROCEDURE [stdcall] (): INTEGER; |
set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER; |
getch* : PROCEDURE [stdcall] (): INTEGER; |
getch2* : PROCEDURE [stdcall] (): INTEGER; |
kbhit* : PROCEDURE [stdcall] (): INTEGER; |
gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER; |
gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER; |
cls* : PROCEDURE [stdcall] (); |
get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER); |
set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER); |
set_title* : PROCEDURE [stdcall] (title: INTEGER); |
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR); |
BEGIN |
init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0])) |
END open; |
PROCEDURE main; |
VAR Lib: INTEGER; |
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
BEGIN |
a := KOSAPI.GetProcAdr(name, Lib); |
ASSERT(a # 0); |
sys.PUT(v, a) |
END GetProc; |
BEGIN |
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj"); |
ASSERT(Lib # 0); |
GetProc(Lib, sys.ADR(version), "version"); |
GetProc(Lib, sys.ADR(init), "con_init"); |
GetProc(Lib, sys.ADR(exit), "con_exit"); |
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz"); |
GetProc(Lib, sys.ADR(write_string), "con_write_string"); |
GetProc(Lib, sys.ADR(get_flags), "con_get_flags"); |
GetProc(Lib, sys.ADR(set_flags), "con_set_flags"); |
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height"); |
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height"); |
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height"); |
GetProc(Lib, sys.ADR(getch), "con_getch"); |
GetProc(Lib, sys.ADR(getch2), "con_getch2"); |
GetProc(Lib, sys.ADR(kbhit), "con_kbhit"); |
GetProc(Lib, sys.ADR(gets), "con_gets"); |
GetProc(Lib, sys.ADR(gets2), "con_gets2"); |
GetProc(Lib, sys.ADR(cls), "con_cls"); |
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos"); |
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos"); |
GetProc(Lib, sys.ADR(set_title), "con_set_title"); |
END main; |
BEGIN |
main |
END ConsoleLib. |
/programs/develop/oberon07/lib/KolibriOS/DateTime.ob07 |
---|
0,0 → 1,141 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE DateTime; |
IMPORT KOSAPI; |
CONST ERR* = -7.0E5; |
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL; |
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL; |
BEGIN |
Res := ERR; |
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) & |
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) & |
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) THEN |
M := "_303232332323"; |
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN |
M[2] := "1" |
END; |
IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN |
DEC(Year); |
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594; |
FOR i := 1 TO Month - 1 DO |
d := d + ORD(M[i]) - ORD("0") + 28 |
END; |
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0 |
END |
END |
RETURN Res |
END Encode; |
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN; |
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR; |
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN; |
VAR Res: BOOLEAN; |
BEGIN |
Res := FALSE; |
IF d > ORD(M[n]) - ORD("0") + 28 THEN |
d := d - ORD(M[n]) + ORD("0") - 28; |
INC(Month); |
Res := TRUE |
END |
RETURN Res |
END MonthDay; |
BEGIN |
IF (Date >= -693593.0) & (Date < 2958466.0) THEN |
d := FLOOR(Date); |
t := FLOOR((Date - FLT(d)) * 86400000.0); |
d := d + 693593; |
Year := 1; |
Month := 1; |
WHILE d > 0 DO |
d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)); |
INC(Year) |
END; |
IF d < 0 THEN |
DEC(Year); |
d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0)) |
END; |
INC(d); |
M := "_303232332323"; |
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN |
M[2] := "1" |
END; |
i := 1; |
flag := TRUE; |
WHILE flag & (i <= 12) DO |
flag := MonthDay(i, d, Month, M); |
INC(i) |
END; |
Day := d; |
Hour := t DIV 3600000; |
t := t MOD 3600000; |
Min := t DIV 60000; |
t := t MOD 60000; |
Sec := t DIV 1000; |
Res := TRUE |
ELSE |
Res := FALSE |
END |
RETURN Res |
END Decode; |
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER); |
VAR date, time: INTEGER; |
BEGIN |
date := KOSAPI.sysfunc1(29); |
time := KOSAPI.sysfunc1(3); |
Year := date MOD 16; |
date := date DIV 16; |
Year := (date MOD 16) * 10 + Year; |
date := date DIV 16; |
Month := date MOD 16; |
date := date DIV 16; |
Month := (date MOD 16) * 10 + Month; |
date := date DIV 16; |
Day := date MOD 16; |
date := date DIV 16; |
Day := (date MOD 16) * 10 + Day; |
date := date DIV 16; |
Hour := time MOD 16; |
time := time DIV 16; |
Hour := (time MOD 16) * 10 + Hour; |
time := time DIV 16; |
Min := time MOD 16; |
time := time DIV 16; |
Min := (time MOD 16) * 10 + Min; |
time := time DIV 16; |
Sec := time MOD 16; |
time := time DIV 16; |
Sec := (time MOD 16) * 10 + Sec; |
time := time DIV 16; |
Year := Year + 2000; |
Msec := 0 |
END Now; |
END DateTime. |
/programs/develop/oberon07/lib/KolibriOS/Debug.ob07 |
---|
0,0 → 1,292 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Debug; |
IMPORT KOSAPI, sys := SYSTEM; |
CONST |
d = 1.0 - 5.0E-12; |
VAR |
Realp: PROCEDURE (x: REAL; width: INTEGER); |
PROCEDURE Char*(c: CHAR); |
VAR res: INTEGER; |
BEGIN |
res := KOSAPI.sysfunc3(63, 1, ORD(c)) |
END Char; |
PROCEDURE String*(s: ARRAY OF CHAR); |
VAR n, i: INTEGER; |
BEGIN |
n := LENGTH(s); |
FOR i := 0 TO n - 1 DO |
Char(s[i]) |
END |
END String; |
PROCEDURE WriteInt(x, n: INTEGER); |
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN; |
BEGIN |
i := 0; |
IF n < 1 THEN |
n := 1 |
END; |
IF x < 0 THEN |
x := -x; |
DEC(n); |
neg := TRUE |
END; |
REPEAT |
a[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10; |
INC(i) |
UNTIL x = 0; |
WHILE n > i DO |
Char(" "); |
DEC(n) |
END; |
IF neg THEN |
Char("-") |
END; |
REPEAT |
DEC(i); |
Char(a[i]) |
UNTIL i = 0 |
END WriteInt; |
PROCEDURE IsNan(AValue: REAL): BOOLEAN; |
VAR h, l: SET; |
BEGIN |
sys.GET(sys.ADR(AValue), l); |
sys.GET(sys.ADR(AValue) + 4, h) |
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) |
END IsNan; |
PROCEDURE IsInf(x: REAL): BOOLEAN; |
RETURN ABS(x) = sys.INF() |
END IsInf; |
PROCEDURE Int*(x, width: INTEGER); |
VAR i: INTEGER; |
BEGIN |
IF x # 80000000H THEN |
WriteInt(x, width) |
ELSE |
FOR i := 12 TO width DO |
Char(20X) |
END; |
String("-2147483648") |
END |
END Int; |
PROCEDURE OutInf(x: REAL; width: INTEGER); |
VAR s: ARRAY 5 OF CHAR; i: INTEGER; |
BEGIN |
IF IsNan(x) THEN |
s := "Nan"; |
INC(width) |
ELSIF IsInf(x) & (x > 0.0) THEN |
s := "+Inf" |
ELSIF IsInf(x) & (x < 0.0) THEN |
s := "-Inf" |
END; |
FOR i := 1 TO width - 4 DO |
Char(" ") |
END; |
String(s) |
END OutInf; |
PROCEDURE Ln*; |
BEGIN |
Char(0DX); |
Char(0AX) |
END Ln; |
PROCEDURE _FixReal(x: REAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
ELSIF p < 0 THEN |
Realp(x, width) |
ELSE |
len := 0; |
minus := FALSE; |
IF x < 0.0 THEN |
minus := TRUE; |
INC(len); |
x := ABS(x) |
END; |
e := 0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
IF e >= 0 THEN |
len := len + e + p + 1; |
IF x > 9.0 + d THEN |
INC(len) |
END; |
IF p > 0 THEN |
INC(len) |
END |
ELSE |
len := len + p + 2 |
END; |
FOR i := 1 TO width - len DO |
Char(" ") |
END; |
IF minus THEN |
Char("-") |
END; |
y := x; |
WHILE (y < 1.0) & (y # 0.0) DO |
y := y * 10.0; |
DEC(e) |
END; |
IF e < 0 THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char("1"); |
x := 0.0 |
ELSE |
Char("0"); |
x := x * 10.0 |
END |
ELSE |
WHILE e >= 0 DO |
IF x - FLT(FLOOR(x)) > d THEN |
IF x > 9.0 THEN |
String("10") |
ELSE |
Char(CHR(FLOOR(x) + ORD("0") + 1)) |
END; |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(e) |
END |
END; |
IF p > 0 THEN |
Char(".") |
END; |
WHILE p > 0 DO |
IF x - FLT(FLOOR(x)) > d THEN |
Char(CHR(FLOOR(x) + ORD("0") + 1)); |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(p) |
END |
END |
END _FixReal; |
PROCEDURE Real*(x: REAL; width: INTEGER); |
VAR e, n, i: INTEGER; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
ELSE |
e := 0; |
n := 0; |
IF width > 23 THEN |
n := width - 23; |
width := 23 |
ELSIF width < 9 THEN |
width := 9 |
END; |
width := width - 5; |
IF x < 0.0 THEN |
x := -x; |
minus := TRUE |
ELSE |
minus := FALSE |
END; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
WHILE (x < 1.0) & (x # 0.0) DO |
x := x * 10.0; |
DEC(e) |
END; |
IF x > 9.0 + d THEN |
x := 1.0; |
INC(e) |
END; |
FOR i := 1 TO n DO |
Char(" ") |
END; |
IF minus THEN |
x := -x |
END; |
Realp := Real; |
_FixReal(x, width, width - 3); |
Char("E"); |
IF e >= 0 THEN |
Char("+") |
ELSE |
Char("-"); |
e := ABS(e) |
END; |
IF e < 100 THEN |
Char("0") |
END; |
IF e < 10 THEN |
Char("0") |
END; |
Int(e, 0) |
END |
END Real; |
PROCEDURE FixReal*(x: REAL; width, p: INTEGER); |
BEGIN |
Realp := Real; |
_FixReal(x, width, p) |
END FixReal; |
PROCEDURE Open*; |
TYPE |
info_struct = RECORD |
subfunc: INTEGER; |
flags: INTEGER; |
param: INTEGER; |
rsrvd1: INTEGER; |
rsrvd2: INTEGER; |
fname: ARRAY 1024 OF CHAR |
END; |
VAR info: info_struct; res: INTEGER; |
BEGIN |
info.subfunc := 7; |
info.flags := 0; |
info.param := sys.SADR(" "); |
info.rsrvd1 := 0; |
info.rsrvd2 := 0; |
info.fname := "/rd/1/develop/board"; |
res := KOSAPI.sysfunc2(70, sys.ADR(info)) |
END Open; |
END Debug. |
/programs/develop/oberon07/lib/KolibriOS/In.ob07 |
---|
0,0 → 1,282 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE In; |
IMPORT sys := SYSTEM, ConsoleLib; |
TYPE |
STRING = ARRAY 260 OF CHAR; |
VAR |
Done* : BOOLEAN; |
PROCEDURE digit(ch: CHAR): BOOLEAN; |
RETURN (ch >= "0") & (ch <= "9") |
END digit; |
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN; |
VAR i: INTEGER; |
BEGIN |
i := 0; |
neg := FALSE; |
WHILE (s[i] <= 20X) & (s[i] # 0X) DO |
INC(i) |
END; |
IF s[i] = "-" THEN |
neg := TRUE; |
INC(i) |
ELSIF s[i] = "+" THEN |
INC(i) |
END; |
first := i; |
WHILE digit(s[i]) DO |
INC(i) |
END; |
last := i |
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first]) |
END CheckInt; |
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN; |
VAR i: INTEGER; min: STRING; |
BEGIN |
i := 0; |
min := "2147483648"; |
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO |
INC(i) |
END |
RETURN i = 10 |
END IsMinInt; |
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER; |
CONST maxINT = 7FFFFFFFH; |
VAR i, n, res: INTEGER; flag, neg: BOOLEAN; |
BEGIN |
res := 0; |
flag := CheckInt(str, i, n, neg, FALSE); |
err := ~flag; |
IF flag & neg & IsMinInt(str, i) THEN |
flag := FALSE; |
neg := FALSE; |
res := 80000000H |
END; |
WHILE flag & digit(str[i]) DO |
IF res > maxINT DIV 10 THEN |
err := TRUE; |
flag := FALSE; |
res := 0 |
ELSE |
res := res * 10; |
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN |
err := TRUE; |
flag := FALSE; |
res := 0 |
ELSE |
res := res + (ORD(str[i]) - ORD("0")); |
INC(i) |
END |
END |
END; |
IF neg THEN |
res := -res |
END |
RETURN res |
END StrToInt; |
PROCEDURE Space(s: STRING): BOOLEAN; |
VAR i: INTEGER; |
BEGIN |
i := 0; |
WHILE (s[i] # 0X) & (s[i] <= 20X) DO |
INC(i) |
END |
RETURN s[i] = 0X |
END Space; |
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN; |
VAR i: INTEGER; Res: BOOLEAN; |
BEGIN |
Res := CheckInt(s, n, i, neg, TRUE); |
IF Res THEN |
IF s[i] = "." THEN |
INC(i); |
WHILE digit(s[i]) DO |
INC(i) |
END; |
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN |
INC(i); |
IF (s[i] = "+") OR (s[i] = "-") THEN |
INC(i) |
END; |
Res := digit(s[i]); |
WHILE digit(s[i]) DO |
INC(i) |
END |
END |
END |
END |
RETURN Res & (s[i] <= 20X) |
END CheckReal; |
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL; |
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH; |
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN; |
PROCEDURE part1 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): BOOLEAN; |
BEGIN |
res := 0.0; |
d := 1.0; |
WHILE digit(str[i]) DO |
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0")); |
INC(i) |
END; |
IF str[i] = "." THEN |
INC(i); |
WHILE digit(str[i]) DO |
d := d / 10.0; |
res := res + FLT(ORD(str[i]) - ORD("0")) * d; |
INC(i) |
END |
END |
RETURN str[i] # 0X |
END part1; |
PROCEDURE part2 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): BOOLEAN; |
BEGIN |
INC(i); |
m := 10.0; |
minus := FALSE; |
IF str[i] = "+" THEN |
INC(i) |
ELSIF str[i] = "-" THEN |
minus := TRUE; |
INC(i); |
m := 0.1 |
END; |
scale := 0; |
err := FALSE; |
WHILE ~err & digit(str[i]) DO |
IF scale > maxINT DIV 10 THEN |
err := TRUE; |
res := 0.0 |
ELSE |
scale := scale * 10; |
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN |
err := TRUE; |
res := 0.0 |
ELSE |
scale := scale + (ORD(str[i]) - ORD("0")); |
INC(i) |
END |
END |
END |
RETURN ~err |
END part2; |
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR res, m: REAL; VAR scale: INTEGER); |
VAR i: INTEGER; |
BEGIN |
err := FALSE; |
IF scale = maxINT THEN |
err := TRUE; |
res := 0.0 |
END; |
i := 1; |
WHILE ~err & (i <= scale) DO |
IF ~minus & (res > maxDBL / m) THEN |
err := TRUE; |
res := 0.0 |
ELSE |
res := res * m; |
INC(i) |
END |
END |
END part3; |
BEGIN |
IF CheckReal(str, i, neg) THEN |
IF part1(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN |
part3(err, minus, res, m, scale) |
END; |
IF neg THEN |
res := -res |
END |
ELSE |
res := 0.0; |
err := TRUE |
END |
RETURN res |
END StrToFloat; |
PROCEDURE String*(VAR s: ARRAY OF CHAR); |
VAR res, length: INTEGER; str: STRING; |
BEGIN |
res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str)); |
length := LENGTH(str); |
IF length > 0 THEN |
str[length - 1] := 0X |
END; |
COPY(str, s); |
Done := TRUE |
END String; |
PROCEDURE Char*(VAR x: CHAR); |
VAR str: STRING; |
BEGIN |
String(str); |
x := str[0]; |
Done := TRUE |
END Char; |
PROCEDURE Ln*; |
VAR str: STRING; |
BEGIN |
String(str); |
Done := TRUE |
END Ln; |
PROCEDURE Real* (VAR x: REAL); |
VAR str: STRING; err: BOOLEAN; |
BEGIN |
err := FALSE; |
REPEAT |
String(str) |
UNTIL ~Space(str); |
x := StrToFloat(str, err); |
Done := ~err |
END Real; |
PROCEDURE Int*(VAR x: INTEGER); |
VAR str: STRING; err: BOOLEAN; |
BEGIN |
err := FALSE; |
REPEAT |
String(str) |
UNTIL ~Space(str); |
x := StrToInt(str, err); |
Done := ~err |
END Int; |
PROCEDURE Open*; |
BEGIN |
Done := TRUE |
END Open; |
END In. |
/programs/develop/oberon07/lib/KolibriOS/KOSAPI.ob07 |
---|
0,0 → 1,430 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2019, Anton Krotov |
All rights reserved. |
*) |
MODULE KOSAPI; |
IMPORT SYSTEM; |
TYPE |
STRING = ARRAY 1024 OF CHAR; |
VAR |
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER); |
imp_error*: RECORD |
proc*, lib*: STRING; |
error*: INTEGER |
END; |
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
0CDH, 040H, (* int 64 *) |
0C9H, (* leave *) |
0C2H, 004H, 000H (* ret 4 *) |
) |
RETURN 0 |
END sysfunc1; |
PROCEDURE [stdcall-] sysfunc2* (arg1, arg2: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
0CDH, 040H, (* int 64 *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 8 *) |
) |
RETURN 0 |
END sysfunc2; |
PROCEDURE [stdcall-] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
0CDH, 040H, (* int 64 *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 00CH, 000H (* ret 12 *) |
) |
RETURN 0 |
END sysfunc3; |
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *) |
0CDH, 040H, (* int 64 *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 010H, 000H (* ret 16 *) |
) |
RETURN 0 |
END sysfunc4; |
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
056H, (* push esi *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *) |
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *) |
0CDH, 040H, (* int 64 *) |
05EH, (* pop esi *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 014H, 000H (* ret 20 *) |
) |
RETURN 0 |
END sysfunc5; |
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
056H, (* push esi *) |
057H, (* push edi *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *) |
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *) |
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *) |
0CDH, 040H, (* int 64 *) |
05FH, (* pop edi *) |
05EH, (* pop esi *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 018H, 000H (* ret 24 *) |
) |
RETURN 0 |
END sysfunc6; |
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
056H, (* push esi *) |
057H, (* push edi *) |
055H, (* push ebp *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *) |
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *) |
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *) |
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *) |
0CDH, 040H, (* int 64 *) |
05DH, (* pop ebp *) |
05FH, (* pop edi *) |
05EH, (* pop esi *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 01CH, 000H (* ret 28 *) |
) |
RETURN 0 |
END sysfunc7; |
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE( |
053H, (* push ebx *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
0CDH, 040H, (* int 64 *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
089H, 019H, (* mov dword [ecx], ebx *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 00CH, 000H (* ret 12 *) |
) |
RETURN 0 |
END sysfunc22; |
PROCEDURE mem_commit (adr, size: INTEGER); |
VAR |
tmp: INTEGER; |
BEGIN |
FOR tmp := adr TO adr + size - 1 BY 4096 DO |
SYSTEM.PUT(tmp, 0) |
END |
END mem_commit; |
PROCEDURE [stdcall] malloc* (size: INTEGER): INTEGER; |
VAR |
ptr: INTEGER; |
BEGIN |
SYSTEM.CODE(060H); (* pusha *) |
IF sysfunc2(18, 16) > ASR(size, 10) THEN |
ptr := sysfunc3(68, 12, size); |
IF ptr # 0 THEN |
mem_commit(ptr, size) |
END |
ELSE |
ptr := 0 |
END; |
SYSTEM.CODE(061H) (* popa *) |
RETURN ptr |
END malloc; |
PROCEDURE [stdcall] free* (ptr: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE(060H); (* pusha *) |
IF ptr # 0 THEN |
ptr := sysfunc3(68, 13, ptr) |
END; |
SYSTEM.CODE(061H) (* popa *) |
RETURN 0 |
END free; |
PROCEDURE [stdcall] realloc* (ptr, size: INTEGER): INTEGER; |
BEGIN |
SYSTEM.CODE(060H); (* pusha *) |
ptr := sysfunc4(68, 20, size, ptr); |
SYSTEM.CODE(061H) (* popa *) |
RETURN ptr |
END realloc; |
PROCEDURE AppAdr (): INTEGER; |
VAR |
buf: ARRAY 1024 OF CHAR; |
a: INTEGER; |
BEGIN |
a := sysfunc3(9, SYSTEM.ADR(buf), -1); |
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a) |
RETURN a |
END AppAdr; |
PROCEDURE GetCommandLine* (): INTEGER; |
VAR |
param: INTEGER; |
BEGIN |
SYSTEM.GET(28 + AppAdr(), param) |
RETURN param |
END GetCommandLine; |
PROCEDURE GetName* (): INTEGER; |
VAR |
name: INTEGER; |
BEGIN |
SYSTEM.GET(32 + AppAdr(), name) |
RETURN name |
END GetName; |
PROCEDURE [stdcall] dll_init2 (arg1, arg2, arg3, arg4, arg5: INTEGER); |
BEGIN |
SYSTEM.CODE( |
060H, (* pusha *) |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *) |
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *) |
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *) |
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *) |
0FFH, 0D6H, (* call esi *) |
061H, (* popa *) |
0C9H, (* leave *) |
0C2H, 014H, 000H (* ret 20 *) |
) |
END dll_init2; |
PROCEDURE GetProcAdr* (name: ARRAY OF CHAR; lib: INTEGER): INTEGER; |
VAR |
cur, procname, adr: INTEGER; |
PROCEDURE streq (str1, str2: INTEGER): BOOLEAN; |
VAR |
c1, c2: CHAR; |
BEGIN |
REPEAT |
SYSTEM.GET(str1, c1); |
SYSTEM.GET(str2, c2); |
INC(str1); |
INC(str2) |
UNTIL (c1 # c2) OR (c1 = 0X) |
RETURN c1 = c2 |
END streq; |
BEGIN |
adr := 0; |
IF (lib # 0) & (name # "") THEN |
cur := lib; |
REPEAT |
SYSTEM.GET(cur, procname); |
INC(cur, 8) |
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0])); |
IF procname # 0 THEN |
SYSTEM.GET(cur - 4, adr) |
END |
END |
RETURN adr |
END GetProcAdr; |
PROCEDURE init (dll: INTEGER); |
VAR |
lib_init: INTEGER; |
BEGIN |
lib_init := GetProcAdr("lib_init", dll); |
IF lib_init # 0 THEN |
DLL_INIT(lib_init) |
END; |
lib_init := GetProcAdr("START", dll); |
IF lib_init # 0 THEN |
DLL_INIT(lib_init) |
END |
END init; |
PROCEDURE GetStr (adr, i: INTEGER; VAR str: STRING); |
VAR |
c: CHAR; |
BEGIN |
REPEAT |
SYSTEM.GET(adr, c); INC(adr); |
str[i] := c; INC(i) |
UNTIL c = 0X |
END GetStr; |
PROCEDURE [stdcall] dll_Load* (import_table: INTEGER): INTEGER; |
VAR |
imp, lib, exp, proc, res: INTEGER; |
fail, done: BOOLEAN; |
procname, libname: STRING; |
BEGIN |
SYSTEM.CODE(060H); (* pusha *) |
fail := FALSE; |
done := FALSE; |
res := 0; |
libname := "/rd/1/lib/"; |
REPEAT |
SYSTEM.GET(import_table, imp); |
IF imp # 0 THEN |
SYSTEM.GET(import_table + 4, lib); |
GetStr(lib, 10, libname); |
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0])); |
fail := exp = 0; |
ELSE |
done := TRUE |
END; |
IF fail THEN |
done := TRUE; |
imp_error.proc := ""; |
imp_error.lib := libname; |
imp_error.error := 1 |
END; |
IF (imp # 0) & ~fail THEN |
REPEAT |
SYSTEM.GET(imp, proc); |
IF proc # 0 THEN |
GetStr(proc, 0, procname); |
proc := GetProcAdr(procname, exp); |
IF proc # 0 THEN |
SYSTEM.PUT(imp, proc); |
INC(imp, 4) |
ELSE |
imp_error.proc := procname; |
imp_error.lib := libname; |
imp_error.error := 2 |
END |
END |
UNTIL proc = 0; |
init(exp); |
INC(import_table, 8) |
END |
UNTIL done; |
IF fail THEN |
res := 1 |
END; |
import_table := res; |
SYSTEM.CODE(061H) (* popa *) |
RETURN import_table |
END dll_Load; |
PROCEDURE [stdcall] dll_Init (entry: INTEGER); |
BEGIN |
SYSTEM.CODE(060H); (* pusha *) |
IF entry # 0 THEN |
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry) |
END; |
SYSTEM.CODE(061H); (* popa *) |
END dll_Init; |
PROCEDURE LoadLib* (name: ARRAY OF CHAR): INTEGER; |
VAR |
Lib: INTEGER; |
BEGIN |
DLL_INIT := dll_Init; |
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0])); |
IF Lib # 0 THEN |
init(Lib) |
END |
RETURN Lib |
END LoadLib; |
PROCEDURE _init*; |
BEGIN |
DLL_INIT := dll_Init; |
imp_error.lib := ""; |
imp_error.proc := ""; |
imp_error.error := 0 |
END _init; |
END KOSAPI. |
/programs/develop/oberon07/lib/KolibriOS/NetDevices.ob07 |
---|
0,0 → 1,107 |
(* |
Copyright 2017 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE NetDevices; |
IMPORT sys := SYSTEM, K := KOSAPI; |
CONST |
//net devices types |
LOOPBACK* = 0; |
ETH* = 1; |
SLIP* = 2; |
//Link status |
LINK_DOWN* = 0; |
LINK_UNKNOWN* = 1; |
LINK_FD* = 2; //full duplex flag |
LINK_10M* = 4; |
LINK_100M* = 8; |
LINK_1G* = 12; |
TYPE |
DEVICENAME* = ARRAY 64 OF CHAR; |
PROCEDURE Number* (): INTEGER; |
RETURN K.sysfunc2(74, -1) |
END Number; |
PROCEDURE Type* (num: INTEGER): INTEGER; |
RETURN K.sysfunc2(74, num * 256) |
END Type; |
PROCEDURE Name* (num: INTEGER; VAR name: DEVICENAME): BOOLEAN; |
VAR err: BOOLEAN; |
BEGIN |
err := K.sysfunc3(74, num * 256 + 1, sys.ADR(name[0])) = -1; |
IF err THEN |
name := "" |
END |
RETURN ~err |
END Name; |
PROCEDURE Reset* (num: INTEGER): BOOLEAN; |
RETURN K.sysfunc2(74, num * 256 + 2) # -1 |
END Reset; |
PROCEDURE Stop* (num: INTEGER): BOOLEAN; |
RETURN K.sysfunc2(74, num * 256 + 3) # -1 |
END Stop; |
PROCEDURE Pointer* (num: INTEGER): INTEGER; |
RETURN K.sysfunc2(74, num * 256 + 4) |
END Pointer; |
PROCEDURE SentPackets* (num: INTEGER): INTEGER; |
RETURN K.sysfunc2(74, num * 256 + 6) |
END SentPackets; |
PROCEDURE ReceivedPackets* (num: INTEGER): INTEGER; |
RETURN K.sysfunc2(74, num * 256 + 7) |
END ReceivedPackets; |
PROCEDURE SentBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER; |
RETURN K.sysfunc22(74, num * 256 + 8, hValue) |
END SentBytes; |
PROCEDURE ReceivedBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER; |
RETURN K.sysfunc22(74, num * 256 + 9, hValue) |
END ReceivedBytes; |
PROCEDURE LinkStatus* (num: INTEGER): INTEGER; |
RETURN K.sysfunc2(74, num * 256 + 10) |
END LinkStatus; |
END NetDevices. |
/programs/develop/oberon07/lib/KolibriOS/Out.ob07 |
---|
0,0 → 1,267 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Out; |
IMPORT ConsoleLib, sys := SYSTEM; |
CONST |
d = 1.0 - 5.0E-12; |
VAR |
Realp: PROCEDURE (x: REAL; width: INTEGER); |
PROCEDURE Char*(c: CHAR); |
BEGIN |
ConsoleLib.write_string(sys.ADR(c), 1) |
END Char; |
PROCEDURE String*(s: ARRAY OF CHAR); |
BEGIN |
ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s)) |
END String; |
PROCEDURE WriteInt(x, n: INTEGER); |
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN; |
BEGIN |
i := 0; |
IF n < 1 THEN |
n := 1 |
END; |
IF x < 0 THEN |
x := -x; |
DEC(n); |
neg := TRUE |
END; |
REPEAT |
a[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10; |
INC(i) |
UNTIL x = 0; |
WHILE n > i DO |
Char(" "); |
DEC(n) |
END; |
IF neg THEN |
Char("-") |
END; |
REPEAT |
DEC(i); |
Char(a[i]) |
UNTIL i = 0 |
END WriteInt; |
PROCEDURE IsNan(AValue: REAL): BOOLEAN; |
VAR h, l: SET; |
BEGIN |
sys.GET(sys.ADR(AValue), l); |
sys.GET(sys.ADR(AValue) + 4, h) |
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) |
END IsNan; |
PROCEDURE IsInf(x: REAL): BOOLEAN; |
RETURN ABS(x) = sys.INF() |
END IsInf; |
PROCEDURE Int*(x, width: INTEGER); |
VAR i: INTEGER; |
BEGIN |
IF x # 80000000H THEN |
WriteInt(x, width) |
ELSE |
FOR i := 12 TO width DO |
Char(20X) |
END; |
String("-2147483648") |
END |
END Int; |
PROCEDURE OutInf(x: REAL; width: INTEGER); |
VAR s: ARRAY 5 OF CHAR; i: INTEGER; |
BEGIN |
IF IsNan(x) THEN |
s := "Nan"; |
INC(width) |
ELSIF IsInf(x) & (x > 0.0) THEN |
s := "+Inf" |
ELSIF IsInf(x) & (x < 0.0) THEN |
s := "-Inf" |
END; |
FOR i := 1 TO width - 4 DO |
Char(" ") |
END; |
String(s) |
END OutInf; |
PROCEDURE Ln*; |
BEGIN |
Char(0DX); |
Char(0AX) |
END Ln; |
PROCEDURE _FixReal(x: REAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
ELSIF p < 0 THEN |
Realp(x, width) |
ELSE |
len := 0; |
minus := FALSE; |
IF x < 0.0 THEN |
minus := TRUE; |
INC(len); |
x := ABS(x) |
END; |
e := 0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
IF e >= 0 THEN |
len := len + e + p + 1; |
IF x > 9.0 + d THEN |
INC(len) |
END; |
IF p > 0 THEN |
INC(len) |
END |
ELSE |
len := len + p + 2 |
END; |
FOR i := 1 TO width - len DO |
Char(" ") |
END; |
IF minus THEN |
Char("-") |
END; |
y := x; |
WHILE (y < 1.0) & (y # 0.0) DO |
y := y * 10.0; |
DEC(e) |
END; |
IF e < 0 THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char("1"); |
x := 0.0 |
ELSE |
Char("0"); |
x := x * 10.0 |
END |
ELSE |
WHILE e >= 0 DO |
IF x - FLT(FLOOR(x)) > d THEN |
IF x > 9.0 THEN |
String("10") |
ELSE |
Char(CHR(FLOOR(x) + ORD("0") + 1)) |
END; |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(e) |
END |
END; |
IF p > 0 THEN |
Char(".") |
END; |
WHILE p > 0 DO |
IF x - FLT(FLOOR(x)) > d THEN |
Char(CHR(FLOOR(x) + ORD("0") + 1)); |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(p) |
END |
END |
END _FixReal; |
PROCEDURE Real*(x: REAL; width: INTEGER); |
VAR e, n, i: INTEGER; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
ELSE |
e := 0; |
n := 0; |
IF width > 23 THEN |
n := width - 23; |
width := 23 |
ELSIF width < 9 THEN |
width := 9 |
END; |
width := width - 5; |
IF x < 0.0 THEN |
x := -x; |
minus := TRUE |
ELSE |
minus := FALSE |
END; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
WHILE (x < 1.0) & (x # 0.0) DO |
x := x * 10.0; |
DEC(e) |
END; |
IF x > 9.0 + d THEN |
x := 1.0; |
INC(e) |
END; |
FOR i := 1 TO n DO |
Char(" ") |
END; |
IF minus THEN |
x := -x |
END; |
Realp := Real; |
_FixReal(x, width, width - 3); |
Char("E"); |
IF e >= 0 THEN |
Char("+") |
ELSE |
Char("-"); |
e := ABS(e) |
END; |
IF e < 100 THEN |
Char("0") |
END; |
IF e < 10 THEN |
Char("0") |
END; |
Int(e, 0) |
END |
END Real; |
PROCEDURE FixReal*(x: REAL; width, p: INTEGER); |
BEGIN |
Realp := Real; |
_FixReal(x, width, p) |
END FixReal; |
PROCEDURE Open*; |
END Open; |
END Out. |
/programs/develop/oberon07/lib/KolibriOS/RasterWorks.ob07 |
---|
0,0 → 1,124 |
(* |
Copyright 2016, 2018 KolibriOS team |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE RasterWorks; |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
(* flags *) |
bold *= 1; |
italic *= 2; |
underline *= 4; |
strike_through *= 8; |
align_right *= 16; |
align_center *= 32; |
bpp32 *= 128; |
(* encoding *) |
cp866 *= 1; |
utf16le *= 2; |
utf8 *= 3; |
VAR |
// draw text on 24bpp or 32bpp image |
// autofits text between 'x' and 'xSize' |
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER; |
(* |
[canvas]: |
xSize dd ? |
ySize dd ? |
picture rb xSize * ySize * bpp |
fontColor dd AARRGGBB |
AA = alpha channel ; 0 = transparent, FF = non transparent |
params dd ffeewwhh |
hh = char height |
ww = char width ; 0 = auto (proportional) |
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8 |
ff = flags ; 0001 = bold, 0010 = italic |
; 0100 = underline, 1000 = strike-through |
00010000 = align right, 00100000 = align center |
01000000 = set text area between higher and lower halfs of 'x' |
10000000 = 32bpp canvas insted of 24bpp |
all flags combinable, except align right + align center |
returns: char width (0 = error) |
*) |
// calculate amount of valid chars in UTF-8 string |
// supports zero terminated string (set byteQuantity = -1) |
cntUTF_8 *: PROCEDURE (string, byteQuantity: INTEGER): INTEGER; |
// calculate amount of chars that fits given width |
charsFit *: PROCEDURE (areaWidth, charHeight: INTEGER): INTEGER; |
// calculate string width in pixels |
strWidth *: PROCEDURE (charQuantity, charHeight: INTEGER): INTEGER; |
PROCEDURE params* (charHeight, charWidth, encoding, flags: INTEGER): INTEGER; |
(* |
hh = char height |
ww = char width ; 0 = auto (proportional) |
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8 |
ff = flags ; 0001 = bold, 0010 = italic |
; 0100 = underline, 1000 = strike-through |
00010000 = align right, 00100000 = align center |
01000000 = set text area between higher and lower halfs of 'x' |
10000000 = 32bpp canvas insted of 24bpp |
all flags combinable, except align right + align center |
*) |
RETURN charHeight + LSL(charWidth, 8) + LSL(encoding, 16) + LSL(flags, 24) |
END params; |
PROCEDURE main; |
VAR Lib: INTEGER; |
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
BEGIN |
a := KOSAPI.GetProcAdr(name, Lib); |
ASSERT(a # 0); |
sys.PUT(v, a) |
END GetProc; |
BEGIN |
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj"); |
ASSERT(Lib # 0); |
GetProc(Lib, sys.ADR(drawText), "drawText"); |
GetProc(Lib, sys.ADR(cntUTF_8), "cntUTF-8"); |
GetProc(Lib, sys.ADR(charsFit), "charsFit"); |
GetProc(Lib, sys.ADR(strWidth), "strWidth"); |
END main; |
BEGIN |
main |
END RasterWorks. |
/programs/develop/oberon07/lib/KolibriOS/Read.ob07 |
---|
0,0 → 1,46 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Read; |
IMPORT File, sys := SYSTEM; |
PROCEDURE Char*(F: File.FS; VAR x: CHAR): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) |
END Char; |
PROCEDURE Int*(F: File.FS; VAR x: INTEGER): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) |
END Int; |
PROCEDURE Real*(F: File.FS; VAR x: REAL): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) |
END Real; |
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) |
END Boolean; |
PROCEDURE Set*(F: File.FS; VAR x: SET): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) |
END Set; |
PROCEDURE WChar*(F: File.FS; VAR x: WCHAR): BOOLEAN; |
RETURN File.Read(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR) |
END WChar; |
END Read. |
/programs/develop/oberon07/lib/KolibriOS/UnixTime.ob07 |
---|
0,0 → 1,64 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2019, Anton Krotov |
All rights reserved. |
*) |
MODULE UnixTime; |
VAR |
days: ARRAY 12, 31, 2 OF INTEGER; |
PROCEDURE init; |
VAR |
i, j, k, n0, n1: INTEGER; |
BEGIN |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
days[i, j, 0] := 0; |
days[i, j, 1] := 0; |
END |
END; |
days[ 1, 28, 0] := -1; |
FOR k := 0 TO 1 DO |
days[ 1, 29, k] := -1; |
days[ 1, 30, k] := -1; |
days[ 3, 30, k] := -1; |
days[ 5, 30, k] := -1; |
days[ 8, 30, k] := -1; |
days[10, 30, k] := -1; |
END; |
n0 := 0; |
n1 := 0; |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
IF days[i, j, 0] = 0 THEN |
days[i, j, 0] := n0; |
INC(n0) |
END; |
IF days[i, j, 1] = 0 THEN |
days[i, j, 1] := n1; |
INC(n1) |
END |
END |
END |
END init; |
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER; |
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec |
END time; |
BEGIN |
init |
END UnixTime. |
/programs/develop/oberon07/lib/KolibriOS/Vector.ob07 |
---|
0,0 → 1,121 |
(* |
Copyright 2016 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Vector; |
IMPORT sys := SYSTEM, K := KOSAPI; |
TYPE |
DESC_VECTOR = RECORD |
data : INTEGER; |
count : INTEGER; |
size : INTEGER |
END; |
VECTOR* = POINTER TO DESC_VECTOR; |
ANYREC* = RECORD END; |
ANYPTR* = POINTER TO ANYREC; |
DESTRUCTOR* = PROCEDURE (VAR ptr: ANYPTR); |
PROCEDURE count* (vector: VECTOR): INTEGER; |
BEGIN |
ASSERT(vector # NIL) |
RETURN vector.count |
END count; |
PROCEDURE push* (vector: VECTOR; value: ANYPTR); |
BEGIN |
ASSERT(vector # NIL); |
IF vector.count = vector.size THEN |
vector.data := K.realloc(vector.data, (vector.size + 1024) * 4); |
ASSERT(vector.data # 0); |
vector.size := vector.size + 1024 |
END; |
sys.PUT(vector.data + vector.count * 4, value); |
INC(vector.count) |
END push; |
PROCEDURE get* (vector: VECTOR; idx: INTEGER): ANYPTR; |
VAR res: ANYPTR; |
BEGIN |
ASSERT(vector # NIL); |
ASSERT( (0 <= idx) & (idx < vector.count) ); |
sys.GET(vector.data + idx * 4, res) |
RETURN res |
END get; |
PROCEDURE put* (vector: VECTOR; idx: INTEGER; value: ANYPTR); |
BEGIN |
ASSERT(vector # NIL); |
ASSERT( (0 <= idx) & (idx < vector.count) ); |
sys.PUT(vector.data + idx * 4, value) |
END put; |
PROCEDURE create* (size: INTEGER): VECTOR; |
VAR vector: VECTOR; |
BEGIN |
NEW(vector); |
IF vector # NIL THEN |
vector.data := K.malloc(4 * size); |
IF vector.data # 0 THEN |
vector.size := size; |
vector.count := 0 |
ELSE |
DISPOSE(vector) |
END |
END |
RETURN vector |
END create; |
PROCEDURE def_destructor (VAR any: ANYPTR); |
BEGIN |
DISPOSE(any) |
END def_destructor; |
PROCEDURE destroy* (VAR vector: VECTOR; destructor: DESTRUCTOR); |
VAR i: INTEGER; |
any: ANYPTR; |
BEGIN |
ASSERT(vector # NIL); |
IF destructor = NIL THEN |
destructor := def_destructor |
END; |
FOR i := 0 TO vector.count - 1 DO |
any := get(vector, i); |
destructor(any) |
END; |
vector.data := K.free(vector.data); |
DISPOSE(vector) |
END destroy; |
END Vector. |
/programs/develop/oberon07/lib/KolibriOS/Write.ob07 |
---|
0,0 → 1,46 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE Write; |
IMPORT File, sys := SYSTEM; |
PROCEDURE Char*(F: File.FS; x: CHAR): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR) |
END Char; |
PROCEDURE Int*(F: File.FS; x: INTEGER): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER) |
END Int; |
PROCEDURE Real*(F: File.FS; x: REAL): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL) |
END Real; |
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN) |
END Boolean; |
PROCEDURE Set*(F: File.FS; x: SET): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET) |
END Set; |
PROCEDURE WChar*(F: File.FS; x: WCHAR): BOOLEAN; |
RETURN File.Write(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR) |
END WChar; |
END Write. |
/programs/develop/oberon07/lib/KolibriOS/kfonts.ob07 |
---|
0,0 → 1,492 |
(* |
Copyright 2016, 2018 Anton Krotov |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE kfonts; |
IMPORT sys := SYSTEM, File, KOSAPI; |
CONST |
MIN_FONT_SIZE = 8; |
MAX_FONT_SIZE = 46; |
bold *= 1; |
italic *= 2; |
underline *= 4; |
strike_through *= 8; |
smoothing *= 16; |
bpp32 *= 32; |
TYPE |
Glyph = RECORD |
base: INTEGER; |
xsize, ysize: INTEGER; |
width: INTEGER |
END; |
TFont_desc = RECORD |
data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER; |
glyphs: ARRAY 4, 256 OF Glyph |
END; |
TFont* = POINTER TO TFont_desc; |
PROCEDURE [stdcall] zeromem(size, adr: INTEGER); |
BEGIN |
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH) |
END zeromem; |
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN); |
VAR xsize, ysize: INTEGER; |
BEGIN |
sys.GET(buf, xsize); |
sys.GET(buf + 4, ysize); |
INC(buf, 8); |
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN |
IF bpp32 THEN |
sys.PUT(buf + 4 * (xsize * y + x), color) |
ELSE |
sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3) |
END |
END |
END pset; |
PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER; |
VAR xsize, ysize, color: INTEGER; |
BEGIN |
sys.GET(buf, xsize); |
sys.GET(buf + 4, ysize); |
INC(buf, 8); |
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN |
IF bpp32 THEN |
sys.GET(buf + 4 * (xsize * y + x), color) |
ELSE |
sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3) |
END |
END |
RETURN color |
END pget; |
PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER); |
BEGIN |
b := LSR(LSL(color, 24), 24); |
g := LSR(LSL(color, 16), 24); |
r := LSR(LSL(color, 8), 24); |
END getrgb; |
PROCEDURE rgb(r, g, b: INTEGER): INTEGER; |
RETURN b + LSL(g, 8) + LSL(r, 16) |
END rgb; |
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER); |
BEGIN |
glyph.base := Font.mempos; |
glyph.xsize := xsize; |
glyph.ysize := ysize; |
Font.mempos := Font.mempos + xsize * ysize |
END create_glyph; |
PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR; |
VAR res: CHAR; |
BEGIN |
sys.GET(Font.mem + n + x + y * xsize, res) |
RETURN res |
END getpix; |
PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR); |
BEGIN |
sys.PUT(Font.mem + n + x + y * xsize, c) |
END setpix; |
PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER); |
VAR x, y: INTEGER; |
BEGIN |
FOR y := 1 TO ysize - 1 DO |
FOR x := 1 TO xsize - 1 DO |
IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) & |
(getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN |
setpix(Font, n, x - 1, y, xsize, 2X); |
setpix(Font, n, x, y - 1, xsize, 2X) |
END; |
IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) & |
(getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN |
setpix(Font, n, x, y, xsize, 2X); |
setpix(Font, n, x - 1, y - 1, xsize, 2X) |
END |
END |
END |
END smooth; |
PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER); |
VAR i, j, k: INTEGER; pix: CHAR; |
BEGIN |
FOR i := 0 TO src_xsize - 1 DO |
FOR j := 0 TO Font.height - 1 DO |
pix := getpix(Font, src, i, j, src_xsize); |
IF pix = 1X THEN |
FOR k := 0 TO n DO |
setpix(Font, dst, i + k, j, dst_xsize, pix) |
END |
END |
END |
END |
END _bold; |
PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER); |
VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN; |
glyph: Glyph; pix: CHAR; bold_width: INTEGER; |
BEGIN |
create_glyph(Font, glyph, Font.width, Font.height); |
x := 0; |
y := 0; |
max := 0; |
ptr := Font.font + Font.char_size * c; |
eoc := FALSE; |
REPEAT |
sys.GET(ptr, s); |
INC(ptr, 4); |
FOR i := 0 TO 31 DO |
IF ~eoc THEN |
IF i IN s THEN |
setpix(Font, glyph.base, x, y, Font.width, 1X); |
IF x > max THEN |
max := x |
END |
ELSE |
setpix(Font, glyph.base, x, y, Font.width, 0X) |
END |
END; |
INC(x); |
IF x = Font.width THEN |
x := 0; |
INC(y); |
eoc := eoc OR (y = Font.height) |
END |
END |
UNTIL eoc; |
IF max = 0 THEN |
max := Font.width DIV 3 |
END; |
glyph.width := max; |
smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
Font.glyphs[0, c] := glyph; |
bold_width := 1; |
create_glyph(Font, glyph, Font.width + bold_width, Font.height); |
_bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width); |
smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
glyph.width := max + bold_width; |
Font.glyphs[1, c] := glyph; |
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height); |
FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO |
FOR j := 0 TO Font.height - 1 DO |
pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize); |
IF pix = 1X THEN |
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix) |
END |
END |
END; |
smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
glyph.width := max; |
Font.glyphs[2, c] := glyph; |
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height); |
_bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width); |
smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
glyph.width := max + bold_width; |
Font.glyphs[3, c] := glyph; |
END make_glyph; |
PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER; |
VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph; |
BEGIN |
x0 := x; |
y0 := y; |
style := style MOD 4; |
glyph := Font.glyphs[style, c]; |
xsize := glyph.xsize; |
xmax := x0 + xsize; |
mem := Font.mem + glyph.base; |
getrgb(color, r0, g0, b0); |
FOR i := mem TO mem + xsize * Font.height - 1 DO |
sys.GET(i, ch); |
IF ch = 1X THEN |
pset(buf, x, y, color, bpp32); |
ELSIF (ch = 2X) & smoothing THEN |
getrgb(pget(buf, x, y, bpp32), r, g, b); |
r := (r * 3 + r0) DIV 4; |
g := (g * 3 + g0) DIV 4; |
b := (b * 3 + b0) DIV 4; |
pset(buf, x, y, rgb(r, g, b), bpp32) |
END; |
INC(x); |
IF x = xmax THEN |
x := x0; |
INC(y) |
END |
END |
RETURN glyph.width |
END OutChar; |
PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN); |
VAR i: INTEGER; |
BEGIN |
FOR i := x TO x + width - 1 DO |
pset(buf, i, y, color, bpp32) |
END |
END hline; |
PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER; |
VAR res: INTEGER; c: CHAR; |
BEGIN |
res := 0; |
params := params MOD 4; |
IF Font # NIL THEN |
sys.GET(str, c); |
WHILE (length > 0) OR (length = -1) & (c # 0X) DO |
INC(str); |
res := res + Font.glyphs[params, ORD(c)].width; |
IF length > 0 THEN |
DEC(length) |
END; |
IF length # 0 THEN |
sys.GET(str, c) |
END |
END |
END |
RETURN res |
END TextWidth; |
PROCEDURE TextHeight*(Font: TFont): INTEGER; |
VAR res: INTEGER; |
BEGIN |
IF Font # NIL THEN |
res := Font.height |
ELSE |
res := 0 |
END |
RETURN res |
END TextHeight; |
PROCEDURE TextClipLeft(Font: TFont; str, length, params: INTEGER; VAR x: INTEGER): INTEGER; |
VAR x1: INTEGER; c: CHAR; |
BEGIN |
params := params MOD 4; |
sys.GET(str, c); |
WHILE (length > 0) OR (length = -1) & (c # 0X) DO |
INC(str); |
x1 := x; |
x := x + Font.glyphs[params, ORD(c)].width; |
IF x > 0 THEN |
length := 0; |
END; |
IF length > 0 THEN |
DEC(length) |
END; |
IF length # 0 THEN |
sys.GET(str, c) |
END |
END; |
x := x1 |
RETURN str - 1 |
END TextClipLeft; |
PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER); |
VAR width, xsize, ysize, str1, n: INTEGER; c: CHAR; bpp32, smoothing, underline, strike: BOOLEAN; |
BEGIN |
IF Font # NIL THEN |
sys.GET(canvas, xsize); |
sys.GET(canvas + 4, ysize); |
IF (y <= -TextHeight(Font)) OR (y >= ysize) THEN |
length := 0 |
END; |
IF length # 0 THEN |
smoothing := 4 IN BITS(params); |
bpp32 := 5 IN BITS(params); |
underline := 2 IN BITS(params); |
strike := 3 IN BITS(params); |
str1 := TextClipLeft(Font, str, length, params, x); |
n := str1 - str; |
str := str1; |
IF length >= n THEN |
length := length - n |
END; |
sys.GET(str, c) |
END; |
WHILE (length > 0) OR (length = -1) & (c # 0X) DO |
INC(str); |
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params); |
IF strike THEN |
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32) |
END; |
IF underline THEN |
hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32) |
END; |
x := x + width; |
IF x > xsize THEN |
length := 0 |
END; |
IF length > 0 THEN |
DEC(length) |
END; |
IF length # 0 THEN |
sys.GET(str, c) |
END |
END |
END |
END TextOut; |
PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN; |
VAR temp, offset, fsize, i, memsize, mem: INTEGER; |
c: CHAR; Font, Font2: TFont_desc; |
BEGIN |
offset := -1; |
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN |
Font := _Font^; |
Font2 := Font; |
temp := Font.data + (font_size - 8) * 4; |
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN |
sys.GET(temp, offset); |
IF offset # -1 THEN |
Font.font_size := font_size; |
INC(offset, 156); |
offset := offset + Font.data; |
IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN |
sys.GET(offset, fsize); |
IF fsize > 256 + 6 THEN |
temp := offset + fsize - 1; |
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN |
sys.GET(temp, c); |
IF c # 0X THEN |
Font.height := ORD(c); |
DEC(temp); |
sys.GET(temp, c); |
IF c # 0X THEN |
Font.width := ORD(c); |
DEC(fsize, 6); |
Font.char_size := fsize DIV 256; |
IF fsize MOD 256 # 0 THEN |
INC(Font.char_size) |
END; |
IF Font.char_size > 0 THEN |
Font.font := offset + 4; |
Font.mempos := 0; |
memsize := (Font.width + 10) * Font.height * 1024; |
mem := Font.mem; |
Font.mem := KOSAPI.sysfunc3(68, 12, memsize); |
IF Font.mem # 0 THEN |
IF mem # 0 THEN |
mem := KOSAPI.sysfunc3(68, 13, mem) |
END; |
zeromem(memsize DIV 4, Font.mem); |
FOR i := 0 TO 255 DO |
make_glyph(Font, i) |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
ELSE |
offset := -1 |
END |
END; |
ELSE |
offset := -1 |
END; |
IF offset # -1 THEN |
_Font^ := Font |
ELSE |
_Font^ := Font2 |
END |
END |
RETURN offset # -1 |
END SetSize; |
PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN; |
VAR offset, temp: INTEGER; |
BEGIN |
offset := -1; |
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN |
temp := Font.data + (font_size - 8) * 4; |
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN |
sys.GET(temp, offset) |
END |
END |
RETURN offset # -1 |
END Enabled; |
PROCEDURE Destroy*(VAR Font: TFont); |
BEGIN |
IF Font # NIL THEN |
IF Font.mem # 0 THEN |
Font.mem := KOSAPI.sysfunc3(68, 13, Font.mem) |
END; |
IF Font.data # 0 THEN |
Font.data := KOSAPI.sysfunc3(68, 13, Font.data) |
END; |
DISPOSE(Font) |
END |
END Destroy; |
PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont; |
VAR Font: TFont; data, size, n: INTEGER; |
BEGIN |
data := File.Load(file_name, size); |
IF (data # 0) & (size > 156) THEN |
NEW(Font); |
Font.data := data; |
Font.size := size; |
Font.font_size := 0; |
n := MIN_FONT_SIZE; |
WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO |
INC(n) |
END; |
IF Font.font_size = 0 THEN |
Destroy(Font) |
END |
ELSE |
IF data # 0 THEN |
data := KOSAPI.sysfunc3(68, 13, data) |
END; |
Font := NIL |
END |
RETURN Font |
END LoadFont; |
END kfonts. |
/programs/develop/oberon07/lib/RVMxI/32/FPU.ob07 |
---|
0,0 → 1,460 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE FPU; |
CONST |
INF = 07F800000H; |
NINF = 0FF800000H; |
NAN = 07FC00000H; |
PROCEDURE div2 (b, a: INTEGER): INTEGER; |
VAR |
n, e, r, s: INTEGER; |
BEGIN |
s := ORD(BITS(a) / BITS(b) - {0..30}); |
e := (a DIV 800000H) MOD 256 - (b DIV 800000H) MOD 256 + 127; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
n := 800000H; |
r := 0; |
IF a < b THEN |
a := a * 2; |
DEC(e) |
END; |
WHILE (a > 0) & (n > 0) DO |
IF a >= b THEN |
INC(r, n); |
DEC(a, b) |
END; |
a := a * 2; |
n := n DIV 2 |
END; |
IF e <= 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
ELSIF e >= 255 THEN |
e := 255; |
r := 800000H |
END |
RETURN (r - 800000H) + e * 800000H + s |
END div2; |
PROCEDURE mul2 (b, a: INTEGER): INTEGER; |
VAR |
e, r, s: INTEGER; |
BEGIN |
s := ORD(BITS(a) / BITS(b) - {0..30}); |
e := (a DIV 800000H) MOD 256 + (b DIV 800000H) MOD 256 - 127; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
r := a * (b MOD 256); |
b := b DIV 256; |
r := LSR(r, 8); |
INC(r, a * (b MOD 256)); |
b := b DIV 256; |
r := LSR(r, 8); |
INC(r, a * (b MOD 256)); |
r := LSR(r, 7); |
IF r >= 1000000H THEN |
r := r DIV 2; |
INC(e) |
END; |
IF e <= 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
ELSIF e >= 255 THEN |
e := 255; |
r := 800000H |
END |
RETURN (r - 800000H) + e * 800000H + s |
END mul2; |
PROCEDURE add2 (b, a: INTEGER): INTEGER; |
VAR |
t, e, d: INTEGER; |
BEGIN |
e := (a DIV 800000H) MOD 256; |
t := (b DIV 800000H) MOD 256; |
d := e - t; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
IF d > 0 THEN |
IF d < 24 THEN |
b := LSR(b, d) |
ELSE |
b := 0 |
END |
ELSIF d < 0 THEN |
IF d > -24 THEN |
a := LSR(a, -d) |
ELSE |
a := 0 |
END; |
e := t |
END; |
INC(a, b); |
IF a >= 1000000H THEN |
a := a DIV 2; |
INC(e) |
END; |
IF e >= 255 THEN |
e := 255; |
a := 800000H |
END |
RETURN (a - 800000H) + e * 800000H |
END add2; |
PROCEDURE sub2 (b, a: INTEGER): INTEGER; |
VAR |
t, e, d, s: INTEGER; |
BEGIN |
e := (a DIV 800000H) MOD 256; |
t := (b DIV 800000H) MOD 256; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
d := e - t; |
IF (d > 0) OR (d = 0) & (a >= b) THEN |
s := 0 |
ELSE |
e := t; |
d := -d; |
t := a; |
a := b; |
b := t; |
s := 80000000H |
END; |
IF d > 0 THEN |
IF d < 24 THEN |
b := LSR(b, d) |
ELSE |
b := 0 |
END |
END; |
DEC(a, b); |
IF a = 0 THEN |
e := 0; |
a := 800000H; |
s := 0 |
ELSE |
WHILE a < 800000H DO |
a := a * 2; |
DEC(e) |
END |
END; |
IF e <= 0 THEN |
e := 0; |
a := 800000H; |
s := 0 |
END |
RETURN (a - 800000H) + e * 800000H + s |
END sub2; |
PROCEDURE zero (VAR x: INTEGER); |
BEGIN |
IF LSR(LSL(x, 1), 24) = 0 THEN |
x := 0 |
END |
END zero; |
PROCEDURE isNaN (a: INTEGER): BOOLEAN; |
RETURN (a > INF) OR (a < 0) & (a > NINF) |
END isNaN; |
PROCEDURE isInf (a: INTEGER): BOOLEAN; |
RETURN LSL(a, 1) = 0FF000000H |
END isInf; |
PROCEDURE isNormal (a, b: INTEGER): BOOLEAN; |
RETURN (LSR(LSL(a, 1), 24) # 255) & (LSR(LSL(a, 1), 24) # 0) & |
(LSR(LSL(b, 1), 24) # 255) & (LSR(LSL(b, 1), 24) # 0) |
END isNormal; |
PROCEDURE add* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a, b) THEN |
IF a > 0 THEN |
IF b > 0 THEN |
r := add2(b, a) |
ELSE |
r := sub2(b, a) |
END |
ELSE |
IF b > 0 THEN |
r := sub2(a, b) |
ELSE |
r := add2(b, a) + 80000000H |
END |
END |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF isInf(a) & isInf(b) THEN |
IF a = b THEN |
r := a |
ELSE |
r := NAN |
END |
ELSIF isInf(a) THEN |
r := a |
ELSIF isInf(b) THEN |
r := b |
ELSIF a = 0 THEN |
r := b |
ELSIF b = 0 THEN |
r := a |
END |
RETURN r |
END add; |
PROCEDURE sub* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a, b) THEN |
IF a > 0 THEN |
IF b > 0 THEN |
r := sub2(b, a) |
ELSE |
r := add2(b, a) |
END |
ELSE |
IF b > 0 THEN |
r := add2(b, a) + 80000000H |
ELSE |
r := sub2(a, b) |
END |
END |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF isInf(a) & isInf(b) THEN |
IF a # b THEN |
r := a |
ELSE |
r := NAN |
END |
ELSIF isInf(a) THEN |
r := a |
ELSIF isInf(b) THEN |
r := INF + ORD(BITS(b) / {31} - {0..30}) |
ELSIF (a = 0) & (b = 0) THEN |
r := 0 |
ELSIF a = 0 THEN |
r := ORD(BITS(b) / {31}) |
ELSIF b = 0 THEN |
r := a |
END |
RETURN r |
END sub; |
PROCEDURE mul* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a, b) THEN |
r := mul2(b, a) |
ELSIF isNaN(a) OR isNaN(b) OR (isInf(a) & (b = 0)) OR (isInf(b) & (a = 0)) THEN |
r := NAN |
ELSIF isInf(a) OR isInf(b) THEN |
r := INF + ORD(BITS(a) / BITS(b) - {0..30}) |
ELSIF (a = 0) OR (b = 0) THEN |
r := 0 |
END |
RETURN r |
END mul; |
PROCEDURE _div* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a, b) THEN |
r := div2(b, a) |
ELSIF isNaN(a) OR isNaN(b) OR isInf(a) & isInf(b) THEN |
r := NAN |
ELSIF isInf(a) THEN |
r := INF + ORD(BITS(a) / BITS(b) - {0..30}) |
ELSIF isInf(b) THEN |
r := 0 |
ELSIF a = 0 THEN |
IF b = 0 THEN |
r := NAN |
ELSE |
r := 0 |
END |
ELSIF b = 0 THEN |
IF a > 0 THEN |
r := INF |
ELSE |
r := NINF |
END |
END |
RETURN r |
END _div; |
PROCEDURE cmp* (op, b, a: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
zero(a); zero(b); |
IF isNaN(a) OR isNaN(b) THEN |
res := op = 1 |
ELSE |
IF (a < 0) & (b < 0) THEN |
INC(op, 6) |
END; |
CASE op OF |
|0, 6: res := a = b |
|1, 7: res := a # b |
|2, 10: res := a < b |
|3, 11: res := a <= b |
|4, 8: res := a > b |
|5, 9: res := a >= b |
END |
END |
RETURN res |
END cmp; |
PROCEDURE flt* (x: INTEGER): INTEGER; |
VAR |
n, y, s: INTEGER; |
BEGIN |
IF x = 0 THEN |
s := 0; |
x := 800000H; |
n := -126 |
ELSIF x = 80000000H THEN |
s := 80000000H; |
x := 800000H; |
n := 32 |
ELSE |
IF x < 0 THEN |
s := 80000000H; |
x := -x |
ELSE |
s := 0 |
END; |
n := 0; |
y := x; |
WHILE y > 0 DO |
y := y DIV 2; |
INC(n) |
END; |
IF n > 24 THEN |
x := LSR(x, n - 24) |
ELSE |
x := LSL(x, 24 - n) |
END |
END |
RETURN (x - 800000H) + (n + 126) * 800000H + s |
END flt; |
PROCEDURE floor* (x: INTEGER): INTEGER; |
VAR |
r, e: INTEGER; |
BEGIN |
zero(x); |
e := (x DIV 800000H) MOD 256 - 127; |
r := x MOD 800000H + 800000H; |
IF (0 <= e) & (e <= 22) THEN |
r := LSR(r, 23 - e) + ORD((x < 0) & (LSL(r, e + 9) # 0)) |
ELSIF (23 <= e) & (e <= 54) THEN |
r := LSL(r, e - 23) |
ELSIF (e < 0) & (x < 0) THEN |
r := 1 |
ELSE |
r := 0 |
END; |
IF x < 0 THEN |
r := -r |
END |
RETURN r |
END floor; |
END FPU. |
/programs/develop/oberon07/lib/RVMxI/32/HOST.ob07 |
---|
0,0 → 1,185 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT SYSTEM, Trap; |
CONST |
$IF (host_linux) |
slash* = "/"; |
eol* = 0AX; |
$ELSE |
slash* = "\"; |
eol* = 0DX + 0AX; |
$END |
bit_depth* = 32; |
maxint* = 7FFFFFFFH; |
minint* = 80000000H; |
VAR |
maxreal*: REAL; |
PROCEDURE syscall0 (fn: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall0; |
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall1; |
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall2; |
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall3; |
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall4; |
PROCEDURE ExitProcess* (code: INTEGER); |
BEGIN |
code := syscall1(0, code) |
END ExitProcess; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0])) |
END GetCurrentDirectory; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
BEGIN |
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0])) |
END GetArg; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileRead; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileWrite; |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileCreate; |
PROCEDURE FileClose* (F: INTEGER); |
BEGIN |
F := syscall1(6, F) |
END FileClose; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileOpen; |
PROCEDURE chmod* (FName: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0])) |
END chmod; |
PROCEDURE OutChar* (c: CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall1(8, ORD(c)) |
END OutChar; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN syscall0(9) |
END GetTickCount; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0 |
END isRelative; |
PROCEDURE UnixTime* (): INTEGER; |
RETURN syscall0(10) |
END UnixTime; |
PROCEDURE s2d (x: INTEGER; VAR h, l: INTEGER); |
VAR |
s, e, f: INTEGER; |
BEGIN |
s := ASR(x, 31) MOD 2; |
f := x MOD 800000H; |
e := (x DIV 800000H) MOD 256; |
IF e = 255 THEN |
e := 2047 |
ELSE |
INC(e, 896) |
END; |
h := LSL(s, 31) + LSL(e, 20) + (f DIV 8); |
l := (f MOD 8) * 20000000H |
END s2d; |
PROCEDURE d2s* (x: REAL): INTEGER; |
VAR |
i: INTEGER; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(x), i) |
RETURN i |
END d2s; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
BEGIN |
s2d(d2s(x), b, a) |
RETURN a |
END splitf; |
BEGIN |
maxreal := 1.9; |
PACK(maxreal, 127) |
END HOST. |
/programs/develop/oberon07/lib/RVMxI/32/Out.ob07 |
---|
0,0 → 1,273 |
(* |
BSD 2-Clause License |
Copyright (c) 2016, 2018, 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE Out; |
IMPORT HOST, SYSTEM; |
PROCEDURE Char* (c: CHAR); |
BEGIN |
HOST.OutChar(c) |
END Char; |
PROCEDURE String* (s: ARRAY OF CHAR); |
VAR |
i, n: INTEGER; |
BEGIN |
n := LENGTH(s) - 1; |
FOR i := 0 TO n DO |
Char(s[i]) |
END |
END String; |
PROCEDURE Int* (x, width: INTEGER); |
VAR |
i, a: INTEGER; |
str: ARRAY 12 OF CHAR; |
BEGIN |
IF x = 80000000H THEN |
COPY("-2147483648", str); |
DEC(width, 11) |
ELSE |
i := 0; |
IF x < 0 THEN |
x := -x; |
i := 1; |
str[0] := "-" |
END; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
DEC(width, i); |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(str) |
END Int; |
PROCEDURE Inf (x: REAL; width: INTEGER); |
VAR |
s: ARRAY 5 OF CHAR; |
BEGIN |
DEC(width, 4); |
IF x # x THEN |
s := " Nan" |
ELSIF x = SYSTEM.INF() THEN |
s := "+Inf" |
ELSIF x = -SYSTEM.INF() THEN |
s := "-Inf" |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(s) |
END Inf; |
PROCEDURE Ln*; |
BEGIN |
Char(0DX); |
Char(0AX) |
END Ln; |
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER); |
VAR |
a, b: REAL; |
BEGIN |
ASSERT(x > 0.0); |
n := 0; |
WHILE x < 1.0 DO |
x := x * 10.0; |
DEC(n) |
END; |
a := 10.0; |
b := 1.0; |
WHILE a <= x DO |
b := a; |
a := a * 10.0; |
INC(n) |
END; |
x := x / b |
END unpk10; |
PROCEDURE _Real (x: REAL; width: INTEGER); |
VAR |
n, k, p: INTEGER; |
BEGIN |
p := MIN(MAX(width - 7, 1), 10); |
width := width - p - 7; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF x < 0.0 THEN |
Char("-"); |
x := -x |
ELSE |
Char(20X) |
END; |
unpk10(x, n); |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
Char("."); |
WHILE p > 0 DO |
x := (x - FLT(k)) * 10.0; |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
DEC(p) |
END; |
Char("E"); |
IF n >= 0 THEN |
Char("+") |
ELSE |
Char("-") |
END; |
n := ABS(n); |
Char(CHR(n DIV 10 + 30H)); |
Char(CHR(n MOD 10 + 30H)) |
END _Real; |
PROCEDURE Real* (x: REAL; width: INTEGER); |
BEGIN |
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
WHILE width > 17 DO |
Char(20X); |
DEC(width) |
END; |
DEC(width, 8); |
String(" 0.0"); |
WHILE width > 0 DO |
Char("0"); |
DEC(width) |
END; |
String("E+00") |
ELSE |
_Real(x, width) |
END |
END Real; |
PROCEDURE _FixReal (x: REAL; width, p: INTEGER); |
VAR |
n, k: INTEGER; |
minus: BOOLEAN; |
BEGIN |
minus := x < 0.0; |
IF minus THEN |
x := -x |
END; |
unpk10(x, n); |
DEC(width, 3 + MAX(p, 0) + MAX(n, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF minus THEN |
Char("-") |
ELSE |
Char(20X) |
END; |
IF n < 0 THEN |
INC(n); |
Char("0"); |
Char("."); |
WHILE (n < 0) & (p > 0) DO |
Char("0"); |
INC(n); |
DEC(p) |
END |
ELSE |
WHILE n >= 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(n) |
END; |
Char(".") |
END; |
WHILE p > 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(p) |
END |
END _FixReal; |
PROCEDURE FixReal* (x: REAL; width, p: INTEGER); |
BEGIN |
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
DEC(width, 3 + MAX(p, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(" 0."); |
WHILE p > 0 DO |
Char("0"); |
DEC(p) |
END |
ELSE |
_FixReal(x, width, p) |
END |
END FixReal; |
PROCEDURE Open*; |
END Open; |
END Out. |
/programs/develop/oberon07/lib/RVMxI/32/RTL.ob07 |
---|
0,0 → 1,411 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT SYSTEM, F := FPU, Trap; |
CONST |
bit_depth = 32; |
maxint = 7FFFFFFFH; |
minint = 80000000H; |
WORD = bit_depth DIV 8; |
MAX_SET = bit_depth - 1; |
VAR |
Heap, Types, TypesCount: INTEGER; |
PROCEDURE _error* (modnum, _module, err, line: INTEGER); |
BEGIN |
Trap.trap(modnum, _module, err, line) |
END _error; |
PROCEDURE _fmul* (b, a: INTEGER): INTEGER; |
RETURN F.mul(b, a) |
END _fmul; |
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER; |
RETURN F._div(b, a) |
END _fdiv; |
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER; |
RETURN F._div(a, b) |
END _fdivi; |
PROCEDURE _fadd* (b, a: INTEGER): INTEGER; |
RETURN F.add(b, a) |
END _fadd; |
PROCEDURE _fsub* (b, a: INTEGER): INTEGER; |
RETURN F.sub(b, a) |
END _fsub; |
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER; |
RETURN F.sub(a, b) |
END _fsubi; |
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN; |
RETURN F.cmp(op, b, a) |
END _fcmp; |
PROCEDURE _floor* (x: INTEGER): INTEGER; |
RETURN F.floor(x) |
END _floor; |
PROCEDURE _flt* (x: INTEGER): INTEGER; |
RETURN F.flt(x) |
END _flt; |
PROCEDURE _pack* (n: INTEGER; VAR x: SET); |
BEGIN |
n := LSL((LSR(ORD(x), 23) MOD 256 + n) MOD 256, 23); |
x := x - {23..30} + BITS(n) |
END _pack; |
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET); |
BEGIN |
n := LSR(ORD(x), 23) MOD 256 - 127; |
x := x - {30} + {23..29} |
END _unpk; |
PROCEDURE _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
k := LEN(A) - 1; |
n := A[0]; |
i := 0; |
WHILE i < k DO |
A[i] := A[i + 1]; |
INC(i) |
END; |
A[k] := n |
END _rot; |
PROCEDURE _set* (b, a: INTEGER): INTEGER; |
BEGIN |
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN |
IF b > MAX_SET THEN |
b := MAX_SET |
END; |
IF a < 0 THEN |
a := 0 |
END; |
a := LSR(ASR(minint, b - a), MAX_SET - b) |
ELSE |
a := 0 |
END |
RETURN a |
END _set; |
PROCEDURE _set1* (a: INTEGER): INTEGER; |
BEGIN |
IF ASR(a, 5) = 0 THEN |
a := LSL(1, a) |
ELSE |
a := 0 |
END |
RETURN a |
END _set1; |
PROCEDURE _length* (len, str: INTEGER): INTEGER; |
VAR |
c: CHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _length; |
PROCEDURE _move* (bytes, dest, source: INTEGER); |
VAR |
b: BYTE; |
i: INTEGER; |
BEGIN |
IF (source MOD WORD = 0) & (dest MOD WORD = 0) THEN |
WHILE bytes >= WORD DO |
SYSTEM.GET(source, i); |
SYSTEM.PUT(dest, i); |
INC(source, WORD); |
INC(dest, WORD); |
DEC(bytes, WORD) |
END |
END; |
WHILE bytes > 0 DO |
SYSTEM.GET(source, b); |
SYSTEM.PUT8(dest, b); |
INC(source); |
INC(dest); |
DEC(bytes) |
END |
END _move; |
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER; |
VAR |
c: WCHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str, 2); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _lengthw; |
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: CHAR; |
res: INTEGER; |
BEGIN |
res := minint; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a); |
SYSTEM.GET(b, B); INC(b); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = 0X THEN |
res := 0; |
n := 0 |
END |
END |
RETURN res |
END strncmp; |
PROCEDURE _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: CHAR; |
BEGIN |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmp; |
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: WCHAR; |
res: INTEGER; |
BEGIN |
res := minint; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a, 2); |
SYSTEM.GET(b, B); INC(b, 2); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = 0X THEN |
res := 0; |
n := 0 |
END |
END |
RETURN res |
END strncmpw; |
PROCEDURE _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: WCHAR; |
BEGIN |
res := strncmpw(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2 * 2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1 * 2, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmpw; |
PROCEDURE _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, dst, src); |
res := TRUE |
END |
RETURN res |
END _arrcpy; |
PROCEDURE _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
_move(MIN(len_dst, len_src) * chr_size, dst, src) |
END _strcpy; |
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER); |
VAR |
ptr: INTEGER; |
BEGIN |
ptr := Heap; |
IF ptr + size < Trap.sp() - 64 THEN |
INC(Heap, size); |
p := ptr + WORD; |
SYSTEM.PUT(ptr, t); |
INC(ptr, WORD); |
DEC(size, WORD); |
WHILE size > 0 DO |
SYSTEM.PUT(ptr, 0); |
INC(ptr, WORD); |
DEC(size, WORD) |
END |
ELSE |
p := 0 |
END |
END _new; |
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
ELSE |
_type := t |
END |
RETURN _type = t |
END _guard; |
PROCEDURE _is* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
_type := 0; |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
END |
RETURN _type = t |
END _is; |
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(Types + t1 * WORD, t1) |
END |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE _init* (tcount, heap, types: INTEGER); |
BEGIN |
Heap := heap; |
TypesCount := tcount; |
Types := types |
END _init; |
END RTL. |
/programs/develop/oberon07/lib/RVMxI/32/Trap.ob07 |
---|
0,0 → 1,133 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE Trap; |
IMPORT SYSTEM; |
CONST |
SP = 4; |
PROCEDURE [code] sp* (): INTEGER |
22, 0, SP; (* MOV R0, SP *) |
PROCEDURE [code] syscall* (ptr: INTEGER) |
22, 0, SP, (* MOV R0, SP *) |
27, 0, 4, (* ADD R0, 4 *) |
9, 0, 0, (* LDW R0, R0 *) |
67, 0, 0; (* SYSCALL R0 *) |
PROCEDURE Char (c: CHAR); |
VAR |
a: ARRAY 2 OF INTEGER; |
BEGIN |
a[0] := 8; |
a[1] := ORD(c); |
syscall(SYSTEM.ADR(a[0])) |
END Char; |
PROCEDURE String (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE s[i] # 0X DO |
Char(s[i]); |
INC(i) |
END |
END String; |
PROCEDURE PString (ptr: INTEGER); |
VAR |
c: CHAR; |
BEGIN |
SYSTEM.GET(ptr, c); |
WHILE c # 0X DO |
Char(c); |
INC(ptr); |
SYSTEM.GET(ptr, c) |
END |
END PString; |
PROCEDURE Ln; |
BEGIN |
String(0DX + 0AX) |
END Ln; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
BEGIN |
i := 0; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END IntToStr; |
PROCEDURE Int (x: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
IntToStr(x, s); |
String(s) |
END Int; |
PROCEDURE trap* (modnum, _module, err, line: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
CASE err OF |
| 1: s := "assertion failure" |
| 2: s := "NIL dereference" |
| 3: s := "bad divisor" |
| 4: s := "NIL procedure call" |
| 5: s := "type guard error" |
| 6: s := "index out of range" |
| 7: s := "invalid CASE" |
| 8: s := "array assignment error" |
| 9: s := "CHR out of range" |
|10: s := "WCHR out of range" |
|11: s := "BYTE out of range" |
END; |
Ln; |
String("error ("); Int(err); String("): "); String(s); Ln; |
String("module: "); PString(_module); Ln; |
String("line: "); Int(line); Ln; |
SYSTEM.CODE(0, 0, 0) (* STOP *) |
END trap; |
END Trap. |
/programs/develop/oberon07/lib/RVMxI/64/HOST.ob07 |
---|
0,0 → 1,201 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT SYSTEM, Trap; |
CONST |
$IF (host_linux) |
slash* = "/"; |
eol* = 0AX; |
$ELSE |
slash* = "\"; |
eol* = 0DX + 0AX; |
$END |
bit_depth* = 64; |
maxint* = ROR(-2, 1); |
minint* = ROR(1, 1); |
VAR |
maxreal*: REAL; |
PROCEDURE syscall0 (fn: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall0; |
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall1; |
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall2; |
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall3; |
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall4; |
PROCEDURE ExitProcess* (code: INTEGER); |
BEGIN |
code := syscall1(0, code) |
END ExitProcess; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0])) |
END GetCurrentDirectory; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
BEGIN |
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0])) |
END GetArg; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileRead; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileWrite; |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileCreate; |
PROCEDURE FileClose* (F: INTEGER); |
BEGIN |
F := syscall1(6, F) |
END FileClose; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileOpen; |
PROCEDURE chmod* (FName: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0])) |
END chmod; |
PROCEDURE OutChar* (c: CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall1(8, ORD(c)) |
END OutChar; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN syscall0(9) |
END GetTickCount; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0 |
END isRelative; |
PROCEDURE UnixTime* (): INTEGER; |
RETURN syscall0(10) |
END UnixTime; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
a := 0; |
b := 0; |
SYSTEM.GET32(SYSTEM.ADR(x), a); |
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b); |
SYSTEM.GET(SYSTEM.ADR(x), res) |
RETURN res |
END splitf; |
PROCEDURE d2s* (x: REAL): INTEGER; |
VAR |
h, l, s, e: INTEGER; |
BEGIN |
e := splitf(x, l, h); |
s := ASR(h, 31) MOD 2; |
e := (h DIV 100000H) MOD 2048; |
IF e <= 896 THEN |
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H; |
REPEAT |
h := h DIV 2; |
INC(e) |
UNTIL e = 897; |
e := 896; |
l := (h MOD 8) * 20000000H; |
h := h DIV 8 |
ELSIF (1151 <= e) & (e < 2047) THEN |
e := 1151; |
h := 0; |
l := 0 |
ELSIF e = 2047 THEN |
e := 1151; |
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN |
h := 80000H; |
l := 0 |
END |
END; |
DEC(e, 896) |
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 |
END d2s; |
BEGIN |
maxreal := 1.9; |
PACK(maxreal, 1023) |
END HOST. |
/programs/develop/oberon07/lib/RVMxI/64/Out.ob07 |
---|
0,0 → 1,288 |
(* |
BSD 2-Clause License |
Copyright (c) 2016, 2018, 2020-2021 Anton Krotov |
All rights reserved. |
*) |
MODULE Out; |
IMPORT HOST, SYSTEM; |
PROCEDURE Char* (c: CHAR); |
BEGIN |
HOST.OutChar(c) |
END Char; |
PROCEDURE String* (s: ARRAY OF CHAR); |
VAR |
i, n: INTEGER; |
BEGIN |
n := LENGTH(s) - 1; |
FOR i := 0 TO n DO |
Char(s[i]) |
END |
END String; |
PROCEDURE Int* (x, width: INTEGER); |
VAR |
i, a: INTEGER; |
str: ARRAY 21 OF CHAR; |
BEGIN |
IF x = ROR(1, 1) THEN |
str := "-9223372036854775808"; |
DEC(width, 20) |
ELSE |
i := 0; |
IF x < 0 THEN |
x := -x; |
i := 1; |
str[0] := "-" |
END; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
DEC(width, i); |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(str) |
END Int; |
PROCEDURE IsNan (x: REAL): BOOLEAN; |
CONST |
INF = LSR(ASR(ROR(1, 1), 10), 1); |
NINF = ASR(ASR(ROR(1, 1), 10), 1); |
VAR |
a: INTEGER; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(x), a) |
RETURN (a > INF) OR (a < 0) & (a > NINF) |
END IsNan; |
PROCEDURE Inf (x: REAL; width: INTEGER); |
VAR |
s: ARRAY 5 OF CHAR; |
BEGIN |
DEC(width, 4); |
IF IsNan(x) THEN |
s := " Nan" |
ELSIF x = SYSTEM.INF() THEN |
s := "+Inf" |
ELSIF x = -SYSTEM.INF() THEN |
s := "-Inf" |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(s) |
END Inf; |
PROCEDURE Ln*; |
BEGIN |
Char(0DX); |
Char(0AX) |
END Ln; |
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER); |
VAR |
a, b: REAL; |
BEGIN |
ASSERT(x > 0.0); |
n := 0; |
WHILE x < 1.0 DO |
x := x * 10.0; |
DEC(n) |
END; |
a := 10.0; |
b := 1.0; |
WHILE a <= x DO |
b := a; |
a := a * 10.0; |
INC(n) |
END; |
x := x / b |
END unpk10; |
PROCEDURE _Real (x: REAL; width: INTEGER); |
VAR |
n, k, p: INTEGER; |
BEGIN |
p := MIN(MAX(width - 8, 1), 15); |
width := width - p - 8; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF x < 0.0 THEN |
Char("-"); |
x := -x |
ELSE |
Char(20X) |
END; |
unpk10(x, n); |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
Char("."); |
WHILE p > 0 DO |
x := (x - FLT(k)) * 10.0; |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
DEC(p) |
END; |
Char("E"); |
IF n >= 0 THEN |
Char("+") |
ELSE |
Char("-") |
END; |
n := ABS(n); |
Char(CHR(n DIV 100 + 30H)); n := n MOD 100; |
Char(CHR(n DIV 10 + 30H)); |
Char(CHR(n MOD 10 + 30H)) |
END _Real; |
PROCEDURE Real* (x: REAL; width: INTEGER); |
BEGIN |
IF IsNan(x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
WHILE width > 23 DO |
Char(20X); |
DEC(width) |
END; |
DEC(width, 9); |
String(" 0.0"); |
WHILE width > 0 DO |
Char("0"); |
DEC(width) |
END; |
String("E+000") |
ELSE |
_Real(x, width) |
END |
END Real; |
PROCEDURE _FixReal (x: REAL; width, p: INTEGER); |
VAR |
n, k: INTEGER; |
minus: BOOLEAN; |
BEGIN |
minus := x < 0.0; |
IF minus THEN |
x := -x |
END; |
unpk10(x, n); |
DEC(width, 3 + MAX(p, 0) + MAX(n, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF minus THEN |
Char("-") |
ELSE |
Char(20X) |
END; |
IF n < 0 THEN |
INC(n); |
Char("0"); |
Char("."); |
WHILE (n < 0) & (p > 0) DO |
Char("0"); |
INC(n); |
DEC(p) |
END |
ELSE |
WHILE n >= 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(n) |
END; |
Char(".") |
END; |
WHILE p > 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(p) |
END |
END _FixReal; |
PROCEDURE FixReal* (x: REAL; width, p: INTEGER); |
BEGIN |
IF IsNan(x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
DEC(width, 3 + MAX(p, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(" 0."); |
WHILE p > 0 DO |
Char("0"); |
DEC(p) |
END |
ELSE |
_FixReal(x, width, p) |
END |
END FixReal; |
PROCEDURE Open*; |
END Open; |
END Out. |
/programs/develop/oberon07/lib/RVMxI/64/RTL.ob07 |
---|
0,0 → 1,432 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT SYSTEM, Trap; |
CONST |
bit_depth = 64; |
maxint = ROR(-2, 1); |
minint = ROR(1, 1); |
WORD = bit_depth DIV 8; |
MAX_SET = bit_depth - 1; |
VAR |
Heap, Types, TypesCount: INTEGER; |
PROCEDURE _error* (modnum, _module, err, line: INTEGER); |
BEGIN |
Trap.trap(modnum, _module, err, line) |
END _error; |
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall1; |
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall2; |
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall3; |
PROCEDURE _fmul* (b, a: INTEGER): INTEGER; |
RETURN syscall2(100, b, a) |
END _fmul; |
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER; |
RETURN syscall2(101, b, a) |
END _fdiv; |
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER; |
RETURN syscall2(101, a, b) |
END _fdivi; |
PROCEDURE _fadd* (b, a: INTEGER): INTEGER; |
RETURN syscall2(102, b, a) |
END _fadd; |
PROCEDURE _fsub* (b, a: INTEGER): INTEGER; |
RETURN syscall2(103, b, a) |
END _fsub; |
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER; |
RETURN syscall2(103, a, b) |
END _fsubi; |
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN; |
RETURN syscall3(104, op, b, a) # 0 |
END _fcmp; |
PROCEDURE _floor* (x: INTEGER): INTEGER; |
RETURN syscall1(105, x) |
END _floor; |
PROCEDURE _flt* (x: INTEGER): INTEGER; |
RETURN syscall1(106, x) |
END _flt; |
PROCEDURE _pack* (n: INTEGER; VAR x: SET); |
BEGIN |
n := LSL((LSR(ORD(x), 52) MOD 2048 + n) MOD 2048, 52); |
x := x - {52..62} + BITS(n) |
END _pack; |
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET); |
BEGIN |
n := LSR(ORD(x), 52) MOD 2048 - 1023; |
x := x - {62} + {52..61} |
END _unpk; |
PROCEDURE _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
k := LEN(A) - 1; |
n := A[0]; |
i := 0; |
WHILE i < k DO |
A[i] := A[i + 1]; |
INC(i) |
END; |
A[k] := n |
END _rot; |
PROCEDURE _set* (b, a: INTEGER): INTEGER; |
BEGIN |
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN |
IF b > MAX_SET THEN |
b := MAX_SET |
END; |
IF a < 0 THEN |
a := 0 |
END; |
a := LSR(ASR(minint, b - a), MAX_SET - b) |
ELSE |
a := 0 |
END |
RETURN a |
END _set; |
PROCEDURE _set1* (a: INTEGER): INTEGER; |
BEGIN |
IF ASR(a, 6) = 0 THEN |
a := LSL(1, a) |
ELSE |
a := 0 |
END |
RETURN a |
END _set1; |
PROCEDURE _length* (len, str: INTEGER): INTEGER; |
VAR |
c: CHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _length; |
PROCEDURE _move* (bytes, dest, source: INTEGER); |
VAR |
b: BYTE; |
i: INTEGER; |
BEGIN |
IF (source MOD WORD = 0) & (dest MOD WORD = 0) THEN |
WHILE bytes >= WORD DO |
SYSTEM.GET(source, i); |
SYSTEM.PUT(dest, i); |
INC(source, WORD); |
INC(dest, WORD); |
DEC(bytes, WORD) |
END |
END; |
WHILE bytes > 0 DO |
SYSTEM.GET(source, b); |
SYSTEM.PUT8(dest, b); |
INC(source); |
INC(dest); |
DEC(bytes) |
END |
END _move; |
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER; |
VAR |
c: WCHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str, 2); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _lengthw; |
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: CHAR; |
res: INTEGER; |
BEGIN |
res := minint; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a); |
SYSTEM.GET(b, B); INC(b); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = 0X THEN |
res := 0; |
n := 0 |
END |
END |
RETURN res |
END strncmp; |
PROCEDURE _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: CHAR; |
BEGIN |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmp; |
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: WCHAR; |
res: INTEGER; |
BEGIN |
res := minint; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a, 2); |
SYSTEM.GET(b, B); INC(b, 2); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = 0X THEN |
res := 0; |
n := 0 |
END |
END |
RETURN res |
END strncmpw; |
PROCEDURE _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
c: WCHAR; |
BEGIN |
res := strncmpw(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
SYSTEM.GET(str1 + len2 * 2, c); |
res := ORD(c) |
ELSIF len1 < len2 THEN |
SYSTEM.GET(str2 + len1 * 2, c); |
res := -ORD(c) |
ELSE |
res := 0 |
END |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmpw; |
PROCEDURE _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, dst, src); |
res := TRUE |
END |
RETURN res |
END _arrcpy; |
PROCEDURE _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
_move(MIN(len_dst, len_src) * chr_size, dst, src) |
END _strcpy; |
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER); |
VAR |
ptr: INTEGER; |
BEGIN |
ptr := Heap; |
IF ptr + size < Trap.sp() - 128 THEN |
INC(Heap, size); |
p := ptr + WORD; |
SYSTEM.PUT(ptr, t); |
INC(ptr, WORD); |
DEC(size, WORD); |
WHILE size > 0 DO |
SYSTEM.PUT(ptr, 0); |
INC(ptr, WORD); |
DEC(size, WORD) |
END |
ELSE |
p := 0 |
END |
END _new; |
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
ELSE |
_type := t |
END |
RETURN _type = t |
END _guard; |
PROCEDURE _is* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
_type := 0; |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
END |
RETURN _type = t |
END _is; |
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(Types + t1 * WORD, t1) |
END |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE _init* (tcount, heap, types: INTEGER); |
BEGIN |
Heap := heap; |
TypesCount := tcount; |
Types := types |
END _init; |
END RTL. |
/programs/develop/oberon07/lib/RVMxI/64/Trap.ob07 |
---|
0,0 → 1,133 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE Trap; |
IMPORT SYSTEM; |
CONST |
SP = 4; |
PROCEDURE [code] sp* (): INTEGER |
22, 0, SP; (* MOV R0, SP *) |
PROCEDURE [code] syscall* (ptr: INTEGER) |
22, 0, SP, (* MOV R0, SP *) |
27, 0, 8, (* ADD R0, 8 *) |
16, 0, 0, (* LDD R0, R0 *) |
67, 0, 0; (* SYSCALL R0 *) |
PROCEDURE Char (c: CHAR); |
VAR |
a: ARRAY 2 OF INTEGER; |
BEGIN |
a[0] := 8; |
a[1] := ORD(c); |
syscall(SYSTEM.ADR(a[0])) |
END Char; |
PROCEDURE String (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE s[i] # 0X DO |
Char(s[i]); |
INC(i) |
END |
END String; |
PROCEDURE PString (ptr: INTEGER); |
VAR |
c: CHAR; |
BEGIN |
SYSTEM.GET(ptr, c); |
WHILE c # 0X DO |
Char(c); |
INC(ptr); |
SYSTEM.GET(ptr, c) |
END |
END PString; |
PROCEDURE Ln; |
BEGIN |
String(0DX + 0AX) |
END Ln; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
BEGIN |
i := 0; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END IntToStr; |
PROCEDURE Int (x: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
IntToStr(x, s); |
String(s) |
END Int; |
PROCEDURE trap* (modnum, _module, err, line: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
CASE err OF |
| 1: s := "assertion failure" |
| 2: s := "NIL dereference" |
| 3: s := "bad divisor" |
| 4: s := "NIL procedure call" |
| 5: s := "type guard error" |
| 6: s := "index out of range" |
| 7: s := "invalid CASE" |
| 8: s := "array assignment error" |
| 9: s := "CHR out of range" |
|10: s := "WCHR out of range" |
|11: s := "BYTE out of range" |
END; |
Ln; |
String("error ("); Int(err); String("): "); String(s); Ln; |
String("module: "); PString(_module); Ln; |
String("line: "); Int(line); Ln; |
SYSTEM.CODE(0, 0, 0) (* STOP *) |
END trap; |
END Trap. |
/programs/develop/oberon07/lib/Math/CMath.ob07 |
---|
0,0 → 1,462 |
(* *********************************************** |
Модуль работы с комплексными числами. |
Вадим Исаев, 2020 |
Module for complex numbers. |
Vadim Isaev, 2020 |
*************************************************** *) |
MODULE CMath; |
IMPORT Math, Out; |
TYPE |
complex* = POINTER TO RECORD |
re*: REAL; |
im*: REAL |
END; |
VAR |
result: complex; |
i* : complex; |
_0*: complex; |
(* Инициализация комплексного числа. |
Init complex number. *) |
PROCEDURE CInit* (re : REAL; im: REAL): complex; |
VAR |
temp: complex; |
BEGIN |
NEW(temp); |
temp.re:=re; |
temp.im:=im; |
RETURN temp |
END CInit; |
(* Четыре основных арифметических операций. |
Four base operations +, -, * , / *) |
(* Сложение |
addition : z := z1 + z2 *) |
PROCEDURE CAdd* (z1, z2: complex): complex; |
BEGIN |
result.re := z1.re + z2.re; |
result.im := z1.im + z2.im; |
RETURN result |
END CAdd; |
(* Сложение с REAL. |
addition : z := z1 + r1 *) |
PROCEDURE CAdd_r* (z1: complex; r1: REAL): complex; |
BEGIN |
result.re := z1.re + r1; |
result.im := z1.im; |
RETURN result |
END CAdd_r; |
(* Сложение с INTEGER. |
addition : z := z1 + i1 *) |
PROCEDURE CAdd_i* (z1: complex; i1: INTEGER): complex; |
BEGIN |
result.re := z1.re + FLT(i1); |
result.im := z1.im; |
RETURN result |
END CAdd_i; |
(* Смена знака. |
substraction : z := - z1 *) |
PROCEDURE CNeg (z1 : complex): complex; |
BEGIN |
result.re := -z1.re; |
result.im := -z1.im; |
RETURN result |
END CNeg; |
(* Вычитание. |
substraction : z := z1 - z2 *) |
PROCEDURE CSub* (z1, z2 : complex): complex; |
BEGIN |
result.re := z1.re - z2.re; |
result.im := z1.im - z2.im; |
RETURN result |
END CSub; |
(* Вычитание REAL. |
substraction : z := z1 - r1 *) |
PROCEDURE CSub_r1* (z1 : complex; r1 : REAL): complex; |
BEGIN |
result.re := z1.re - r1; |
result.im := z1.im; |
RETURN result |
END CSub_r1; |
(* Вычитание из REAL. |
substraction : z := r1 - z1 *) |
PROCEDURE CSub_r2* (r1 : REAL; z1 : complex): complex; |
BEGIN |
result.re := r1 - z1.re; |
result.im := - z1.im; |
RETURN result |
END CSub_r2; |
(* Вычитание INTEGER. |
substraction : z := z1 - i1 *) |
PROCEDURE CSub_i* (z1 : complex; i1 : INTEGER): complex; |
BEGIN |
result.re := z1.re - FLT(i1); |
result.im := z1.im; |
RETURN result |
END CSub_i; |
(* Умножение. |
multiplication : z := z1 * z2 *) |
PROCEDURE CMul (z1, z2 : complex): complex; |
BEGIN |
result.re := (z1.re * z2.re) - (z1.im * z2.im); |
result.im := (z1.re * z2.im) + (z1.im * z2.re); |
RETURN result |
END CMul; |
(* Умножение с REAL. |
multiplication : z := z1 * r1 *) |
PROCEDURE CMul_r (z1 : complex; r1 : REAL): complex; |
BEGIN |
result.re := z1.re * r1; |
result.im := z1.im * r1; |
RETURN result |
END CMul_r; |
(* Умножение с INTEGER. |
multiplication : z := z1 * i1 *) |
PROCEDURE CMul_i (z1 : complex; i1 : INTEGER): complex; |
BEGIN |
result.re := z1.re * FLT(i1); |
result.im := z1.im * FLT(i1); |
RETURN result |
END CMul_i; |
(* Деление. |
division : z := znum / zden *) |
PROCEDURE CDiv (z1, z2 : complex): complex; |
(* The following algorithm is used to properly handle |
denominator overflow: |
| a + b(d/c) c - a(d/c) |
| ---------- + ---------- I if |d| < |c| |
a + b I | c + d(d/c) a + d(d/c) |
------- = | |
c + d I | b + a(c/d) -a+ b(c/d) |
| ---------- + ---------- I if |d| >= |c| |
| d + c(c/d) d + c(c/d) |
*) |
VAR |
tmp, denom : REAL; |
BEGIN |
IF ( ABS(z2.re) > ABS(z2.im) ) THEN |
tmp := z2.im / z2.re; |
denom := z2.re + z2.im * tmp; |
result.re := (z1.re + z1.im * tmp) / denom; |
result.im := (z1.im - z1.re * tmp) / denom; |
ELSE |
tmp := z2.re / z2.im; |
denom := z2.im + z2.re * tmp; |
result.re := (z1.im + z1.re * tmp) / denom; |
result.im := (-z1.re + z1.im * tmp) / denom; |
END; |
RETURN result |
END CDiv; |
(* Деление на REAL. |
division : z := znum / r1 *) |
PROCEDURE CDiv_r* (z1 : complex; r1 : REAL): complex; |
BEGIN |
result.re := z1.re / r1; |
result.im := z1.im / r1; |
RETURN result |
END CDiv_r; |
(* Деление на INTEGER. |
division : z := znum / i1 *) |
PROCEDURE CDiv_i* (z1 : complex; i1 : INTEGER): complex; |
BEGIN |
result.re := z1.re / FLT(i1); |
result.im := z1.im / FLT(i1); |
RETURN result |
END CDiv_i; |
(* fonctions elementaires *) |
(* Вывод на экран. |
out complex number *) |
PROCEDURE CPrint* (z: complex; width: INTEGER); |
BEGIN |
Out.Real(z.re, width); |
IF z.im>=0.0 THEN |
Out.String("+"); |
END; |
Out.Real(z.im, width); |
Out.String("i"); |
END CPrint; |
PROCEDURE CPrintLn* (z: complex; width: INTEGER); |
BEGIN |
CPrint(z, width); |
Out.Ln; |
END CPrintLn; |
(* Вывод на экран с фиксированным кол-вом знаков |
после запятой (p) *) |
PROCEDURE CPrintFix* (z: complex; width, p: INTEGER); |
BEGIN |
Out.FixReal(z.re, width, p); |
IF z.im>=0.0 THEN |
Out.String("+"); |
END; |
Out.FixReal(z.im, width, p); |
Out.String("i"); |
END CPrintFix; |
PROCEDURE CPrintFixLn* (z: complex; width, p: INTEGER); |
BEGIN |
CPrintFix(z, width, p); |
Out.Ln; |
END CPrintFixLn; |
(* Модуль числа. |
module : r = |z| *) |
PROCEDURE CMod* (z1 : complex): REAL; |
BEGIN |
RETURN Math.sqrt((z1.re * z1.re) + (z1.im * z1.im)) |
END CMod; |
(* Квадрат числа. |
square : r := z*z *) |
PROCEDURE CSqr* (z1: complex): complex; |
BEGIN |
result.re := z1.re * z1.re - z1.im * z1.im; |
result.im := 2.0 * z1.re * z1.im; |
RETURN result |
END CSqr; |
(* Квадратный корень числа. |
square root : r := sqrt(z) *) |
PROCEDURE CSqrt* (z1: complex): complex; |
VAR |
root, q: REAL; |
BEGIN |
IF (z1.re#0.0) OR (z1.im#0.0) THEN |
root := Math.sqrt(0.5 * (ABS(z1.re) + CMod(z1))); |
q := z1.im / (2.0 * root); |
IF z1.re >= 0.0 THEN |
result.re := root; |
result.im := q; |
ELSE |
IF z1.im < 0.0 THEN |
result.re := - q; |
result.im := - root |
ELSE |
result.re := q; |
result.im := root |
END |
END |
ELSE |
result := z1; |
END; |
RETURN result |
END CSqrt; |
(* Экспонента. |
exponantial : r := exp(z) *) |
(* exp(x + iy) = exp(x).exp(iy) = exp(x).[cos(y) + i sin(y)] *) |
PROCEDURE CExp* (z: complex): complex; |
VAR |
expz : REAL; |
BEGIN |
expz := Math.exp(z.re); |
result.re := expz * Math.cos(z.im); |
result.im := expz * Math.sin(z.im); |
RETURN result |
END CExp; |
(* Натуральный логарифм. |
natural logarithm : r := ln(z) *) |
(* ln( p exp(i0)) = ln(p) + i0 + 2kpi *) |
PROCEDURE CLn* (z: complex): complex; |
BEGIN |
result.re := Math.ln(CMod(z)); |
result.im := Math.arctan2(z.im, z.re); |
RETURN result |
END CLn; |
(* Число в степени. |
exp : z := z1^z2 *) |
PROCEDURE CPower* (z1, z2 : complex): complex; |
VAR |
a: complex; |
BEGIN |
a:=CLn(z1); |
a:=CMul(z2, a); |
result:=CExp(a); |
RETURN result |
END CPower; |
(* Число в степени REAL. |
multiplication : z := z1^r *) |
PROCEDURE CPower_r* (z1: complex; r: REAL): complex; |
VAR |
a: complex; |
BEGIN |
a:=CLn(z1); |
a:=CMul_r(a, r); |
result:=CExp(a); |
RETURN result |
END CPower_r; |
(* Обратное число. |
inverse : r := 1 / z *) |
PROCEDURE CInv* (z: complex): complex; |
VAR |
denom : REAL; |
BEGIN |
denom := (z.re * z.re) + (z.im * z.im); |
(* generates a fpu exception if denom=0 as for reals *) |
result.re:=z.re/denom; |
result.im:=-z.im/denom; |
RETURN result |
END CInv; |
(* direct trigonometric functions *) |
(* Косинус. |
complex cosinus *) |
(* cos(x+iy) = cos(x).cos(iy) - sin(x).sin(iy) *) |
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *) |
PROCEDURE CCos* (z: complex): complex; |
BEGIN |
result.re := Math.cos(z.re) * Math.cosh(z.im); |
result.im := - Math.sin(z.re) * Math.sinh(z.im); |
RETURN result |
END CCos; |
(* Синус. |
sinus complex *) |
(* sin(x+iy) = sin(x).cos(iy) + cos(x).sin(iy) *) |
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *) |
PROCEDURE CSin (z: complex): complex; |
BEGIN |
result.re := Math.sin(z.re) * Math.cosh(z.im); |
result.im := Math.cos(z.re) * Math.sinh(z.im); |
RETURN result |
END CSin; |
(* Тангенс. |
tangente *) |
PROCEDURE CTg* (z: complex): complex; |
VAR |
temp1, temp2: complex; |
BEGIN |
temp1:=CSin(z); |
temp2:=CCos(z); |
result:=CDiv(temp1, temp2); |
RETURN result |
END CTg; |
(* inverse complex hyperbolic functions *) |
(* Гиперболический арккосинус. |
hyberbolic arg cosinus *) |
(* _________ *) |
(* argch(z) = -/+ ln(z + i.V 1 - z.z) *) |
PROCEDURE CArcCosh* (z : complex): complex; |
BEGIN |
result:=CNeg(CLn(CAdd(z, CMul(i, CSqrt(CSub_r2(1.0, CMul(z, z))))))); |
RETURN result |
END CArcCosh; |
(* Гиперболический арксинус. |
hyperbolic arc sinus *) |
(* ________ *) |
(* argsh(z) = ln(z + V 1 + z.z) *) |
PROCEDURE CArcSinh* (z : complex): complex; |
BEGIN |
result:=CLn(CAdd(z, CSqrt(CAdd_r(CMul(z, z), 1.0)))); |
RETURN result |
END CArcSinh; |
(* Гиперболический арктангенс. |
hyperbolic arc tangent *) |
(* argth(z) = 1/2 ln((z + 1) / (1 - z)) *) |
PROCEDURE CArcTgh (z : complex): complex; |
BEGIN |
result:=CDiv_r(CLn(CDiv(CAdd_r(z, 1.0), CSub_r2(1.0, z))), 2.0); |
RETURN result |
END CArcTgh; |
(* trigonometriques inverses *) |
(* Арккосинус. |
arc cosinus complex *) |
(* arccos(z) = -i.argch(z) *) |
PROCEDURE CArcCos* (z: complex): complex; |
BEGIN |
result := CNeg(CMul(i, CArcCosh(z))); |
RETURN result |
END CArcCos; |
(* Арксинус. |
arc sinus complex *) |
(* arcsin(z) = -i.argsh(i.z) *) |
PROCEDURE CArcSin* (z : complex): complex; |
BEGIN |
result := CNeg(CMul(i, CArcSinh(z))); |
RETURN result |
END CArcSin; |
(* Арктангенс. |
arc tangente complex *) |
(* arctg(z) = -i.argth(i.z) *) |
PROCEDURE CArcTg* (z : complex): complex; |
BEGIN |
result := CNeg(CMul(i, CArcTgh(CMul(i, z)))); |
RETURN result |
END CArcTg; |
BEGIN |
result:=CInit(0.0, 0.0); |
i :=CInit(0.0, 1.0); |
_0:=CInit(0.0, 0.0); |
END CMath. |
/programs/develop/oberon07/lib/Math/MathBits.ob07 |
---|
0,0 → 1,33 |
(* **************************************** |
Дополнение к модулю Math. |
Побитовые операции над целыми числами. |
Вадим Исаев, 2020 |
Additional functions to the module Math. |
Bitwise operations on integers. |
Vadim Isaev, 2020 |
******************************************* *) |
MODULE MathBits; |
PROCEDURE iand* (x, y: INTEGER): INTEGER; |
RETURN ORD(BITS(x) * BITS(y)) |
END iand; |
PROCEDURE ior* (x, y: INTEGER): INTEGER; |
RETURN ORD(BITS(x) + BITS(y)) |
END ior; |
PROCEDURE ixor* (x, y: INTEGER): INTEGER; |
RETURN ORD(BITS(x) / BITS(y)) |
END ixor; |
PROCEDURE inot* (x: INTEGER): INTEGER; |
RETURN ORD(-BITS(x)) |
END inot; |
END MathBits. |
/programs/develop/oberon07/lib/Math/MathRound.ob07 |
---|
0,0 → 1,99 |
(* ****************************************** |
Дополнительные функции к модулю Math. |
Функции округления. |
Вадим Исаев, 2020 |
------------------------------------- |
Additional functions to the module Math. |
Rounding functions. |
Vadim Isaev, 2020 |
********************************************* *) |
MODULE MathRound; |
IMPORT Math; |
(* Возвращается целая часть числа x. |
Returns the integer part of a argument x.*) |
PROCEDURE trunc* (x: REAL): REAL; |
VAR |
a: REAL; |
BEGIN |
a := FLT(FLOOR(x)); |
IF (x < 0.0) & (x # a) THEN |
a := a + 1.0 |
END |
RETURN a |
END trunc; |
(* Возвращается дробная часть числа x. |
Returns the fractional part of the argument x *) |
PROCEDURE frac* (x: REAL): REAL; |
RETURN x - trunc(x) |
END frac; |
(* Округление к ближайшему целому. |
Rounding to the nearest integer. *) |
PROCEDURE round* (x: REAL): REAL; |
VAR |
a: REAL; |
BEGIN |
a := trunc(x); |
IF ABS(frac(x)) >= 0.5 THEN |
a := a + FLT(Math.sgn(x)) |
END |
RETURN a |
END round; |
(* Округление к бОльшему целому. |
Rounding to a largest integer *) |
PROCEDURE ceil* (x: REAL): REAL; |
VAR |
a: REAL; |
BEGIN |
a := FLT(FLOOR(x)); |
IF x # a THEN |
a := a + 1.0 |
END |
RETURN a |
END ceil; |
(* Округление к меньшему целому. |
Rounding to a smallest integer *) |
PROCEDURE floor* (x: REAL): REAL; |
RETURN FLT(FLOOR(x)) |
END floor; |
(* Округление до определённого количества знаков: |
- если Digits отрицательное, то округление |
в знаках после десятичной запятой; |
- если Digits положительное, то округление |
в знаках до запятой *) |
PROCEDURE SimpleRoundTo* (AValue: REAL; Digits: INTEGER): REAL; |
VAR |
RV, a : REAL; |
BEGIN |
RV := Math.ipower(10.0, -Digits); |
IF AValue < 0.0 THEN |
a := trunc((AValue * RV) - 0.5) |
ELSE |
a := trunc((AValue * RV) + 0.5) |
END |
RETURN a / RV |
END SimpleRoundTo; |
END MathRound. |
/programs/develop/oberon07/lib/Math/MathStat.ob07 |
---|
0,0 → 1,238 |
(* ******************************************** |
Дополнение к модулю Math. |
Статистические процедуры. |
------------------------------------- |
Additional functions to the module Math. |
Statistical functions |
*********************************************** *) |
MODULE MathStat; |
IMPORT Math; |
(*Минимальное значение. Нецелое *) |
PROCEDURE MinValue* (data: ARRAY OF REAL; N: INTEGER): REAL; |
VAR |
i: INTEGER; |
a: REAL; |
BEGIN |
a := data[0]; |
FOR i := 1 TO N - 1 DO |
IF data[i] < a THEN |
a := data[i] |
END |
END |
RETURN a |
END MinValue; |
(*Минимальное значение. Целое *) |
PROCEDURE MinIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER; |
VAR |
i: INTEGER; |
a: INTEGER; |
BEGIN |
a := data[0]; |
FOR i := 1 TO N - 1 DO |
IF data[i] < a THEN |
a := data[i] |
END |
END |
RETURN a |
END MinIntValue; |
(*Максимальное значение. Нецелое *) |
PROCEDURE MaxValue* (data: ARRAY OF REAL; N: INTEGER): REAL; |
VAR |
i: INTEGER; |
a: REAL; |
BEGIN |
a := data[0]; |
FOR i := 1 TO N - 1 DO |
IF data[i] > a THEN |
a := data[i] |
END |
END |
RETURN a |
END MaxValue; |
(*Максимальное значение. Целое *) |
PROCEDURE MaxIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER; |
VAR |
i: INTEGER; |
a: INTEGER; |
BEGIN |
a := data[0]; |
FOR i := 1 TO N - 1 DO |
IF data[i] > a THEN |
a := data[i] |
END |
END |
RETURN a |
END MaxIntValue; |
(* Сумма значений массива *) |
PROCEDURE Sum* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
VAR |
a: REAL; |
i: INTEGER; |
BEGIN |
a := 0.0; |
FOR i := 0 TO Count - 1 DO |
a := a + data[i] |
END |
RETURN a |
END Sum; |
(* Сумма целых значений массива *) |
PROCEDURE SumInt* (data: ARRAY OF INTEGER; Count: INTEGER): INTEGER; |
VAR |
a: INTEGER; |
i: INTEGER; |
BEGIN |
a := 0; |
FOR i := 0 TO Count - 1 DO |
a := a + data[i] |
END |
RETURN a |
END SumInt; |
(* Сумма квадратов значений массива *) |
PROCEDURE SumOfSquares* (data : ARRAY OF REAL; Count: INTEGER): REAL; |
VAR |
a: REAL; |
i: INTEGER; |
BEGIN |
a := 0.0; |
FOR i := 0 TO Count - 1 DO |
a := a + Math.sqrr(data[i]) |
END |
RETURN a |
END SumOfSquares; |
(* Сумма значений и сумма квадратов значений массмва *) |
PROCEDURE SumsAndSquares* (data: ARRAY OF REAL; Count : INTEGER; |
VAR sum, sumofsquares : REAL); |
VAR |
i: INTEGER; |
temp: REAL; |
BEGIN |
sumofsquares := 0.0; |
sum := 0.0; |
FOR i := 0 TO Count - 1 DO |
temp := data[i]; |
sumofsquares := sumofsquares + Math.sqrr(temp); |
sum := sum + temp |
END |
END SumsAndSquares; |
(* Средниее значений массива *) |
PROCEDURE Mean* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
RETURN Sum(data, Count) / FLT(Count) |
END Mean; |
PROCEDURE MeanAndTotalVariance* (data: ARRAY OF REAL; Count: INTEGER; |
VAR mu: REAL; VAR variance: REAL); |
VAR |
i: INTEGER; |
BEGIN |
mu := Mean(data, Count); |
variance := 0.0; |
FOR i := 0 TO Count - 1 DO |
variance := variance + Math.sqrr(data[i] - mu) |
END |
END MeanAndTotalVariance; |
(* Вычисление статистической дисперсии равной сумме квадратов разницы |
между каждым конкретным значением массива Data и средним значением *) |
PROCEDURE TotalVariance* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
VAR |
mu, tv: REAL; |
BEGIN |
MeanAndTotalVariance(data, Count, mu, tv) |
RETURN tv |
END TotalVariance; |
(* Типовая дисперсия всех значений массива *) |
PROCEDURE Variance* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
VAR |
a: REAL; |
BEGIN |
IF Count = 1 THEN |
a := 0.0 |
ELSE |
a := TotalVariance(data, Count) / FLT(Count - 1) |
END |
RETURN a |
END Variance; |
(* Стандартное среднеквадратичное отклонение *) |
PROCEDURE StdDev* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
RETURN Math.sqrt(Variance(data, Count)) |
END StdDev; |
(* Среднее арифметическое всех значений массива, и среднее отклонение *) |
PROCEDURE MeanAndStdDev* (data: ARRAY OF REAL; Count: INTEGER; |
VAR mean: REAL; VAR stdDev: REAL); |
VAR |
totalVariance: REAL; |
BEGIN |
MeanAndTotalVariance(data, Count, mean, totalVariance); |
IF Count < 2 THEN |
stdDev := 0.0 |
ELSE |
stdDev := Math.sqrt(totalVariance / FLT(Count - 1)) |
END |
END MeanAndStdDev; |
(* Евклидова норма для всех значений массива *) |
PROCEDURE Norm* (data: ARRAY OF REAL; Count: INTEGER): REAL; |
VAR |
a: REAL; |
i: INTEGER; |
BEGIN |
a := 0.0; |
FOR i := 0 TO Count - 1 DO |
a := a + Math.sqrr(data[i]) |
END |
RETURN Math.sqrt(a) |
END Norm; |
END MathStat. |
/programs/develop/oberon07/lib/Math/Rand.ob07 |
---|
0,0 → 1,81 |
(* ************************************ |
Генератор какбыслучайных чисел, |
Линейный конгруэнтный метод, |
алгоритм Лемера. |
Вадим Исаев, 2020 |
------------------------------- |
Generator pseudorandom numbers, |
Linear congruential generator, |
Algorithm by D. H. Lehmer. |
Vadim Isaev, 2020 |
*************************************** *) |
MODULE Rand; |
IMPORT HOST, Math; |
CONST |
RAND_MAX = 2147483647; |
VAR |
seed: INTEGER; |
PROCEDURE Randomize*; |
BEGIN |
seed := HOST.GetTickCount() |
END Randomize; |
(* Целые какбыслучайные числа до RAND_MAX *) |
PROCEDURE RandomI* (): INTEGER; |
CONST |
a = 630360016; |
BEGIN |
seed := (a * seed) MOD RAND_MAX |
RETURN seed |
END RandomI; |
(* Какбыслучайные числа с плавающей запятой от 0 до 1 *) |
PROCEDURE RandomR* (): REAL; |
RETURN FLT(RandomI()) / FLT(RAND_MAX) |
END RandomR; |
(* Какбыслучайное число в диапазоне от 0 до l. |
Return a random number in a range 0 ... l *) |
PROCEDURE RandomITo* (aTo: INTEGER): INTEGER; |
RETURN FLOOR(RandomR() * FLT(aTo)) |
END RandomITo; |
(* Какбыслучайное число в диапазоне. |
Return a random number in a range *) |
PROCEDURE RandomIRange* (aFrom, aTo: INTEGER): INTEGER; |
RETURN FLOOR(RandomR() * FLT(aTo - aFrom)) + aFrom |
END RandomIRange; |
(* Какбыслучайное число. Распределение Гаусса *) |
PROCEDURE RandG* (mean, stddev: REAL): REAL; |
VAR |
U, S: REAL; |
BEGIN |
REPEAT |
U := 2.0 * RandomR() - 1.0; |
S := Math.sqrr(U) + Math.sqrr(2.0 * RandomR() - 1.0) |
UNTIL (1.0E-20 < S) & (S <= 1.0) |
RETURN Math.sqrt(-2.0 * Math.ln(S) / S) * U * stddev + mean |
END RandG; |
BEGIN |
seed := 654321 |
END Rand. |
/programs/develop/oberon07/lib/Math/RandExt.ob07 |
---|
0,0 → 1,298 |
(* ************************************************************ |
Дополнительные алгоритмы генераторов какбыслучайных чисел. |
Вадим Исаев, 2020 |
Additional generators of pseudorandom numbers. |
Vadim Isaev, 2020 |
************************************************************ *) |
MODULE RandExt; |
IMPORT HOST, MathRound, MathBits; |
CONST |
(* Для алгоритма Мерсена-Твистера *) |
N = 624; |
M = 397; |
MATRIX_A = 9908B0DFH; (* constant vector a *) |
UPPER_MASK = 80000000H; (* most significant w-r bits *) |
LOWER_MASK = 7FFFFFFFH; (* least significant r bits *) |
INT_MAX = 4294967295; |
TYPE |
(* структура служебных данных, для алгоритма mrg32k3a *) |
random_t = RECORD |
mrg32k3a_seed : REAL; |
mrg32k3a_x : ARRAY 3 OF REAL; |
mrg32k3a_y : ARRAY 3 OF REAL |
END; |
(* Для алгоритма Мерсена-Твистера *) |
MTKeyArray = ARRAY N OF INTEGER; |
VAR |
(* Для алгоритма mrg32k3a *) |
prndl: random_t; |
(* Для алгоритма Мерсена-Твистера *) |
mt : MTKeyArray; (* the array for the state vector *) |
mti : INTEGER; (* mti == N+1 means mt[N] is not initialized *) |
(* --------------------------------------------------------------------------- |
Генератор какбыслучайных чисел в диапазоне [a,b]. |
Алгоритм 133б из книги "Агеев и др. - Бибилотека алгоритмов 101б-150б", |
стр. 53. |
Переделка из Algol на Oberon и доработка, Вадим Исаев, 2020 |
Generator pseudorandom numbers, algorithm 133b from |
Comm ACM 5,10 (Oct 1962) 553. |
Convert from Algol to Oberon Vadim Isaev, 2020. |
Входные параметры: |
a - начальное вычисляемое значение, тип REAL; |
b - конечное вычисляемое значение, тип REAL; |
seed - начальное значение для генерации случайного числа. |
Должно быть в диапазоне от 10 000 000 000 до 34 359 738 368 (2^35), |
нечётное. |
--------------------------------------------------------------------------- *) |
PROCEDURE alg133b* (a, b: REAL; VAR seed: INTEGER): REAL; |
CONST |
m35 = 34359738368; |
m36 = 68719476736; |
m37 = 137438953472; |
VAR |
x: INTEGER; |
BEGIN |
IF seed # 0 THEN |
IF (seed MOD 2 = 0) THEN |
seed := seed + 1 |
END; |
x:=seed; |
seed:=0; |
END; |
x:=5*x; |
IF x>=m37 THEN |
x:=x-m37 |
END; |
IF x>=m36 THEN |
x:=x-m36 |
END; |
IF x>=m35 THEN |
x:=x-m35 |
END; |
RETURN FLT(x) / FLT(m35) * (b - a) + a |
END alg133b; |
(* ---------------------------------------------------------- |
Генератор почти равномерно распределённых |
какбыслучайных чисел mrg32k3a |
(Combined Multiple Recursive Generator) от 0 до 1. |
Период повторения последовательности = 2^127 |
Generator pseudorandom numbers, |
algorithm mrg32k3a. |
Переделка из FreePascal на Oberon, Вадим Исаев, 2020 |
Convert from FreePascal to Oberon, Vadim Isaev, 2020 |
---------------------------------------------------------- *) |
(* Инициализация генератора. |
Входные параметры: |
seed - значение для инициализации. Любое. Если передать |
ноль, то вместо ноля будет подставлено кол-во |
процессорных тиков. *) |
PROCEDURE mrg32k3a_init* (seed: REAL); |
BEGIN |
prndl.mrg32k3a_x[0] := 1.0; |
prndl.mrg32k3a_x[1] := 1.0; |
prndl.mrg32k3a_y[0] := 1.0; |
prndl.mrg32k3a_y[1] := 1.0; |
prndl.mrg32k3a_y[2] := 1.0; |
IF seed # 0.0 THEN |
prndl.mrg32k3a_x[2] := seed; |
ELSE |
prndl.mrg32k3a_x[2] := FLT(HOST.GetTickCount()); |
END; |
END mrg32k3a_init; |
(* Генератор какбыслучайных чисел от 0.0 до 1.0. *) |
PROCEDURE mrg32k3a* (): REAL; |
CONST |
(* random MRG32K3A algorithm constants *) |
MRG32K3A_NORM = 2.328306549295728E-10; |
MRG32K3A_M1 = 4294967087.0; |
MRG32K3A_M2 = 4294944443.0; |
MRG32K3A_A12 = 1403580.0; |
MRG32K3A_A13 = 810728.0; |
MRG32K3A_A21 = 527612.0; |
MRG32K3A_A23 = 1370589.0; |
RAND_BUFSIZE = 512; |
VAR |
xn, yn, result: REAL; |
BEGIN |
(* Часть 1 *) |
xn := MRG32K3A_A12 * prndl.mrg32k3a_x[1] - MRG32K3A_A13 * prndl.mrg32k3a_x[2]; |
xn := xn - MathRound.trunc(xn / MRG32K3A_M1) * MRG32K3A_M1; |
IF xn < 0.0 THEN |
xn := xn + MRG32K3A_M1; |
END; |
prndl.mrg32k3a_x[2] := prndl.mrg32k3a_x[1]; |
prndl.mrg32k3a_x[1] := prndl.mrg32k3a_x[0]; |
prndl.mrg32k3a_x[0] := xn; |
(* Часть 2 *) |
yn := MRG32K3A_A21 * prndl.mrg32k3a_y[0] - MRG32K3A_A23 * prndl.mrg32k3a_y[2]; |
yn := yn - MathRound.trunc(yn / MRG32K3A_M2) * MRG32K3A_M2; |
IF yn < 0.0 THEN |
yn := yn + MRG32K3A_M2; |
END; |
prndl.mrg32k3a_y[2] := prndl.mrg32k3a_y[1]; |
prndl.mrg32k3a_y[1] := prndl.mrg32k3a_y[0]; |
prndl.mrg32k3a_y[0] := yn; |
(* Смешение частей *) |
IF xn <= yn THEN |
result := ((xn - yn + MRG32K3A_M1) * MRG32K3A_NORM) |
ELSE |
result := (xn - yn) * MRG32K3A_NORM; |
END; |
RETURN result |
END mrg32k3a; |
(* ------------------------------------------------------------------- |
Генератор какбыслучайных чисел, алгоритм Мерсена-Твистера (MT19937). |
Переделка из Delphi в Oberon Вадим Исаев, 2020. |
Mersenne Twister Random Number Generator. |
A C-program for MT19937, with initialization improved 2002/1/26. |
Coded by Takuji Nishimura and Makoto Matsumoto. |
Adapted for DMath by Jean Debord - Feb. 2007 |
Adapted for Oberon-07 by Vadim Isaev - May 2020 |
------------------------------------------------------------ *) |
(* Initializes MT generator with a seed *) |
PROCEDURE InitMT(Seed : INTEGER); |
VAR |
i : INTEGER; |
BEGIN |
mt[0] := MathBits.iand(Seed, INT_MAX); |
FOR i := 1 TO N-1 DO |
mt[i] := (1812433253 * MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) + i); |
(* See Knuth TAOCP Vol2. 3rd Ed. P.106 For multiplier. |
In the previous versions, MSBs of the seed affect |
only MSBs of the array mt[]. |
2002/01/09 modified by Makoto Matsumoto *) |
mt[i] := MathBits.iand(mt[i], INT_MAX); |
(* For >32 Bit machines *) |
END; |
mti := N; |
END InitMT; |
(* Initialize MT generator with an array InitKey[0..(KeyLength - 1)] *) |
PROCEDURE InitMTbyArray(InitKey : MTKeyArray; KeyLength : INTEGER); |
VAR |
i, j, k, k1 : INTEGER; |
BEGIN |
InitMT(19650218); |
i := 1; |
j := 0; |
IF N > KeyLength THEN |
k1 := N |
ELSE |
k1 := KeyLength; |
END; |
FOR k := k1 TO 1 BY -1 DO |
(* non linear *) |
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1664525)) + InitKey[j] + j; |
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *) |
INC(i); |
INC(j); |
IF i >= N THEN |
mt[0] := mt[N-1]; |
i := 1; |
END; |
IF j >= KeyLength THEN |
j := 0; |
END; |
END; |
FOR k := N-1 TO 1 BY -1 DO |
(* non linear *) |
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1566083941)) - i; |
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *) |
INC(i); |
IF i >= N THEN |
mt[0] := mt[N-1]; |
i := 1; |
END; |
END; |
mt[0] := UPPER_MASK; (* MSB is 1; assuring non-zero initial array *) |
END InitMTbyArray; |
(* Generates a integer Random number on [-2^31 .. 2^31 - 1] interval *) |
PROCEDURE IRanMT(): INTEGER; |
VAR |
mag01 : ARRAY 2 OF INTEGER; |
y,k : INTEGER; |
BEGIN |
IF mti >= N THEN (* generate N words at one Time *) |
(* If IRanMT() has not been called, a default initial seed is used *) |
IF mti = N + 1 THEN |
InitMT(5489); |
END; |
FOR k := 0 TO (N-M)-1 DO |
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK)); |
mt[k] := MathBits.ixor(MathBits.ixor(mt[k+M], LSR(y, 1)), mag01[MathBits.iand(y, 1H)]); |
END; |
FOR k := (N-M) TO (N-2) DO |
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK)); |
mt[k] := MathBits.ixor(mt[k - (N - M)], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)])); |
END; |
y := MathBits.ior(MathBits.iand(mt[N-1], UPPER_MASK), MathBits.iand(mt[0], LOWER_MASK)); |
mt[N-1] := MathBits.ixor(mt[M-1], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)])); |
mti := 0; |
END; |
y := mt[mti]; |
INC(mti); |
(* Tempering *) |
y := MathBits.ixor(y, LSR(y, 11)); |
y := MathBits.ixor(y, MathBits.iand(LSL(y, 7), 9D2C5680H)); |
y := MathBits.ixor(y, MathBits.iand(LSL(y, 15), 4022730752)); |
y := MathBits.ixor(y, LSR(y, 18)); |
RETURN y |
END IRanMT; |
(* Generates a real Random number on [0..1] interval *) |
PROCEDURE RRanMT(): REAL; |
BEGIN |
RETURN FLT(IRanMT())/FLT(INT_MAX) |
END RRanMT; |
END RandExt. |
/programs/develop/oberon07/lib/RVM32I/FPU.ob07 |
---|
0,0 → 1,465 |
(* |
BSD 2-Clause License |
Copyright (c) 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE FPU; |
CONST |
INF = 07F800000H; |
NINF = 0FF800000H; |
NAN = 07FC00000H; |
PROCEDURE div2 (b, a: INTEGER): INTEGER; |
VAR |
n, e, r, s: INTEGER; |
BEGIN |
s := ORD(BITS(a) / BITS(b) - {0..30}); |
e := (a DIV 800000H) MOD 256 - (b DIV 800000H) MOD 256 + 127; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
n := 800000H; |
r := 0; |
IF a < b THEN |
a := a * 2; |
DEC(e) |
END; |
WHILE (a > 0) & (n > 0) DO |
IF a >= b THEN |
INC(r, n); |
DEC(a, b) |
END; |
a := a * 2; |
n := n DIV 2 |
END; |
IF e <= 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
ELSIF e >= 255 THEN |
e := 255; |
r := 800000H |
END |
RETURN (r - 800000H) + e * 800000H + s |
END div2; |
PROCEDURE mul2 (b, a: INTEGER): INTEGER; |
VAR |
e, r, s: INTEGER; |
BEGIN |
s := ORD(BITS(a) / BITS(b) - {0..30}); |
e := (a DIV 800000H) MOD 256 + (b DIV 800000H) MOD 256 - 127; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
r := a * (b MOD 256); |
b := b DIV 256; |
r := LSR(r, 8); |
INC(r, a * (b MOD 256)); |
b := b DIV 256; |
r := LSR(r, 8); |
INC(r, a * (b MOD 256)); |
r := LSR(r, 7); |
IF r >= 1000000H THEN |
r := r DIV 2; |
INC(e) |
END; |
IF e <= 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
ELSIF e >= 255 THEN |
e := 255; |
r := 800000H |
END |
RETURN (r - 800000H) + e * 800000H + s |
END mul2; |
PROCEDURE add2 (b, a: INTEGER): INTEGER; |
VAR |
ea, eb, e, d, r: INTEGER; |
BEGIN |
ea := (a DIV 800000H) MOD 256; |
eb := (b DIV 800000H) MOD 256; |
d := ea - eb; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
IF d > 0 THEN |
IF d < 24 THEN |
b := LSR(b, d) |
ELSE |
b := 0 |
END; |
e := ea |
ELSIF d < 0 THEN |
IF d > -24 THEN |
a := LSR(a, -d) |
ELSE |
a := 0 |
END; |
e := eb |
ELSE |
e := ea |
END; |
r := a + b; |
IF r >= 1000000H THEN |
r := r DIV 2; |
INC(e) |
END; |
IF e >= 255 THEN |
e := 255; |
r := 800000H |
END |
RETURN (r - 800000H) + e * 800000H |
END add2; |
PROCEDURE sub2 (b, a: INTEGER): INTEGER; |
VAR |
ea, eb, e, d, r, s: INTEGER; |
BEGIN |
ea := (a DIV 800000H) MOD 256; |
eb := (b DIV 800000H) MOD 256; |
a := a MOD 800000H + 800000H; |
b := b MOD 800000H + 800000H; |
d := ea - eb; |
IF (d > 0) OR (d = 0) & (a >= b) THEN |
s := 0 |
ELSE |
ea := eb; |
d := -d; |
r := a; |
a := b; |
b := r; |
s := 80000000H |
END; |
e := ea; |
IF d > 0 THEN |
IF d < 24 THEN |
b := LSR(b, d) |
ELSE |
b := 0 |
END |
END; |
r := a - b; |
IF r = 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
ELSE |
WHILE r < 800000H DO |
r := r * 2; |
DEC(e) |
END |
END; |
IF e <= 0 THEN |
e := 0; |
r := 800000H; |
s := 0 |
END |
RETURN (r - 800000H) + e * 800000H + s |
END sub2; |
PROCEDURE zero (VAR x: INTEGER); |
BEGIN |
IF BITS(x) * {23..30} = {} THEN |
x := 0 |
END |
END zero; |
PROCEDURE isNaN (a: INTEGER): BOOLEAN; |
RETURN (a > INF) OR (a < 0) & (a > NINF) |
END isNaN; |
PROCEDURE isInf (a: INTEGER): BOOLEAN; |
RETURN (a = INF) OR (a = NINF) |
END isInf; |
PROCEDURE isNormal (a: INTEGER): BOOLEAN; |
RETURN (BITS(a) * {23..30} # {23..30}) & (BITS(a) * {23..30} # {}) |
END isNormal; |
PROCEDURE add* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a) & isNormal(b) THEN |
IF (a > 0) & (b > 0) THEN |
r := add2(b, a) |
ELSIF (a < 0) & (b < 0) THEN |
r := add2(b, a) + 80000000H |
ELSIF (a > 0) & (b < 0) THEN |
r := sub2(b, a) |
ELSIF (a < 0) & (b > 0) THEN |
r := sub2(a, b) |
END |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF isInf(a) & isInf(b) THEN |
IF a = b THEN |
r := a |
ELSE |
r := NAN |
END |
ELSIF isInf(a) THEN |
r := a |
ELSIF isInf(b) THEN |
r := b |
ELSIF a = 0 THEN |
r := b |
ELSIF b = 0 THEN |
r := a |
END |
RETURN r |
END add; |
PROCEDURE sub* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a) & isNormal(b) THEN |
IF (a > 0) & (b > 0) THEN |
r := sub2(b, a) |
ELSIF (a < 0) & (b < 0) THEN |
r := sub2(a, b) |
ELSIF (a > 0) & (b < 0) THEN |
r := add2(b, a) |
ELSIF (a < 0) & (b > 0) THEN |
r := add2(b, a) + 80000000H |
END |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF isInf(a) & isInf(b) THEN |
IF a # b THEN |
r := a |
ELSE |
r := NAN |
END |
ELSIF isInf(a) THEN |
r := a |
ELSIF isInf(b) THEN |
r := INF + ORD(BITS(b) / {31} - {0..30}) |
ELSIF (a = 0) & (b = 0) THEN |
r := 0 |
ELSIF a = 0 THEN |
r := ORD(BITS(b) / {31}) |
ELSIF b = 0 THEN |
r := a |
END |
RETURN r |
END sub; |
PROCEDURE mul* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a) & isNormal(b) THEN |
r := mul2(b, a) |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF (isInf(a) & (b = 0)) OR (isInf(b) & (a = 0)) THEN |
r := NAN |
ELSIF isInf(a) OR isInf(b) THEN |
r := INF + ORD(BITS(a) / BITS(b) - {0..30}) |
ELSIF (a = 0) OR (b = 0) THEN |
r := 0 |
END |
RETURN r |
END mul; |
PROCEDURE _div* (b, a: INTEGER): INTEGER; |
VAR |
r: INTEGER; |
BEGIN |
zero(a); zero(b); |
IF isNormal(a) & isNormal(b) THEN |
r := div2(b, a) |
ELSIF isNaN(a) OR isNaN(b) THEN |
r := NAN |
ELSIF isInf(a) & isInf(b) THEN |
r := NAN |
ELSIF isInf(a) THEN |
r := INF + ORD(BITS(a) / BITS(b) - {0..30}) |
ELSIF isInf(b) THEN |
r := 0 |
ELSIF a = 0 THEN |
IF b = 0 THEN |
r := NAN |
ELSE |
r := 0 |
END |
ELSIF b = 0 THEN |
IF a > 0 THEN |
r := INF |
ELSE |
r := NINF |
END |
END |
RETURN r |
END _div; |
PROCEDURE cmp* (op, b, a: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
zero(a); zero(b); |
IF isNaN(a) OR isNaN(b) THEN |
res := op = 1 |
ELSIF (a < 0) & (b < 0) THEN |
CASE op OF |
|0: res := a = b |
|1: res := a # b |
|2: res := a > b |
|3: res := a >= b |
|4: res := a < b |
|5: res := a <= b |
END |
ELSE |
CASE op OF |
|0: res := a = b |
|1: res := a # b |
|2: res := a < b |
|3: res := a <= b |
|4: res := a > b |
|5: res := a >= b |
END |
END |
RETURN res |
END cmp; |
PROCEDURE flt* (x: INTEGER): INTEGER; |
VAR |
n, y, r, s: INTEGER; |
BEGIN |
IF x = 0 THEN |
s := 0; |
r := 800000H; |
n := -126 |
ELSIF x = 80000000H THEN |
s := 80000000H; |
r := 800000H; |
n := 32 |
ELSE |
IF x < 0 THEN |
s := 80000000H |
ELSE |
s := 0 |
END; |
n := 0; |
y := ABS(x); |
r := y; |
WHILE y > 0 DO |
y := y DIV 2; |
INC(n) |
END; |
IF n > 24 THEN |
r := LSR(r, n - 24) |
ELSE |
r := LSL(r, 24 - n) |
END |
END |
RETURN (r - 800000H) + (n + 126) * 800000H + s |
END flt; |
PROCEDURE floor* (x: INTEGER): INTEGER; |
VAR |
r, e: INTEGER; |
BEGIN |
zero(x); |
e := (x DIV 800000H) MOD 256 - 127; |
r := x MOD 800000H + 800000H; |
IF (0 <= e) & (e <= 22) THEN |
r := LSR(r, 23 - e) + ORD((x < 0) & (LSL(r, e + 9) # 0)) |
ELSIF (23 <= e) & (e <= 54) THEN |
r := LSL(r, e - 23) |
ELSIF (e < 0) & (x < 0) THEN |
r := 1 |
ELSE |
r := 0 |
END; |
IF x < 0 THEN |
r := -r |
END |
RETURN r |
END floor; |
END FPU. |
/programs/develop/oberon07/lib/RVM32I/HOST.ob07 |
---|
0,0 → 1,176 |
(* |
BSD 2-Clause License |
Copyright (c) 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT SYSTEM, Trap; |
CONST |
slash* = "\"; |
eol* = 0DX + 0AX; |
bit_depth* = 32; |
maxint* = 7FFFFFFFH; |
minint* = 80000000H; |
VAR |
maxreal*: REAL; |
PROCEDURE syscall0 (fn: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall0; |
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall1; |
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall2; |
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall3; |
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER; |
BEGIN |
Trap.syscall(SYSTEM.ADR(fn)) |
RETURN fn |
END syscall4; |
PROCEDURE ExitProcess* (code: INTEGER); |
BEGIN |
code := syscall1(0, code) |
END ExitProcess; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0])) |
END GetCurrentDirectory; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
BEGIN |
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0])) |
END GetArg; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileRead; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes) |
END FileWrite; |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileCreate; |
PROCEDURE FileClose* (F: INTEGER); |
BEGIN |
F := syscall1(6, F) |
END FileClose; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0])) |
END FileOpen; |
PROCEDURE chmod* (FName: ARRAY OF CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0])) |
END chmod; |
PROCEDURE OutChar* (c: CHAR); |
VAR |
a: INTEGER; |
BEGIN |
a := syscall1(8, ORD(c)) |
END OutChar; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN syscall0(9) |
END GetTickCount; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0 |
END isRelative; |
PROCEDURE UnixTime* (): INTEGER; |
RETURN syscall0(10) |
END UnixTime; |
PROCEDURE s2d (x: INTEGER; VAR h, l: INTEGER); |
VAR |
s, e, f: INTEGER; |
BEGIN |
s := ASR(x, 31) MOD 2; |
f := x MOD 800000H; |
e := (x DIV 800000H) MOD 256; |
IF e = 255 THEN |
e := 2047 |
ELSE |
INC(e, 896) |
END; |
h := LSL(s, 31) + LSL(e, 20) + (f DIV 8); |
l := (f MOD 8) * 20000000H |
END s2d; |
PROCEDURE d2s* (x: REAL): INTEGER; |
VAR |
i: INTEGER; |
BEGIN |
SYSTEM.GET(SYSTEM.ADR(x), i) |
RETURN i |
END d2s; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
BEGIN |
s2d(d2s(x), b, a) |
RETURN a |
END splitf; |
BEGIN |
maxreal := 1.9; |
PACK(maxreal, 127) |
END HOST. |
/programs/develop/oberon07/lib/RVM32I/Out.ob07 |
---|
0,0 → 1,273 |
(* |
BSD 2-Clause License |
Copyright (c) 2016, 2018, 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE Out; |
IMPORT HOST, SYSTEM; |
PROCEDURE Char* (c: CHAR); |
BEGIN |
HOST.OutChar(c) |
END Char; |
PROCEDURE String* (s: ARRAY OF CHAR); |
VAR |
i, n: INTEGER; |
BEGIN |
n := LENGTH(s) - 1; |
FOR i := 0 TO n DO |
Char(s[i]) |
END |
END String; |
PROCEDURE Int* (x, width: INTEGER); |
VAR |
i, a: INTEGER; |
str: ARRAY 12 OF CHAR; |
BEGIN |
IF x = 80000000H THEN |
COPY("-2147483648", str); |
DEC(width, 11) |
ELSE |
i := 0; |
IF x < 0 THEN |
x := -x; |
i := 1; |
str[0] := "-" |
END; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
DEC(width, i); |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(str) |
END Int; |
PROCEDURE Inf (x: REAL; width: INTEGER); |
VAR |
s: ARRAY 5 OF CHAR; |
BEGIN |
DEC(width, 4); |
IF x # x THEN |
s := " Nan" |
ELSIF x = SYSTEM.INF() THEN |
s := "+Inf" |
ELSIF x = -SYSTEM.INF() THEN |
s := "-Inf" |
END; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(s) |
END Inf; |
PROCEDURE Ln*; |
BEGIN |
Char(0DX); |
Char(0AX) |
END Ln; |
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER); |
VAR |
a, b: REAL; |
BEGIN |
ASSERT(x > 0.0); |
n := 0; |
WHILE x < 1.0 DO |
x := x * 10.0; |
DEC(n) |
END; |
a := 10.0; |
b := 1.0; |
WHILE a <= x DO |
b := a; |
a := a * 10.0; |
INC(n) |
END; |
x := x / b |
END unpk10; |
PROCEDURE _Real (x: REAL; width: INTEGER); |
VAR |
n, k, p: INTEGER; |
BEGIN |
p := MIN(MAX(width - 7, 1), 10); |
width := width - p - 7; |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF x < 0.0 THEN |
Char("-"); |
x := -x |
ELSE |
Char(20X) |
END; |
unpk10(x, n); |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
Char("."); |
WHILE p > 0 DO |
x := (x - FLT(k)) * 10.0; |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
DEC(p) |
END; |
Char("E"); |
IF n >= 0 THEN |
Char("+") |
ELSE |
Char("-") |
END; |
n := ABS(n); |
Char(CHR(n DIV 10 + 30H)); |
Char(CHR(n MOD 10 + 30H)) |
END _Real; |
PROCEDURE Real* (x: REAL; width: INTEGER); |
BEGIN |
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
WHILE width > 17 DO |
Char(20X); |
DEC(width) |
END; |
DEC(width, 8); |
String(" 0.0"); |
WHILE width > 0 DO |
Char("0"); |
DEC(width) |
END; |
String("E+00") |
ELSE |
_Real(x, width) |
END |
END Real; |
PROCEDURE _FixReal (x: REAL; width, p: INTEGER); |
VAR |
n, k: INTEGER; |
minus: BOOLEAN; |
BEGIN |
minus := x < 0.0; |
IF minus THEN |
x := -x |
END; |
unpk10(x, n); |
DEC(width, 3 + MAX(p, 0) + MAX(n, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
IF minus THEN |
Char("-") |
ELSE |
Char(20X) |
END; |
IF n < 0 THEN |
INC(n); |
Char("0"); |
Char("."); |
WHILE (n < 0) & (p > 0) DO |
Char("0"); |
INC(n); |
DEC(p) |
END |
ELSE |
WHILE n >= 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(n) |
END; |
Char(".") |
END; |
WHILE p > 0 DO |
k := FLOOR(x); |
Char(CHR(k + 30H)); |
x := (x - FLT(k)) * 10.0; |
DEC(p) |
END |
END _FixReal; |
PROCEDURE FixReal* (x: REAL; width, p: INTEGER); |
BEGIN |
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN |
Inf(x, width) |
ELSIF x = 0.0 THEN |
DEC(width, 3 + MAX(p, 0)); |
WHILE width > 0 DO |
Char(20X); |
DEC(width) |
END; |
String(" 0."); |
WHILE p > 0 DO |
Char("0"); |
DEC(p) |
END |
ELSE |
_FixReal(x, width, p) |
END |
END FixReal; |
PROCEDURE Open*; |
END Open; |
END Out. |
/programs/develop/oberon07/lib/RVM32I/RTL.ob07 |
---|
0,0 → 1,390 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT SYSTEM, F := FPU, Trap; |
CONST |
bit_depth = 32; |
maxint = 7FFFFFFFH; |
minint = 80000000H; |
WORD = bit_depth DIV 8; |
MAX_SET = bit_depth - 1; |
VAR |
Heap, Types, TypesCount: INTEGER; |
PROCEDURE _error* (modnum, _module, err, line: INTEGER); |
BEGIN |
Trap.trap(modnum, _module, err, line) |
END _error; |
PROCEDURE _fmul* (b, a: INTEGER): INTEGER; |
RETURN F.mul(b, a) |
END _fmul; |
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER; |
RETURN F._div(b, a) |
END _fdiv; |
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER; |
RETURN F._div(a, b) |
END _fdivi; |
PROCEDURE _fadd* (b, a: INTEGER): INTEGER; |
RETURN F.add(b, a) |
END _fadd; |
PROCEDURE _fsub* (b, a: INTEGER): INTEGER; |
RETURN F.sub(b, a) |
END _fsub; |
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER; |
RETURN F.sub(a, b) |
END _fsubi; |
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN; |
RETURN F.cmp(op, b, a) |
END _fcmp; |
PROCEDURE _floor* (x: INTEGER): INTEGER; |
RETURN F.floor(x) |
END _floor; |
PROCEDURE _flt* (x: INTEGER): INTEGER; |
RETURN F.flt(x) |
END _flt; |
PROCEDURE _pack* (n: INTEGER; VAR x: SET); |
BEGIN |
n := LSL((LSR(ORD(x), 23) MOD 256 + n) MOD 256, 23); |
x := x - {23..30} + BITS(n) |
END _pack; |
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET); |
BEGIN |
n := LSR(ORD(x), 23) MOD 256 - 127; |
x := x - {30} + {23..29} |
END _unpk; |
PROCEDURE _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
k := LEN(A) - 1; |
n := A[0]; |
i := 0; |
WHILE i < k DO |
A[i] := A[i + 1]; |
INC(i) |
END; |
A[k] := n |
END _rot; |
PROCEDURE _set* (b, a: INTEGER): INTEGER; |
BEGIN |
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN |
IF b > MAX_SET THEN |
b := MAX_SET |
END; |
IF a < 0 THEN |
a := 0 |
END; |
a := LSR(ASR(minint, b - a), MAX_SET - b) |
ELSE |
a := 0 |
END |
RETURN a |
END _set; |
PROCEDURE _set1* (a: INTEGER): INTEGER; |
BEGIN |
IF ASR(a, 5) = 0 THEN |
a := LSL(1, a) |
ELSE |
a := 0 |
END |
RETURN a |
END _set1; |
PROCEDURE _length* (len, str: INTEGER): INTEGER; |
VAR |
c: CHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _length; |
PROCEDURE _move* (bytes, dest, source: INTEGER); |
VAR |
b: BYTE; |
i: INTEGER; |
BEGIN |
WHILE ((source MOD WORD # 0) OR (dest MOD WORD # 0)) & (bytes > 0) DO |
SYSTEM.GET(source, b); |
SYSTEM.PUT8(dest, b); |
INC(source); |
INC(dest); |
DEC(bytes) |
END; |
WHILE bytes >= WORD DO |
SYSTEM.GET(source, i); |
SYSTEM.PUT(dest, i); |
INC(source, WORD); |
INC(dest, WORD); |
DEC(bytes, WORD) |
END; |
WHILE bytes > 0 DO |
SYSTEM.GET(source, b); |
SYSTEM.PUT8(dest, b); |
INC(source); |
INC(dest); |
DEC(bytes) |
END |
END _move; |
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER; |
VAR |
c: WCHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
REPEAT |
SYSTEM.GET(str, c); |
INC(str, 2); |
DEC(len); |
INC(res) |
UNTIL (len = 0) OR (c = 0X); |
RETURN res - ORD(c = 0X) |
END _lengthw; |
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: CHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a); |
SYSTEM.GET(b, B); INC(b); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = 0X THEN |
n := 0 |
END |
END |
RETURN res |
END strncmp; |
PROCEDURE _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
BEGIN |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = 0 THEN |
res := _length(len1, str1) - _length(len2, str2) |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmp; |
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER; |
VAR |
A, B: WCHAR; |
res: INTEGER; |
BEGIN |
res := 0; |
WHILE n > 0 DO |
SYSTEM.GET(a, A); INC(a, 2); |
SYSTEM.GET(b, B); INC(b, 2); |
DEC(n); |
IF A # B THEN |
res := ORD(A) - ORD(B); |
n := 0 |
ELSIF A = WCHR(0) THEN |
n := 0 |
END |
END |
RETURN res |
END strncmpw; |
PROCEDURE _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN; |
VAR |
res: INTEGER; |
bRes: BOOLEAN; |
BEGIN |
res := strncmpw(str1, str2, MIN(len1, len2)); |
IF res = 0 THEN |
res := _lengthw(len1, str1) - _lengthw(len2, str2) |
END; |
CASE op OF |
|0: bRes := res = 0 |
|1: bRes := res # 0 |
|2: bRes := res < 0 |
|3: bRes := res <= 0 |
|4: bRes := res > 0 |
|5: bRes := res >= 0 |
END |
RETURN bRes |
END _strcmpw; |
PROCEDURE _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, dst, src); |
res := TRUE |
END |
RETURN res |
END _arrcpy; |
PROCEDURE _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
_move(MIN(len_dst, len_src) * chr_size, dst, src) |
END _strcpy; |
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER); |
BEGIN |
IF Heap + size < Trap.sp() - 64 THEN |
p := Heap + WORD; |
REPEAT |
SYSTEM.PUT(Heap, t); |
INC(Heap, WORD); |
DEC(size, WORD); |
t := 0 |
UNTIL size = 0 |
ELSE |
p := 0 |
END |
END _new; |
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
ELSE |
_type := t |
END |
RETURN _type = t |
END _guard; |
PROCEDURE _is* (t, p: INTEGER): BOOLEAN; |
VAR |
_type: INTEGER; |
BEGIN |
_type := 0; |
IF p # 0 THEN |
SYSTEM.GET(p - WORD, _type); |
WHILE (_type # t) & (_type # 0) DO |
SYSTEM.GET(Types + _type * WORD, _type) |
END |
END |
RETURN _type = t |
END _is; |
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(Types + t1 * WORD, t1) |
END |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE _init* (tcount, heap, types: INTEGER); |
BEGIN |
Heap := heap; |
TypesCount := tcount; |
Types := types |
END _init; |
END RTL. |
/programs/develop/oberon07/lib/RVM32I/Trap.ob07 |
---|
0,0 → 1,128 |
(* |
BSD 2-Clause License |
Copyright (c) 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE Trap; |
IMPORT SYSTEM; |
PROCEDURE [code] sp* (): INTEGER |
22, 0, 4; (* MOV R0, SP *) |
PROCEDURE [code] syscall* (ptr: INTEGER) |
22, 0, 4, (* MOV R0, SP *) |
27, 0, 4, (* ADD R0, 4 *) |
9, 0, 0, (* LDR32 R0, R0 *) |
80, 0, 0; (* SYSCALL R0 *) |
PROCEDURE Char (c: CHAR); |
VAR |
a: ARRAY 2 OF INTEGER; |
BEGIN |
a[0] := 8; |
a[1] := ORD(c); |
syscall(SYSTEM.ADR(a[0])) |
END Char; |
PROCEDURE String (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE s[i] # 0X DO |
Char(s[i]); |
INC(i) |
END |
END String; |
PROCEDURE PString (ptr: INTEGER); |
VAR |
c: CHAR; |
BEGIN |
SYSTEM.GET(ptr, c); |
WHILE c # 0X DO |
Char(c); |
INC(ptr); |
SYSTEM.GET(ptr, c) |
END |
END PString; |
PROCEDURE Ln; |
BEGIN |
String(0DX + 0AX) |
END Ln; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
BEGIN |
i := 0; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END IntToStr; |
PROCEDURE Int (x: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
IntToStr(x, s); |
String(s) |
END Int; |
PROCEDURE trap* (modnum, _module, err, line: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
CASE err OF |
| 1: s := "assertion failure" |
| 2: s := "NIL dereference" |
| 3: s := "bad divisor" |
| 4: s := "NIL procedure call" |
| 5: s := "type guard error" |
| 6: s := "index out of range" |
| 7: s := "invalid CASE" |
| 8: s := "array assignment error" |
| 9: s := "CHR out of range" |
|10: s := "WCHR out of range" |
|11: s := "BYTE out of range" |
END; |
Ln; |
String("error ("); Int(err); String("): "); String(s); Ln; |
String("module: "); PString(_module); Ln; |
String("line: "); Int(line); Ln; |
SYSTEM.CODE(0, 0, 0) (* STOP *) |
END trap; |
END Trap. |
/programs/develop/oberon07/samples/KolibriOS/Dialogs.ob07 |
---|
0,0 → 1,110 |
MODULE Dialogs; |
IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg; |
VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER; |
PROCEDURE WindowRedrawStatus(p: INTEGER); |
BEGIN |
KOSAPI.sysfunc2(12, p) |
END WindowRedrawStatus; |
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); |
BEGIN |
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) |
END DefineAndDrawWindow; |
PROCEDURE WaitForEvent(): INTEGER; |
RETURN KOSAPI.sysfunc1(10) |
END WaitForEvent; |
PROCEDURE ExitApp; |
BEGIN |
KOSAPI.sysfunc1(-1) |
END ExitApp; |
PROCEDURE pause(t: INTEGER); |
BEGIN |
KOSAPI.sysfunc2(5, t) |
END pause; |
PROCEDURE Buttons; |
PROCEDURE Button(id, X, Y, W, H: INTEGER; Caption: ARRAY OF CHAR); |
VAR n, aux: INTEGER; |
BEGIN |
n := LENGTH(Caption); |
aux := KOSAPI.sysfunc5(8, X * 65536 + W, Y * 65536 + H, id, 00C0C0C0H); |
X := X + (W - 8 * n) DIV 2; |
Y := Y + (H - 14) DIV 2; |
aux := KOSAPI.sysfunc6(4, X * 65536 + Y, LSL(48, 24), sys.ADR(Caption[0]), n, 0) |
END Button; |
BEGIN |
Button(17, 5, 5, 70, 25, "open"); |
Button(18, 85, 5, 70, 25, "color"); |
END Buttons; |
PROCEDURE draw_window; |
BEGIN |
WindowRedrawStatus(1); |
DefineAndDrawWindow(200, 200, 500, 100, back_color, 51, 0, 0, sys.ADR(header[0])); |
Buttons; |
WindowRedrawStatus(2); |
END draw_window; |
PROCEDURE OpenFile(Open: OpenDlg.Dialog); |
BEGIN |
IF Open # NIL THEN |
OpenDlg.Show(Open, 500, 450); |
WHILE Open.status = 2 DO |
pause(30) |
END; |
IF Open.status = 1 THEN |
COPY(Open.FilePath, header) |
END |
END |
END OpenFile; |
PROCEDURE SelColor(Color: ColorDlg.Dialog); |
BEGIN |
IF Color # NIL THEN |
ColorDlg.Show(Color); |
WHILE Color.status = 2 DO |
pause(30) |
END; |
IF Color.status = 1 THEN |
back_color := Color.color |
END |
END |
END SelColor; |
PROCEDURE main; |
VAR Open: OpenDlg.Dialog; Color: ColorDlg.Dialog; res, al: INTEGER; |
BEGIN |
back_color := 00FFFFFFH; |
header := "Dialogs"; |
draw_window; |
Open := OpenDlg.Create(draw_window, 0, "/rd/1", "ASM|TXT|INI"); |
Color := ColorDlg.Create(draw_window); |
WHILE TRUE DO |
CASE WaitForEvent() OF |
|1: draw_window |
|3: res := KOSAPI.sysfunc1(17); |
al := LSR(LSL(res, 24), 24); |
res := LSR(res, 8); |
IF al = 0 THEN |
CASE res OF |
| 1: ExitApp |
|17: OpenFile(Open) |
|18: SelColor(Color) |
END |
END |
ELSE |
END |
END |
END main; |
BEGIN |
main |
END Dialogs. |
/programs/develop/oberon07/samples/KolibriOS/HW.ob07 |
---|
0,0 → 1,50 |
MODULE HW; |
IMPORT sys := SYSTEM, KOSAPI; |
PROCEDURE WindowRedrawStatus(p: INTEGER); |
BEGIN |
KOSAPI.sysfunc2(12, p) |
END WindowRedrawStatus; |
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); |
BEGIN |
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) |
END DefineAndDrawWindow; |
PROCEDURE WriteTextToWindow(x, y, color: INTEGER; text: ARRAY OF CHAR); |
BEGIN |
KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0) |
END WriteTextToWindow; |
PROCEDURE WaitForEvent(): INTEGER; |
RETURN KOSAPI.sysfunc1(10) |
END WaitForEvent; |
PROCEDURE ExitApp; |
BEGIN |
KOSAPI.sysfunc1(-1) |
END ExitApp; |
PROCEDURE draw_window(header, text: ARRAY OF CHAR); |
BEGIN |
WindowRedrawStatus(1); |
DefineAndDrawWindow(200, 200, 200, 100, 0FFFFFFH, 51, 0, 0, sys.ADR(header)); |
WriteTextToWindow(10, 10, 0FF0000H, text); |
WindowRedrawStatus(2); |
END draw_window; |
PROCEDURE Main(header, text: ARRAY OF CHAR); |
BEGIN |
WHILE TRUE DO |
CASE WaitForEvent() OF |
|1: draw_window(header, text) |
|3: ExitApp |
ELSE |
END |
END |
END Main; |
BEGIN |
Main("HW", "Hello, world!") |
END HW. |
/programs/develop/oberon07/samples/KolibriOS/HW_con.ob07 |
---|
0,0 → 1,63 |
MODULE HW_con; |
IMPORT Out, In, Console, DateTime; |
PROCEDURE OutInt2(n: INTEGER); |
BEGIN |
ASSERT((0 <= n) & (n <= 99)); |
IF n < 10 THEN |
Out.Char("0") |
END; |
Out.Int(n, 0) |
END OutInt2; |
PROCEDURE OutMonth(n: INTEGER); |
VAR |
str: ARRAY 4 OF CHAR; |
BEGIN |
CASE n OF |
| 1: str := "jan" |
| 2: str := "feb" |
| 3: str := "mar" |
| 4: str := "apr" |
| 5: str := "may" |
| 6: str := "jun" |
| 7: str := "jul" |
| 8: str := "aug" |
| 9: str := "sep" |
|10: str := "oct" |
|11: str := "nov" |
|12: str := "dec" |
END; |
Out.String(str) |
END OutMonth; |
PROCEDURE main; |
VAR |
Year, Month, Day, Hour, Min, Sec, Msec: INTEGER; |
BEGIN |
Out.String("Hello, world!"); Out.Ln; |
Console.SetColor(Console.White, Console.Red); |
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec); |
Out.Int(Year, 0); Out.Char("-"); |
OutMonth(Month); Out.Char("-"); |
OutInt2(Day); Out.Char(" "); |
OutInt2(Hour); Out.Char(":"); |
OutInt2(Min); Out.Char(":"); |
OutInt2(Sec) |
END main; |
BEGIN |
Console.open; |
main; |
In.Ln; |
Console.exit(TRUE) |
END HW_con. |
/programs/develop/oberon07/source/AMD64.ob07 |
---|
0,0 → 1,2408 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE AMD64; |
IMPORT IL, BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PATHS, PROG, TARGETS, |
REG, UTILS, S := STRINGS, PE32, ELF, X86, ERRORS; |
CONST |
rax = REG.R0; |
r10 = REG.R10; |
r11 = REG.R11; |
rcx = REG.R1; |
rdx = REG.R2; |
r8 = REG.R8; |
r9 = REG.R9; |
rsp = 4; |
rbp = 5; |
rsi = 6; |
rdi = 7; |
MAX_XMM = 5; |
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; |
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H; |
shl = IL.opLSL2; shr = IL.opLSR2; sar = IL.opASR2; ror = IL.opROR2; |
sCODE = BIN.PICCODE; |
sDATA = BIN.PICDATA; |
sBSS = BIN.PICBSS; |
sIMP = BIN.PICIMP; |
FPR_ERR = 41; |
TYPE |
COMMAND = IL.COMMAND; |
Number = POINTER TO RECORD (LISTS.ITEM) value: INTEGER END; |
OPRR = PROCEDURE (reg1, reg2: INTEGER); |
VAR |
R: REG.REGS; |
Numbers: LISTS.LIST; |
Numbers_Count: INTEGER; |
Numbers_Offs: INTEGER; |
prog: BIN.PROGRAM; |
tcount: INTEGER; |
dllret, sofinit: INTEGER; |
Win64RegPar: ARRAY 4 OF INTEGER; |
SystemVRegPar: ARRAY 6 OF INTEGER; |
Xmm: ARRAY 1000 OF INTEGER; |
fname: PATHS.PATH; |
PROCEDURE OutByte (b: BYTE); |
BEGIN |
X86.OutByte(b) |
END OutByte; |
PROCEDURE OutByte2 (a, b: BYTE); |
BEGIN |
X86.OutByte(a); |
X86.OutByte(b) |
END OutByte2; |
PROCEDURE OutByte3 (a, b, c: BYTE); |
BEGIN |
X86.OutByte(a); |
X86.OutByte(b); |
X86.OutByte(c) |
END OutByte3; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
X86.OutByte(n MOD 256); |
X86.OutByte(UTILS.Byte(n, 1)); |
X86.OutByte(UTILS.Byte(n, 2)); |
X86.OutByte(UTILS.Byte(n, 3)) |
END OutInt; |
PROCEDURE short (n: INTEGER): INTEGER; |
RETURN 2 * ORD(X86.isByte(n)) |
END short; |
PROCEDURE long (n: INTEGER): INTEGER; |
RETURN 40H * ORD(~X86.isByte(n)) |
END long; |
PROCEDURE OutIntByte (n: INTEGER); |
BEGIN |
IF X86.isByte(n) THEN |
OutByte(n MOD 256) |
ELSE |
OutInt(n) |
END |
END OutIntByte; |
PROCEDURE isLong (n: INTEGER): BOOLEAN; |
RETURN (n > UTILS.max32) OR (n < UTILS.min32) |
END isLong; |
PROCEDURE NewNumber (value: INTEGER); |
VAR |
number: Number; |
BEGIN |
NEW(number); |
number.value := value; |
LISTS.push(Numbers, number); |
INC(Numbers_Count) |
END NewNumber; |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
BIN.NewLabel(prog) |
RETURN IL.NewLabel() |
END NewLabel; |
PROCEDURE Rex (reg1, reg2: INTEGER); |
BEGIN |
OutByte(48H + reg1 DIV 8 + 4 * (reg2 DIV 8)) |
END Rex; |
PROCEDURE lea (reg, offset, section: INTEGER); |
BEGIN |
Rex(0, reg); |
OutByte2(8DH, 05H + 8 * (reg MOD 8)); (* lea reg, [rip + offset] *) |
X86.Reloc(section, offset) |
END lea; |
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *) |
BEGIN |
Rex(reg1, reg2); |
OutByte2(op, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8) |
END oprr; |
PROCEDURE oprr2 (op1, op2: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *) |
BEGIN |
Rex(reg1, reg2); |
OutByte3(op1, op2, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8) |
END oprr2; |
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *) |
BEGIN |
oprr(89H, reg1, reg2) |
END mov; |
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *) |
BEGIN |
oprr(31H, reg1, reg2) |
END xor; |
PROCEDURE and (reg1, reg2: INTEGER); (* and reg1, reg2 *) |
BEGIN |
oprr(21H, reg1, reg2) |
END and; |
PROCEDURE _or (reg1, reg2: INTEGER); (* or reg1, reg2 *) |
BEGIN |
oprr(09H, reg1, reg2) |
END _or; |
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *) |
BEGIN |
oprr(01H, reg1, reg2) |
END add; |
PROCEDURE sub (reg1, reg2: INTEGER); (* sub reg1, reg2 *) |
BEGIN |
oprr(29H, reg1, reg2) |
END sub; |
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *) |
BEGIN |
IF rax IN {reg1, reg2} THEN |
Rex(reg1 + reg2, 0); |
OutByte(90H + (reg1 + reg2) MOD 8) |
ELSE |
oprr(87H, reg1, reg2) |
END |
END xchg; |
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *) |
BEGIN |
oprr(39H, reg1, reg2) |
END cmprr; |
PROCEDURE pop (reg: INTEGER); (* pop reg *) |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(58H + reg MOD 8) |
END pop; |
PROCEDURE push (reg: INTEGER); (* push reg *) |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(50H + reg MOD 8) |
END push; |
PROCEDURE decr (reg: INTEGER); |
BEGIN |
Rex(reg, 0); |
OutByte2(0FFH, 0C8H + reg MOD 8) (* dec reg1 *) |
END decr; |
PROCEDURE incr (reg: INTEGER); |
BEGIN |
Rex(reg, 0); |
OutByte2(0FFH, 0C0H + reg MOD 8) (* inc reg1 *) |
END incr; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE callimp (label: INTEGER); |
BEGIN |
OutByte2(0FFH, 15H); (* call qword[rip + label + IMP] *) |
X86.Reloc(sIMP, label) |
END callimp; |
PROCEDURE pushDA (offs: INTEGER); |
VAR |
reg: INTEGER; |
BEGIN |
reg := GetAnyReg(); |
lea(reg, offs, sDATA); |
push(reg); |
drop |
END pushDA; |
PROCEDURE CallRTL (proc: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
label := IL.codes.rtl[proc]; |
IF label < 0 THEN |
callimp(-label) |
ELSE |
X86.call(label) |
END |
END CallRTL; |
PROCEDURE UnOp (VAR reg: INTEGER); |
BEGIN |
REG.UnOp(R, reg) |
END UnOp; |
PROCEDURE BinOp (VAR reg1, reg2: INTEGER); |
BEGIN |
REG.BinOp(R, reg1, reg2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE movabs (reg, n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
Rex(reg, 0); |
OutByte(0B8H + reg MOD 8); (* movabs reg, n *) |
FOR i := 0 TO 7 DO |
OutByte(UTILS.Byte(n, i)) |
END |
END movabs; |
PROCEDURE movrc (reg, n: INTEGER); (* mov reg, n *) |
BEGIN |
IF isLong(n) THEN |
movabs(reg, n) |
ELSIF n = 0 THEN |
xor(reg, reg) |
ELSE |
Rex(reg, 0); |
OutByte2(0C7H, 0C0H + reg MOD 8); |
OutInt(n) |
END |
END movrc; |
PROCEDURE test (reg: INTEGER); (* test reg, reg *) |
BEGIN |
oprr(85H, reg, reg) |
END test; |
PROCEDURE oprlongc (reg, n: INTEGER; oprr: OPRR); |
VAR |
reg2: INTEGER; |
BEGIN |
reg2 := GetAnyReg(); |
ASSERT(reg2 # reg); |
movabs(reg2, n); |
oprr(reg, reg2); |
drop |
END oprlongc; |
PROCEDURE oprc (op, reg, n: INTEGER; oprr: OPRR); |
BEGIN |
IF isLong(n) THEN |
oprlongc(reg, n, oprr) |
ELSE |
Rex(reg, 0); |
X86.oprc(op, reg, n) |
END |
END oprc; |
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *) |
BEGIN |
IF n = 0 THEN |
test(reg) |
ELSE |
oprc(0F8H, reg, n, cmprr) |
END |
END cmprc; |
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *) |
BEGIN |
oprc(0C0H, reg, n, add) |
END addrc; |
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *) |
BEGIN |
oprc(0E8H, reg, n, sub) |
END subrc; |
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *) |
BEGIN |
oprc(0E0H, reg, n, and) |
END andrc; |
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *) |
BEGIN |
oprc(0C8H, reg, n, _or) |
END orrc; |
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *) |
BEGIN |
oprc(0F0H, reg, n, xor) |
END xorrc; |
PROCEDURE pushc (n: INTEGER); |
VAR |
reg2: INTEGER; |
BEGIN |
IF isLong(n) THEN |
reg2 := GetAnyReg(); |
movabs(reg2, n); |
push(reg2); |
drop |
ELSE |
X86.pushc(n) |
END |
END pushc; |
PROCEDURE not (reg: INTEGER); (* not reg *) |
BEGIN |
Rex(reg, 0); |
OutByte2(0F7H, 0D0H + reg MOD 8) |
END not; |
PROCEDURE neg (reg: INTEGER); (* neg reg *) |
BEGIN |
Rex(reg, 0); |
OutByte2(0F7H, 0D8H + reg MOD 8) |
END neg; |
PROCEDURE movzx (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *) |
BEGIN |
Rex(reg2, reg1); |
X86.movzx(reg1, reg2, offs, word) |
END movzx; |
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_32 *) |
BEGIN |
X86._movrm(reg2, reg1, offs, 32, TRUE) |
END movmr32; |
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); (* mov reg1_32, dword[reg2+offs] *) |
BEGIN |
X86._movrm(reg1, reg2, offs, 32, FALSE) |
END movrm32; |
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov qword[reg1+offs], reg2 *) |
BEGIN |
X86._movrm(reg2, reg1, offs, 64, TRUE) |
END movmr; |
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, qword[reg2+offs] *) |
BEGIN |
X86._movrm(reg1, reg2, offs, 64, FALSE) |
END movrm; |
PROCEDURE comisd (xmm1, xmm2: INTEGER); (* comisd xmm1, xmm2 *) |
BEGIN |
OutByte(66H); |
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN |
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8) |
END; |
OutByte3(0FH, 2FH, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8) |
END comisd; |
PROCEDURE _movsdrm (xmm, reg, offs: INTEGER; mr: BOOLEAN); |
VAR |
b: BYTE; |
BEGIN |
OutByte(0F2H); |
IF (xmm >= 8) OR (reg >= 8) THEN |
OutByte(40H + (xmm DIV 8) * 4 + reg DIV 8) |
END; |
OutByte2(0FH, 10H + ORD(mr)); |
IF (offs = 0) & (reg # rbp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (xmm MOD 8) * 8 + reg MOD 8); |
IF reg = rsp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END _movsdrm; |
PROCEDURE movsdrm (xmm, reg, offs: INTEGER); (* movsd xmm, qword[reg+offs] *) |
BEGIN |
_movsdrm(xmm, reg, offs, FALSE) |
END movsdrm; |
PROCEDURE movsdmr (reg, offs, xmm: INTEGER); (* movsd qword[reg+offs], xmm *) |
BEGIN |
_movsdrm(xmm, reg, offs, TRUE) |
END movsdmr; |
PROCEDURE opxx (op, xmm1, xmm2: INTEGER); |
BEGIN |
OutByte(0F2H); |
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN |
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8) |
END; |
OutByte3(0FH, op, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8) |
END opxx; |
PROCEDURE jcc (cc, label: INTEGER); (* jcc label *) |
BEGIN |
X86.jcc(cc, label) |
END jcc; |
PROCEDURE shiftrc (op, reg, n: INTEGER); |
BEGIN |
Rex(reg, 0); |
IF n = 1 THEN |
OutByte(0D1H) |
ELSE |
OutByte(0C1H) |
END; |
X86.shift(op, reg MOD 8); |
IF n # 1 THEN |
OutByte(n) |
END |
END shiftrc; |
PROCEDURE GetRegA; |
BEGIN |
ASSERT(REG.GetReg(R, rax)) |
END GetRegA; |
PROCEDURE Win64Passing (params: INTEGER); |
VAR |
n, i: INTEGER; |
BEGIN |
n := params MOD 32; |
params := params DIV 32; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(params) THEN |
movsdrm(i, rsp, i * 8) |
ELSE |
movrm(Win64RegPar[i], rsp, i * 8) |
END |
END |
END Win64Passing; |
PROCEDURE SysVPassing (params: INTEGER); |
VAR |
n, i, s, p, ofs: INTEGER; |
i_count, f_count: INTEGER; |
reg: BOOLEAN; |
BEGIN |
ASSERT(r11 IN R.regs); |
n := params MOD 32; |
params := params DIV 32; |
s := 0; |
i_count := 0; |
f_count := 0; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(params) THEN |
INC(f_count) |
ELSE |
INC(i_count) |
END |
END; |
s := MAX(0, f_count - 8) + MAX(0, i_count - 6); |
p := 0; |
subrc(rsp, s * 8); |
i_count := 0; |
f_count := 0; |
FOR i := 0 TO n - 1 DO |
ofs := (i + s) * 8; |
IF i IN BITS(params) THEN |
reg := f_count <= 7; |
IF reg THEN |
movsdrm(f_count, rsp, ofs); |
INC(f_count) |
END |
ELSE |
reg := i_count <= 5; |
IF reg THEN |
movrm(SystemVRegPar[i_count], rsp, ofs); |
INC(i_count) |
END |
END; |
IF ~reg THEN |
movrm(r11, rsp, ofs); |
movmr(rsp, p, r11); |
INC(p, 8) |
END |
END |
END SysVPassing; |
PROCEDURE fcmp (op: INTEGER; xmm: INTEGER); |
VAR |
cc, reg: INTEGER; |
BEGIN |
reg := GetAnyReg(); |
xor(reg, reg); |
CASE op OF |
|IL.opEQF: |
comisd(xmm - 1, xmm); |
cc := sete |
|IL.opNEF: |
comisd(xmm - 1, xmm); |
cc := setne |
|IL.opLTF: |
comisd(xmm - 1, xmm); |
cc := setc |
|IL.opGTF: |
comisd(xmm, xmm - 1); |
cc := setc |
|IL.opLEF: |
comisd(xmm, xmm - 1); |
cc := setnc |
|IL.opGEF: |
comisd(xmm - 1, xmm); |
cc := setnc |
END; |
OutByte2(7AH, 3 + reg DIV 8); (* jp L *) |
X86.setcc(cc, reg) |
(* L: *) |
END fcmp; |
PROCEDURE translate (commands: LISTS.LIST; stroffs: INTEGER); |
VAR |
cmd, next: COMMAND; |
opcode, param1, param2, param3, a, b, c, n, label, L, i, cc: INTEGER; |
reg1, reg2, xmm: INTEGER; |
float: REAL; |
BEGIN |
xmm := -1; |
cmd := commands.first(COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
X86.jmp(param1) |
|IL.opCALL, IL.opWIN64CALL, IL.opSYSVCALL: |
CASE opcode OF |
|IL.opCALL: |
|IL.opWIN64CALL: Win64Passing(param2) |
|IL.opSYSVCALL: SysVPassing(param2) |
END; |
X86.call(param1) |
|IL.opCALLP, IL.opWIN64CALLP, IL.opSYSVCALLP: |
UnOp(reg1); |
IF reg1 # rax THEN |
mov(rax, reg1) |
END; |
drop; |
CASE opcode OF |
|IL.opCALLP: |
|IL.opWIN64CALLP: Win64Passing(param2) |
|IL.opSYSVCALLP: SysVPassing(param2) |
END; |
OutByte2(0FFH, 0D0H); (* call rax *) |
ASSERT(R.top = -1) |
|IL.opCALLI, IL.opWIN64CALLI, IL.opSYSVCALLI: |
CASE opcode OF |
|IL.opCALLI: |
|IL.opWIN64CALLI: Win64Passing(param2) |
|IL.opSYSVCALLI: SysVPassing(param2) |
END; |
callimp(param1) |
|IL.opLABEL: |
X86.SetLabel(param1) |
|IL.opERR: |
CallRTL(IL._error) |
|IL.opONERR: |
pushc(param2); |
X86.jmp(param1) |
|IL.opPUSHC: |
pushc(param2) |
|IL.opPRECALL: |
PushAll(0); |
IF (param2 # 0) & (xmm >= 0) THEN |
subrc(rsp, 8) |
END; |
INC(Xmm[0]); |
Xmm[Xmm[0]] := xmm + 1; |
WHILE xmm >= 0 DO |
subrc(rsp, 8); |
movsdmr(rsp, 0, xmm); |
DEC(xmm) |
END; |
ASSERT(xmm = -1) |
|IL.opWIN64ALIGN16: |
ASSERT(rax IN R.regs); |
mov(rax, rsp); |
andrc(rsp, -16); |
push(rax); |
subrc(rsp, (MAX(param2 - 4, 0) MOD 2 + MAX(4 - param2, 0) + 1) * 8) |
|IL.opSYSVALIGN16: |
ASSERT(rax IN R.regs); |
mov(rax, rsp); |
andrc(rsp, -16); |
push(rax); |
IF ~ODD(param2) THEN |
push(rax) |
END |
|IL.opRESF, IL.opRES: |
ASSERT(R.top = -1); |
ASSERT(xmm = -1); |
n := Xmm[Xmm[0]]; DEC(Xmm[0]); |
IF opcode = IL.opRESF THEN |
INC(xmm); |
IF n > 0 THEN |
movsdmr(rsp, n * 8, 0); |
DEC(xmm); |
INC(n) |
END; |
IF xmm + n > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END |
ELSE |
GetRegA |
END; |
WHILE n > 0 DO |
INC(xmm); |
movsdrm(xmm, rsp, 0); |
addrc(rsp, 8); |
DEC(n) |
END |
|IL.opENTER: |
ASSERT(R.top = -1); |
X86.SetLabel(param1); |
param3 := cmd.param3; |
IF param3 > 0 THEN |
push(rbp); |
mov(rbp, rsp); |
n := param3 MOD 32; |
param3 := param3 DIV 32; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(param3) THEN |
movsdmr(rbp, i * 8 + 16, i) |
ELSE |
movmr(rbp, i * 8 + 16, Win64RegPar[i]) |
END |
END |
ELSIF param3 < 0 THEN |
param3 := -param3; |
n := (param3 MOD 32) * 8; |
param3 := param3 DIV 32; |
pop(r11); |
subrc(rsp, n); |
push(r11); |
push(rbp); |
mov(rbp, rsp); |
a := 0; |
b := 0; |
c := 0; |
INC(n, 16); |
FOR i := 16 TO n - 8 BY 8 DO |
IF ODD(param3) THEN |
IF b <= 7 THEN |
movsdmr(rbp, i, b); |
INC(b) |
ELSE |
movrm(r11, rbp, n + c); |
movmr(rbp, i, r11); |
INC(c, 8) |
END |
ELSE |
IF a <= 5 THEN |
movmr(rbp, i, SystemVRegPar[a]); |
INC(a) |
ELSE |
movrm(r11, rbp, n + c); |
movmr(rbp, i, r11); |
INC(c, 8) |
END |
END; |
param3 := param3 DIV 2 |
END |
ELSE |
push(rbp); |
mov(rbp, rsp) |
END; |
n := param2; |
IF n > 4 THEN |
movrc(rcx, n); |
(* L: *) |
pushc(0); |
OutByte2(0E2H, 0FCH) (* loop L *) |
ELSE |
WHILE n > 0 DO |
pushc(0); |
DEC(n) |
END |
END |
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF: |
IF opcode = IL.opLEAVER THEN |
UnOp(reg1); |
IF reg1 # rax THEN |
mov(rax, reg1) |
END; |
drop |
END; |
ASSERT(R.top = -1); |
IF opcode = IL.opLEAVEF THEN |
DEC(xmm) |
END; |
ASSERT(xmm = -1); |
IF param1 > 0 THEN |
mov(rsp, rbp) |
END; |
pop(rbp); |
IF param2 > 0 THEN |
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) (* ret param2*8 *) |
ELSE |
X86.ret |
END |
|IL.opSAVES: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushDA(stroffs + param2); |
push(reg1); |
drop; |
pushc(param1); |
CallRTL(IL._move) |
|IL.opSADR: |
lea(GetAnyReg(), stroffs + param2, sDATA) |
|IL.opLOAD8: |
UnOp(reg1); |
movzx(reg1, reg1, 0, FALSE) |
|IL.opLOAD16: |
UnOp(reg1); |
movzx(reg1, reg1, 0, TRUE) |
|IL.opLOAD32: |
UnOp(reg1); |
movrm32(reg1, reg1, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32) |
|IL.opLOAD64: |
UnOp(reg1); |
movrm(reg1, reg1, 0) |
|IL.opLLOAD64: |
reg1 := GetAnyReg(); |
movrm(reg1, rbp, param2 * 8) |
|IL.opLLOAD8, |
IL.opLLOAD16: |
reg1 := GetAnyReg(); |
movzx(reg1, rbp, param2 * 8, opcode = IL.opLLOAD16) |
|IL.opLLOAD32: |
reg1 := GetAnyReg(); |
movrm32(reg1, rbp, param2 * 8); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32) |
|IL.opGLOAD64: |
reg1 := GetAnyReg(); |
Rex(0, reg1); (* mov reg1, qword[rip + param2 + BSS] *) |
OutByte2(8BH, 05H + 8 * (reg1 MOD 8)); |
X86.Reloc(sBSS, param2) |
|IL.opGLOAD8, IL.opGLOAD16: |
reg1 := GetAnyReg(); |
Rex(0, reg1); (* movzx reg1, byte/word[rip + param2 + BSS] *) |
OutByte3(0FH, 0B6H + ORD(opcode = IL.opGLOAD16), 05H + 8 * (reg1 MOD 8)); |
X86.Reloc(sBSS, param2) |
|IL.opGLOAD32: |
reg1 := GetAnyReg(); |
lea(reg1, param2, sBSS); |
movrm32(reg1, reg1, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32) |
|IL.opVLOAD64: |
reg1 := GetAnyReg(); |
movrm(reg1, rbp, param2 * 8); |
movrm(reg1, reg1, 0) |
|IL.opVLOAD8, |
IL.opVLOAD16: |
reg1 := GetAnyReg(); |
movrm(reg1, rbp, param2 * 8); |
movzx(reg1, reg1, 0, opcode = IL.opVLOAD16) |
|IL.opVLOAD32: |
reg1 := GetAnyReg(); |
reg2 := GetAnyReg(); |
movrm(reg2, rbp, param2 * 8); |
movrm32(reg1, reg2, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32); |
drop |
|IL.opLADR: |
n := param2 * 8; |
next := cmd.next(COMMAND); |
IF (next.opcode = IL.opSAVEF) OR (next.opcode = IL.opSAVEFI) THEN |
ASSERT(xmm >= 0); |
movsdmr(rbp, n, xmm); |
DEC(xmm); |
cmd := next |
ELSIF next.opcode = IL.opLOADF THEN |
INC(xmm); |
IF xmm > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, next.param1, next.param2, FPR_ERR) |
END; |
movsdrm(xmm, rbp, n); |
cmd := next |
ELSE |
IF (next.opcode = IL.opADDC) & ~isLong(n + next.param2) THEN |
INC(n, next.param2); |
cmd := next |
END; |
reg1 := GetAnyReg(); |
Rex(0, reg1); |
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); (* lea reg1, qword[rbp+n] *) |
OutIntByte(n) |
END |
|IL.opGADR: |
next := cmd.next(COMMAND); |
IF (next.opcode = IL.opADDC) & ~isLong(param2 + next.param2) THEN |
INC(param2, next.param2); |
cmd := next |
END; |
lea(GetAnyReg(), param2, sBSS) |
|IL.opVADR: |
movrm(GetAnyReg(), rbp, param2 * 8) |
|IL.opSAVE8C: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0C6H, reg1 MOD 8, param2); (* mov byte[reg1], param2 *) |
drop |
|IL.opSAVE16C: |
UnOp(reg1); |
OutByte(66H); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte2(0C7H, reg1 MOD 8); |
OutByte2(param2 MOD 256, param2 DIV 256); (* mov word[reg1], param2 *) |
drop |
|IL.opSAVEC: |
UnOp(reg1); |
IF isLong(param2) THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2); |
movmr(reg1, 0, reg2); |
drop |
ELSE |
Rex(reg1, 0); |
OutByte2(0C7H, reg1 MOD 8); (* mov qword[reg1], param2 *) |
OutInt(param2) |
END; |
drop |
|IL.opRSET: |
PushAll(2); |
CallRTL(IL._set); |
GetRegA |
|IL.opRSETR: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._set); |
GetRegA |
|IL.opRSETL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(IL._set); |
GetRegA |
|IL.opRSET1: |
PushAll(1); |
CallRTL(IL._set1); |
GetRegA |
|IL.opINCL, IL.opEXCL: |
BinOp(reg1, reg2); |
cmprc(reg1, 64); |
OutByte2(73H, 04H); (* jnb L *) |
Rex(reg2, reg1); |
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); (* bts/btr qword[reg2], reg1 *) |
(* L: *) |
drop; |
drop |
|IL.opINCLC, IL.opEXCLC: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); (* bts/btr qword[reg1], param2 *) |
OutByte2(28H + 8 * ORD(opcode = IL.opEXCLC) + reg1 MOD 8, param2); |
drop |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
pushc(opcode - IL.opEQS); |
CallRTL(IL._strcmp); |
GetRegA |
|IL.opEQSW .. IL.opGESW: |
PushAll(4); |
pushc(opcode - IL.opEQSW); |
CallRTL(IL._strcmpw); |
GetRegA |
|IL.opCONST: |
movrc(GetAnyReg(), param2) |
|IL.opEQ..IL.opGE, |
IL.opEQC..IL.opGEC: |
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
drop |
ELSE |
UnOp(reg1); |
cmprc(reg1, param2) |
END; |
drop; |
cc := X86.cond(opcode); |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opJNZ THEN |
jcc(cc, next.param1); |
cmd := next |
ELSIF next.opcode = IL.opJZ THEN |
jcc(X86.inv0(cc), next.param1); |
cmd := next |
ELSE |
reg1 := GetAnyReg(); |
X86.setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END |
|IL.opCODE: |
OutByte(param2) |
|IL.opPUSHIP: |
reg1 := GetAnyReg(); |
lea(reg1, param2, sIMP); |
movrm(reg1, reg1, 0) |
|IL.opPARAM: |
n := param2; |
IF n = 1 THEN |
UnOp(reg1); |
push(reg1); |
drop |
ELSE |
ASSERT(R.top + 1 <= n); |
PushAll(n) |
END |
|IL.opJNZ1: |
UnOp(reg1); |
test(reg1); |
jcc(jne, param1) |
|IL.opJG: |
UnOp(reg1); |
test(reg1); |
jcc(jg, param1) |
|IL.opJNZ: |
UnOp(reg1); |
test(reg1); |
jcc(jne, param1); |
drop |
|IL.opJZ: |
UnOp(reg1); |
test(reg1); |
jcc(je, param1); |
drop |
|IL.opIN, IL.opINR: |
IF opcode = IL.opINR THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2) |
END; |
label := NewLabel(); |
L := NewLabel(); |
BinOp(reg1, reg2); |
cmprc(reg1, 64); |
jcc(jb, L); |
xor(reg1, reg1); |
X86.jmp(label); |
X86.SetLabel(L); |
Rex(reg2, reg1); |
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); (* bt reg2, reg1 *) |
X86.setcc(setc, reg1); |
andrc(reg1, 1); |
X86.SetLabel(label); |
drop |
|IL.opINL: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); (* bt reg1, param2 *) |
OutByte2(0E0H + reg1 MOD 8, param2); |
X86.setcc(setc, reg1); |
andrc(reg1, 1) |
|IL.opNOT: |
UnOp(reg1); |
test(reg1); |
X86.setcc(sete, reg1); |
andrc(reg1, 1) |
|IL.opORD: |
UnOp(reg1); |
test(reg1); |
X86.setcc(setne, reg1); |
andrc(reg1, 1) |
|IL.opABS: |
UnOp(reg1); |
test(reg1); |
OutByte2(7DH, 03H); (* jge L *) |
neg(reg1) |
(* L: *) |
|IL.opEQB, IL.opNEB: |
BinOp(reg1, reg2); |
drop; |
test(reg1); |
label := NewLabel(); |
jcc(je, label); |
movrc(reg1, 1); |
X86.SetLabel(label); |
test(reg2); |
label := NewLabel(); |
jcc(je, label); |
movrc(reg2, 1); |
X86.SetLabel(label); |
cmprr(reg1, reg2); |
IF opcode = IL.opEQB THEN |
X86.setcc(sete, reg1) |
ELSE |
X86.setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|IL.opMULSC: |
UnOp(reg1); |
andrc(reg1, param2) |
|IL.opDIVSC: |
UnOp(reg1); |
xorrc(reg1, param2) |
|IL.opADDSC: |
UnOp(reg1); |
orrc(reg1, param2) |
|IL.opSUBSL: |
UnOp(reg1); |
not(reg1); |
andrc(reg1, param2) |
|IL.opSUBSR: |
UnOp(reg1); |
andrc(reg1, ORD(-BITS(param2))) |
|IL.opMULS: |
BinOp(reg1, reg2); |
and(reg1, reg2); |
drop |
|IL.opDIVS: |
BinOp(reg1, reg2); |
xor(reg1, reg2); |
drop |
|IL.opUMINS: |
UnOp(reg1); |
not(reg1) |
|IL.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(IL._move) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(IL._move) |
|IL.opCOPYA: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._arrcpy); |
GetRegA |
|IL.opCOPYS: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._strcpy) |
|IL.opROT: |
PushAll(0); |
push(rsp); |
pushc(param2); |
CallRTL(IL._rot) |
|IL.opNEW: |
PushAll(1); |
n := param2 + 8; |
ASSERT(UTILS.Align(n, 8)); |
pushc(n); |
pushc(param1); |
CallRTL(IL._new) |
|IL.opDISP: |
PushAll(1); |
CallRTL(IL._dispose) |
|IL.opPUSHT: |
UnOp(reg1); |
movrm(GetAnyReg(), reg1, -8) |
|IL.opISREC: |
PushAll(2); |
pushc(param2 * tcount); |
CallRTL(IL._isrec); |
GetRegA |
|IL.opIS: |
PushAll(1); |
pushc(param2 * tcount); |
CallRTL(IL._is); |
GetRegA |
|IL.opTYPEGR: |
PushAll(1); |
pushc(param2 * tcount); |
CallRTL(IL._guardrec); |
GetRegA |
|IL.opTYPEGP: |
UnOp(reg1); |
PushAll(0); |
push(reg1); |
pushc(param2 * tcount); |
CallRTL(IL._guard); |
GetRegA |
|IL.opTYPEGD: |
UnOp(reg1); |
PushAll(0); |
X86.pushm(reg1, -8); |
pushc(param2 * tcount); |
CallRTL(IL._guardrec); |
GetRegA |
|IL.opCASET: |
push(rcx); |
push(rcx); |
pushc(param2 * tcount); |
CallRTL(IL._guardrec); |
pop(rcx); |
test(rax); |
jcc(jne, param1) |
|IL.opSAVEP: |
UnOp(reg1); |
reg2 := GetAnyReg(); |
lea(reg2, param2, sCODE); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|IL.opPUSHP: |
lea(GetAnyReg(), param2, sCODE) |
|IL.opINC, IL.opDEC: |
BinOp(reg1, reg2); |
(* add/sub qword[reg2], reg1 *) |
Rex(reg2, reg1); |
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg2 MOD 8 + (reg1 MOD 8) * 8); |
drop; |
drop |
|IL.opINCC: |
UnOp(reg1); |
IF isLong(param2) THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2); |
(* add qword[reg1], reg2 *) |
Rex(reg1, reg2); |
OutByte2(01H, reg1 MOD 8 + (reg2 MOD 8) * 8); |
drop |
ELSIF ABS(param2) = 1 THEN |
Rex(reg1, 0); |
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(param2 = -1)) (* inc/dec qword[reg1] *) |
ELSE |
(* add qword[reg1], param2 *) |
Rex(reg1, 0); |
OutByte2(81H + short(param2), reg1 MOD 8); |
OutIntByte(param2) |
END; |
drop |
|IL.opDROP: |
UnOp(reg1); |
drop |
|IL.opSAVE, IL.opSAVE64: |
BinOp(reg2, reg1); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(reg2, reg1); |
X86.movmr8(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVE16: |
BinOp(reg2, reg1); |
X86.movmr16(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVE32: |
BinOp(reg2, reg1); |
movmr32(reg1, 0, reg2); |
drop; |
drop |
|IL.opMAX, IL.opMIN: |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
OutByte2(7DH + ORD(opcode = IL.opMIN), 3); (* jge/jle L *) |
mov(reg1, reg2); |
(* L: *) |
drop |
|IL.opMAXC, IL.opMINC: |
UnOp(reg1); |
cmprc(reg1, param2); |
label := NewLabel(); |
IF opcode = IL.opMINC THEN |
cc := jle |
ELSE |
cc := jge |
END; |
jcc(cc, label); |
movrc(reg1, param2); |
X86.SetLabel(label) |
|IL.opSBOOL: |
BinOp(reg2, reg1); |
test(reg2); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0FH, 95H, reg1 MOD 8); (* setne byte[reg1] *) |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *) |
drop |
|IL.opUMINUS: |
UnOp(reg1); |
neg(reg1) |
|IL.opADD: |
BinOp(reg1, reg2); |
add(reg1, reg2); |
drop |
|IL.opSUB: |
BinOp(reg1, reg2); |
sub(reg1, reg2); |
drop |
|IL.opSUBR, IL.opSUBL: |
UnOp(reg1); |
IF param2 = 1 THEN |
decr(reg1) |
ELSIF param2 = -1 THEN |
incr(reg1) |
ELSIF param2 # 0 THEN |
subrc(reg1, param2) |
END; |
IF opcode = IL.opSUBL THEN |
neg(reg1) |
END |
|IL.opADDC: |
IF (param2 # 0) & ~isLong(param2) THEN |
UnOp(reg1); |
next := cmd.next(COMMAND); |
CASE next.opcode OF |
|IL.opLOAD64: |
movrm(reg1, reg1, param2); |
cmd := next |
|IL.opLOAD32: |
movrm32(reg1, reg1, param2); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32); |
cmd := next |
|IL.opLOAD16: |
movzx(reg1, reg1, param2, TRUE); |
cmd := next |
|IL.opLOAD8: |
movzx(reg1, reg1, param2, FALSE); |
cmd := next |
|IL.opLOAD64_PARAM: |
X86.pushm(reg1, param2); |
drop; |
cmd := next |
ELSE |
IF param2 = 1 THEN |
incr(reg1) |
ELSIF param2 = -1 THEN |
decr(reg1) |
ELSE |
addrc(reg1, param2) |
END |
END |
ELSIF isLong(param2) THEN |
UnOp(reg1); |
addrc(reg1, param2) |
END |
|IL.opDIV: |
PushAll(2); |
CallRTL(IL._divmod); |
GetRegA |
|IL.opDIVR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(reg1); |
shiftrc(sar, reg1, n) |
ELSIF n < 0 THEN |
PushAll(1); |
pushc(param2); |
CallRTL(IL._divmod); |
GetRegA |
END |
|IL.opDIVL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(IL._divmod); |
GetRegA |
|IL.opMOD: |
PushAll(2); |
CallRTL(IL._divmod); |
mov(rax, rdx); |
GetRegA |
|IL.opMODR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(reg1); |
andrc(reg1, param2 - 1); |
ELSIF n < 0 THEN |
PushAll(1); |
pushc(param2); |
CallRTL(IL._divmod); |
mov(rax, rdx); |
GetRegA |
ELSE |
UnOp(reg1); |
xor(reg1, reg1) |
END |
|IL.opMODL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(IL._divmod); |
mov(rax, rdx); |
GetRegA |
|IL.opMUL: |
BinOp(reg1, reg2); |
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *) |
drop |
|IL.opMULC: |
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN |
BinOp(reg1, reg2); |
OutByte2(48H + 5 * (reg1 DIV 8) + 2 * (reg2 DIV 8), 8DH); (* lea reg1, [reg1 + reg2 * param2] *) |
reg1 := reg1 MOD 8; |
reg2 := reg2 MOD 8; |
OutByte2(04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2)); |
drop; |
cmd := cmd.next(COMMAND) |
ELSE |
UnOp(reg1); |
a := param2; |
IF a > 1 THEN |
n := UTILS.Log2(a) |
ELSIF a < -1 THEN |
n := UTILS.Log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
neg(reg1) |
ELSIF a = 0 THEN |
xor(reg1, reg1) |
ELSE |
IF n > 0 THEN |
IF a < 0 THEN |
neg(reg1) |
END; |
shiftrc(shl, reg1, n) |
ELSE |
IF isLong(a) THEN |
reg2 := GetAnyReg(); |
movabs(reg2, a); |
ASSERT(reg1 # reg2); |
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *) |
drop |
ELSE |
(* imul reg1, a *) |
Rex(reg1, reg1); |
OutByte2(69H + short(a), 0C0H + (reg1 MOD 8) * 9); |
OutIntByte(a) |
END |
END |
END |
END |
|IL.opADDS: |
BinOp(reg1, reg2); |
_or(reg1, reg2); |
drop |
|IL.opSUBS: |
BinOp(reg1, reg2); |
not(reg2); |
and(reg1, reg2); |
drop |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opSWITCH: |
UnOp(reg1); |
IF param2 = 0 THEN |
reg2 := rax |
ELSE |
reg2 := rcx |
END; |
IF reg1 # reg2 THEN |
ASSERT(REG.GetReg(R, reg2)); |
ASSERT(REG.Exchange(R, reg1, reg2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
GetRegA; |
cmprc(rax, param1); |
jcc(jl, param2); |
drop |
|IL.opCASER: |
GetRegA; |
cmprc(rax, param1); |
jcc(jg, param2); |
drop |
|IL.opCASELR: |
GetRegA; |
cmprc(rax, param1); |
IF param2 = cmd.param3 THEN |
jcc(jne, param2) |
ELSE |
jcc(jl, param2); |
jcc(jg, cmd.param3) |
END; |
drop |
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR: |
UnOp(reg1); |
IF reg1 # rcx THEN |
ASSERT(REG.GetReg(R, rcx)); |
ASSERT(REG.Exchange(R, reg1, rcx)); |
drop |
END; |
BinOp(reg1, reg2); |
ASSERT(reg2 = rcx); |
Rex(reg1, 0); |
OutByte(0D3H); |
X86.shift(opcode, reg1 MOD 8); (* shift reg1, cl *) |
drop |
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1: |
UnOp(reg1); |
IF reg1 # rcx THEN |
ASSERT(REG.GetReg(R, rcx)); |
ASSERT(REG.Exchange(R, reg1, rcx)); |
drop |
END; |
reg1 := GetAnyReg(); |
movrc(reg1, param2); |
BinOp(reg1, reg2); |
ASSERT(reg1 = rcx); |
Rex(reg2, 0); |
OutByte(0D3H); |
X86.shift(opcode, reg2 MOD 8); (* shift reg2, cl *) |
drop; |
drop; |
ASSERT(REG.GetReg(R, reg2)) |
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2: |
UnOp(reg1); |
shiftrc(opcode, reg1, param2 MOD 64) |
|IL.opGET, IL.opGETC: |
IF opcode = IL.opGET THEN |
BinOp(reg1, reg2) |
ELSIF opcode = IL.opGETC THEN |
UnOp(reg2); |
reg1 := GetAnyReg(); |
movrc(reg1, param1) |
END; |
drop; |
drop; |
X86._movrm(reg1, reg1, 0, param2 * 8, FALSE); |
X86._movrm(reg1, reg2, 0, param2 * 8, TRUE) |
|IL.opCHKBYTE: |
BinOp(reg1, reg2); |
cmprc(reg1, 256); |
jcc(jb, param1) |
|IL.opCHKIDX: |
UnOp(reg1); |
cmprc(reg1, param2); |
jcc(jb, param1) |
|IL.opCHKIDX2: |
BinOp(reg1, reg2); |
IF param2 # -1 THEN |
cmprr(reg2, reg1); |
jcc(jb, param1); |
END; |
INCL(R.regs, reg1); |
DEC(R.top); |
R.stk[R.top] := reg2 |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(IL._length); |
GetRegA |
|IL.opLENGTHW: |
PushAll(2); |
CallRTL(IL._lengthw); |
GetRegA |
|IL.opLEN: |
n := param2; |
UnOp(reg1); |
drop; |
EXCL(R.regs, reg1); |
WHILE n > 0 DO |
UnOp(reg2); |
drop; |
DEC(n) |
END; |
INCL(R.regs, reg1); |
ASSERT(REG.GetReg(R, reg1)) |
|IL.opCHR: |
UnOp(reg1); |
andrc(reg1, 255) |
|IL.opWCHR: |
UnOp(reg1); |
andrc(reg1, 65535) |
|IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP: |
UnOp(reg1); |
reg2 := GetAnyReg(); |
CASE opcode OF |
|IL.opEQP, IL.opNEP: |
lea(reg2, param1, sCODE) |
|IL.opEQIP, IL.opNEIP: |
lea(reg2, param1, sIMP); |
movrm(reg2, reg2, 0) |
END; |
cmprr(reg1, reg2); |
drop; |
drop; |
reg1 := GetAnyReg(); |
CASE opcode OF |
|IL.opEQP, IL.opEQIP: X86.setcc(sete, reg1) |
|IL.opNEP, IL.opNEIP: X86.setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|IL.opINCCB, IL.opDECCB: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1 MOD 8, param2 MOD 256); (* add/sub byte[reg1], param2 MOD 256 *) |
drop |
|IL.opINCB, IL.opDECB: |
BinOp(reg1, reg2); |
IF (reg1 >= 8) OR (reg2 >= 8) THEN |
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8)) |
END; |
OutByte2(28H * ORD(opcode = IL.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); (* add/sub byte[reg2], reg1_8 *) |
drop; |
drop |
|IL.opSAVEIP: |
UnOp(reg1); |
reg2 := GetAnyReg(); |
lea(reg2, param2, sIMP); |
movrm(reg2, reg2, 0); |
push(reg2); |
drop; |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte2(8FH, reg1 MOD 8); (* pop qword[reg1] *) |
drop |
|IL.opCLEANUP: |
IF param2 # 0 THEN |
addrc(rsp, param2 * 8) |
END |
|IL.opPOPSP: |
pop(rsp) |
|IL.opLOADF: |
UnOp(reg1); |
INC(xmm); |
IF xmm > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
movsdrm(xmm, reg1, 0); |
drop |
|IL.opPUSHF: |
ASSERT(xmm >= 0); |
subrc(rsp, 8); |
movsdmr(rsp, 0, xmm); |
DEC(xmm) |
|IL.opCONSTF: |
float := cmd.float; |
INC(xmm); |
IF xmm > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
(* movsd xmm, qword ptr [rip + Numbers_Offs + Numbers_Count * 8 + DATA] *) |
OutByte(0F2H); |
IF xmm >= 8 THEN |
OutByte(44H) |
END; |
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8)); |
X86.Reloc(sDATA, Numbers_Offs + Numbers_Count * 8); |
NewNumber(UTILS.splitf(float, a, b)) |
|IL.opSAVEF, IL.opSAVEFI: |
ASSERT(xmm >= 0); |
UnOp(reg1); |
movsdmr(reg1, 0, xmm); |
DEC(xmm); |
drop |
|IL.opADDF: |
ASSERT(xmm >= 1); |
opxx(58H, xmm - 1, xmm); |
DEC(xmm) |
|IL.opSUBF: |
ASSERT(xmm >= 1); |
opxx(5CH, xmm - 1, xmm); |
DEC(xmm) |
|IL.opSUBFI: |
ASSERT(xmm >= 1); |
opxx(5CH, xmm, xmm - 1); |
opxx(10H, xmm - 1, xmm); |
DEC(xmm) |
|IL.opMULF: |
ASSERT(xmm >= 1); |
opxx(59H, xmm - 1, xmm); |
DEC(xmm) |
|IL.opDIVF: |
ASSERT(xmm >= 1); |
opxx(5EH, xmm - 1, xmm); |
DEC(xmm) |
|IL.opDIVFI: |
ASSERT(xmm >= 1); |
opxx(5EH, xmm, xmm - 1); |
opxx(10H, xmm - 1, xmm); |
DEC(xmm) |
|IL.opFABS, IL.opUMINF: (* andpd/xorpd xmm, xmmword[rip + Numbers_Offs + (16) + DATA] *) |
ASSERT(xmm >= 0); |
OutByte(66H); |
IF xmm >= 8 THEN |
OutByte(44H) |
END; |
OutByte3(0FH, 54H + 3 * ORD(opcode = IL.opUMINF), 05H + (xmm MOD 8) * 8); |
X86.Reloc(sDATA, Numbers_Offs + 16 * ORD(opcode = IL.opFABS)) |
|IL.opFLT: |
UnOp(reg1); |
INC(xmm); |
IF xmm > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); (* cvtsi2sd xmm, reg1 *) |
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8); |
drop |
|IL.opFLOOR: |
ASSERT(xmm >= 0); |
reg1 := GetAnyReg(); |
subrc(rsp, 8); |
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); (* stmxcsr dword[rsp+4]; *) |
OutByte2(00FH, 0AEH); OutByte2(01CH, 024H); (* stmxcsr dword[rsp]; *) |
OutByte3(081H, 024H, 024H); OutByte2(0FFH, 09FH); OutByte2(0FFH, 0FFH); (* and dword[rsp],11111111111111111001111111111111b; *) |
OutByte3(081H, 00CH, 024H); OutByte2(000H, 020H); OutByte2(000H, 000H); (* or dword[rsp],00000000000000000010000000000000b; *) |
OutByte2(00FH, 0AEH); OutByte2(014H, 024H); (* ldmxcsr dword[rsp]; *) |
OutByte(0F2H); Rex(xmm, reg1); OutByte(0FH); (* cvtsd2si reg1, xmm *) |
OutByte2(2DH, 0C0H + xmm MOD 8 + (reg1 MOD 8) * 8); |
OutByte3(00FH, 0AEH, 054H); OutByte2(024H, 004H); (* ldmxcsr dword[rsp+4]; *) |
addrc(rsp, 8); |
DEC(xmm) |
|IL.opEQF .. IL.opGEF: |
ASSERT(xmm >= 1); |
fcmp(opcode, xmm); |
DEC(xmm, 2) |
|IL.opINF: |
INC(xmm); |
IF xmm > MAX_XMM THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
(* movsd xmm, qword ptr [rip + Numbers_Offs + 32 + DATA] *) |
OutByte(0F2H); |
IF xmm >= 8 THEN |
OutByte(44H) |
END; |
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8)); |
X86.Reloc(sDATA, Numbers_Offs + 32) |
|IL.opPACK, IL.opPACKC: |
IF opcode = IL.opPACK THEN |
BinOp(reg1, reg2) |
ELSE |
UnOp(reg1); |
reg2 := GetAnyReg(); |
movrc(reg2, param2) |
END; |
push(reg1); |
movrm(reg1, reg1, 0); |
shiftrc(shl, reg1, 1); |
shiftrc(shr, reg1, 53); |
add(reg1, reg2); |
andrc(reg1, ORD({0..10})); |
shiftrc(shl, reg1, 52); |
movrm(reg2, rsp, 0); |
movrm(reg2, reg2, 0); |
push(reg1); |
lea(reg1, Numbers_Offs + 40, sDATA); (* {0..51, 63} *) |
movrm(reg1, reg1, 0); |
and(reg2, reg1); |
pop(reg1); |
_or(reg2, reg1); |
pop(reg1); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|IL.opUNPK, IL.opLADR_UNPK: |
IF opcode = IL.opLADR_UNPK THEN |
n := param2 * 8; |
UnOp(reg1); |
reg2 := GetAnyReg(); |
Rex(0, reg2); |
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); (* lea reg2, qword[rbp+n] *) |
OutIntByte(n) |
ELSE |
BinOp(reg1, reg2) |
END; |
push(reg1); |
movrm(reg1, reg1, 0); |
shiftrc(shl, reg1, 1); |
shiftrc(shr, reg1, 53); |
subrc(reg1, 1023); |
movmr(reg2, 0, reg1); |
pop(reg2); |
movrm(reg1, reg2, 0); |
push(reg2); |
lea(reg2, Numbers_Offs + 48, sDATA); (* {52..61} *) |
movrm(reg2, reg2, 0); |
_or(reg1, reg2); |
pop(reg2); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); |
OutByte2(0F0H + reg1 MOD 8, 3EH); (* btr reg1, 62 *) |
movmr(reg2, 0, reg1); |
drop; |
drop |
|IL.opSADR_PARAM: |
pushDA(stroffs + param2) |
|IL.opVADR_PARAM: |
X86.pushm(rbp, param2 * 8) |
|IL.opLOAD64_PARAM: |
UnOp(reg1); |
X86.pushm(reg1, 0); |
drop |
|IL.opLLOAD64_PARAM: |
X86.pushm(rbp, param2 * 8) |
|IL.opGLOAD64_PARAM: |
OutByte2(0FFH, 35H); (* push qword[rip + param2 + BSS] *) |
X86.Reloc(sBSS, param2) |
|IL.opCONST_PARAM: |
pushc(param2) |
|IL.opGLOAD32_PARAM, IL.opLOAD32_PARAM: |
IF opcode = IL.opGLOAD32_PARAM THEN |
reg1 := GetAnyReg(); |
lea(reg1, param2, sBSS) |
ELSE |
UnOp(reg1) |
END; |
movrm32(reg1, reg1, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32); |
push(reg1); |
drop |
|IL.opLLOAD32_PARAM: |
reg1 := GetAnyReg(); |
movrm32(reg1, rbp, param2 * 8); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32); |
push(reg1); |
drop |
|IL.opLADR_SAVEC: |
n := param1 * 8; |
IF isLong(param2) THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2); |
movmr(rbp, n, reg2); |
drop |
ELSE |
OutByte3(48H, 0C7H, 45H + long(n)); (* mov qword[rbp+n], param2 *) |
OutIntByte(n); |
OutInt(param2) |
END |
|IL.opGADR_SAVEC: |
IF isLong(param2) THEN |
reg1 := GetAnyReg(); |
movrc(reg1, param2); |
reg2 := GetAnyReg(); |
lea(reg2, param1, sBSS); |
movmr(reg2, 0, reg1); |
drop; |
drop |
ELSE |
(* mov qword[rip + param1 - 4 + BSS], param2 *) |
OutByte3(48H, 0C7H, 05H); |
X86.Reloc(sBSS, param1 - 4); |
OutInt(param2) |
END |
|IL.opLADR_SAVE: |
UnOp(reg1); |
movmr(rbp, param2 * 8, reg1); |
drop |
|IL.opLADR_INCC: |
IF isLong(param2) THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2); |
n := param1 * 8; |
Rex(0, reg2); |
OutByte2(01H, 45H + long(n) + (reg2 MOD 8) * 8); |
OutIntByte(n); (* add qword[rbp+n], reg2 *) |
drop |
ELSIF ABS(param2) = 1 THEN |
n := param1 * 8; |
OutByte3(48H, 0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec qword[rbp+n] *) |
OutIntByte(n) |
ELSE |
n := param1 * 8; |
OutByte3(48H, 81H + short(param2), 45H + long(n)); |
OutIntByte(n); |
OutIntByte(param2) (* add qword[rbp+n], param2 *) |
END |
|IL.opLADR_INCCB, IL.opLADR_DECCB: |
param2 := param2 MOD 256; |
n := param1 * 8; |
OutByte2(80H, 45H + long(n) + 28H * ORD(opcode = IL.opLADR_DECCB)); |
OutIntByte(n); |
OutByte(param2) (* add/sub byte[rbp+n], param2 *) |
|IL.opLADR_INC, IL.opLADR_DEC: |
UnOp(reg1); |
n := param2 * 8; |
Rex(0, reg1); |
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + (reg1 MOD 8) * 8); |
OutIntByte(n); (* add/sub qword[rbp+n], reg1 *) |
drop |
|IL.opLADR_INCB, IL.opLADR_DECB: |
UnOp(reg1); |
n := param2 * 8; |
IF reg1 >= 8 THEN |
OutByte(44H) |
END; |
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + 8 * (reg1 MOD 8)); |
OutIntByte(n); (* add/sub byte[rbp+n], reg1_8 *) |
drop |
|IL.opLADR_INCL, IL.opLADR_EXCL: |
UnOp(reg1); |
cmprc(reg1, 64); |
n := param2 * 8; |
OutByte2(73H, 5 + 3 * ORD(~X86.isByte(n))); (* jnb L *) |
Rex(0, reg1); |
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8)); |
OutIntByte(n); (* bts/btr qword[rbp+n], reg1 *) |
(* L: *) |
drop |
|IL.opLADR_INCLC, IL.opLADR_EXCLC: |
n := param1 * 8; |
OutByte3(48H, 0FH, 0BAH); (* bts/btr qword[rbp+n], param2 *) |
OutByte(6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC)); |
OutIntByte(n); |
OutByte(param2) |
|IL.opFNAME: |
fname := cmd(IL.FNAMECMD).fname |
END; |
cmd := cmd.next(COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1); |
ASSERT(xmm = -1) |
END translate; |
PROCEDURE prolog (modname: ARRAY OF CHAR; target, stack_size: INTEGER); |
VAR |
ModName_Offs, entry, L: INTEGER; |
BEGIN |
ModName_Offs := tcount * 8 + CHL.Length(IL.codes.data); |
Numbers_Offs := ModName_Offs + LENGTH(modname) + 1; |
ASSERT(UTILS.Align(Numbers_Offs, 16)); |
entry := NewLabel(); |
X86.SetLabel(entry); |
IF target = TARGETS.Win64DLL THEN |
dllret := NewLabel(); |
push(r8); |
push(rdx); |
push(rcx); |
CallRTL(IL._dllentry); |
test(rax); |
jcc(je, dllret); |
pushc(0) |
ELSIF target = TARGETS.Linux64 THEN |
push(rsp) |
ELSE |
pushc(0) |
END; |
lea(rax, entry, sCODE); |
push(rax); |
pushDA(0); (* TYPES *) |
pushc(tcount); |
pushDA(ModName_Offs); (* MODNAME *) |
CallRTL(IL._init); |
IF target IN {TARGETS.Win64C, TARGETS.Win64GUI, TARGETS.Linux64} THEN |
L := NewLabel(); |
pushc(0); |
push(rsp); |
pushc(1024 * 1024 * stack_size); |
pushc(0); |
CallRTL(IL._new); |
pop(rax); |
test(rax); |
jcc(je, L); |
GetRegA; |
addrc(rax, 1024 * 1024 * stack_size - 8); |
drop; |
mov(rsp, rax); |
X86.SetLabel(L) |
END |
END prolog; |
PROCEDURE epilog (modname: ARRAY OF CHAR; target: INTEGER); |
VAR |
i, n: INTEGER; |
number: Number; |
exp: IL.EXPORT_PROC; |
PROCEDURE _import (imp: LISTS.LIST); |
VAR |
lib: IL.IMPORT_LIB; |
proc: IL.IMPORT_PROC; |
BEGIN |
lib := imp.first(IL.IMPORT_LIB); |
WHILE lib # NIL DO |
BIN.Import(prog, lib.name, 0); |
proc := lib.procs.first(IL.IMPORT_PROC); |
WHILE proc # NIL DO |
BIN.Import(prog, proc.name, proc.label); |
proc := proc.next(IL.IMPORT_PROC) |
END; |
lib := lib.next(IL.IMPORT_LIB) |
END |
END _import; |
BEGIN |
IF target = TARGETS.Win64DLL THEN |
X86.SetLabel(dllret); |
X86.ret |
ELSIF target = TARGETS.Linux64SO THEN |
sofinit := NewLabel(); |
X86.ret; |
X86.SetLabel(sofinit); |
CallRTL(IL._sofinit); |
X86.ret |
ELSE |
pushc(0); |
CallRTL(IL._exit) |
END; |
X86.fixup; |
i := 0; |
WHILE i < tcount DO |
BIN.PutData64LE(prog, CHL.GetInt(IL.codes.types, i)); |
INC(i) |
END; |
i := 0; |
WHILE i < CHL.Length(IL.codes.data) DO |
BIN.PutData(prog, CHL.GetByte(IL.codes.data, i)); |
INC(i) |
END; |
BIN.PutDataStr(prog, modname); |
BIN.PutData(prog, 0); |
n := CHL.Length(prog.data); |
ASSERT(UTILS.Align(n, 16)); |
i := n - CHL.Length(prog.data); |
WHILE i > 0 DO |
BIN.PutData(prog, 0); |
DEC(i) |
END; |
number := Numbers.first(Number); |
FOR i := 0 TO Numbers_Count - 1 DO |
BIN.PutData64LE(prog, number.value); |
number := number.next(Number) |
END; |
exp := IL.codes.export.first(IL.EXPORT_PROC); |
WHILE exp # NIL DO |
BIN.Export(prog, exp.name, exp.label); |
exp := exp.next(IL.EXPORT_PROC) |
END; |
_import(IL.codes._import) |
END epilog; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
VAR |
path, modname, ext: PATHS.PATH; |
BEGIN |
Xmm[0] := 0; |
tcount := CHL.Length(IL.codes.types); |
Win64RegPar[0] := rcx; |
Win64RegPar[1] := rdx; |
Win64RegPar[2] := r8; |
Win64RegPar[3] := r9; |
SystemVRegPar[0] := rdi; |
SystemVRegPar[1] := rsi; |
SystemVRegPar[2] := rdx; |
SystemVRegPar[3] := rcx; |
SystemVRegPar[4] := r8; |
SystemVRegPar[5] := r9; |
PATHS.split(outname, path, modname, ext); |
S.append(modname, ext); |
REG.Init(R, push, pop, mov, xchg, {rax, rcx, rdx, r8, r9, r10, r11}); |
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 8))); |
Numbers := LISTS.create(NIL); |
Numbers_Count := 0; |
NewNumber(ROR(1, 1)); (* 8000000000000000H *) |
NewNumber(0); |
NewNumber(ROR(-2, 1)); (* 7FFFFFFFFFFFFFFFH *) |
NewNumber(-1); |
NewNumber(ROR(7FFH, 12)); (* +Infinity *) |
NewNumber(ORD(-BITS(LSR(ASR(ROR(1, 1), 10), 1)))); (* {0..51, 63} *) |
NewNumber(LSR(ASR(ROR(1, 1), 9), 2)); (* {52..61} *) |
prog := BIN.create(IL.codes.lcount); |
BIN.SetParams(prog, IL.codes.bss, 1, WCHR(1), WCHR(0)); |
X86.SetProgram(prog); |
prolog(modname, target, options.stack); |
translate(IL.codes.commands, tcount * 8); |
epilog(modname, target); |
BIN.fixup(prog); |
IF TARGETS.OS = TARGETS.osWIN64 THEN |
PE32.write(prog, outname, target = TARGETS.Win64C, target = TARGETS.Win64DLL, TRUE) |
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN |
ELF.write(prog, outname, sofinit, target = TARGETS.Linux64SO, TRUE) |
END |
END CodeGen; |
END AMD64. |
/programs/develop/oberon07/source/ARITH.ob07 |
---|
0,0 → 1,806 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE ARITH; |
IMPORT STRINGS, UTILS, LISTS; |
CONST |
tINTEGER* = 1; tREAL* = 2; tSET* = 3; |
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6; |
tSTRING* = 7; |
opEQ* = 0; opNE* = 1; opLT* = 2; opLE* = 3; opGT* = 4; opGE* = 5; |
opIN* = 6; opIS* = 7; |
TYPE |
VALUE* = RECORD |
typ*: INTEGER; |
int: INTEGER; |
float: REAL; |
set: SET; |
bool: BOOLEAN; |
string*: LISTS.ITEM |
END; |
VAR |
digit: ARRAY 256 OF INTEGER; |
PROCEDURE Int* (v: VALUE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE v.typ OF |
|tINTEGER, tCHAR, tWCHAR: |
res := v.int |
|tSET: |
res := UTILS.Long(ORD(v.set)) |
|tBOOLEAN: |
res := ORD(v.bool) |
END |
RETURN res |
END Int; |
PROCEDURE getBool* (v: VALUE): BOOLEAN; |
BEGIN |
ASSERT(v.typ = tBOOLEAN); |
RETURN v.bool |
END getBool; |
PROCEDURE Float* (v: VALUE): REAL; |
BEGIN |
ASSERT(v.typ = tREAL); |
RETURN v.float |
END Float; |
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN; |
RETURN (a <= i.int) & (i.int <= b) |
END range; |
PROCEDURE check* (v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
CASE v.typ OF |
|tINTEGER: res := range(v, UTILS.target.minInt, UTILS.target.maxInt) |
|tCHAR: res := range(v, 0, 255) |
|tWCHAR: res := range(v, 0, 65535) |
|tREAL: res := (-UTILS.target.maxReal <= v.float) & (v.float <= UTILS.target.maxReal) |
END |
RETURN res |
END check; |
PROCEDURE isZero* (v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
CASE v.typ OF |
|tINTEGER: res := v.int = 0 |
|tREAL: res := v.float = 0.0 |
END |
RETURN res |
END isZero; |
PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: INTEGER; |
i: INTEGER; |
d: INTEGER; |
BEGIN |
error := 0; |
value := 0; |
i := 0; |
WHILE STRINGS.digit(s[i]) & (error = 0) DO |
d := digit[ORD(s[i])]; |
IF value <= (UTILS.maxint - d) DIV 10 THEN |
value := value * 10 + d; |
INC(i) |
ELSE |
error := 1 |
END |
END; |
IF error = 0 THEN |
v.int := value; |
v.typ := tINTEGER; |
IF ~check(v) THEN |
error := 1 |
END |
END |
END iconv; |
PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: INTEGER; |
i: INTEGER; |
n: INTEGER; |
d: INTEGER; |
BEGIN |
ASSERT(STRINGS.digit(s[0])); |
error := 0; |
value := 0; |
n := -1; |
i := 0; |
WHILE (s[i] # "H") & (s[i] # "X") & (s[i] # "h") & (s[i] # "x") & (error = 0) DO |
d := digit[ORD(s[i])]; |
IF (n = -1) & (d # 0) THEN |
n := i |
END; |
IF (n # -1) & (i - n + 1 > UTILS.target.maxHex) THEN |
error := 2 |
ELSE |
value := value * 16 + d; |
INC(i) |
END |
END; |
value := UTILS.Long(value); |
IF ((s[i] = "X") OR (s[i] = "x")) & (n # -1) & (i - n > 4) THEN |
error := 3 |
END; |
IF error = 0 THEN |
v.int := value; |
IF (s[i] = "X") OR (s[i] = "x") THEN |
v.typ := tCHAR; |
IF ~check(v) THEN |
v.typ := tWCHAR; |
IF ~check(v) THEN |
error := 3 |
END |
END |
ELSE |
v.typ := tINTEGER; |
IF ~check(v) THEN |
error := 2 |
END |
END |
END |
END hconv; |
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN; |
BEGIN |
CASE op OF |
|"+": a := a + b |
|"-": a := a - b |
|"*": a := a * b |
|"/": a := a / b |
END |
RETURN (-UTILS.maxreal <= a) & (a <= UTILS.maxreal) (* +inf > UTILS.maxreal *) |
END opFloat2; |
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: REAL; |
frac: REAL; |
exp10: REAL; |
i, n, d: INTEGER; |
minus: BOOLEAN; |
BEGIN |
error := 0; |
value := 0.0; |
frac := 0.0; |
exp10 := 1.0; |
minus := FALSE; |
n := 0; |
i := 0; |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN |
INC(i) |
ELSE |
error := 4 |
END |
END; |
INC(i); |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
IF opFloat2(frac, 10.0, "*") & opFloat2(frac, FLT(digit[ORD(s[i])]), "+") THEN |
exp10 := exp10 * 10.0; |
INC(i) |
ELSE |
error := 4 |
END |
END; |
IF ~opFloat2(value, frac / exp10, "+") THEN |
error := 4 |
END; |
IF (s[i] = "E") OR (s[i] = "e") THEN |
INC(i) |
END; |
IF (s[i] = "-") OR (s[i] = "+") THEN |
minus := s[i] = "-"; |
INC(i) |
END; |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
d := digit[ORD(s[i])]; |
IF n <= (UTILS.maxint - d) DIV 10 THEN |
n := n * 10 + d; |
INC(i) |
ELSE |
error := 5 |
END |
END; |
exp10 := 1.0; |
WHILE (error = 0) & (n > 0) DO |
IF opFloat2(exp10, 10.0, "*") THEN |
DEC(n) |
ELSE |
error := 4 |
END |
END; |
IF error = 0 THEN |
IF minus THEN |
IF ~opFloat2(value, exp10, "/") THEN |
error := 4 |
END |
ELSE |
IF ~opFloat2(value, exp10, "*") THEN |
error := 4 |
END |
END |
END; |
IF error = 0 THEN |
v.float := value; |
v.typ := tREAL; |
IF ~check(v) THEN |
error := 4 |
END |
END |
END fconv; |
PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER); |
BEGIN |
v.typ := tCHAR; |
v.int := ord |
END setChar; |
PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER); |
BEGIN |
v.typ := tWCHAR; |
v.int := ord |
END setWChar; |
PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
BEGIN |
IF (a > 0) & (b > 0) THEN |
error := a > UTILS.maxint - b |
ELSIF (a < 0) & (b < 0) THEN |
error := a < UTILS.minint - b |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a + b |
ELSE |
a := 0 |
END |
RETURN ~error |
END addInt; |
PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
BEGIN |
IF (a > 0) & (b < 0) THEN |
error := a > UTILS.maxint + b |
ELSIF (a < 0) & (b > 0) THEN |
error := a < UTILS.minint + b |
ELSIF (a = 0) & (b < 0) THEN |
error := b = UTILS.minint |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a - b |
ELSE |
a := 0 |
END |
RETURN ~error |
END subInt; |
PROCEDURE lg2 (x: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
BEGIN |
ASSERT(x > 0); |
n := UTILS.Log2(x); |
IF n = -1 THEN |
n := 255 |
END |
RETURN n |
END lg2; |
PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
min, max: INTEGER; |
BEGIN |
min := UTILS.minint; |
max := UTILS.maxint; |
IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN |
error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b)) |
ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN |
error := (a = min) OR (b = min); |
IF ~error THEN |
IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN |
error := ABS(a) > max DIV ABS(b) |
END |
END |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a * b |
ELSE |
a := 0 |
END |
RETURN ~error |
END mulInt; |
PROCEDURE _ASR (x, n: INTEGER): INTEGER; |
RETURN ASR(UTILS.Long(x), n) |
END _ASR; |
PROCEDURE _LSR (x, n: INTEGER): INTEGER; |
RETURN UTILS.Long(LSR(UTILS.Short(x), n)) |
END _LSR; |
PROCEDURE _LSL (x, n: INTEGER): INTEGER; |
RETURN UTILS.Long(LSL(x, n)) |
END _LSL; |
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER; |
BEGIN |
x := UTILS.Short(x); |
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31))) |
RETURN UTILS.Long(x) |
END _ROR1_32; |
PROCEDURE _ROR1_16 (x: INTEGER): INTEGER; |
BEGIN |
x := x MOD 65536; |
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 15))) |
RETURN UTILS.Long(x) |
END _ROR1_16; |
PROCEDURE _ROR (x, n: INTEGER): INTEGER; |
BEGIN |
CASE UTILS.bit_diff OF |
|0: x := ROR(x, n) |
|16, 48: |
n := n MOD 16; |
WHILE n > 0 DO |
x := _ROR1_16(x); |
DEC(n) |
END |
|32: |
n := n MOD 32; |
WHILE n > 0 DO |
x := _ROR1_32(x); |
DEC(n) |
END |
END |
RETURN x |
END _ROR; |
PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN; |
VAR |
success: BOOLEAN; |
BEGIN |
success := TRUE; |
CASE op OF |
|"+": success := addInt(a.int, b.int) |
|"-": success := subInt(a.int, b.int) |
|"*": success := mulInt(a.int, b.int) |
|"/": success := FALSE |
|"D": a.int := a.int DIV b.int |
|"M": a.int := a.int MOD b.int |
|"L": a.int := _LSL(a.int, b.int) |
|"A": a.int := _ASR(a.int, b.int) |
|"O": a.int := _ROR(a.int, b.int) |
|"R": a.int := _LSR(a.int, b.int) |
|"m": a.int := MIN(a.int, b.int) |
|"x": a.int := MAX(a.int, b.int) |
END; |
a.typ := tINTEGER |
RETURN success & check(a) |
END opInt; |
PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR); |
BEGIN |
s[0] := CHR(c.int); |
s[1] := 0X |
END charToStr; |
PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR); |
BEGIN |
CASE op OF |
|"+": a.set := a.set + b.set |
|"-": a.set := a.set - b.set |
|"*": a.set := a.set * b.set |
|"/": a.set := a.set / b.set |
END; |
a.typ := tSET |
END opSet; |
PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN; |
BEGIN |
a.typ := tREAL |
RETURN opFloat2(a.float, b.float, op) & check(a) |
END opFloat; |
PROCEDURE ord* (VAR v: VALUE); |
BEGIN |
CASE v.typ OF |
|tCHAR, tWCHAR: |
|tBOOLEAN: v.int := ORD(v.bool) |
|tSET: v.int := UTILS.Long(ORD(v.set)) |
END; |
v.typ := tINTEGER |
END ord; |
PROCEDURE odd* (VAR v: VALUE); |
BEGIN |
v.typ := tBOOLEAN; |
v.bool := ODD(v.int) |
END odd; |
PROCEDURE bits* (VAR v: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := BITS(v.int) |
END bits; |
PROCEDURE abs* (VAR v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
CASE v.typ OF |
|tREAL: |
v.float := ABS(v.float); |
res := TRUE |
|tINTEGER: |
IF v.int # UTILS.minint THEN |
v.int := ABS(v.int); |
res := TRUE |
END |
END |
RETURN res |
END abs; |
PROCEDURE floor* (VAR v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
v.typ := tINTEGER; |
res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint)); |
IF res THEN |
v.int := FLOOR(v.float) |
END |
RETURN res |
END floor; |
PROCEDURE flt* (VAR v: VALUE); |
BEGIN |
v.typ := tREAL; |
v.float := FLT(v.int) |
END flt; |
PROCEDURE neg* (VAR v: VALUE): BOOLEAN; |
VAR |
z: VALUE; |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
z.typ := tINTEGER; |
z.int := 0; |
CASE v.typ OF |
|tREAL: v.float := -v.float |
|tSET: v.set := -v.set |
|tINTEGER: res := opInt(z, v, "-"); v := z |
|tBOOLEAN: v.bool := ~v.bool |
END |
RETURN res |
END neg; |
PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN); |
BEGIN |
v.bool := b; |
v.typ := tBOOLEAN |
END setbool; |
PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR); |
BEGIN |
CASE op OF |
|"&": a.bool := a.bool & b.bool |
|"|": a.bool := a.bool OR b.bool |
END; |
a.typ := tBOOLEAN |
END opBoolean; |
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN |
CASE v.typ OF |
|tINTEGER, |
tWCHAR, |
tCHAR: res := v.int < v2.int |
|tREAL: res := v.float < v2.float |
|tBOOLEAN, |
tSET: error := 1 |
END |
ELSE |
error := 1 |
END |
RETURN res |
END less; |
PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN |
CASE v.typ OF |
|tINTEGER, |
tWCHAR, |
tCHAR: res := v.int = v2.int |
|tREAL: res := v.float = v2.float |
|tBOOLEAN: res := v.bool = v2.bool |
|tSET: res := v.set = v2.set |
END |
ELSE |
error := 1 |
END |
RETURN res |
END equal; |
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; op: INTEGER; VAR error: INTEGER); |
VAR |
res: BOOLEAN; |
BEGIN |
error := 0; |
res := FALSE; |
CASE op OF |
|opEQ: |
res := equal(v, v2, error) |
|opNE: |
res := ~equal(v, v2, error) |
|opLT: |
res := less(v, v2, error) |
|opLE: |
res := less(v, v2, error); |
IF error = 0 THEN |
res := equal(v, v2, error) OR res |
END |
|opGE: |
res := ~less(v, v2, error) |
|opGT: |
res := less(v, v2, error); |
IF error = 0 THEN |
res := equal(v, v2, error) OR res |
END; |
res := ~res |
|opIN: |
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN |
IF range(v, 0, UTILS.target.maxSet) THEN |
res := v.int IN v2.set |
ELSE |
error := 2 |
END |
ELSE |
error := 1 |
END |
END; |
IF error = 0 THEN |
v.bool := res; |
v.typ := tBOOLEAN |
END |
END relation; |
PROCEDURE emptySet* (VAR v: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := {} |
END emptySet; |
PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := {a.int .. b.int} |
END constrSet; |
PROCEDURE getInt* (v: VALUE): INTEGER; |
BEGIN |
ASSERT(check(v)) |
RETURN v.int |
END getInt; |
PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN; |
BEGIN |
v.int := i; |
v.typ := tINTEGER |
RETURN check(v) |
END setInt; |
PROCEDURE concat* (VAR s: ARRAY OF CHAR; s1: ARRAY OF CHAR): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := LENGTH(s) + LENGTH(s1) < LEN(s); |
IF res THEN |
STRINGS.append(s, s1) |
END |
RETURN res |
END concat; |
PROCEDURE init; |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO LEN(digit) - 1 DO |
digit[i] := -1 |
END; |
FOR i := ORD("0") TO ORD("9") DO |
digit[i] := i - ORD("0") |
END; |
FOR i := ORD("A") TO ORD("F") DO |
digit[i] := i - ORD("A") + 10 |
END |
END init; |
BEGIN |
init |
END ARITH. |
/programs/develop/oberon07/source/CHUNKLISTS.ob07 |
---|
0,0 → 1,255 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE CHUNKLISTS; |
IMPORT LISTS, WR := WRITER; |
CONST |
LENOFBYTECHUNK = 65536; |
LENOFINTCHUNK = 16384; |
TYPE |
ANYLIST = POINTER TO RECORD (LISTS.LIST) |
length: INTEGER |
END; |
BYTELIST* = POINTER TO RECORD (ANYLIST) END; |
BYTECHUNK = POINTER TO RECORD (LISTS.ITEM) |
data: ARRAY LENOFBYTECHUNK OF BYTE; |
count: INTEGER |
END; |
INTLIST* = POINTER TO RECORD (ANYLIST) END; |
INTCHUNK = POINTER TO RECORD (LISTS.ITEM) |
data: ARRAY LENOFINTCHUNK OF INTEGER; |
count: INTEGER |
END; |
PROCEDURE SetByte* (list: BYTELIST; idx: INTEGER; byte: BYTE); |
VAR |
chunk: BYTECHUNK; |
item: LISTS.ITEM; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK); |
ASSERT(item # NIL); |
chunk := item(BYTECHUNK); |
idx := idx MOD LENOFBYTECHUNK; |
ASSERT(idx < chunk.count); |
chunk.data[idx] := byte |
END SetByte; |
PROCEDURE GetByte* (list: BYTELIST; idx: INTEGER): BYTE; |
VAR |
chunk: BYTECHUNK; |
item: LISTS.ITEM; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK); |
ASSERT(item # NIL); |
chunk := item(BYTECHUNK); |
idx := idx MOD LENOFBYTECHUNK; |
ASSERT(idx < chunk.count) |
RETURN chunk.data[idx] |
END GetByte; |
PROCEDURE PushByte* (list: BYTELIST; byte: BYTE); |
VAR |
chunk: BYTECHUNK; |
BEGIN |
ASSERT(list # NIL); |
chunk := list.last(BYTECHUNK); |
IF chunk.count = LENOFBYTECHUNK THEN |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
END; |
chunk.data[chunk.count] := byte; |
INC(chunk.count); |
INC(list.length) |
END PushByte; |
PROCEDURE PushStr* (list: BYTELIST; str: ARRAY OF CHAR): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := list.length; |
i := 0; |
REPEAT |
PushByte(list, ORD(str[i])); |
INC(i) |
UNTIL str[i - 1] = 0X |
RETURN res |
END PushStr; |
PROCEDURE GetStr* (list: BYTELIST; pos: INTEGER; VAR str: ARRAY OF CHAR): BOOLEAN; |
VAR |
i: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
i := 0; |
WHILE (pos < list.length) & (i < LEN(str)) & ~res DO |
str[i] := CHR(GetByte(list, pos)); |
res := str[i] = 0X; |
INC(pos); |
INC(i) |
END |
RETURN res |
END GetStr; |
PROCEDURE WriteToFile* (list: BYTELIST); |
VAR |
chunk: BYTECHUNK; |
BEGIN |
chunk := list.first(BYTECHUNK); |
WHILE chunk # NIL DO |
WR.Write(chunk.data, chunk.count); |
chunk := chunk.next(BYTECHUNK) |
END |
END WriteToFile; |
PROCEDURE CreateByteList* (): BYTELIST; |
VAR |
bytelist: BYTELIST; |
list: LISTS.LIST; |
chunk: BYTECHUNK; |
BEGIN |
NEW(bytelist); |
list := LISTS.create(bytelist); |
bytelist.length := 0; |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
RETURN list(BYTELIST) |
END CreateByteList; |
PROCEDURE SetInt* (list: INTLIST; idx: INTEGER; int: INTEGER); |
VAR |
chunk: INTCHUNK; |
item: LISTS.ITEM; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK); |
ASSERT(item # NIL); |
chunk := item(INTCHUNK); |
idx := idx MOD LENOFINTCHUNK; |
ASSERT(idx < chunk.count); |
chunk.data[idx] := int |
END SetInt; |
PROCEDURE GetInt* (list: INTLIST; idx: INTEGER): INTEGER; |
VAR |
chunk: INTCHUNK; |
item: LISTS.ITEM; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK); |
ASSERT(item # NIL); |
chunk := item(INTCHUNK); |
idx := idx MOD LENOFINTCHUNK; |
ASSERT(idx < chunk.count) |
RETURN chunk.data[idx] |
END GetInt; |
PROCEDURE PushInt* (list: INTLIST; int: INTEGER); |
VAR |
chunk: INTCHUNK; |
BEGIN |
ASSERT(list # NIL); |
chunk := list.last(INTCHUNK); |
IF chunk.count = LENOFINTCHUNK THEN |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
END; |
chunk.data[chunk.count] := int; |
INC(chunk.count); |
INC(list.length) |
END PushInt; |
PROCEDURE CreateIntList* (): INTLIST; |
VAR |
intlist: INTLIST; |
list: LISTS.LIST; |
chunk: INTCHUNK; |
BEGIN |
NEW(intlist); |
list := LISTS.create(intlist); |
intlist.length := 0; |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
RETURN list(INTLIST) |
END CreateIntList; |
PROCEDURE Length* (list: ANYLIST): INTEGER; |
RETURN list.length |
END Length; |
END CHUNKLISTS. |
/programs/develop/oberon07/source/CONSOLE.ob07 |
---|
0,0 → 1,78 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE CONSOLE; |
IMPORT UTILS, STRINGS; |
PROCEDURE String* (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i < LEN(s)) & (s[i] # 0X) DO |
UTILS.OutChar(s[i]); |
INC(i) |
END |
END String; |
PROCEDURE Int* (x: INTEGER); |
VAR |
s: ARRAY 24 OF CHAR; |
BEGIN |
STRINGS.IntToStr(x, s); |
String(s) |
END Int; |
PROCEDURE Int2* (x: INTEGER); |
BEGIN |
IF x < 10 THEN |
String("0") |
END; |
Int(x) |
END Int2; |
PROCEDURE Ln*; |
BEGIN |
String(UTILS.eol) |
END Ln; |
PROCEDURE StringLn* (s: ARRAY OF CHAR); |
BEGIN |
String(s); |
Ln |
END StringLn; |
PROCEDURE IntLn* (x: INTEGER); |
BEGIN |
Int(x); |
Ln |
END IntLn; |
PROCEDURE Int2Ln* (x: INTEGER); |
BEGIN |
Int2(x); |
Ln |
END Int2Ln; |
PROCEDURE Dashes*; |
BEGIN |
StringLn("------------------------------------------------") |
END Dashes; |
END CONSOLE. |
/programs/develop/oberon07/source/Compiler.ob07 |
---|
0,0 → 1,333 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE Compiler; |
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE, |
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS, SCAN; |
CONST |
DEF_WINDOWS = "WINDOWS"; |
DEF_LINUX = "LINUX"; |
DEF_KOLIBRIOS = "KOLIBRIOS"; |
DEF_CPU_X86 = "CPU_X86"; |
DEF_CPU_X8664 = "CPU_X8664"; |
PROCEDURE keys (VAR options: PROG.OPTIONS; VAR out: PARS.PATH); |
VAR |
param: PARS.PATH; |
i, j: INTEGER; |
_end: BOOLEAN; |
value: INTEGER; |
minor, |
major: INTEGER; |
checking: SET; |
BEGIN |
out := ""; |
checking := options.checking; |
_end := FALSE; |
i := 3; |
REPEAT |
UTILS.GetArg(i, param); |
IF param = "-stk" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN |
options.stack := value |
END; |
IF param[0] = "-" THEN |
DEC(i) |
END |
ELSIF param = "-out" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF param[0] = "-" THEN |
DEC(i) |
ELSE |
out := param |
END |
ELSIF param = "-ram" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToInt(param, value) THEN |
options.ram := value |
END; |
IF param[0] = "-" THEN |
DEC(i) |
END |
ELSIF param = "-rom" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToInt(param, value) THEN |
options.rom := value |
END; |
IF param[0] = "-" THEN |
DEC(i) |
END |
ELSIF param = "-nochk" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF param[0] = "-" THEN |
DEC(i) |
ELSE |
j := 0; |
WHILE param[j] # 0X DO |
IF param[j] = "p" THEN |
EXCL(checking, ST.chkPTR) |
ELSIF param[j] = "t" THEN |
EXCL(checking, ST.chkGUARD) |
ELSIF param[j] = "i" THEN |
EXCL(checking, ST.chkIDX) |
ELSIF param[j] = "b" THEN |
EXCL(checking, ST.chkBYTE) |
ELSIF param[j] = "c" THEN |
EXCL(checking, ST.chkCHR) |
ELSIF param[j] = "w" THEN |
EXCL(checking, ST.chkWCHR) |
ELSIF param[j] = "r" THEN |
EXCL(checking, ST.chkCHR); |
EXCL(checking, ST.chkWCHR); |
EXCL(checking, ST.chkBYTE) |
ELSIF param[j] = "s" THEN |
EXCL(checking, ST.chkSTK) |
ELSIF param[j] = "a" THEN |
checking := {} |
END; |
INC(j) |
END; |
END |
ELSIF param = "-ver" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToVer(param, major, minor) THEN |
options.version := major * 65536 + minor |
END; |
IF param[0] = "-" THEN |
DEC(i) |
END |
ELSIF param = "-lower" THEN |
options.lower := TRUE |
ELSIF param = "-pic" THEN |
options.pic := TRUE |
ELSIF param = "-def" THEN |
INC(i); |
UTILS.GetArg(i, param); |
SCAN.NewDef(param) |
ELSIF param = "" THEN |
_end := TRUE |
ELSE |
ERRORS.BadParam(param) |
END; |
INC(i) |
UNTIL _end; |
options.checking := checking |
END keys; |
PROCEDURE OutTargetItem (target: INTEGER; text: ARRAY OF CHAR); |
VAR |
width: INTEGER; |
BEGIN |
width := 15; |
width := width - LENGTH(TARGETS.Targets[target].ComLinePar) - 4; |
C.String(" '"); C.String(TARGETS.Targets[target].ComLinePar); C.String("'"); |
WHILE width > 0 DO |
C.String(20X); |
DEC(width) |
END; |
C.StringLn(text) |
END OutTargetItem; |
PROCEDURE main; |
VAR |
path: PARS.PATH; |
inname: PARS.PATH; |
ext: PARS.PATH; |
app_path: PARS.PATH; |
lib_path: PARS.PATH; |
modname: PARS.PATH; |
outname: PARS.PATH; |
param: PARS.PATH; |
temp: PARS.PATH; |
target: INTEGER; |
time: INTEGER; |
options: PROG.OPTIONS; |
BEGIN |
options.stack := 2; |
options.version := 65536; |
options.pic := FALSE; |
options.lower := FALSE; |
options.checking := ST.chkALL; |
PATHS.GetCurrentDirectory(app_path); |
UTILS.GetArg(0, temp); |
PATHS.split(temp, path, modname, ext); |
IF PATHS.isRelative(path) THEN |
PATHS.RelPath(app_path, path, temp); |
path := temp |
END; |
lib_path := path; |
UTILS.GetArg(1, inname); |
STRINGS.replace(inname, "\", UTILS.slash); |
STRINGS.replace(inname, "/", UTILS.slash); |
C.Ln; |
C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor); |
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit) " + UTILS.Date); |
C.StringLn("Copyright (c) 2018-2021, Anton Krotov"); |
IF inname = "" THEN |
C.Ln; |
C.StringLn("Usage: Compiler <main module> <target> [optional settings]"); C.Ln; |
C.StringLn("target ="); |
IF UTILS.bit_depth = 64 THEN |
OutTargetItem(TARGETS.Win64C, "Windows64 Console"); |
OutTargetItem(TARGETS.Win64GUI, "Windows64 GUI"); |
OutTargetItem(TARGETS.Win64DLL, "Windows64 DLL"); |
OutTargetItem(TARGETS.Linux64, "Linux64 Exec"); |
OutTargetItem(TARGETS.Linux64SO, "Linux64 SO") |
END; |
OutTargetItem(TARGETS.Win32C, "Windows32 Console"); |
OutTargetItem(TARGETS.Win32GUI, "Windows32 GUI"); |
OutTargetItem(TARGETS.Win32DLL, "Windows32 DLL"); |
OutTargetItem(TARGETS.Linux32, "Linux32 Exec"); |
OutTargetItem(TARGETS.Linux32SO, "Linux32 SO"); |
OutTargetItem(TARGETS.KolibriOS, "KolibriOS Exec"); |
OutTargetItem(TARGETS.KolibriOSDLL, "KolibriOS DLL"); |
OutTargetItem(TARGETS.MSP430, "MSP430x{1,2}xx microcontrollers"); |
OutTargetItem(TARGETS.STM32CM3, "STM32 Cortex-M3 microcontrollers"); |
C.Ln; |
C.StringLn("optional settings:"); C.Ln; |
C.StringLn(" -out <file name> output"); C.Ln; |
C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln; |
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,"); |
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln; |
C.StringLn(" -lower allow lower case for keywords"); C.Ln; |
C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln; |
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln; |
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln; |
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430) or Kbytes (STM32)"); C.Ln; |
UTILS.Exit(0) |
END; |
C.Dashes; |
PATHS.split(inname, path, modname, ext); |
IF ext # UTILS.FILE_EXT THEN |
ERRORS.Error(207) |
END; |
IF PATHS.isRelative(path) THEN |
PATHS.RelPath(app_path, path, temp); |
path := temp |
END; |
UTILS.GetArg(2, param); |
IF param = "" THEN |
ERRORS.Error(205) |
END; |
SCAN.NewDef(param); |
IF TARGETS.Select(param) THEN |
target := TARGETS.target |
ELSE |
ERRORS.Error(206) |
END; |
IF TARGETS.CPU = TARGETS.cpuMSP430 THEN |
options.ram := MSP430.minRAM; |
options.rom := MSP430.minROM |
END; |
IF (TARGETS.CPU = TARGETS.cpuTHUMB) & (TARGETS.OS = TARGETS.osNONE) THEN |
options.ram := THUMB.minRAM; |
options.rom := THUMB.minROM |
END; |
IF UTILS.bit_depth < TARGETS.BitDepth THEN |
ERRORS.Error(206) |
END; |
STRINGS.append(lib_path, "lib"); |
STRINGS.append(lib_path, UTILS.slash); |
STRINGS.append(lib_path, TARGETS.LibDir); |
STRINGS.append(lib_path, UTILS.slash); |
keys(options, outname); |
IF outname = "" THEN |
outname := path; |
STRINGS.append(outname, modname); |
STRINGS.append(outname, TARGETS.FileExt) |
ELSE |
IF PATHS.isRelative(outname) THEN |
PATHS.RelPath(app_path, outname, temp); |
outname := temp |
END |
END; |
PARS.init(options); |
CASE TARGETS.OS OF |
|TARGETS.osNONE: |
|TARGETS.osWIN32, |
TARGETS.osWIN64: SCAN.NewDef(DEF_WINDOWS) |
|TARGETS.osLINUX32, |
TARGETS.osLINUX64: SCAN.NewDef(DEF_LINUX) |
|TARGETS.osKOS: SCAN.NewDef(DEF_KOLIBRIOS) |
END; |
CASE TARGETS.CPU OF |
|TARGETS.cpuX86: SCAN.NewDef(DEF_CPU_X86) |
|TARGETS.cpuAMD64: SCAN.NewDef(DEF_CPU_X8664) |
|TARGETS.cpuMSP430: |
|TARGETS.cpuTHUMB: |
|TARGETS.cpuRVM32I: |
|TARGETS.cpuRVM64I: |
END; |
ST.compile(path, lib_path, modname, outname, target, options); |
time := UTILS.GetTickCount() - UTILS.time; |
C.Dashes; |
C.Int(PARS.lines); C.String(" lines, "); |
C.Int(time DIV 100); C.String("."); C.Int2(time MOD 100); C.String(" sec, "); |
C.Int(WRITER.counter); C.StringLn(" bytes"); |
UTILS.Exit(0) |
END main; |
BEGIN |
main |
END Compiler. |
/programs/develop/oberon07/source/ELF.ob07 |
---|
0,0 → 1,592 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE ELF; |
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PE32, UTILS, STRINGS; |
CONST |
EI_NIDENT = 16; |
ET_EXEC = 2; |
ET_DYN = 3; |
EM_386 = 3; |
EM_8664 = 3EH; |
ELFCLASS32 = 1; |
ELFCLASS64 = 2; |
ELFDATA2LSB = 1; |
ELFDATA2MSB = 2; |
PF_X = 1; |
PF_W = 2; |
PF_R = 4; |
TYPE |
Elf32_Ehdr = RECORD |
e_ident: ARRAY EI_NIDENT OF BYTE; |
e_type, |
e_machine: WCHAR; |
e_version, |
e_entry, |
e_phoff, |
e_shoff, |
e_flags: INTEGER; |
e_ehsize, |
e_phentsize, |
e_phnum, |
e_shentsize, |
e_shnum, |
e_shstrndx: WCHAR |
END; |
Elf32_Phdr = RECORD |
p_type, |
p_offset, |
p_vaddr, |
p_paddr, |
p_filesz, |
p_memsz, |
p_flags, |
p_align: INTEGER |
END; |
Elf32_Dyn = POINTER TO RECORD (LISTS.ITEM) |
d_tag, d_val: INTEGER |
END; |
Elf32_Sym = POINTER TO RECORD (LISTS.ITEM) |
name, value, size: INTEGER; |
info, other: CHAR; |
shndx: WCHAR |
END; |
VAR |
dynamic: LISTS.LIST; |
strtab: CHL.BYTELIST; |
symtab: LISTS.LIST; |
hashtab, bucket, chain: CHL.INTLIST; |
PROCEDURE Write16 (w: WCHAR); |
BEGIN |
WR.Write16LE(ORD(w)) |
END Write16; |
PROCEDURE WritePH (ph: Elf32_Phdr); |
BEGIN |
WR.Write32LE(ph.p_type); |
WR.Write32LE(ph.p_offset); |
WR.Write32LE(ph.p_vaddr); |
WR.Write32LE(ph.p_paddr); |
WR.Write32LE(ph.p_filesz); |
WR.Write32LE(ph.p_memsz); |
WR.Write32LE(ph.p_flags); |
WR.Write32LE(ph.p_align) |
END WritePH; |
PROCEDURE WritePH64 (ph: Elf32_Phdr); |
BEGIN |
WR.Write32LE(ph.p_type); |
WR.Write32LE(ph.p_flags); |
WR.Write64LE(ph.p_offset); |
WR.Write64LE(ph.p_vaddr); |
WR.Write64LE(ph.p_paddr); |
WR.Write64LE(ph.p_filesz); |
WR.Write64LE(ph.p_memsz); |
WR.Write64LE(ph.p_align) |
END WritePH64; |
PROCEDURE NewDyn (tag, val: INTEGER); |
VAR |
dyn: Elf32_Dyn; |
BEGIN |
NEW(dyn); |
dyn.d_tag := tag; |
dyn.d_val := val; |
LISTS.push(dynamic, dyn) |
END NewDyn; |
PROCEDURE NewSym (name, value, size: INTEGER; info, other: CHAR; shndx: WCHAR); |
VAR |
sym: Elf32_Sym; |
BEGIN |
NEW(sym); |
sym.name := name; |
sym.value := value; |
sym.size := size; |
sym.info := info; |
sym.other := other; |
sym.shndx := shndx; |
LISTS.push(symtab, sym) |
END NewSym; |
PROCEDURE MakeHash (bucket, chain: CHL.INTLIST; symCount: INTEGER); |
VAR |
symi, hi, k: INTEGER; |
BEGIN |
FOR symi := 0 TO symCount - 1 DO |
CHL.SetInt(chain, symi, 0); |
hi := CHL.GetInt(hashtab, symi) MOD symCount; |
IF CHL.GetInt(bucket, hi) # 0 THEN |
k := symi; |
WHILE CHL.GetInt(chain, k) # 0 DO |
k := CHL.GetInt(chain, k) |
END; |
CHL.SetInt(chain, k, CHL.GetInt(bucket, hi)) |
END; |
CHL.SetInt(bucket, hi, symi) |
END |
END MakeHash; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; fini: INTEGER; so, amd64: BOOLEAN); |
CONST |
interp = 0; |
dyn = 1; |
header = 2; |
text = 3; |
data = 4; |
bss = 5; |
linuxInterpreter64 = "/lib64/ld-linux-x86-64.so.2"; |
linuxInterpreter32 = "/lib/ld-linux.so.2"; |
exeBaseAddress32 = 8048000H; |
exeBaseAddress64 = 400000H; |
dllBaseAddress = 0; |
DT_NULL = 0; |
DT_NEEDED = 1; |
DT_HASH = 4; |
DT_STRTAB = 5; |
DT_SYMTAB = 6; |
DT_RELA = 7; |
DT_RELASZ = 8; |
DT_RELAENT = 9; |
DT_STRSZ = 10; |
DT_SYMENT = 11; |
DT_INIT = 12; |
DT_FINI = 13; |
DT_SONAME = 14; |
DT_REL = 17; |
DT_RELSZ = 18; |
DT_RELENT = 19; |
VAR |
ehdr: Elf32_Ehdr; |
phdr: ARRAY 16 OF Elf32_Phdr; |
i, BaseAdr, DynAdr, offset, pad, VA, symCount: INTEGER; |
SizeOf: RECORD header, code, data, bss: INTEGER END; |
Offset: RECORD symtab, reltab, hash, strtab: INTEGER END; |
Interpreter: ARRAY 40 OF CHAR; lenInterpreter: INTEGER; |
item: LISTS.ITEM; |
Name: ARRAY 2048 OF CHAR; |
Address: PE32.VIRTUAL_ADDR; |
BEGIN |
dynamic := LISTS.create(NIL); |
symtab := LISTS.create(NIL); |
strtab := CHL.CreateByteList(); |
IF amd64 THEN |
BaseAdr := exeBaseAddress64; |
Interpreter := linuxInterpreter64 |
ELSE |
BaseAdr := exeBaseAddress32; |
Interpreter := linuxInterpreter32 |
END; |
IF so THEN |
BaseAdr := dllBaseAddress |
END; |
lenInterpreter := LENGTH(Interpreter) + 1; |
SizeOf.code := CHL.Length(program.code); |
SizeOf.data := CHL.Length(program.data); |
SizeOf.bss := program.bss; |
ehdr.e_ident[0] := 7FH; |
ehdr.e_ident[1] := ORD("E"); |
ehdr.e_ident[2] := ORD("L"); |
ehdr.e_ident[3] := ORD("F"); |
IF amd64 THEN |
ehdr.e_ident[4] := ELFCLASS64 |
ELSE |
ehdr.e_ident[4] := ELFCLASS32 |
END; |
ehdr.e_ident[5] := ELFDATA2LSB; |
ehdr.e_ident[6] := 1; |
ehdr.e_ident[7] := 3; |
FOR i := 8 TO EI_NIDENT - 1 DO |
ehdr.e_ident[i] := 0 |
END; |
IF so THEN |
ehdr.e_type := WCHR(ET_DYN) |
ELSE |
ehdr.e_type := WCHR(ET_EXEC) |
END; |
ehdr.e_version := 1; |
ehdr.e_shoff := 0; |
ehdr.e_flags := 0; |
ehdr.e_shnum := WCHR(0); |
ehdr.e_shstrndx := WCHR(0); |
ehdr.e_phnum := WCHR(6); |
IF amd64 THEN |
ehdr.e_machine := WCHR(EM_8664); |
ehdr.e_phoff := 40H; |
ehdr.e_ehsize := WCHR(40H); |
ehdr.e_phentsize := WCHR(38H); |
ehdr.e_shentsize := WCHR(40H) |
ELSE |
ehdr.e_machine := WCHR(EM_386); |
ehdr.e_phoff := 34H; |
ehdr.e_ehsize := WCHR(34H); |
ehdr.e_phentsize := WCHR(20H); |
ehdr.e_shentsize := WCHR(28H) |
END; |
SizeOf.header := ORD(ehdr.e_ehsize) + ORD(ehdr.e_phentsize) * ORD(ehdr.e_phnum); |
phdr[interp].p_type := 3; |
phdr[interp].p_offset := SizeOf.header; |
phdr[interp].p_vaddr := BaseAdr + phdr[interp].p_offset; |
phdr[interp].p_paddr := phdr[interp].p_vaddr; |
phdr[interp].p_filesz := lenInterpreter; |
phdr[interp].p_memsz := lenInterpreter; |
phdr[interp].p_flags := PF_R; |
phdr[interp].p_align := 1; |
phdr[dyn].p_type := 2; |
phdr[dyn].p_offset := phdr[interp].p_offset + phdr[interp].p_filesz; |
phdr[dyn].p_vaddr := BaseAdr + phdr[dyn].p_offset; |
phdr[dyn].p_paddr := phdr[dyn].p_vaddr; |
hashtab := CHL.CreateIntList(); |
CHL.PushInt(hashtab, STRINGS.HashStr("")); |
NewSym(CHL.PushStr(strtab, ""), 0, 0, 0X, 0X, 0X); |
CHL.PushInt(hashtab, STRINGS.HashStr("dlopen")); |
NewSym(CHL.PushStr(strtab, "dlopen"), 0, 0, 12X, 0X, 0X); |
CHL.PushInt(hashtab, STRINGS.HashStr("dlsym")); |
NewSym(CHL.PushStr(strtab, "dlsym"), 0, 0, 12X, 0X, 0X); |
IF so THEN |
item := program.exp_list.first; |
WHILE item # NIL DO |
ASSERT(CHL.GetStr(program.export, item(BIN.EXPRT).nameoffs, Name)); |
CHL.PushInt(hashtab, STRINGS.HashStr(Name)); |
NewSym(CHL.PushStr(strtab, Name), item(BIN.EXPRT).label, 0, 12X, 0X, 0X); |
item := item.next |
END; |
ASSERT(CHL.GetStr(program.data, program.modname, Name)) |
END; |
symCount := LISTS.count(symtab); |
bucket := CHL.CreateIntList(); |
chain := CHL.CreateIntList(); |
FOR i := 1 TO symCount DO |
CHL.PushInt(bucket, 0); |
CHL.PushInt(chain, 0) |
END; |
MakeHash(bucket, chain, symCount); |
NewDyn(DT_NEEDED, CHL.PushStr(strtab, "libdl.so.2")); |
NewDyn(DT_STRTAB, 0); |
NewDyn(DT_STRSZ, CHL.Length(strtab)); |
NewDyn(DT_SYMTAB, 0); |
IF amd64 THEN |
NewDyn(DT_SYMENT, 24); |
NewDyn(DT_RELA, 0); |
NewDyn(DT_RELASZ, 48); |
NewDyn(DT_RELAENT, 24) |
ELSE |
NewDyn(DT_SYMENT, 16); |
NewDyn(DT_REL, 0); |
NewDyn(DT_RELSZ, 16); |
NewDyn(DT_RELENT, 8) |
END; |
NewDyn(DT_HASH, 0); |
IF so THEN |
NewDyn(DT_SONAME, CHL.PushStr(strtab, Name)); |
NewDyn(DT_INIT, 0); |
NewDyn(DT_FINI, 0) |
END; |
NewDyn(DT_NULL, 0); |
Offset.symtab := LISTS.count(dynamic) * (8 + 8 * ORD(amd64)); |
Offset.reltab := Offset.symtab + symCount * (16 + 8 * ORD(amd64)); |
Offset.hash := Offset.reltab + (8 + 16 * ORD(amd64)) * 2; |
Offset.strtab := Offset.hash + (symCount * 2 + 2) * 4; |
DynAdr := phdr[dyn].p_offset + BaseAdr; |
item := LISTS.getidx(dynamic, 1); item(Elf32_Dyn).d_val := Offset.strtab + DynAdr; |
item := LISTS.getidx(dynamic, 3); item(Elf32_Dyn).d_val := Offset.symtab + DynAdr; |
item := LISTS.getidx(dynamic, 5); item(Elf32_Dyn).d_val := Offset.reltab + DynAdr; |
item := LISTS.getidx(dynamic, 8); item(Elf32_Dyn).d_val := Offset.hash + DynAdr; |
phdr[dyn].p_filesz := Offset.strtab + CHL.Length(strtab) + 8 + 8 * ORD(amd64); |
phdr[dyn].p_memsz := phdr[dyn].p_filesz; |
phdr[dyn].p_flags := PF_R; |
phdr[dyn].p_align := 1; |
offset := 0; |
phdr[header].p_type := 1; |
phdr[header].p_offset := offset; |
phdr[header].p_vaddr := BaseAdr; |
phdr[header].p_paddr := BaseAdr; |
phdr[header].p_filesz := SizeOf.header + lenInterpreter + phdr[dyn].p_filesz; |
phdr[header].p_memsz := phdr[header].p_filesz; |
phdr[header].p_flags := PF_R + PF_W; |
phdr[header].p_align := 1000H; |
INC(offset, phdr[header].p_filesz); |
VA := BaseAdr + offset + 1000H; |
phdr[text].p_type := 1; |
phdr[text].p_offset := offset; |
phdr[text].p_vaddr := VA; |
phdr[text].p_paddr := VA; |
phdr[text].p_filesz := SizeOf.code; |
phdr[text].p_memsz := SizeOf.code; |
phdr[text].p_flags := PF_X + PF_R; |
phdr[text].p_align := 1000H; |
ehdr.e_entry := phdr[text].p_vaddr; |
INC(offset, phdr[text].p_filesz); |
VA := BaseAdr + offset + 2000H; |
pad := (16 - VA MOD 16) MOD 16; |
phdr[data].p_type := 1; |
phdr[data].p_offset := offset; |
phdr[data].p_vaddr := VA; |
phdr[data].p_paddr := VA; |
phdr[data].p_filesz := SizeOf.data + pad; |
phdr[data].p_memsz := SizeOf.data + pad; |
phdr[data].p_flags := PF_R + PF_W; |
phdr[data].p_align := 1000H; |
INC(offset, phdr[data].p_filesz); |
VA := BaseAdr + offset + 3000H; |
phdr[bss].p_type := 1; |
phdr[bss].p_offset := offset; |
phdr[bss].p_vaddr := VA; |
phdr[bss].p_paddr := VA; |
phdr[bss].p_filesz := 0; |
phdr[bss].p_memsz := SizeOf.bss + 16; |
phdr[bss].p_flags := PF_R + PF_W; |
phdr[bss].p_align := 1000H; |
Address.Code := ehdr.e_entry; |
Address.Data := phdr[data].p_vaddr + pad; |
Address.Bss := WR.align(phdr[bss].p_vaddr, 16); |
Address.Import := 0; |
PE32.fixup(program, Address, amd64); |
item := symtab.first; |
WHILE item # NIL DO |
IF item(Elf32_Sym).value # 0 THEN |
INC(item(Elf32_Sym).value, ehdr.e_entry) |
END; |
item := item.next |
END; |
IF so THEN |
item := LISTS.getidx(dynamic, 10); item(Elf32_Dyn).d_val := ehdr.e_entry; |
item := LISTS.getidx(dynamic, 11); item(Elf32_Dyn).d_val := BIN.GetLabel(program, fini) + ehdr.e_entry |
END; |
WR.Create(FileName); |
FOR i := 0 TO EI_NIDENT - 1 DO |
WR.WriteByte(ehdr.e_ident[i]) |
END; |
Write16(ehdr.e_type); |
Write16(ehdr.e_machine); |
WR.Write32LE(ehdr.e_version); |
IF amd64 THEN |
WR.Write64LE(ehdr.e_entry); |
WR.Write64LE(ehdr.e_phoff); |
WR.Write64LE(ehdr.e_shoff) |
ELSE |
WR.Write32LE(ehdr.e_entry); |
WR.Write32LE(ehdr.e_phoff); |
WR.Write32LE(ehdr.e_shoff) |
END; |
WR.Write32LE(ehdr.e_flags); |
Write16(ehdr.e_ehsize); |
Write16(ehdr.e_phentsize); |
Write16(ehdr.e_phnum); |
Write16(ehdr.e_shentsize); |
Write16(ehdr.e_shnum); |
Write16(ehdr.e_shstrndx); |
IF amd64 THEN |
WritePH64(phdr[interp]); |
WritePH64(phdr[dyn]); |
WritePH64(phdr[header]); |
WritePH64(phdr[text]); |
WritePH64(phdr[data]); |
WritePH64(phdr[bss]) |
ELSE |
WritePH(phdr[interp]); |
WritePH(phdr[dyn]); |
WritePH(phdr[header]); |
WritePH(phdr[text]); |
WritePH(phdr[data]); |
WritePH(phdr[bss]) |
END; |
FOR i := 0 TO lenInterpreter - 1 DO |
WR.WriteByte(ORD(Interpreter[i])) |
END; |
IF amd64 THEN |
item := dynamic.first; |
WHILE item # NIL DO |
WR.Write64LE(item(Elf32_Dyn).d_tag); |
WR.Write64LE(item(Elf32_Dyn).d_val); |
item := item.next |
END; |
item := symtab.first; |
WHILE item # NIL DO |
WR.Write32LE(item(Elf32_Sym).name); |
WR.WriteByte(ORD(item(Elf32_Sym).info)); |
WR.WriteByte(ORD(item(Elf32_Sym).other)); |
Write16(item(Elf32_Sym).shndx); |
WR.Write64LE(item(Elf32_Sym).value); |
WR.Write64LE(item(Elf32_Sym).size); |
item := item.next |
END; |
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 16); |
WR.Write32LE(1); |
WR.Write32LE(1); |
WR.Write64LE(0); |
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 8); |
WR.Write32LE(1); |
WR.Write32LE(2); |
WR.Write64LE(0) |
ELSE |
item := dynamic.first; |
WHILE item # NIL DO |
WR.Write32LE(item(Elf32_Dyn).d_tag); |
WR.Write32LE(item(Elf32_Dyn).d_val); |
item := item.next |
END; |
item := symtab.first; |
WHILE item # NIL DO |
WR.Write32LE(item(Elf32_Sym).name); |
WR.Write32LE(item(Elf32_Sym).value); |
WR.Write32LE(item(Elf32_Sym).size); |
WR.WriteByte(ORD(item(Elf32_Sym).info)); |
WR.WriteByte(ORD(item(Elf32_Sym).other)); |
Write16(item(Elf32_Sym).shndx); |
item := item.next |
END; |
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 8); |
WR.Write32LE(00000101H); |
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 4); |
WR.Write32LE(00000201H) |
END; |
WR.Write32LE(symCount); |
WR.Write32LE(symCount); |
FOR i := 0 TO symCount - 1 DO |
WR.Write32LE(CHL.GetInt(bucket, i)) |
END; |
FOR i := 0 TO symCount - 1 DO |
WR.Write32LE(CHL.GetInt(chain, i)) |
END; |
CHL.WriteToFile(strtab); |
IF amd64 THEN |
WR.Write64LE(0); |
WR.Write64LE(0) |
ELSE |
WR.Write32LE(0); |
WR.Write32LE(0) |
END; |
CHL.WriteToFile(program.code); |
WHILE pad > 0 DO |
WR.WriteByte(0); |
DEC(pad) |
END; |
CHL.WriteToFile(program.data); |
WR.Close; |
UTILS.chmod(FileName) |
END write; |
END ELF. |
/programs/develop/oberon07/source/ERRORS.ob07 |
---|
0,0 → 1,221 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE ERRORS; |
IMPORT C := CONSOLE, UTILS; |
PROCEDURE HintMsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER); |
BEGIN |
IF hint = 0 THEN |
C.String(" hint ("); C.Int(line); C.String(":"); C.Int(col); C.String(") "); |
C.String("variable '"); C.String(name); C.StringLn("' never used") |
END |
END HintMsg; |
PROCEDURE WarningMsg* (line, col, warning: INTEGER); |
BEGIN |
C.String(" warning ("); C.Int(line); C.String(":"); C.Int(col); C.String(") "); |
CASE warning OF |
|0: C.StringLn("passing a string value as a fixed array") |
|1: C.StringLn("endless FOR loop") |
|2: C.StringLn("identifier too long") |
END |
END WarningMsg; |
PROCEDURE ErrorMsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER); |
VAR |
str: ARRAY 80 OF CHAR; |
BEGIN |
C.Ln; |
C.String(" error ("); C.Int(errno); C.String(") ("); C.Int(line); C.String(":"); C.Int(col); C.String(") "); |
CASE errno OF |
| 1: str := "missing 'H' or 'X'" |
| 2: str := "missing scale" |
| 3: str := "unclosed string" |
| 4: str := "illegal character" |
| 5: str := "string too long" |
| 7: str := "number too long" |
| 8..12: str := "number too large" |
| 13: str := "real numbers not supported" |
| 21: str := "'MODULE' expected" |
| 22: str := "identifier expected" |
| 23: str := "module name does not match file name" |
| 24: str := "';' expected" |
| 25: str := "identifier does not match module name" |
| 26: str := "'.' expected" |
| 27: str := "'END' expected" |
| 28: str := "',', ';' or ':=' expected" |
| 29: str := "module not found" |
| 30: str := "multiply defined identifier" |
| 31: str := "recursive import" |
| 32: str := "'=' expected" |
| 33: str := "')' expected" |
| 34: str := "syntax error in expression" |
| 35: str := "'}' expected" |
| 36: str := "incompatible operand" |
| 37: str := "incompatible operands" |
| 38: str := "'RETURN' expected" |
| 39: str := "integer overflow" |
| 40: str := "floating point overflow" |
| 41: str := "not enough floating point registers; simplify expression" |
| 42: str := "out of range 0..255" |
| 43: str := "expression is not an integer" |
| 44: str := "out of range 0..MAXSET" |
| 45: str := "division by zero" |
| 46: str := "IV out of range" |
| 47: str := "'OF' or ',' expected" |
| 48: str := "undeclared identifier" |
| 49: str := "type expected" |
| 50: str := "recursive type definition" |
| 51: str := "illegal value of constant" |
| 52: str := "not a record type" |
| 53: str := "':' expected" |
| 54: str := "need to import SYSTEM" |
| 55: str := "pointer type not defined" |
| 56: str := "out of range 0..MAXSET" |
| 57: str := "'TO' expected" |
| 58: str := "not a record type" |
| 59: str := "this expression cannot be a procedure" |
| 60: str := "identifier does not match procedure name" |
| 61: str := "illegally marked identifier" |
| 62: str := "expression should be constant" |
| 63: str := "not enough RAM" |
| 64: str := "'(' expected" |
| 65: str := "',' expected" |
| 66: str := "incompatible parameter" |
| 67: str := "'OF' expected" |
| 68: str := "type expected" |
| 69: str := "result type of procedure is not a basic type" |
| 70: str := "import not supported" |
| 71: str := "']' expected" |
| 72: str := "expression is not BOOLEAN" |
| 73: str := "not a record" |
| 74: str := "undefined record field" |
| 75: str := "not an array" |
| 76: str := "expression is not an integer" |
| 77: str := "not a pointer" |
| 78: str := "type guard not allowed" |
| 79: str := "not a type" |
| 80: str := "not a record type" |
| 81: str := "not a pointer type" |
| 82: str := "type guard not allowed" |
| 83: str := "index out of range" |
| 84: str := "dimension too large" |
| 85: str := "procedure must have level 0" |
| 86: str := "not a procedure" |
| 87: str := "incompatible expression (RETURN)" |
| 88: str := "'THEN' expected" |
| 89: str := "'DO' expected" |
| 90: str := "'UNTIL' expected" |
| 91: str := "incompatible assignment" |
| 92: str := "procedure call of a function" |
| 93: str := "not a variable" |
| 94: str := "read only variable" |
| 95: str := "invalid type of expression (CASE)" |
| 96: str := "':=' expected" |
| 97: str := "not INTEGER variable" |
| 98: str := "illegal value of constant (0)" |
| 99: str := "incompatible label" |
|100: str := "multiply defined label" |
|101: str := "too large parameter of WCHR" |
|102: str := "label expected" |
|103: str := "illegal value of constant" |
|104: str := "type too large" |
|105: str := "access to intermediate variables not allowed" |
|106: str := "qualified identifier expected" |
|107: str := "too large parameter of CHR" |
|108: str := "a variable or a procedure expected" |
|109: str := "expression should be constant" |
|110: str := "out of range 0..65535" |
|111: str := "record [noalign] cannot have a base type" |
|112: str := "record [noalign] cannot be a base type" |
|113: str := "result type of procedure should not be REAL" |
|114: str := "identifiers 'lib_init' and 'version' are reserved" |
|115: str := "recursive constant definition" |
|116: str := "procedure too deep nested" |
|117: str := "string expected" |
|118: str := "'$END', '$ELSE' or '$ELSIF' without '$IF'" |
|119: str := "'$IF', '$ELSIF', '$ELSE' or '$END' expected" |
|120: str := "too many formal parameters" |
|121: str := "multiply defined handler" |
|122: str := "bad divisor" |
|123: str := "illegal flag" |
|124: str := "unknown flag" |
|125: str := "flag not supported" |
END; |
C.StringLn(str); |
C.String(" file: "); C.StringLn(fname); |
UTILS.Exit(1) |
END ErrorMsg; |
PROCEDURE Error1 (s1: ARRAY OF CHAR); |
BEGIN |
C.Ln; |
C.StringLn(s1); |
UTILS.Exit(1) |
END Error1; |
PROCEDURE Error3 (s1, s2, s3: ARRAY OF CHAR); |
BEGIN |
C.Ln; |
C.String(s1); C.String(s2); C.StringLn(s3); |
UTILS.Exit(1) |
END Error3; |
PROCEDURE Error5 (s1, s2, s3, s4, s5: ARRAY OF CHAR); |
BEGIN |
C.Ln; |
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5); |
UTILS.Exit(1) |
END Error5; |
PROCEDURE WrongRTL* (ProcName: ARRAY OF CHAR); |
BEGIN |
Error5("procedure ", UTILS.RTL_NAME, ".", ProcName, " not found") |
END WrongRTL; |
PROCEDURE BadParam* (param: ARRAY OF CHAR); |
BEGIN |
Error3("bad parameter: ", param, "") |
END BadParam; |
PROCEDURE FileNotFound* (Path, Name, Ext: ARRAY OF CHAR); |
BEGIN |
Error5("file ", Path, Name, Ext, " not found") |
END FileNotFound; |
PROCEDURE Error* (n: INTEGER); |
BEGIN |
CASE n OF |
|201: Error1("writing file error") |
|202: Error1("too many relocations") |
|203: Error1("size of program is too large") |
|204: Error1("size of variables is too large") |
|205: Error1("not enough parameters") |
|206: Error1("bad parameter <target>") |
|207: Error3('inputfile name extension must be "', UTILS.FILE_EXT, '"') |
|208: Error1("not enough RAM") |
END |
END Error; |
END ERRORS. |
/programs/develop/oberon07/source/FILES.ob07 |
---|
0,0 → 1,200 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE FILES; |
IMPORT UTILS, C := COLLECTIONS, CONSOLE; |
TYPE |
FILE* = POINTER TO RECORD (C.ITEM) |
ptr: INTEGER; |
buffer: ARRAY 64*1024 OF BYTE; |
count: INTEGER |
END; |
VAR |
files: C.COLLECTION; |
PROCEDURE copy (src: ARRAY OF BYTE; src_idx: INTEGER; VAR dst: ARRAY OF BYTE; dst_idx: INTEGER; bytes: INTEGER); |
BEGIN |
WHILE bytes > 0 DO |
dst[dst_idx] := src[src_idx]; |
INC(dst_idx); |
INC(src_idx); |
DEC(bytes) |
END |
END copy; |
PROCEDURE flush (file: FILE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF file # NIL THEN |
res := UTILS.FileWrite(file.ptr, file.buffer, file.count); |
IF res < 0 THEN |
res := 0 |
END |
ELSE |
res := 0 |
END |
RETURN res |
END flush; |
PROCEDURE NewFile (): FILE; |
VAR |
file: FILE; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(files); |
IF citem = NIL THEN |
NEW(file) |
ELSE |
file := citem(FILE) |
END |
RETURN file |
END NewFile; |
PROCEDURE create* (name: ARRAY OF CHAR): FILE; |
VAR |
file: FILE; |
ptr: INTEGER; |
BEGIN |
ptr := UTILS.FileCreate(name); |
IF ptr > 0 THEN |
file := NewFile(); |
file.ptr := ptr; |
file.count := 0 |
ELSE |
file := NIL |
END |
RETURN file |
END create; |
PROCEDURE open* (name: ARRAY OF CHAR): FILE; |
VAR |
file: FILE; |
ptr: INTEGER; |
BEGIN |
ptr := UTILS.FileOpen(name); |
IF ptr > 0 THEN |
file := NewFile(); |
file.ptr := ptr; |
file.count := -1 |
ELSE |
file := NIL |
END |
RETURN file |
END open; |
PROCEDURE close* (VAR file: FILE); |
VAR |
n: INTEGER; |
BEGIN |
IF file # NIL THEN |
IF file.count > 0 THEN |
n := flush(file) |
END; |
file.count := -1; |
UTILS.FileClose(file.ptr); |
file.ptr := 0; |
C.push(files, file); |
file := NIL |
END |
END close; |
PROCEDURE read* (file: FILE; VAR chunk: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF file # NIL THEN |
res := UTILS.FileRead(file.ptr, chunk, MAX(MIN(bytes, LEN(chunk)), 0)); |
IF res < 0 THEN |
res := 0 |
END |
ELSE |
res := 0 |
END |
RETURN res |
END read; |
PROCEDURE write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
free, n, idx: INTEGER; |
BEGIN |
idx := 0; |
IF (file # NIL) & (file.count >= 0) THEN |
free := LEN(file.buffer) - file.count; |
WHILE bytes > 0 DO |
n := MIN(free, bytes); |
copy(chunk, idx, file.buffer, file.count, n); |
DEC(free, n); |
DEC(bytes, n); |
INC(idx, n); |
INC(file.count, n); |
IF free = 0 THEN |
IF flush(file) # LEN(file.buffer) THEN |
bytes := 0; |
DEC(idx, n) |
ELSE |
file.count := 0; |
free := LEN(file.buffer) |
END |
END |
END |
END |
RETURN idx |
END write; |
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN; |
VAR |
arr: ARRAY 1 OF BYTE; |
BEGIN |
arr[0] := byte |
RETURN write(file, arr, 1) = 1 |
END WriteByte; |
BEGIN |
files := C.create() |
END FILES. |
/programs/develop/oberon07/source/IL.ob07 |
---|
0,0 → 1,1171 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE IL; |
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS, TARGETS, PATHS; |
CONST |
call_stack* = 0; |
call_win64* = 1; |
call_sysv* = 2; |
begin_loop* = 1; end_loop* = 2; |
opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5; |
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; opDIV* = 10; opMOD* = 11; |
opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; opUMINUS* = 16; |
opADD* = 17; opSUB* = 18; opONERR* = 19; opSUBL* = 20; opADDC* = 21; opSUBR* = 22; |
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28; |
opNOT* = 29; |
opEQ* = 30; opNE* = opEQ + 1; opLT* = opEQ + 2; opLE* = opEQ + 3; opGT* = opEQ + 4; opGE* = opEQ + 5 (* 35 *); |
opEQC* = 36; opNEC* = opEQC + 1; opLTC* = opEQC + 2; opLEC* = opEQC + 3; opGTC* = opEQC + 4; opGEC* = opEQC + 5; (* 41 *) |
opEQF* = 42; opNEF* = opEQF + 1; opLTF* = opEQF + 2; opLEF* = opEQF + 3; opGTF* = opEQF + 4; opGEF* = opEQF + 5; (* 47 *) |
opEQS* = 48; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5; (* 53 *) |
opEQSW* = 54; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 59 *); |
opVLOAD32* = 60; opGLOAD32* = 61; |
opJZ* = 62; opJNZ* = 63; |
opSAVE32* = 64; opLLOAD8* = 65; |
opCONSTF* = 66; opLOADF* = 67; opSAVEF* = 68; opMULF* = 69; opDIVF* = 70; opDIVFI* = 71; |
opUMINF* = 72; opSAVEFI* = 73; opSUBFI* = 74; opADDF* = 75; opSUBF* = 76; |
opJNZ1* = 77; opJG* = 78; |
opINCCB* = 79; opDECCB* = 80; opINCB* = 81; opDECB* = 82; |
opCASEL* = 83; opCASER* = 84; opCASELR* = 85; |
opPOPSP* = 86; |
opWIN64CALL* = 87; opWIN64CALLI* = 88; opWIN64CALLP* = 89; opAND* = 90; opOR* = 91; |
opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97; |
opPUSHC* = 98; opSWITCH* = 99; |
opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102; |
opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106; |
opADDS* = 107; opSUBS* = 108; opERR* = 109; opSUBSL* = 110; opADDSC* = 111; opSUBSR* = 112; |
opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116; |
opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121; |
opLEAVEC* = 122; opCODE* = 123; opALIGN16* = 124; |
opINCC* = 125; opINC* = 126; opDEC* = 127; |
opINCL* = 128; opEXCL* = 129; opINCLC* = 130; opEXCLC* = 131; opNEW* = 132; opDISP* = 133; |
opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139; |
opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145; |
opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151; |
opGETC* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156; |
opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162; |
opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168; |
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173; |
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opLENGTHW* = 179; |
opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184; |
opLSR* = 185; opLSR1* = 186; opLSR2* = 187; |
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opSYSVALIGN16* = 192; |
opEQB* = 193; opNEB* = 194; opINF* = 195; opWIN64ALIGN16* = 196; opVLOAD8* = 197; opGLOAD8* = 198; |
opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201; |
opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206; |
opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212; |
opSAVE16C* = 213; opWCHR* = 214; opHANDLER* = 215; |
opSYSVCALL* = 216; opSYSVCALLI* = 217; opSYSVCALLP* = 218; opFNAME* = 219; |
opSADR_PARAM* = -1; opLOAD64_PARAM* = -2; opLLOAD64_PARAM* = -3; opGLOAD64_PARAM* = -4; |
opVADR_PARAM* = -5; opCONST_PARAM* = -6; opGLOAD32_PARAM* = -7; opLLOAD32_PARAM* = -8; |
opLOAD32_PARAM* = -9; |
opLADR_SAVEC* = -10; opGADR_SAVEC* = -11; opLADR_SAVE* = -12; |
opLADR_INCC* = -13; opLADR_INCCB* = -14; opLADR_DECCB* = -15; |
opLADR_INC* = -16; opLADR_DEC* = -17; opLADR_INCB* = -18; opLADR_DECB* = -19; |
opLADR_INCL* = -20; opLADR_EXCL* = -21; opLADR_INCLC* = -22; opLADR_EXCLC* = -23; |
opLADR_UNPK* = -24; |
_init *= 0; |
_move *= 1; |
_strcmpw *= 2; |
_exit *= 3; |
_set *= 4; |
_set1 *= 5; |
_lengthw *= 6; |
_strcpy *= 7; |
_length *= 8; |
_divmod *= 9; |
_dllentry *= 10; |
_sofinit *= 11; |
_arrcpy *= 12; |
_rot *= 13; |
_new *= 14; |
_dispose *= 15; |
_strcmp *= 16; |
_error *= 17; |
_is *= 18; |
_isrec *= 19; |
_guard *= 20; |
_guardrec *= 21; |
_fmul *= 22; |
_fdiv *= 23; |
_fdivi *= 24; |
_fadd *= 25; |
_fsub *= 26; |
_fsubi *= 27; |
_fcmp *= 28; |
_floor *= 29; |
_flt *= 30; |
_pack *= 31; |
_unpk *= 32; |
TYPE |
COMMAND* = POINTER TO RECORD (LISTS.ITEM) |
opcode*: INTEGER; |
param1*: INTEGER; |
param2*: INTEGER; |
param3*: INTEGER; |
float*: REAL |
END; |
FNAMECMD* = POINTER TO RECORD (COMMAND) |
fname*: PATHS.PATH |
END; |
CMDSTACK = POINTER TO RECORD |
data: ARRAY 1000 OF COMMAND; |
top: INTEGER |
END; |
EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
name*: SCAN.IDSTR |
END; |
IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM) |
name*: SCAN.TEXTSTR; |
procs*: LISTS.LIST |
END; |
IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
lib*: IMPORT_LIB; |
name*: SCAN.TEXTSTR; |
count: INTEGER |
END; |
CODES = RECORD |
last: COMMAND; |
begcall: CMDSTACK; |
endcall: CMDSTACK; |
commands*: LISTS.LIST; |
export*: LISTS.LIST; |
_import*: LISTS.LIST; |
types*: CHL.INTLIST; |
data*: CHL.BYTELIST; |
dmin*: INTEGER; |
lcount*: INTEGER; |
bss*: INTEGER; |
rtl*: ARRAY 33 OF INTEGER; |
errlabels*: ARRAY 12 OF INTEGER; |
charoffs: ARRAY 256 OF INTEGER; |
wcharoffs: ARRAY 65536 OF INTEGER; |
wstr: ARRAY 4*1024 OF WCHAR |
END; |
VAR |
codes*: CODES; |
CPU: INTEGER; |
commands: C.COLLECTION; |
PROCEDURE set_dmin* (value: INTEGER); |
BEGIN |
codes.dmin := value |
END set_dmin; |
PROCEDURE set_bss* (value: INTEGER); |
BEGIN |
codes.bss := value |
END set_bss; |
PROCEDURE set_rtl* (idx, label: INTEGER); |
BEGIN |
codes.rtl[idx] := label |
END set_rtl; |
PROCEDURE NewCmd (): COMMAND; |
VAR |
cmd: COMMAND; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(commands); |
IF citem = NIL THEN |
NEW(cmd) |
ELSE |
cmd := citem(COMMAND) |
END |
RETURN cmd |
END NewCmd; |
PROCEDURE setlast* (cmd: COMMAND); |
BEGIN |
codes.last := cmd |
END setlast; |
PROCEDURE getlast* (): COMMAND; |
RETURN codes.last |
END getlast; |
PROCEDURE PutByte (b: BYTE); |
BEGIN |
CHL.PushByte(codes.data, b) |
END PutByte; |
PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, n, res: INTEGER; |
BEGIN |
res := CHL.Length(codes.data); |
i := 0; |
n := LENGTH(s); |
WHILE i < n DO |
PutByte(ORD(s[i])); |
INC(i) |
END; |
PutByte(0) |
RETURN res |
END putstr; |
PROCEDURE putstr1* (c: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF codes.charoffs[c] = -1 THEN |
res := CHL.Length(codes.data); |
PutByte(c); |
PutByte(0); |
codes.charoffs[c] := res |
ELSE |
res := codes.charoffs[c] |
END |
RETURN res |
END putstr1; |
PROCEDURE putstrW* (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, n, res: INTEGER; |
BEGIN |
res := CHL.Length(codes.data); |
IF ODD(res) THEN |
PutByte(0); |
INC(res) |
END; |
n := STRINGS.Utf8To16(s, codes.wstr); |
i := 0; |
WHILE i < n DO |
IF TARGETS.LittleEndian THEN |
PutByte(ORD(codes.wstr[i]) MOD 256); |
PutByte(ORD(codes.wstr[i]) DIV 256) |
ELSE |
PutByte(ORD(codes.wstr[i]) DIV 256); |
PutByte(ORD(codes.wstr[i]) MOD 256) |
END; |
INC(i) |
END; |
PutByte(0); |
PutByte(0) |
RETURN res |
END putstrW; |
PROCEDURE putstrW1* (c: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF codes.wcharoffs[c] = -1 THEN |
res := CHL.Length(codes.data); |
IF ODD(res) THEN |
PutByte(0); |
INC(res) |
END; |
IF TARGETS.LittleEndian THEN |
PutByte(c MOD 256); |
PutByte(c DIV 256) |
ELSE |
PutByte(c DIV 256); |
PutByte(c MOD 256) |
END; |
PutByte(0); |
PutByte(0); |
codes.wcharoffs[c] := res |
ELSE |
res := codes.wcharoffs[c] |
END |
RETURN res |
END putstrW1; |
PROCEDURE push (stk: CMDSTACK; cmd: COMMAND); |
BEGIN |
INC(stk.top); |
stk.data[stk.top] := cmd |
END push; |
PROCEDURE pop (stk: CMDSTACK): COMMAND; |
VAR |
res: COMMAND; |
BEGIN |
res := stk.data[stk.top]; |
DEC(stk.top) |
RETURN res |
END pop; |
PROCEDURE pushBegEnd* (VAR beg, _end: COMMAND); |
BEGIN |
push(codes.begcall, beg); |
push(codes.endcall, _end); |
beg := codes.last; |
_end := beg.next(COMMAND) |
END pushBegEnd; |
PROCEDURE popBegEnd* (VAR beg, _end: COMMAND); |
BEGIN |
beg := pop(codes.begcall); |
_end := pop(codes.endcall) |
END popBegEnd; |
PROCEDURE AddRec* (base: INTEGER); |
BEGIN |
CHL.PushInt(codes.types, base) |
END AddRec; |
PROCEDURE insert (cur, nov: COMMAND); |
VAR |
old_opcode, param2: INTEGER; |
PROCEDURE set (cur: COMMAND; opcode, param2: INTEGER); |
BEGIN |
cur.opcode := opcode; |
cur.param1 := cur.param2; |
cur.param2 := param2 |
END set; |
BEGIN |
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64, TARGETS.cpuMSP430} THEN |
old_opcode := cur.opcode; |
param2 := nov.param2; |
IF (nov.opcode = opPARAM) & (param2 = 1) THEN |
CASE old_opcode OF |
|opGLOAD64: cur.opcode := opGLOAD64_PARAM |
|opLLOAD64: cur.opcode := opLLOAD64_PARAM |
|opLOAD64: cur.opcode := opLOAD64_PARAM |
|opGLOAD32: cur.opcode := opGLOAD32_PARAM |
|opLLOAD32: cur.opcode := opLLOAD32_PARAM |
|opLOAD32: cur.opcode := opLOAD32_PARAM |
|opSADR: cur.opcode := opSADR_PARAM |
|opVADR: cur.opcode := opVADR_PARAM |
|opCONST: cur.opcode := opCONST_PARAM |
ELSE |
old_opcode := -1 |
END |
ELSIF old_opcode = opLADR THEN |
CASE nov.opcode OF |
|opSAVEC: set(cur, opLADR_SAVEC, param2) |
|opSAVE: cur.opcode := opLADR_SAVE |
|opINC: cur.opcode := opLADR_INC |
|opDEC: cur.opcode := opLADR_DEC |
|opINCB: cur.opcode := opLADR_INCB |
|opDECB: cur.opcode := opLADR_DECB |
|opINCL: cur.opcode := opLADR_INCL |
|opEXCL: cur.opcode := opLADR_EXCL |
|opUNPK: cur.opcode := opLADR_UNPK |
|opINCC: set(cur, opLADR_INCC, param2) |
|opINCCB: set(cur, opLADR_INCCB, param2) |
|opDECCB: set(cur, opLADR_DECCB, param2) |
|opINCLC: set(cur, opLADR_INCLC, param2) |
|opEXCLC: set(cur, opLADR_EXCLC, param2) |
ELSE |
old_opcode := -1 |
END |
ELSIF (nov.opcode = opSAVEC) & (old_opcode = opGADR) THEN |
set(cur, opGADR_SAVEC, param2) |
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN |
cur.param2 := cur.param2 * param2 |
ELSIF (nov.opcode = opADDC) & (old_opcode = opADDC) THEN |
INC(cur.param2, param2) |
ELSE |
old_opcode := -1 |
END |
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN |
old_opcode := cur.opcode; |
param2 := nov.param2; |
IF (old_opcode = opLADR) & (nov.opcode = opSAVE) THEN |
cur.opcode := opLADR_SAVE |
ELSIF (old_opcode = opLADR) & (nov.opcode = opINCC) THEN |
set(cur, opLADR_INCC, param2) |
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN |
cur.param2 := cur.param2 * param2 |
ELSIF (nov.opcode = opADDC) & (old_opcode = opADDC) THEN |
INC(cur.param2, param2) |
ELSE |
old_opcode := -1 |
END |
ELSE |
old_opcode := -1 |
END; |
IF old_opcode = -1 THEN |
LISTS.insert(codes.commands, cur, nov); |
codes.last := nov |
ELSE |
C.push(commands, nov); |
codes.last := cur |
END |
END insert; |
PROCEDURE AddCmd* (opcode: INTEGER; param: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opcode; |
cmd.param1 := 0; |
cmd.param2 := param; |
insert(codes.last, cmd) |
END AddCmd; |
PROCEDURE AddCmd2* (opcode: INTEGER; param1, param2: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opcode; |
cmd.param1 := param1; |
cmd.param2 := param2; |
insert(codes.last, cmd) |
END AddCmd2; |
PROCEDURE Const* (val: INTEGER); |
BEGIN |
AddCmd(opCONST, val) |
END Const; |
PROCEDURE StrAdr* (adr: INTEGER); |
BEGIN |
AddCmd(opSADR, adr) |
END StrAdr; |
PROCEDURE Param1*; |
BEGIN |
AddCmd(opPARAM, 1) |
END Param1; |
PROCEDURE NewLabel* (): INTEGER; |
BEGIN |
INC(codes.lcount) |
RETURN codes.lcount - 1 |
END NewLabel; |
PROCEDURE SetLabel* (label: INTEGER); |
BEGIN |
AddCmd2(opLABEL, label, 0) |
END SetLabel; |
PROCEDURE SetErrLabel* (errno: INTEGER); |
BEGIN |
codes.errlabels[errno] := NewLabel(); |
SetLabel(codes.errlabels[errno]) |
END SetErrLabel; |
PROCEDURE AddCmd0* (opcode: INTEGER); |
BEGIN |
AddCmd(opcode, 0) |
END AddCmd0; |
PROCEDURE delete (cmd: COMMAND); |
BEGIN |
LISTS.delete(codes.commands, cmd); |
C.push(commands, cmd) |
END delete; |
PROCEDURE delete2* (first, last: LISTS.ITEM); |
VAR |
cur, next: LISTS.ITEM; |
BEGIN |
cur := first; |
IF first # last THEN |
REPEAT |
next := cur.next; |
LISTS.delete(codes.commands, cur); |
C.push(commands, cur); |
cur := next |
UNTIL cur = last |
END; |
LISTS.delete(codes.commands, cur); |
C.push(commands, cur) |
END delete2; |
PROCEDURE Jmp* (opcode: INTEGER; label: INTEGER); |
VAR |
prev: COMMAND; |
not: BOOLEAN; |
BEGIN |
prev := codes.last; |
not := prev.opcode = opNOT; |
IF not THEN |
IF opcode = opJNZ THEN |
opcode := opJZ |
ELSIF opcode = opJZ THEN |
opcode := opJNZ |
ELSE |
not := FALSE |
END |
END; |
AddCmd2(opcode, label, label); |
IF not THEN |
delete(prev) |
END |
END Jmp; |
PROCEDURE AndOrOpt* (VAR label: INTEGER); |
VAR |
cur, prev: COMMAND; |
i, op, l: INTEGER; |
jz, not: BOOLEAN; |
BEGIN |
cur := codes.last; |
not := cur.opcode = opNOT; |
IF not THEN |
cur := cur.prev(COMMAND) |
END; |
IF cur.opcode = opAND THEN |
op := opAND |
ELSIF cur.opcode = opOR THEN |
op := opOR |
ELSE |
op := -1 |
END; |
cur := codes.last; |
IF op # -1 THEN |
IF not THEN |
IF op = opAND THEN |
op := opOR |
ELSE (* op = opOR *) |
op := opAND |
END; |
prev := cur.prev(COMMAND); |
delete(cur); |
cur := prev |
END; |
FOR i := 1 TO 9 DO |
IF i = 8 THEN |
l := cur.param1 |
ELSIF i = 9 THEN |
jz := cur.opcode = opJZ |
END; |
prev := cur.prev(COMMAND); |
delete(cur); |
cur := prev |
END; |
setlast(cur); |
IF op = opAND THEN |
label := l; |
jz := ~jz |
END; |
IF jz THEN |
Jmp(opJZ, label) |
ELSE |
Jmp(opJNZ, label) |
END; |
IF op = opOR THEN |
SetLabel(l) |
END |
ELSE |
Jmp(opJZ, label) |
END; |
setlast(codes.last) |
END AndOrOpt; |
PROCEDURE OnError* (line, error: INTEGER); |
BEGIN |
AddCmd2(opONERR, codes.errlabels[error], line) |
END OnError; |
PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
AddCmd(op, t); |
label := NewLabel(); |
Jmp(opJNZ, label); |
OnError(line, error); |
SetLabel(label) |
END TypeGuard; |
PROCEDURE TypeCheck* (t: INTEGER); |
BEGIN |
AddCmd(opIS, t) |
END TypeCheck; |
PROCEDURE TypeCheckRec* (t: INTEGER); |
BEGIN |
AddCmd(opISREC, t) |
END TypeCheckRec; |
PROCEDURE New* (size, typenum: INTEGER); |
BEGIN |
AddCmd2(opNEW, typenum, size) |
END New; |
PROCEDURE not*; |
VAR |
prev: COMMAND; |
BEGIN |
prev := codes.last; |
IF prev.opcode = opNOT THEN |
codes.last := prev.prev(COMMAND); |
delete(prev) |
ELSE |
AddCmd0(opNOT) |
END |
END not; |
PROCEDURE _ord*; |
BEGIN |
IF (codes.last.opcode # opAND) & (codes.last.opcode # opOR) THEN |
AddCmd0(opORD) |
END |
END _ord; |
PROCEDURE Enter* (label, params: INTEGER): COMMAND; |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opENTER; |
cmd.param1 := label; |
cmd.param3 := params; |
insert(codes.last, cmd) |
RETURN codes.last |
END Enter; |
PROCEDURE Leave* (result, float: BOOLEAN; locsize, paramsize: INTEGER): COMMAND; |
BEGIN |
IF result THEN |
IF float THEN |
AddCmd2(opLEAVEF, locsize, paramsize) |
ELSE |
AddCmd2(opLEAVER, locsize, paramsize) |
END |
ELSE |
AddCmd2(opLEAVE, locsize, paramsize) |
END |
RETURN codes.last |
END Leave; |
PROCEDURE EnterC* (label: INTEGER): COMMAND; |
BEGIN |
SetLabel(label) |
RETURN codes.last |
END EnterC; |
PROCEDURE LeaveC* (): COMMAND; |
BEGIN |
AddCmd0(opLEAVEC) |
RETURN codes.last |
END LeaveC; |
PROCEDURE Call* (proc, callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: Jmp(opCALL, proc) |
|call_win64: Jmp(opWIN64CALL, proc) |
|call_sysv: Jmp(opSYSVCALL, proc) |
END; |
codes.last(COMMAND).param2 := fparams |
END Call; |
PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: Jmp(opCALLI, proc(IMPORT_PROC).label) |
|call_win64: Jmp(opWIN64CALLI, proc(IMPORT_PROC).label) |
|call_sysv: Jmp(opSYSVCALLI, proc(IMPORT_PROC).label) |
END; |
codes.last(COMMAND).param2 := fparams |
END CallImp; |
PROCEDURE CallP* (callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: AddCmd0(opCALLP) |
|call_win64: AddCmd(opWIN64CALLP, fparams) |
|call_sysv: AddCmd(opSYSVCALLP, fparams) |
END |
END CallP; |
PROCEDURE AssignProc* (proc: INTEGER); |
BEGIN |
Jmp(opSAVEP, proc) |
END AssignProc; |
PROCEDURE AssignImpProc* (proc: LISTS.ITEM); |
BEGIN |
Jmp(opSAVEIP, proc(IMPORT_PROC).label) |
END AssignImpProc; |
PROCEDURE PushProc* (proc: INTEGER); |
BEGIN |
Jmp(opPUSHP, proc) |
END PushProc; |
PROCEDURE PushImpProc* (proc: LISTS.ITEM); |
BEGIN |
Jmp(opPUSHIP, proc(IMPORT_PROC).label) |
END PushImpProc; |
PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN); |
BEGIN |
IF eq THEN |
Jmp(opEQP, proc) |
ELSE |
Jmp(opNEP, proc) |
END |
END ProcCmp; |
PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN); |
BEGIN |
IF eq THEN |
Jmp(opEQIP, proc(IMPORT_PROC).label) |
ELSE |
Jmp(opNEIP, proc(IMPORT_PROC).label) |
END |
END ProcImpCmp; |
PROCEDURE load* (size: INTEGER); |
VAR |
last: COMMAND; |
BEGIN |
last := codes.last; |
CASE size OF |
|1: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD8 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD8 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD8 |
ELSE |
AddCmd0(opLOAD8) |
END |
|2: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD16 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD16 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD16 |
ELSE |
AddCmd0(opLOAD16) |
END |
|4: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD32 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD32 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD32 |
ELSE |
AddCmd0(opLOAD32) |
END |
|8: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD64 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD64 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD64 |
ELSE |
AddCmd0(opLOAD64) |
END |
END |
END load; |
PROCEDURE SysPut* (size: INTEGER); |
BEGIN |
CASE size OF |
|1: AddCmd0(opSAVE8) |
|2: AddCmd0(opSAVE16) |
|4: AddCmd0(opSAVE32) |
|8: AddCmd0(opSAVE64) |
END |
END SysPut; |
PROCEDURE savef* (inv: BOOLEAN); |
BEGIN |
IF inv THEN |
AddCmd0(opSAVEFI) |
ELSE |
AddCmd0(opSAVEF) |
END |
END savef; |
PROCEDURE saves* (offset, length: INTEGER); |
BEGIN |
AddCmd2(opSAVES, length, offset) |
END saves; |
PROCEDURE abs* (real: BOOLEAN); |
BEGIN |
IF real THEN |
AddCmd0(opFABS) |
ELSE |
AddCmd0(opABS) |
END |
END abs; |
PROCEDURE shift_minmax* (op: CHAR); |
BEGIN |
CASE op OF |
|"A": AddCmd0(opASR) |
|"L": AddCmd0(opLSL) |
|"O": AddCmd0(opROR) |
|"R": AddCmd0(opLSR) |
|"m": AddCmd0(opMIN) |
|"x": AddCmd0(opMAX) |
END |
END shift_minmax; |
PROCEDURE shift_minmax1* (op: CHAR; x: INTEGER); |
BEGIN |
CASE op OF |
|"A": AddCmd(opASR1, x) |
|"L": AddCmd(opLSL1, x) |
|"O": AddCmd(opROR1, x) |
|"R": AddCmd(opLSR1, x) |
|"m": AddCmd(opMINC, x) |
|"x": AddCmd(opMAXC, x) |
END |
END shift_minmax1; |
PROCEDURE shift_minmax2* (op: CHAR; x: INTEGER); |
BEGIN |
CASE op OF |
|"A": AddCmd(opASR2, x) |
|"L": AddCmd(opLSL2, x) |
|"O": AddCmd(opROR2, x) |
|"R": AddCmd(opLSR2, x) |
|"m": AddCmd(opMINC, x) |
|"x": AddCmd(opMAXC, x) |
END |
END shift_minmax2; |
PROCEDURE len* (dim: INTEGER); |
BEGIN |
AddCmd(opLEN, dim) |
END len; |
PROCEDURE Float* (r: REAL; line, col: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opCONSTF; |
cmd.float := r; |
cmd.param1 := line; |
cmd.param2 := col; |
insert(codes.last, cmd) |
END Float; |
PROCEDURE drop*; |
BEGIN |
AddCmd0(opDROP) |
END drop; |
PROCEDURE _case* (a, b, L, R: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
IF a = b THEN |
cmd := NewCmd(); |
cmd.opcode := opCASELR; |
cmd.param1 := a; |
cmd.param2 := L; |
cmd.param3 := R; |
insert(codes.last, cmd) |
ELSE |
AddCmd2(opCASEL, a, L); |
AddCmd2(opCASER, b, R) |
END |
END _case; |
PROCEDURE fname* (name: PATHS.PATH); |
VAR |
cmd: FNAMECMD; |
BEGIN |
NEW(cmd); |
cmd.opcode := opFNAME; |
cmd.fname := name; |
insert(codes.last, cmd) |
END fname; |
PROCEDURE AddExp* (label: INTEGER; name: SCAN.IDSTR); |
VAR |
exp: EXPORT_PROC; |
BEGIN |
NEW(exp); |
exp.label := label; |
exp.name := name; |
LISTS.push(codes.export, exp) |
END AddExp; |
PROCEDURE AddImp* (dll, proc: SCAN.TEXTSTR): IMPORT_PROC; |
VAR |
lib: IMPORT_LIB; |
p: IMPORT_PROC; |
BEGIN |
lib := codes._import.first(IMPORT_LIB); |
WHILE (lib # NIL) & (lib.name # dll) DO |
lib := lib.next(IMPORT_LIB) |
END; |
IF lib = NIL THEN |
NEW(lib); |
lib.name := dll; |
lib.procs := LISTS.create(NIL); |
LISTS.push(codes._import, lib) |
END; |
p := lib.procs.first(IMPORT_PROC); |
WHILE (p # NIL) & (p.name # proc) DO |
p := p.next(IMPORT_PROC) |
END; |
IF p = NIL THEN |
NEW(p); |
p.name := proc; |
p.label := NewLabel(); |
p.lib := lib; |
p.count := 1; |
LISTS.push(lib.procs, p) |
ELSE |
INC(p.count) |
END |
RETURN p |
END AddImp; |
PROCEDURE DelImport* (imp: LISTS.ITEM); |
VAR |
lib: IMPORT_LIB; |
BEGIN |
DEC(imp(IMPORT_PROC).count); |
IF imp(IMPORT_PROC).count = 0 THEN |
lib := imp(IMPORT_PROC).lib; |
LISTS.delete(lib.procs, imp); |
IF lib.procs.first = NIL THEN |
LISTS.delete(codes._import, lib) |
END |
END |
END DelImport; |
PROCEDURE init* (pCPU: INTEGER); |
VAR |
cmd: COMMAND; |
i: INTEGER; |
BEGIN |
commands := C.create(); |
CPU := pCPU; |
NEW(codes.begcall); |
codes.begcall.top := -1; |
NEW(codes.endcall); |
codes.endcall.top := -1; |
codes.commands := LISTS.create(NIL); |
codes.export := LISTS.create(NIL); |
codes._import := LISTS.create(NIL); |
codes.types := CHL.CreateIntList(); |
codes.data := CHL.CreateByteList(); |
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd); |
codes.last := cmd; |
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd); |
AddRec(0); |
codes.lcount := 0; |
FOR i := 0 TO LEN(codes.charoffs) - 1 DO |
codes.charoffs[i] := -1 |
END; |
FOR i := 0 TO LEN(codes.wcharoffs) - 1 DO |
codes.wcharoffs[i] := -1 |
END |
END init; |
END IL. |
/programs/develop/oberon07/source/LISTS.ob07 |
---|
0,0 → 1,199 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE LISTS; |
IMPORT C := COLLECTIONS; |
TYPE |
ITEM* = POINTER TO RECORD (C.ITEM) |
prev*, next*: ITEM |
END; |
LIST* = POINTER TO RECORD |
first*, last*: ITEM |
END; |
PROCEDURE push* (list: LIST; item: ITEM); |
BEGIN |
ASSERT(list # NIL); |
ASSERT(item # NIL); |
IF list.first = NIL THEN |
list.first := item; |
item.prev := NIL |
ELSE |
ASSERT(list.last # NIL); |
item.prev := list.last; |
list.last.next := item |
END; |
list.last := item; |
item.next := NIL |
END push; |
PROCEDURE pop* (list: LIST): ITEM; |
VAR |
last: ITEM; |
BEGIN |
ASSERT(list # NIL); |
last := list.last; |
IF last # NIL THEN |
IF last = list.first THEN |
list.first := NIL; |
list.last := NIL |
ELSE |
list.last := last.prev; |
list.last.next := NIL |
END; |
last.next := NIL; |
last.prev := NIL |
END |
RETURN last |
END pop; |
PROCEDURE insert* (list: LIST; cur, nov: ITEM); |
VAR |
next: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(nov # NIL); |
ASSERT(cur # NIL); |
next := cur.next; |
IF next # NIL THEN |
next.prev := nov; |
nov.next := next; |
cur.next := nov; |
nov.prev := cur |
ELSE |
push(list, nov) |
END |
END insert; |
PROCEDURE insertL* (list: LIST; cur, nov: ITEM); |
VAR |
prev: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(nov # NIL); |
ASSERT(cur # NIL); |
prev := cur.prev; |
IF prev # NIL THEN |
prev.next := nov; |
nov.prev := prev |
ELSE |
nov.prev := NIL; |
list.first := nov |
END; |
cur.prev := nov; |
nov.next := cur |
END insertL; |
PROCEDURE delete* (list: LIST; item: ITEM); |
VAR |
prev, next: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(item # NIL); |
prev := item.prev; |
next := item.next; |
IF next # NIL THEN |
IF prev # NIL THEN |
prev.next := next; |
next.prev := prev |
ELSE |
next.prev := NIL; |
list.first := next |
END |
ELSE |
IF prev # NIL THEN |
prev.next := NIL; |
list.last := prev |
ELSE |
list.first := NIL; |
list.last := NIL |
END |
END |
END delete; |
PROCEDURE count* (list: LIST): INTEGER; |
VAR |
item: ITEM; |
res: INTEGER; |
BEGIN |
ASSERT(list # NIL); |
res := 0; |
item := list.first; |
WHILE item # NIL DO |
INC(res); |
item := item.next |
END |
RETURN res |
END count; |
PROCEDURE getidx* (list: LIST; idx: INTEGER): ITEM; |
VAR |
item: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(idx >= 0); |
item := list.first; |
WHILE (item # NIL) & (idx > 0) DO |
item := item.next; |
DEC(idx) |
END |
RETURN item |
END getidx; |
PROCEDURE create* (list: LIST): LIST; |
BEGIN |
IF list = NIL THEN |
NEW(list) |
END; |
list.first := NIL; |
list.last := NIL |
RETURN list |
END create; |
END LISTS. |
/programs/develop/oberon07/source/MSP430.ob07 |
---|
0,0 → 1,1780 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE MSP430; |
IMPORT IL, LISTS, REG, CHL := CHUNKLISTS, ERRORS, WR := WRITER, HEX, |
UTILS, C := CONSOLE, PROG, RTL := MSP430RTL; |
CONST |
chkSTK* = 6; |
minRAM* = 128; maxRAM* = 2048; |
minROM* = 2048; maxROM* = 24576; |
StkReserve = RTL.StkReserve; |
IntVectorSize* = RTL.IntVectorSize; |
PC = 0; SP = 1; SR = 2; CG = 3; |
R4 = 4; R5 = 5; R6 = 6; R7 = 7; |
HP = RTL.HP; |
ACC = R4; |
opRRC = 1000H; opSWPB = 1080H; opRRA = 1100H; opSXT = 1180H; |
opPUSH = 1200H; opCALL = 1280H; opRETI = 1300H; |
opMOV = 04000H; opADD = 05000H; opADDC = 06000H; opSUBC = 07000H; |
opSUB = 08000H; opCMP = 09000H; opDADD = 0A000H; opBIT = 0B000H; |
opBIC = 0C000H; opBIS = 0D000H; opXOR = 0E000H; opAND = 0F000H; |
opJNE = 2000H; opJEQ = 2400H; opJNC = 2800H; opJC = 2C00H; |
opJN = 3000H; opJGE = 3400H; opJL = 3800H; opJMP = 3C00H; |
sREG = 0; sIDX = 16; sINDIR = 32; sINCR = 48; BW = 64; dIDX = 128; |
NOWORD = 10000H; |
RCODE = 0; RDATA = 1; RBSS = 2; |
je = 0; jne = je + 1; |
jge = 2; jl = jge + 1; |
jle = 4; jg = jle + 1; |
jb = 6; |
TYPE |
ANYCODE = POINTER TO RECORD (LISTS.ITEM) |
offset: INTEGER |
END; |
WORD = POINTER TO RECORD (ANYCODE) |
val: INTEGER |
END; |
LABEL = POINTER TO RECORD (ANYCODE) |
num: INTEGER |
END; |
JMP = POINTER TO RECORD (ANYCODE) |
cc, label: INTEGER; |
short: BOOLEAN |
END; |
CALL = POINTER TO RECORD (ANYCODE) |
label: INTEGER |
END; |
COMMAND = IL.COMMAND; |
RELOC = POINTER TO RECORD (LISTS.ITEM) |
section: INTEGER; |
WordPtr: WORD |
END; |
VAR |
R: REG.REGS; |
CodeList: LISTS.LIST; |
RelList: LISTS.LIST; |
mem: ARRAY 65536 OF BYTE; |
Labels: CHL.INTLIST; |
IV: ARRAY RTL.LenIV OF INTEGER; |
IdxWords: RECORD src, dst: INTEGER END; |
StkCnt, MaxStkCnt: INTEGER; |
PROCEDURE CheckProcDataSize* (VarSize, RamSize: INTEGER): BOOLEAN; |
RETURN (VarSize + 1) * 2 + StkReserve + RTL.VarSize < RamSize |
END CheckProcDataSize; |
PROCEDURE EmitLabel (L: INTEGER); |
VAR |
label: LABEL; |
BEGIN |
NEW(label); |
label.num := L; |
LISTS.push(CodeList, label) |
END EmitLabel; |
PROCEDURE EmitWord (val: INTEGER); |
VAR |
word: WORD; |
BEGIN |
IF val < 0 THEN |
ASSERT(val >= -32768); |
val := val MOD 65536 |
ELSE |
ASSERT(val <= 65535) |
END; |
NEW(word); |
word.val := val; |
LISTS.push(CodeList, word) |
END EmitWord; |
PROCEDURE EmitJmp (cc, label: INTEGER); |
VAR |
jmp: JMP; |
BEGIN |
NEW(jmp); |
jmp.cc := cc; |
jmp.label := label; |
jmp.short := FALSE; |
LISTS.push(CodeList, jmp) |
END EmitJmp; |
PROCEDURE EmitCall (label: INTEGER); |
VAR |
call: CALL; |
BEGIN |
NEW(call); |
call.label := label; |
LISTS.push(CodeList, call) |
END EmitCall; |
PROCEDURE IncStk; |
BEGIN |
INC(StkCnt); |
MaxStkCnt := MAX(StkCnt, MaxStkCnt) |
END IncStk; |
PROCEDURE bw (b: BOOLEAN): INTEGER; |
RETURN BW * ORD(b) |
END bw; |
PROCEDURE src_x (x, Rn: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF (x = 0) & ~(Rn IN {PC, SR, CG}) THEN |
res := Rn * 256 + sINDIR |
ELSE |
IdxWords.src := x; |
res := Rn * 256 + sIDX |
END |
RETURN res |
END src_x; |
PROCEDURE dst_x (x, Rn: INTEGER): INTEGER; |
BEGIN |
IdxWords.dst := x |
RETURN Rn + dIDX |
END dst_x; |
PROCEDURE indir (Rn: INTEGER): INTEGER; |
RETURN Rn * 256 + sINDIR |
END indir; |
PROCEDURE incr (Rn: INTEGER): INTEGER; |
RETURN Rn * 256 + sINCR |
END incr; |
PROCEDURE imm (x: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE x OF |
| 0: res := CG * 256 |
| 1: res := CG * 256 + sIDX |
| 2: res := indir(CG) |
| 4: res := indir(SR) |
| 8: res := incr(SR) |
|-1: res := incr(CG) |
ELSE |
res := incr(PC); |
IdxWords.src := x |
END |
RETURN res |
END imm; |
PROCEDURE Op2 (op, src, dst: INTEGER); |
BEGIN |
ASSERT(BITS(op) - {6, 12..15} = {}); |
ASSERT(BITS(src) - {4, 5, 8..11} = {}); |
ASSERT(BITS(dst) - {0..3, 7} = {}); |
EmitWord(op + src + dst); |
IF IdxWords.src # NOWORD THEN |
EmitWord(IdxWords.src); |
IdxWords.src := NOWORD |
END; |
IF IdxWords.dst # NOWORD THEN |
EmitWord(IdxWords.dst); |
IdxWords.dst := NOWORD |
END |
END Op2; |
PROCEDURE Op1 (op, reg, As: INTEGER); |
BEGIN |
EmitWord(op + reg + As) |
END Op1; |
PROCEDURE MovRR (src, dst: INTEGER); |
BEGIN |
Op2(opMOV, src * 256, dst) |
END MovRR; |
PROCEDURE PushImm (imm: INTEGER); |
BEGIN |
imm := UTILS.Long(imm); |
CASE imm OF |
| 0: Op1(opPUSH, CG, sREG) |
| 1: Op1(opPUSH, CG, sIDX) |
| 2: Op1(opPUSH, CG, sINDIR) |
|-1: Op1(opPUSH, CG, sINCR) |
ELSE |
Op1(opPUSH, PC, sINCR); |
EmitWord(imm) |
END; |
IncStk |
END PushImm; |
PROCEDURE PutWord (word: INTEGER; VAR adr: INTEGER); |
BEGIN |
ASSERT(~ODD(adr)); |
ASSERT((0 <= word) & (word <= 65535)); |
mem[adr] := word MOD 256; |
mem[adr + 1] := word DIV 256; |
INC(adr, 2) |
END PutWord; |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
CHL.PushInt(Labels, 0) |
RETURN IL.NewLabel() |
END NewLabel; |
PROCEDURE LabelOffs (n: INTEGER): INTEGER; |
RETURN CHL.GetInt(Labels, n) |
END LabelOffs; |
PROCEDURE Fixup (CodeAdr, IntVectorSize: INTEGER): INTEGER; |
VAR |
cmd: ANYCODE; |
adr: INTEGER; |
offset: INTEGER; |
diff: INTEGER; |
cc: INTEGER; |
shorted: BOOLEAN; |
BEGIN |
REPEAT |
shorted := FALSE; |
offset := CodeAdr DIV 2; |
cmd := CodeList.first(ANYCODE); |
WHILE cmd # NIL DO |
cmd.offset := offset; |
CASE cmd OF |
|LABEL: CHL.SetInt(Labels, cmd.num, offset) |
|JMP: INC(offset); |
IF ~cmd.short THEN |
INC(offset); |
IF cmd.cc # opJMP THEN |
INC(offset) |
END |
END |
|CALL: INC(offset, 2) |
|WORD: INC(offset) |
END; |
cmd := cmd.next(ANYCODE) |
END; |
cmd := CodeList.first(ANYCODE); |
WHILE cmd # NIL DO |
IF (cmd IS JMP) & ~cmd(JMP).short THEN |
diff := LabelOffs(cmd(JMP).label) - cmd.offset - 1; |
IF ABS(diff) <= 512 THEN |
cmd(JMP).short := TRUE; |
shorted := TRUE |
END |
END; |
cmd := cmd.next(ANYCODE) |
END |
UNTIL ~shorted; |
IF offset * 2 > 10000H - IntVectorSize THEN |
ERRORS.Error(203) |
END; |
adr := CodeAdr; |
cmd := CodeList.first(ANYCODE); |
WHILE cmd # NIL DO |
CASE cmd OF |
|LABEL: |
|JMP: IF ~cmd.short THEN |
CASE cmd.cc OF |
|opJNE: cc := opJEQ |
|opJEQ: cc := opJNE |
|opJNC: cc := opJC |
|opJC: cc := opJNC |
|opJGE: cc := opJL |
|opJL: cc := opJGE |
|opJMP: cc := opJMP |
END; |
IF cc # opJMP THEN |
PutWord(cc + 2, adr) (* jcc L *) |
END; |
PutWord(4030H, adr); (* MOV @PC+, PC *) |
PutWord(LabelOffs(cmd.label) * 2, adr) |
(* L: *) |
ELSE |
diff := LabelOffs(cmd.label) - cmd.offset - 1; |
ASSERT((-512 <= diff) & (diff <= 511)); |
PutWord(cmd.cc + diff MOD 1024, adr) |
END |
|CALL: PutWord(12B0H, adr); (* CALL @PC+ *) |
PutWord(LabelOffs(cmd.label) * 2, adr) |
|WORD: PutWord(cmd.val, adr) |
END; |
cmd := cmd.next(ANYCODE) |
END |
RETURN adr - CodeAdr |
END Fixup; |
PROCEDURE Push (reg: INTEGER); |
BEGIN |
Op1(opPUSH, reg, sREG); |
IncStk |
END Push; |
PROCEDURE Pop (reg: INTEGER); |
BEGIN |
Op2(opMOV, incr(SP), reg); |
DEC(StkCnt) |
END Pop; |
PROCEDURE Test (reg: INTEGER); |
BEGIN |
Op2(opCMP, imm(0), reg) |
END Test; |
PROCEDURE Clear (reg: INTEGER); |
BEGIN |
Op2(opMOV, imm(0), reg) |
END Clear; |
PROCEDURE mov (dst, src: INTEGER); |
BEGIN |
MovRR(src, dst) |
END mov; |
PROCEDURE xchg (reg1, reg2: INTEGER); |
BEGIN |
Push(reg1); |
mov(reg1, reg2); |
Pop(reg2) |
END xchg; |
PROCEDURE Reloc (section: INTEGER); |
VAR |
reloc: RELOC; |
BEGIN |
NEW(reloc); |
reloc.section := section; |
reloc.WordPtr := CodeList.last(WORD); |
LISTS.push(RelList, reloc) |
END Reloc; |
PROCEDURE CallRTL (proc, params: INTEGER); |
BEGIN |
IncStk; |
DEC(StkCnt); |
EmitCall(RTL.rtl[proc].label); |
RTL.Used(proc); |
IF params > 0 THEN |
Op2(opADD, imm(params * 2), SP); |
DEC(StkCnt, params) |
END |
END CallRTL; |
PROCEDURE UnOp (VAR reg: INTEGER); |
BEGIN |
REG.UnOp(R, reg) |
END UnOp; |
PROCEDURE BinOp (VAR reg1, reg2: INTEGER); |
BEGIN |
REG.BinOp(R, reg1, reg2) |
END BinOp; |
PROCEDURE GetRegA; |
BEGIN |
ASSERT(REG.GetReg(R, ACC)) |
END GetRegA; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE PushAll_1; |
BEGIN |
REG.PushAll_1(R) |
END PushAll_1; |
PROCEDURE cond (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|IL.opGT, IL.opGTC: res := jg |
|IL.opGE, IL.opGEC: res := jge |
|IL.opLT, IL.opLTC: res := jl |
|IL.opLE, IL.opLEC: res := jle |
|IL.opEQ, IL.opEQC: res := je |
|IL.opNE, IL.opNEC: res := jne |
END |
RETURN res |
END cond; |
PROCEDURE jcc (cc, label: INTEGER); |
VAR |
L: INTEGER; |
BEGIN |
CASE cc OF |
|jne: |
EmitJmp(opJNE, label) |
|je: |
EmitJmp(opJEQ, label) |
|jge: |
EmitJmp(opJGE, label) |
|jl: |
EmitJmp(opJL, label) |
|jle: |
EmitJmp(opJL, label); |
EmitJmp(opJEQ, label) |
|jg: |
L := NewLabel(); |
EmitJmp(opJEQ, L); |
EmitJmp(opJGE, label); |
EmitLabel(L) |
|jb: |
EmitJmp(opJNC, label) |
END |
END jcc; |
PROCEDURE setcc (cc, reg: INTEGER); |
VAR |
L: INTEGER; |
BEGIN |
L := NewLabel(); |
Op2(opMOV, imm(1), reg); |
jcc(cc, L); |
Clear(reg); |
EmitLabel(L) |
END setcc; |
PROCEDURE Shift2 (op, reg, n: INTEGER); |
VAR |
reg2: INTEGER; |
BEGIN |
IF n >= 8 THEN |
CASE op OF |
|IL.opASR2: Op1(opSWPB, reg, sREG); Op1(opSXT, reg, sREG) |
|IL.opROR2: Op1(opSWPB, reg, sREG) |
|IL.opLSL2: Op1(opSWPB, reg, sREG); Op2(opBIC, imm(255), reg) |
|IL.opLSR2: Op2(opBIC, imm(255), reg); Op1(opSWPB, reg, sREG) |
END; |
DEC(n, 8) |
END; |
IF (op = IL.opROR2) & (n > 0) THEN |
reg2 := GetAnyReg(); |
MovRR(reg, reg2) |
ELSE |
reg2 := -1 |
END; |
WHILE n > 0 DO |
CASE op OF |
|IL.opASR2: Op1(opRRA, reg, sREG) |
|IL.opROR2: Op1(opRRC, reg2, sREG); Op1(opRRC, reg, sREG) |
|IL.opLSL2: Op2(opADD, reg * 256, reg) |
|IL.opLSR2: Op2(opBIC, imm(1), SR); Op1(opRRC, reg, sREG) |
END; |
DEC(n) |
END; |
IF reg2 # -1 THEN |
drop |
END |
END Shift2; |
PROCEDURE Neg (reg: INTEGER); |
BEGIN |
Op2(opXOR, imm(-1), reg); |
Op2(opADD, imm(1), reg) |
END Neg; |
PROCEDURE LocalOffset (offset: INTEGER): INTEGER; |
RETURN (offset + StkCnt - ORD(offset > 0)) * 2 |
END LocalOffset; |
PROCEDURE LocalDst (offset: INTEGER): INTEGER; |
RETURN dst_x(LocalOffset(offset), SP) |
END LocalDst; |
PROCEDURE LocalSrc (offset: INTEGER): INTEGER; |
RETURN src_x(LocalOffset(offset), SP) |
END LocalSrc; |
PROCEDURE translate (chk_stk: BOOLEAN); |
VAR |
cmd, next: COMMAND; |
opcode, param1, param2, L, a, n, c1, c2: INTEGER; |
reg1, reg2: INTEGER; |
cc: INTEGER; |
word: WORD; |
BEGIN |
cmd := IL.codes.commands.first(COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
EmitJmp(opJMP, param1) |
|IL.opCALL: |
IncStk; |
DEC(StkCnt); |
EmitCall(param1) |
|IL.opCALLP: |
IncStk; |
DEC(StkCnt); |
UnOp(reg1); |
Op1(opCALL, reg1, sREG); |
drop; |
ASSERT(R.top = -1) |
|IL.opPRECALL: |
PushAll(0) |
|IL.opLABEL: |
EmitLabel(param1) |
|IL.opSADR_PARAM: |
Op1(opPUSH, PC, sINCR); |
IncStk; |
EmitWord(param2); |
Reloc(RDATA) |
|IL.opERR: |
CallRTL(RTL._error, 2) |
|IL.opPUSHC: |
PushImm(param2) |
|IL.opONERR: |
DEC(StkCnt); |
EmitWord(0C232H); (* BIC #8, SR; DINT *) |
EmitWord(4303H); (* MOV R3, R3; NOP *) |
PushImm(param2); |
EmitJmp(opJMP, param1) |
|IL.opLEAVEC: |
Pop(PC) |
|IL.opENTER: |
ASSERT(R.top = -1); |
EmitLabel(param1); |
n := param2 MOD 65536; |
param2 := param2 DIV 65536; |
StkCnt := 0; |
IF chk_stk THEN |
L := NewLabel(); |
Op2(opMOV, SP * 256, R4); |
Op2(opSUB, HP * 256, R4); |
Op2(opCMP, imm(StkReserve), R4); |
word := CodeList.last(WORD); |
jcc(jge, L); |
DEC(StkCnt); |
EmitWord(0C232H); (* BIC #8, SR; DINT *) |
EmitWord(4303H); (* MOV R3, R3; NOP *) |
PushImm(n); |
EmitJmp(opJMP, cmd.param3); |
EmitLabel(L) |
END; |
IF param2 > 8 THEN |
Op2(opMOV, imm(param2), R4); |
L := NewLabel(); |
EmitLabel(L); |
Push(CG); |
Op2(opSUB, imm(1), R4); |
jcc(jne, L) |
ELSE |
FOR n := 1 TO param2 DO |
Push(CG) |
END |
END; |
StkCnt := param2; |
MaxStkCnt := StkCnt |
|IL.opLEAVE, IL.opLEAVER: |
ASSERT(param2 = 0); |
IF opcode = IL.opLEAVER THEN |
UnOp(reg1); |
IF reg1 # ACC THEN |
mov(ACC, reg1) |
END; |
drop |
END; |
ASSERT(R.top = -1); |
ASSERT(StkCnt = param1); |
IF chk_stk THEN |
INC(word.val, MaxStkCnt * 2) |
END; |
IF param1 > 0 THEN |
Op2(opADD, imm(param1 * 2), SP) |
END; |
Pop(PC) |
|IL.opRES: |
ASSERT(R.top = -1); |
GetRegA |
|IL.opCLEANUP: |
IF param2 # 0 THEN |
Op2(opADD, imm(param2 * 2), SP); |
DEC(StkCnt, param2) |
END |
|IL.opCONST: |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opCONST THEN |
c1 := param2; |
c2 := next.param2; |
next := next.next(COMMAND); |
IF (next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVE16) OR (next.opcode = IL.opSAVE8) THEN |
Op2(opMOV + bw(next.opcode = IL.opSAVE8), imm(c1), dst_x(c2, SR)); |
cmd := next |
ELSE |
Op2(opMOV, imm(param2), GetAnyReg()) |
END |
ELSIF (next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVE16) OR (next.opcode = IL.opSAVE8) THEN |
UnOp(reg1); |
Op2(opMOV + bw(next.opcode = IL.opSAVE8), reg1 * 256, dst_x(param2, SR)); |
drop; |
cmd := next |
ELSE |
Op2(opMOV, imm(param2), GetAnyReg()) |
END |
|IL.opSADR: |
Op2(opMOV, incr(PC), GetAnyReg()); |
EmitWord(param2); |
Reloc(RDATA) |
|IL.opGADR: |
Op2(opMOV, incr(PC), GetAnyReg()); |
EmitWord(param2); |
Reloc(RBSS) |
|IL.opLADR: |
reg1 := GetAnyReg(); |
n := LocalOffset(param2); |
Op2(opMOV, SP * 256, reg1); |
IF n # 0 THEN |
Op2(opADD, imm(n), reg1) |
END |
|IL.opLLOAD8: |
Op2(opMOV + BW, LocalSrc(param2), GetAnyReg()) |
|IL.opLLOAD16, IL.opVADR: |
Op2(opMOV, LocalSrc(param2), GetAnyReg()) |
|IL.opGLOAD8: |
Op2(opMOV + BW, src_x(param2, SR), GetAnyReg()); |
Reloc(RBSS) |
|IL.opGLOAD16: |
Op2(opMOV, src_x(param2, SR), GetAnyReg()); |
Reloc(RBSS) |
|IL.opLOAD8: |
UnOp(reg1); |
Op2(opMOV + BW, indir(reg1), reg1) |
|IL.opLOAD16: |
UnOp(reg1); |
Op2(opMOV, indir(reg1), reg1) |
|IL.opVLOAD8: |
reg1 := GetAnyReg(); |
Op2(opMOV, LocalSrc(param2), reg1); |
Op2(opMOV + BW, indir(reg1), reg1) |
|IL.opVLOAD16: |
reg1 := GetAnyReg(); |
Op2(opMOV, LocalSrc(param2), reg1); |
Op2(opMOV, indir(reg1), reg1) |
|IL.opSAVE, IL.opSAVE16: |
BinOp(reg2, reg1); |
Op2(opMOV, reg2 * 256, dst_x(0, reg1)); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(reg2, reg1); |
Op2(opMOV + BW, reg2 * 256, dst_x(0, reg1)); |
drop; |
drop |
|IL.opSAVE8C: |
UnOp(reg1); |
Op2(opMOV + BW, imm(param2), dst_x(0, reg1)); |
drop |
|IL.opSAVE16C, IL.opSAVEC: |
UnOp(reg1); |
Op2(opMOV, imm(param2), dst_x(0, reg1)); |
drop |
|IL.opUMINUS: |
UnOp(reg1); |
Neg(reg1) |
|IL.opADD: |
BinOp(reg1, reg2); |
Op2(opADD, reg2 * 256, reg1); |
drop |
|IL.opADDC: |
IF param2 # 0 THEN |
UnOp(reg1); |
Op2(opADD, imm(param2), reg1) |
END |
|IL.opSUB: |
BinOp(reg1, reg2); |
Op2(opSUB, reg2 * 256, reg1); |
drop |
|IL.opSUBR, IL.opSUBL: |
UnOp(reg1); |
IF param2 # 0 THEN |
Op2(opSUB, imm(param2), reg1) |
END; |
IF opcode = IL.opSUBL THEN |
Neg(reg1) |
END |
|IL.opLADR_SAVEC: |
Op2(opMOV, imm(param2), LocalDst(param1)) |
|IL.opLADR_SAVE: |
UnOp(reg1); |
Op2(opMOV, reg1 * 256, LocalDst(param2)); |
drop |
|IL.opGADR_SAVEC: |
Op2(opMOV, imm(param2), dst_x(param1, SR)); |
Reloc(RBSS) |
|IL.opCONST_PARAM: |
PushImm(param2) |
|IL.opPARAM: |
IF param2 = 1 THEN |
UnOp(reg1); |
Push(reg1); |
drop |
ELSE |
ASSERT(R.top + 1 <= param2); |
PushAll(param2) |
END |
|IL.opEQ..IL.opGE, |
IL.opEQC..IL.opGEC: |
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN |
BinOp(reg1, reg2); |
Op2(opCMP, reg2 * 256, reg1); |
drop |
ELSE |
UnOp(reg1); |
Op2(opCMP, imm(param2), reg1) |
END; |
drop; |
cc := cond(opcode); |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opJNZ THEN |
jcc(cc, next.param1); |
cmd := next |
ELSIF next.opcode = IL.opJZ THEN |
jcc(ORD(BITS(cc) / {0}), next.param1); |
cmd := next |
ELSE |
setcc(cc, GetAnyReg()) |
END |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opCODE: |
EmitWord(param2) |
|IL.opDROP: |
UnOp(reg1); |
drop |
|IL.opJNZ1: |
UnOp(reg1); |
Test(reg1); |
jcc(jne, param1) |
|IL.opJG: |
UnOp(reg1); |
Test(reg1); |
jcc(jg, param1) |
|IL.opJNZ: |
UnOp(reg1); |
Test(reg1); |
jcc(jne, param1); |
drop |
|IL.opJZ: |
UnOp(reg1); |
Test(reg1); |
jcc(je, param1); |
drop |
|IL.opNOT: |
UnOp(reg1); |
Test(reg1); |
setcc(je, reg1) |
|IL.opORD: |
UnOp(reg1); |
Test(reg1); |
setcc(jne, reg1) |
|IL.opGET: |
BinOp(reg1, reg2); |
drop; |
drop; |
Op2(opMOV + bw(param2 = 1), indir(reg1), dst_x(0, reg2)) |
|IL.opGETC: |
UnOp(reg2); |
drop; |
Op2(opMOV + bw(param2 = 1), src_x(param1, SR), dst_x(0, reg2)) |
|IL.opCHKBYTE: |
BinOp(reg1, reg2); |
Op2(opCMP, imm(256), reg1); |
jcc(jb, param1) |
|IL.opCHKIDX: |
UnOp(reg1); |
Op2(opCMP, imm(param2), reg1); |
jcc(jb, param1) |
|IL.opCHKIDX2: |
BinOp(reg1, reg2); |
IF param2 # -1 THEN |
Op2(opCMP, reg1 * 256, reg2); |
jcc(jb, param1) |
END; |
INCL(R.regs, reg1); |
DEC(R.top); |
R.stk[R.top] := reg2 |
|IL.opINCC, IL.opINCCB: |
UnOp(reg1); |
Op2(opADD + bw(opcode = IL.opINCCB), imm(param2), dst_x(0, reg1)); |
drop |
|IL.opDECCB: |
UnOp(reg1); |
Op2(opSUB + BW, imm(param2), dst_x(0, reg1)); |
drop |
|IL.opINC, IL.opINCB: |
BinOp(reg1, reg2); |
Op2(opADD + bw(opcode = IL.opINCB), reg1 * 256, dst_x(0, reg2)); |
drop; |
drop |
|IL.opDEC, IL.opDECB: |
BinOp(reg1, reg2); |
Op2(opSUB + bw(opcode = IL.opDECB), reg1 * 256, dst_x(0, reg2)); |
drop; |
drop |
|IL.opLADR_INCC, IL.opLADR_INCCB: |
Op2(opADD + bw(opcode = IL.opLADR_INCCB), imm(param2), LocalDst(param1)) |
|IL.opLADR_DECCB: |
Op2(opSUB + BW, imm(param2), LocalDst(param1)) |
|IL.opLADR_INC, IL.opLADR_INCB: |
UnOp(reg1); |
Op2(opADD + bw(opcode = IL.opLADR_INCB), reg1 * 256, LocalDst(param2)); |
drop |
|IL.opLADR_DEC, IL.opLADR_DECB: |
UnOp(reg1); |
Op2(opSUB + bw(opcode = IL.opLADR_DECB), reg1 * 256, LocalDst(param2)); |
drop |
|IL.opPUSHT: |
UnOp(reg1); |
Op2(opMOV, src_x(-2, reg1), GetAnyReg()) |
|IL.opISREC: |
PushAll(2); |
PushImm(param2); |
CallRTL(RTL._guardrec, 3); |
GetRegA |
|IL.opIS: |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._is, 2); |
GetRegA |
|IL.opTYPEGR: |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._guardrec, 2); |
GetRegA |
|IL.opTYPEGP: |
UnOp(reg1); |
PushAll(0); |
Push(reg1); |
PushImm(param2); |
CallRTL(RTL._guard, 2); |
GetRegA |
|IL.opTYPEGD: |
UnOp(reg1); |
PushAll(0); |
Op1(opPUSH, reg1, sIDX); |
IncStk; |
EmitWord(-2); |
PushImm(param2); |
CallRTL(RTL._guardrec, 2); |
GetRegA |
|IL.opMULS: |
BinOp(reg1, reg2); |
Op2(opAND, reg2 * 256, reg1); |
drop |
|IL.opMULSC: |
UnOp(reg1); |
Op2(opAND, imm(param2), reg1) |
|IL.opDIVS: |
BinOp(reg1, reg2); |
Op2(opXOR, reg2 * 256, reg1); |
drop |
|IL.opDIVSC: |
UnOp(reg1); |
Op2(opXOR, imm(param2), reg1) |
|IL.opADDS: |
BinOp(reg1, reg2); |
Op2(opBIS, reg2 * 256, reg1); |
drop |
|IL.opSUBS: |
BinOp(reg1, reg2); |
Op2(opBIC, reg2 * 256, reg1); |
drop |
|IL.opADDSC: |
UnOp(reg1); |
Op2(opBIS, imm(param2), reg1) |
|IL.opSUBSL: |
UnOp(reg1); |
Op2(opXOR, imm(-1), reg1); |
Op2(opAND, imm(param2), reg1) |
|IL.opSUBSR: |
UnOp(reg1); |
Op2(opBIC, imm(param2), reg1) |
|IL.opUMINS: |
UnOp(reg1); |
Op2(opXOR, imm(-1), reg1) |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(RTL._length, 2); |
GetRegA |
|IL.opMAX,IL.opMIN: |
BinOp(reg1, reg2); |
Op2(opCMP, reg2 * 256, reg1); |
IF opcode = IL.opMIN THEN |
cc := opJL + 1 |
ELSE |
cc := opJGE + 1 |
END; |
EmitWord(cc); (* jge/jl L *) |
MovRR(reg2, reg1); |
(* L: *) |
drop |
|IL.opMAXC, IL.opMINC: |
UnOp(reg1); |
Op2(opCMP, imm(param2), reg1); |
L := NewLabel(); |
IF opcode = IL.opMINC THEN |
cc := jl |
ELSE |
cc := jge |
END; |
jcc(cc, L); |
Op2(opMOV, imm(param2), reg1); |
EmitLabel(L) |
|IL.opSWITCH: |
UnOp(reg1); |
IF param2 = 0 THEN |
reg2 := ACC |
ELSE |
reg2 := R5 |
END; |
IF reg1 # reg2 THEN |
ASSERT(REG.GetReg(R, reg2)); |
ASSERT(REG.Exchange(R, reg1, reg2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
Op2(opCMP, imm(param1), ACC); |
jcc(jl, param2) |
|IL.opCASER: |
Op2(opCMP, imm(param1), ACC); |
jcc(jg, param2) |
|IL.opCASELR: |
Op2(opCMP, imm(param1), ACC); |
IF param2 = cmd.param3 THEN |
jcc(jne, param2) |
ELSE |
jcc(jl, param2); |
jcc(jg, cmd.param3) |
END |
|IL.opSBOOL: |
BinOp(reg2, reg1); |
Test(reg2); |
setcc(jne, reg2); |
Op2(opMOV + BW, reg2 * 256, dst_x(0, reg1)); |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(reg1); |
Op2(opMOV + BW, imm(param2), dst_x(0, reg1)); |
drop |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
PushImm((opcode - IL.opEQS) * 12); |
CallRTL(RTL._strcmp, 5); |
GetRegA |
|IL.opLEN: |
UnOp(reg1); |
drop; |
EXCL(R.regs, reg1); |
WHILE param2 > 0 DO |
UnOp(reg2); |
drop; |
DEC(param2) |
END; |
INCL(R.regs, reg1); |
ASSERT(REG.GetReg(R, reg1)) |
|IL.opLSL, IL.opASR, IL.opROR, IL.opLSR: |
PushAll(2); |
CASE opcode OF |
|IL.opLSL: CallRTL(RTL._lsl, 2) |
|IL.opASR: CallRTL(RTL._asr, 2) |
|IL.opROR: CallRTL(RTL._ror, 2) |
|IL.opLSR: CallRTL(RTL._lsr, 2) |
END; |
GetRegA |
|IL.opLSL1, IL.opASR1, IL.opROR1, IL.opLSR1: |
UnOp(reg1); |
PushAll_1; |
PushImm(param2); |
Push(reg1); |
drop; |
CASE opcode OF |
|IL.opLSL1: CallRTL(RTL._lsl, 2) |
|IL.opASR1: CallRTL(RTL._asr, 2) |
|IL.opROR1: CallRTL(RTL._ror, 2) |
|IL.opLSR1: CallRTL(RTL._lsr, 2) |
END; |
GetRegA |
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2: |
param2 := param2 MOD 16; |
IF param2 # 0 THEN |
UnOp(reg1); |
Shift2(opcode, reg1, param2) |
END |
|IL.opMUL: |
PushAll(2); |
CallRTL(RTL._mul, 2); |
GetRegA |
|IL.opMULC: |
UnOp(reg1); |
a := param2; |
IF a > 1 THEN |
n := UTILS.Log2(a) |
ELSIF a < -1 THEN |
n := UTILS.Log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
Neg(reg1) |
ELSIF a = 0 THEN |
Clear(reg1) |
ELSE |
IF n > 0 THEN |
IF a < 0 THEN |
Neg(reg1) |
END; |
Shift2(IL.opLSL2, reg1, n) |
ELSE |
PushAll(1); |
PushImm(a); |
CallRTL(RTL._mul, 2); |
GetRegA |
END |
END |
|IL.opDIV: |
PushAll(2); |
CallRTL(RTL._divmod, 2); |
GetRegA |
|IL.opDIVR: |
ASSERT(param2 > 0); |
IF param2 > 1 THEN |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(reg1); |
Shift2(IL.opASR2, reg1, n) |
ELSE |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._divmod, 2); |
GetRegA |
END |
END |
|IL.opDIVL: |
UnOp(reg1); |
PushAll_1; |
PushImm(param2); |
Push(reg1); |
drop; |
CallRTL(RTL._divmod, 2); |
GetRegA |
|IL.opMOD: |
PushAll(2); |
CallRTL(RTL._divmod, 2); |
ASSERT(REG.GetReg(R, R5)) |
|IL.opMODR: |
ASSERT(param2 > 0); |
IF param2 = 1 THEN |
UnOp(reg1); |
Clear(reg1) |
ELSE |
IF UTILS.Log2(param2) > 0 THEN |
UnOp(reg1); |
Op2(opAND, imm(param2 - 1), reg1) |
ELSE |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._divmod, 2); |
ASSERT(REG.GetReg(R, R5)) |
END |
END |
|IL.opMODL: |
UnOp(reg1); |
PushAll_1; |
PushImm(param2); |
Push(reg1); |
drop; |
CallRTL(RTL._divmod, 2); |
ASSERT(REG.GetReg(R, R5)) |
|IL.opCOPYS: |
ASSERT(R.top = 3); |
Push(R.stk[2]); |
Push(R.stk[0]); |
Op2(opCMP, R.stk[1] * 256, R.stk[3]); |
EmitWord(3801H); (* JL L1 *) |
MovRR(R.stk[1], R.stk[3]); |
(* L1: *) |
Push(R.stk[3]); |
drop; |
drop; |
drop; |
drop; |
CallRTL(RTL._move, 3) |
|IL.opCOPY: |
PushAll(2); |
PushImm(param2); |
CallRTL(RTL._move, 3) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(RTL._move, 3) |
|IL.opCOPYA: |
PushAll(4); |
PushImm(param2); |
CallRTL(RTL._arrcpy, 5); |
GetRegA |
|IL.opROT: |
PushAll(0); |
MovRR(SP, ACC); |
Push(ACC); |
PushImm(param2); |
CallRTL(RTL._rot, 2) |
|IL.opSAVES: |
UnOp(reg1); |
PushAll_1; |
Op1(opPUSH, PC, sINCR); |
IncStk; |
EmitWord(param2); |
Reloc(RDATA); |
Push(reg1); |
drop; |
PushImm(param1); |
CallRTL(RTL._move, 3) |
|IL.opCASET: |
Push(R5); |
Push(R5); |
PushImm(param2); |
CallRTL(RTL._guardrec, 2); |
Pop(R5); |
Test(ACC); |
jcc(jne, param1) |
|IL.opCHR: |
UnOp(reg1); |
Op2(opAND, imm(255), reg1) |
|IL.opABS: |
UnOp(reg1); |
Test(reg1); |
L := NewLabel(); |
jcc(jge, L); |
Neg(reg1); |
EmitLabel(L) |
|IL.opEQB, IL.opNEB: |
BinOp(reg1, reg2); |
drop; |
Test(reg1); |
L := NewLabel(); |
jcc(je, L); |
Op2(opMOV, imm(1), reg1); |
EmitLabel(L); |
Test(reg2); |
L := NewLabel(); |
jcc(je, L); |
Op2(opMOV, imm(1), reg2); |
EmitLabel(L); |
Op2(opCMP, reg2 * 256, reg1); |
IF opcode = IL.opEQB THEN |
setcc(je, reg1) |
ELSE |
setcc(jne, reg1) |
END |
|IL.opSAVEP: |
UnOp(reg1); |
Op2(opMOV, incr(PC), reg1 + dIDX); |
EmitWord(param2); |
Reloc(RCODE); |
EmitWord(0); |
drop |
|IL.opPUSHP: |
Op2(opMOV, incr(PC), GetAnyReg()); |
EmitWord(param2); |
Reloc(RCODE) |
|IL.opEQP, IL.opNEP: |
UnOp(reg1); |
Op2(opCMP, incr(PC), reg1); |
EmitWord(param1); |
Reloc(RCODE); |
drop; |
reg1 := GetAnyReg(); |
IF opcode = IL.opEQP THEN |
setcc(je, reg1) |
ELSIF opcode = IL.opNEP THEN |
setcc(jne, reg1) |
END |
|IL.opVADR_PARAM: |
reg1 := GetAnyReg(); |
Op2(opMOV, LocalSrc(param2), reg1); |
Push(reg1); |
drop |
|IL.opNEW: |
PushAll(1); |
n := param2 + 2; |
ASSERT(UTILS.Align(n, 2)); |
PushImm(n); |
PushImm(param1); |
CallRTL(RTL._new, 3) |
|IL.opRSET: |
PushAll(2); |
CallRTL(RTL._set, 2); |
GetRegA |
|IL.opRSETR: |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._set, 2); |
GetRegA |
|IL.opRSETL: |
UnOp(reg1); |
PushAll_1; |
PushImm(param2); |
Push(reg1); |
drop; |
CallRTL(RTL._set, 2); |
GetRegA |
|IL.opRSET1: |
PushAll(1); |
CallRTL(RTL._set1, 1); |
GetRegA |
|IL.opINCLC: |
UnOp(reg1); |
Op2(opBIS, imm(ORD({param2})), dst_x(0, reg1)); |
drop |
|IL.opEXCLC: |
UnOp(reg1); |
Op2(opBIC, imm(ORD({param2})), dst_x(0, reg1)); |
drop |
|IL.opIN: |
PushAll(2); |
CallRTL(RTL._in, 2); |
GetRegA |
|IL.opINR: |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._in, 2); |
GetRegA |
|IL.opINL: |
PushAll(1); |
PushImm(param2); |
CallRTL(RTL._in2, 2); |
GetRegA |
|IL.opINCL: |
PushAll(2); |
CallRTL(RTL._incl, 2) |
|IL.opEXCL: |
PushAll(2); |
CallRTL(RTL._excl, 2) |
|IL.opLADR_INCL, IL.opLADR_EXCL: |
PushAll(1); |
MovRR(SP, ACC); |
n := LocalOffset(param2); |
IF n # 0 THEN |
Op2(opADD, imm(n), ACC) |
END; |
Push(ACC); |
IF opcode = IL.opLADR_INCL THEN |
CallRTL(RTL._incl, 2) |
ELSIF opcode = IL.opLADR_EXCL THEN |
CallRTL(RTL._excl, 2) |
END |
|IL.opLADR_INCLC: |
Op2(opBIS, imm(ORD({param2})), LocalDst(param1)) |
|IL.opLADR_EXCLC: |
Op2(opBIC, imm(ORD({param2})), LocalDst(param1)) |
END; |
cmd := cmd.next(COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1) |
END translate; |
PROCEDURE prolog; |
VAR |
i: INTEGER; |
BEGIN |
RTL.Init(EmitLabel, EmitWord, EmitCall); |
FOR i := 0 TO LEN(RTL.rtl) - 1 DO |
RTL.Set(i, NewLabel()) |
END; |
IV[LEN(IV) - 1] := NewLabel(); |
EmitLabel(IV[LEN(IV) - 1]); |
Op2(opMOV, incr(PC), SP); |
EmitWord(0); |
Op2(opMOV, incr(PC), HP); |
EmitWord(0); |
Op2(opMOV, imm(5A80H), dst_x(0120H, SR)); (* stop WDT *) |
Op2(opMOV, imm(RTL.empty_proc), dst_x(0, SP)); |
Op2(opMOV, imm(RTL.empty_proc), dst_x(2, SP)); |
END prolog; |
PROCEDURE epilog; |
VAR |
L1, i, n: INTEGER; |
BEGIN |
Op2(opBIS, imm(10H), SR); (* CPUOFF *) |
L1 := NewLabel(); |
FOR i := 0 TO LEN(IV) - 2 DO |
IV[i] := NewLabel(); |
EmitLabel(IV[i]); |
PushImm(i); |
IF i # LEN(IV) - 2 THEN |
EmitJmp(opJMP, L1) |
END |
END; |
EmitLabel(L1); |
n := 0; |
FOR i := 0 TO 15 DO |
IF i IN R.regs THEN |
Push(i); |
INC(n) |
END |
END; |
MovRR(SP, R4); |
Op2(opADD, imm(n * 2), R4); |
Push(R4); |
Op1(opPUSH, R4, sINDIR); |
Op1(opCALL, SR, sIDX); EmitWord(-RTL.VarSize); Reloc(RBSS); (* call int *) |
Op2(opADD, imm(4), SP); |
FOR i := 15 TO 0 BY -1 DO |
IF i IN R.regs THEN |
Pop(i) |
END |
END; |
Op2(opADD, imm(2), SP); |
Op1(opRETI, 0, 0); |
RTL.Gen |
END epilog; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
VAR |
i, adr, heap, stack, TextSize, TypesSize, bits, n, val: INTEGER; |
Code, Data, Bss: RECORD address, size: INTEGER END; |
ram, rom: INTEGER; |
reloc: RELOC; |
BEGIN |
IdxWords.src := NOWORD; |
IdxWords.dst := NOWORD; |
ram := options.ram; |
rom := options.rom; |
IF ODD(ram) THEN DEC(ram) END; |
IF ODD(rom) THEN DEC(rom) END; |
ram := MIN(MAX(ram, minRAM), maxRAM); |
rom := MIN(MAX(rom, minROM), maxROM); |
IF IL.codes.bss > ram - StkReserve - RTL.VarSize THEN |
ERRORS.Error(204) |
END; |
Labels := CHL.CreateIntList(); |
FOR i := 1 TO IL.codes.lcount DO |
CHL.PushInt(Labels, 0) |
END; |
CodeList := LISTS.create(NIL); |
RelList := LISTS.create(NIL); |
REG.Init(R, Push, Pop, mov, xchg, {R4, R5, R6, R7}); |
prolog; |
translate(chkSTK IN options.checking); |
epilog; |
TypesSize := CHL.Length(IL.codes.types) * 2; |
Data.size := CHL.Length(IL.codes.data); |
IF ODD(Data.size) THEN |
CHL.PushByte(IL.codes.data, 0); |
INC(Data.size) |
END; |
Code.size := Fixup(0, IntVectorSize + TypesSize + Data.size); |
Code.address := 10000H - (IntVectorSize + TypesSize + Data.size + Code.size); |
IF Code.address < 10000H - rom THEN |
ERRORS.Error(203) |
END; |
Code.size := Fixup(Code.address, IntVectorSize + TypesSize + Data.size); |
Data.address := Code.address + Code.size; |
TextSize := Code.size + Data.size; |
IF Code.address + TextSize + MAX(IL.codes.dmin - Data.size, IntVectorSize + TypesSize) > 10000H THEN |
ERRORS.Error(203) |
END; |
stack := RTL.ram + ram; |
Bss.size := IL.codes.bss + IL.codes.bss MOD 2; |
DEC(stack, Bss.size); |
Bss.address := stack; |
DEC(stack, RTL.VarSize); |
heap := RTL.ram; |
ASSERT(stack - heap >= StkReserve); |
adr := Code.address + 2; |
PutWord(stack, adr); |
adr := Code.address + 6; |
PutWord(heap, adr); |
reloc := RelList.first(RELOC); |
WHILE reloc # NIL DO |
adr := reloc.WordPtr.offset * 2; |
val := reloc.WordPtr.val; |
CASE reloc.section OF |
|RCODE: PutWord(LabelOffs(val) * 2, adr) |
|RDATA: PutWord(val + Data.address, adr) |
|RBSS: PutWord((val + Bss.address) MOD 65536, adr) |
END; |
reloc := reloc.next(RELOC) |
END; |
adr := Data.address; |
FOR i := 0 TO Data.size - 1 DO |
mem[adr] := CHL.GetByte(IL.codes.data, i); |
INC(adr) |
END; |
FOR i := TypesSize DIV 2 - 1 TO 0 BY -1 DO |
PutWord(CHL.GetInt(IL.codes.types, i), adr) |
END; |
FOR i := 0 TO 15 DO |
PutWord((33 - i) * i, adr); |
END; |
FOR n := 0 TO 15 DO |
bits := ORD({0 .. n}); |
FOR i := 0 TO 15 - n DO |
PutWord(bits, adr); |
bits := LSL(bits, 1) |
END |
END; |
PutWord(4130H, adr); (* RET *) |
PutWord(stack, adr); |
PutWord(0001H, adr); (* bsl signature (adr 0FFBEH) *) |
FOR i := 0 TO LEN(IV) - 1 DO |
PutWord(LabelOffs(IV[i]) * 2, adr) |
END; |
INC(TextSize, IntVectorSize + TypesSize + Code.address MOD 16); |
INC(Bss.size, StkReserve + RTL.VarSize); |
WR.Create(outname); |
HEX.Data(mem, Code.address - Code.address MOD 16, TextSize); |
HEX.End; |
WR.Close; |
C.Dashes; |
C.String(" rom: "); C.Int(TextSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(TextSize * 100 DIV rom); C.StringLn("%)"); |
C.Ln; |
C.String(" ram: "); C.Int(Bss.size); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(Bss.size * 100 DIV ram); C.StringLn("%)") |
END CodeGen; |
END MSP430. |
/programs/develop/oberon07/source/MSP430RTL.ob07 |
---|
0,0 → 1,671 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE MSP430RTL; |
CONST |
_mul* = 0; |
_divmod* = 1; |
_lsl* = 2; |
_asr* = 3; |
_ror* = 4; |
_lsr* = 5; |
_in* = 6; |
_in2* = 7; |
_set1* = 8; |
_incl* = 9; |
_excl* = 10; |
_move* = 11; |
_set* = 12; |
_arrcpy* = 13; |
_rot* = 14; |
_strcmp* = 15; |
_error* = 16; |
_is* = 17; |
_guard* = 18; |
_guardrec* = 19; |
_length* = 20; |
_new* = 21; |
HP* = 15; |
LenIV* = 32; |
iv = 10000H - LenIV * 2; |
bsl = iv - 2; |
sp = bsl - 2; |
empty_proc* = sp - 2; |
bits = empty_proc - 272; |
bits_offs = bits - 32; |
DataSize* = iv - bits_offs; |
types = bits_offs - 2; |
IntVectorSize* = LenIV * 2 + DataSize; |
VarSize* = 4; |
StkReserve* = 40; |
trap = 2; |
TYPE |
EMITPROC = PROCEDURE (n: INTEGER); |
VAR |
ram*: INTEGER; |
rtl*: ARRAY 22 OF |
RECORD |
label*: INTEGER; |
used: BOOLEAN |
END; |
Label, Word, Call: EMITPROC; |
PROCEDURE Gen*; |
PROCEDURE Word1 (word: INTEGER); |
BEGIN |
Word(word) |
END Word1; |
PROCEDURE Word2 (word1, word2: INTEGER); |
BEGIN |
Word1(word1); |
Word1(word2) |
END Word2; |
PROCEDURE Word3 (word1, word2, word3: INTEGER); |
BEGIN |
Word1(word1); |
Word1(word2); |
Word1(word3) |
END Word3; |
BEGIN |
(* _lsl (n, x: INTEGER): INTEGER *) |
IF rtl[_lsl].used THEN |
Label(rtl[_lsl].label); |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *) |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *) |
Word2(0F035H, 15); (* AND #15, R5 *) |
Word1(2400H + 3); (* JZ L1 *) |
(* L2: *) |
Word1(5404H); (* ADD R4, R4 *) |
Word1(8315H); (* SUB #1, R5 *) |
Word1(2000H + 400H - 3); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _asr (n, x: INTEGER): INTEGER *) |
IF rtl[_asr].used THEN |
Label(rtl[_asr].label); |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *) |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *) |
Word2(0F035H, 15); (* AND #15, R5 *) |
Word1(2400H + 3); (* JZ L1 *) |
(* L2: *) |
Word1(1104H); (* RRA R4 *) |
Word1(8315H); (* SUB #1, R5 *) |
Word1(2000H + 400H - 3); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _ror (n, x: INTEGER): INTEGER *) |
IF rtl[_ror].used THEN |
Label(rtl[_ror].label); |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *) |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *) |
Word2(0F035H, 15); (* AND #15, R5 *) |
Word1(2400H + 5); (* JZ L1 *) |
Word1(4406H); (* MOV R4, R6 *) |
(* L2: *) |
Word1(1006H); (* RRC R6 *) |
Word1(1004H); (* RRC R4 *) |
Word1(8315H); (* SUB #1, R5 *) |
Word1(2000H + 400H - 4); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _lsr (n, x: INTEGER): INTEGER *) |
IF rtl[_lsr].used THEN |
Label(rtl[_lsr].label); |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *) |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *) |
Word2(0F035H, 15); (* AND #15, R5 *) |
Word1(2400H + 4); (* JZ L1 *) |
(* L2: *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1004H); (* RRC R4 *) |
Word1(8315H); (* SUB #1, R5 *) |
Word1(2000H + 400H - 4); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _set (b, a: INTEGER): SET *) |
IF rtl[_set].used THEN |
Label(rtl[_set].label); |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- b *) |
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *) |
Word1(9504H); (* CMP R5, R4 *) |
Word1(3800H + 24); (* JL L1 *) |
Word2(9035H, 16); (* CMP #16, R5 *) |
Word1(3400H + 21); (* JGE L1 *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(3800H + 19); (* JL L1 *) |
Word2(9034H, 16); (* CMP #16, R4 *) |
Word1(3800H + 2); (* JL L2 *) |
Word2(4034H, 15); (* MOV #15, R4 *) |
(* L2: *) |
Word1(9305H); (* CMP #0, R5 *) |
Word1(3400H + 1); (* JGE L3 *) |
Word1(4305H); (* MOV #0, R5 *) |
(* L3: *) |
Word1(8504H); (* SUB R5, R4 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits_offs); (* ADD bits_offs, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word1(5505H); (* ADD R5, R5 *) |
Word1(5405H); (* ADD R4, R5 *) |
Word2(5035H, bits); (* ADD bits, R5 *) |
Word1(4524H); (* MOV @R5, R4 *) |
Word1(4130H); (* RET *) |
(* L1: *) |
Word1(4304H); (* MOV #0, R4 *) |
Word1(4130H) (* RET *) |
END; |
(* _set1 (a: INTEGER): SET *) |
IF rtl[_set1].used THEN |
Label(rtl[_set1].label); |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- a *) |
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *) |
Word1(2000H + 5); (* JNZ L1 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits); (* ADD bits, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word1(4130H); (* RET *) |
(* L1: *) |
Word1(4304H); (* MOV #0, R4 *) |
Word1(4130H) (* RET *) |
END; |
(* _in2 (i, s: INTEGER): BOOLEAN *) |
IF rtl[_in2].used THEN |
Label(rtl[_in2].label); |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- i *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits); (* ADD bits, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word2(0F114H, 4); (* AND 4(SP), R4 *) |
Word1(2400H + 1); (* JZ L1 *) |
Word1(4314H); (* MOV #1, R4 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _in (s, i: INTEGER): BOOLEAN *) |
IF rtl[_in].used THEN |
Label(rtl[_in].label); |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *) |
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *) |
Word1(2000H + 9); (* JNZ L2 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits); (* ADD bits, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word2(0F114H, 2); (* AND 2(SP), R4 *) |
Word1(2400H + 3); (* JZ L1 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(4130H); (* RET *) |
(* L2: *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _incl (VAR s: SET; i: INTEGER) *) |
IF rtl[_incl].used THEN |
Label(rtl[_incl].label); |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *) |
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *) |
Word1(2000H + 8); (* JNZ L1 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits); (* ADD bits, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *) |
Word2(0D485H, 0); (* BIS R4, 0(R5) *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _excl (VAR s: SET; i: INTEGER) *) |
IF rtl[_excl].used THEN |
Label(rtl[_excl].label); |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *) |
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *) |
Word1(2000H + 8); (* JNZ L1 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word2(5034H, bits); (* ADD bits, R4 *) |
Word1(4424H); (* MOV @R4, R4 *) |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *) |
Word2(0C485H, 0); (* BIC R4, 0(R5) *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _rot (len, adr: INTEGER) *) |
IF rtl[_rot].used THEN |
Label(rtl[_rot].label); |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- len *) |
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- adr *) |
Word1(8314H); (* SUB #1, R4 *) |
Word1(5404H); (* ADD R4, R4 *) |
Word1(1225H); (* PUSH @R5 *) |
Word1(4406H); (* MOV R4, R6 *) |
(* L1: *) |
Word3(4595H, 2, 0); (* MOV 2(R5), 0(R5) *) |
Word1(5325H); (* ADD #2, R5 *) |
Word1(8326H); (* SUB #2, R6 *) |
Word1(2000H + 400H - 6); (* JNZ L1 *) |
Word2(41B5H, 0); (* MOV @SP+, 0(R5) *) |
Word1(4130H) (* RET *) |
END; |
(* _divmod (b, a: INTEGER): INTEGER (* res -> R4, mod -> R5 *) *) |
IF rtl[_divmod].used THEN |
Label(rtl[_divmod].label); |
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L1: *) |
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *) |
Word1(9605H); (* CMP R6, R5 *) |
Word1(3800H + 17); (* JL L3 *) |
Word1(4327H); (* MOV #2, R7 *) |
Word1(5606H); (* ADD R6, R6 *) |
(* L4: *) |
Word1(9306H); (* CMP #0, R6 *) |
Word1(2400H + 6); (* JZ L2 *) |
Word1(3800H + 5); (* JL L2 *) |
Word1(9605H); (* CMP R6, R5 *) |
Word1(3800H + 3); (* JL L2 *) |
Word1(5606H); (* ADD R6, R6 *) |
Word1(5707H); (* ADD R7, R7 *) |
Word1(3C00H + 400H - 8); (* JMP L4 *) |
(* L2: *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1006H); (* RRC R6 *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1007H); (* RRC R7 *) |
Word1(8605H); (* SUB R6, R5 *) |
Word1(5704H); (* ADD R7, R4 *) |
Word1(3C00H + 400H - 21); (* JMP L1 *) |
(* L3: *) |
(*----------- (a < 0) --------------*) |
(* L1: *) |
Word1(9305H); (* CMP #0, R5 *) |
Word1(3400H + 23); (* JGE L3 *) |
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *) |
Word1(4327H); (* MOV #2, R7 *) |
Word1(5606H); (* ADD R6, R6 *) |
Word1(0E335H); (* XOR #-1, R5 *) |
Word1(5315H); (* ADD #1, R5 *) |
(* L4: *) |
Word1(9306H); (* CMP #0, R6 *) |
Word1(2400H + 6); (* JZ L2 *) |
Word1(3800H + 5); (* JL L2 *) |
Word1(9605H); (* CMP R6, R5 *) |
Word1(3800H + 3); (* JL L2 *) |
Word1(5606H); (* ADD R6, R6 *) |
Word1(5707H); (* ADD R7, R7 *) |
Word1(3C00H + 400H - 8); (* JMP L4 *) |
(* L2: *) |
Word1(0E335H); (* XOR #-1, R5 *) |
Word1(5315H); (* ADD #1, R5 *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1006H); (* RRC R6 *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1007H); (* RRC R7 *) |
Word1(5605H); (* ADD R6, R5 *) |
Word1(8704H); (* SUB R7, R4 *) |
Word1(3C00H + 400H - 25); (* JMP L1 *) |
(* L3: *) |
Word1(4130H) (* RET *) |
END; |
(* _mul (a, b: INTEGER): INTEGER *) |
IF rtl[_mul].used THEN |
Label(rtl[_mul].label); |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- a *) |
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- b *) |
Word1(4304H); (* MOV #0, R4; res := 0 *) |
Word1(9306H); (* CMP #0, R6 *) |
Word1(2400H + 7); (* JZ L1 *) |
(* L2: *) |
Word1(0B316H); (* BIT #1, R6 *) |
Word1(2400H + 1); (* JZ L3 *) |
Word1(5504H); (* ADD R5, R4 *) |
(* L3: *) |
Word1(5505H); (* ADD R5, R5 *) |
Word1(0C312H); (* BIC #1, SR *) |
Word1(1006H); (* RRC R6 *) |
Word1(2000H + 400H - 7); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _error (modNum, modName, err, line: INTEGER) *) |
IF rtl[_error].used THEN |
Label(rtl[_error].label); |
Word1(5321H); (* ADD #2, SP *) |
Word1(4134H); (* POP R4; R4 <- modNum *) |
Word1(4135H); (* POP R5; R5 <- modName *) |
Word1(4136H); (* POP R6; R6 <- err *) |
Word1(4137H); (* POP R7; R7 <- line *) |
Word2(4211H, sp); (* MOV sp(SR), SP *) |
Word1(1207H); (* PUSH R7 *) |
Word1(1206H); (* PUSH R6 *) |
Word1(1205H); (* PUSH R5 *) |
Word1(1204H); (* PUSH R4 *) |
Word2(4214H, sp); (* MOV sp(SR), R4 *) |
Word2(1294H, trap); (* CALL trap(R4) *) |
Word2(04032H, 0F0H) (* MOV CPUOFF+OSCOFF+SCG0+SCG1, SR *) |
END; |
(* _new (t, size: INTEGER; VAR ptr: INTEGER) *) |
IF rtl[_new].used THEN |
Label(rtl[_new].label); |
Word1(1202H); (* PUSH SR *) |
Word1(4302H); (* MOV #0, SR *) |
Word1(4303H); (* NOP *) |
Word1(4104H); (* MOV SP, R4 *) |
Word2(8034H, StkReserve); (* SUB #StkReserve, R4 *) |
Word1(4005H + 100H * HP); (* MOV HP, R5 *) |
Word2(5115H, 6); (* ADD 6(SP), R5 *) |
Word1(9504H); (* CMP R5, R4 *) |
Word2(4114H, 8); (* MOV 8(SP), R4 *) |
Word1(3800H + 12); (* JL L1 *) |
Word3(4190H + HP, 4, 0); (* MOV 4(SP), 0(HP) *) |
Word1(5320H + HP); (* ADD #2, HP *) |
Word2(4084H + 100H * HP, 0); (* MOV HP, 0(R4) *) |
(* L3 *) |
Word2(4380H + HP, 0); (* MOV #0, 0(HP) *) |
Word1(5320H + HP); (* ADD #2, HP *) |
Word1(9500H + HP); (* CMP R5, HP *) |
Word1(3800H + 400H - 5); (* JL L3 *) |
Word1(3C00H + 2); (* JMP L2 *) |
(* L1 *) |
Word2(4384H, 0); (* MOV #0, 0(R4) *) |
(* L2 *) |
Word1(1300H) (* RETI *) |
END; |
(* _guardrec (t0, t1: INTEGER): INTEGER *) |
IF rtl[_guardrec].used THEN |
Label(rtl[_guardrec].label); |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t0 *) |
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- t1 *) |
Word2(4036H, types); (* MOV #types, R6 *) |
(* L3: *) |
Word1(9305H); (* CMP #0, R5 *) |
Word1(2400H + 8); (* JZ L1 *) |
Word1(9405H); (* CMP R4, R5 *) |
Word1(2400H + 10); (* JZ L2 *) |
Word1(5505H); (* ADD R5, R5 *) |
Word1(0E335H); (* XOR #-1, R5 *) |
Word1(5315H); (* ADD #1, R5 *) |
Word1(5605H); (* ADD R6, R5 *) |
Word1(4525H); (* MOV @R5, R5 *) |
Word1(3C00H + 400H - 10); (* JMP L3 *) |
(* L1: *) |
Word1(9405H); (* CMP R4, R5 *) |
Word1(2400H + 2); (* JZ L2 *) |
Word1(4304H); (* MOV #0, R4 *) |
Word1(4130H); (* RET *) |
(* L2: *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(4130H) (* RET *) |
END; |
(* _is (t, p: INTEGER): INTEGER *) |
IF rtl[_is].used THEN |
Label(rtl[_is].label); |
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- p *) |
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- t *) |
Word1(9304H); (* TST R4 *) |
Word1(2400H + 2); (* JZ L *) |
Word2(4414H, -2); (* MOV -2(R4), R4 *) |
(* L: *) |
Word1(1204H); (* PUSH R4 *) |
Word1(1205H); (* PUSH R5 *) |
Call(rtl[_guardrec].label); (* CALL _guardrec *) |
Word1(5221H); (* ADD #4, SP *) |
Word1(4130H) (* RET *) |
END; |
(* _guard (t, p: INTEGER): INTEGER *) |
IF rtl[_guard].used THEN |
Label(rtl[_guard].label); |
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- p *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(4525H); (* MOV @R5, R5 *) |
Word1(9305H); (* TST R5 *) |
Word1(2400H + 9); (* JZ L *) |
Word2(4515H, -2); (* MOV -2(R5), R5 *) |
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t *) |
Word1(1205H); (* PUSH R5 *) |
Word1(1204H); (* PUSH R4 *) |
Call(rtl[_guardrec].label); (* CALL _guardrec *) |
Word1(5221H); (* ADD #4, SP *) |
(* L: *) |
Word1(4130H) (* RET *) |
END; |
(* _move (bytes, dest, source: INTEGER) *) |
IF rtl[_move].used THEN |
Label(rtl[_move].label); |
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- bytes *) |
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- dest *) |
Word2(4115H, 6); (* MOV 6(SP), R5; R5 <- source *) |
Word1(9306H); (* CMP #0, R6 *) |
Word1(3800H + 6); (* JL L1 *) |
Word1(2400H + 5); (* JZ L1 *) |
(* L2: *) |
Word2(45F7H, 0); (* MOV.B @R5+, 0(R7) *) |
Word1(5317H); (* ADD #1, R7 *) |
Word1(8316H); (* SUB #1, R6 *) |
Word1(2000H + 400H - 5); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _arrcpy (base_size, len_dst, dst, len_src, src: INTEGER) *) |
IF rtl[_arrcpy].used THEN |
Label(rtl[_arrcpy].label); |
Word3(9191H, 8, 4); (* CMP 8(SP), 4(SP) *) |
Word1(3800H + 18); (* JL L1 *) |
Word2(1211H, 12); (* PUSH 12(SP) *) |
Word2(1211H, 10); (* PUSH 10(SP) *) |
Word2(1211H, 14); (* PUSH 14(SP) *) |
Word2(1211H, 10); (* PUSH 10(SP) *) |
Call(rtl[_mul].label); (* CALL _mul *) |
Word1(5221H); (* ADD #4, SP *) |
Word1(1204H); (* PUSH R4 *) |
Call(rtl[_move].label); (* CALL _move *) |
Word2(5031H, 6); (* ADD #6, SP *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(4130H); (* RET *) |
(* L1 *) |
Word1(4304H); (* MOV #0, R4 *) |
Word1(4130H) (* RET *) |
END; |
(* _length (len, str: INTEGER): INTEGER *) |
IF rtl[_length].used THEN |
Label(rtl[_length].label); |
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- len *) |
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- str *) |
Word1(4304H); (* MOV #0, R4; res := 0 *) |
(* L2: *) |
Word1(4775H); (* MOV.B @R7+, R5 *) |
Word1(9305H); (* CMP #0, R5 *) |
Word1(2400H + 3); (* JZ L1 *) |
Word1(5314H); (* ADD #1, R4 *) |
Word1(8316H); (* SUB #1, R6 *) |
Word1(2000H + 400H - 6); (* JNZ L2 *) |
(* L1: *) |
Word1(4130H) (* RET *) |
END; |
(* _strcmp (op, len2, str2, len1, str1: INTEGER): BOOLEAN *) |
IF rtl[_strcmp].used THEN |
Label(rtl[_strcmp].label); |
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *) |
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *) |
Word1(9607H); (* CMP R6, R7 *) |
Word1(3400H + 1); (* JGE L5 *) |
Word1(4706H); (* MOV R7, R6 *) |
(* L5: *) |
Word1(1206H); (* PUSH R6 *) |
Word2(4116H, 12); (* MOV 12(SP), R6; R6 <- str1 *) |
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- str2 *) |
(* L3: *) |
Word2(9381H, 0); (* CMP #0, 0(SP) *) |
Word1(2400H + 11); (* JZ L1 *) |
Word1(4674H); (* MOV.B @R6+, R4 *) |
Word1(4775H); (* MOV.B @R7+, R5 *) |
Word2(8391H, 0); (* SUB #1, 0(SP) *) |
Word1(9405H); (* CMP R4, R5 *) |
Word1(2400H + 2); (* JZ L2 *) |
Word1(8504H); (* SUB R5, R4 *) |
Word1(3C00H + 5); (* JMP L4 *) |
(* L2: *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(2000H + 400H - 13); (* JNZ L3 *) |
Word1(3C00H + 2); (* JMP L4 *) |
(* L1: *) |
Word2(4034H, 8000H); (* MOV #8000H, R4 *) |
(* L4: *) |
Word1(5321H); (* ADD #2, SP *) |
Word2(9034H, 8000H); (* CMP #8000H, R4 *) |
Word1(2000H + 18); (* JNZ L6 *) |
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *) |
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *) |
Word1(9607H); (* CMP R6, R7 *) |
Word1(2400H + 11); (* JZ L7 *) |
Word1(3800H + 4); (* JL L8 *) |
Word2(5116H, 10); (* ADD 10(SP), R6 *) |
Word1(4664H); (* MOV.B @R6, R4 *) |
Word1(3C00H + 7); (* JMP L6 *) |
(* L8: *) |
Word2(5117H, 6); (* ADD 6(SP), R7 *) |
Word1(4764H); (* MOV.B @R7, R4 *) |
Word1(0E334H); (* XOR #-1, R4 *) |
Word1(5314H); (* ADD #1, R4 *) |
Word1(3C00H + 1); (* JMP L6 *) |
(* L7: *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L6: *) |
Word2(5110H, 2); (* ADD 2(SP), PC; PC <- PC + op *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(2400H + 1); (* JZ L *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L *) |
Word1(4130H); (* RET *) |
Word1(4303H); (* NOP *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(2000H + 1); (* JNZ L *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L *) |
Word1(4130H); (* RET *) |
Word1(4303H); (* NOP *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(3800H + 1); (* JL L *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L *) |
Word1(4130H); (* RET *) |
Word1(4303H); (* NOP *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(3800H + 2); (* JL L *) |
Word1(2400H + 1); (* JZ L *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L *) |
Word1(4130H); (* RET *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4304H); (* MOV #0, R4 *) |
Word1(3800H + 2); (* JL L *) |
Word1(2400H + 1); (* JZ L *) |
Word1(4314H); (* MOV #1, R4 *) |
(* L *) |
Word1(4130H); (* RET *) |
Word1(9304H); (* CMP #0, R4 *) |
Word1(4314H); (* MOV #1, R4 *) |
Word1(3400H + 1); (* JGE L *) |
Word1(4304H); (* MOV #0, R4 *) |
(* L *) |
Word1(4130H) (* RET *) |
END |
END Gen; |
PROCEDURE Set* (idx, label: INTEGER); |
BEGIN |
rtl[idx].label := label; |
rtl[idx].used := FALSE |
END Set; |
PROCEDURE Used* (idx: INTEGER); |
BEGIN |
rtl[idx].used := TRUE; |
IF (idx = _guard) OR (idx = _is) THEN |
rtl[_guardrec].used := TRUE |
ELSIF idx = _arrcpy THEN |
rtl[_move].used := TRUE; |
rtl[_mul].used := TRUE |
END |
END Used; |
PROCEDURE Init* (pLabel, pWord, pCall: EMITPROC); |
BEGIN |
Label := pLabel; |
Word := pWord; |
Call := pCall; |
ram := 200H; |
END Init; |
END MSP430RTL. |
/programs/develop/oberon07/source/PARS.ob07 |
---|
0,0 → 1,1375 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE PARS; |
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS, |
C := COLLECTIONS, TARGETS, THUMB, MSP430; |
CONST |
eCONST* = 1; eTYPE* = 2; eVAR* = 3; eEXPR* = 4; |
eVREC* = 5; ePROC* = 6; eVPAR* = 7; ePARAM* = 8; |
eSTPROC* = 9; eSTFUNC* = 10; eSYSFUNC* = 11; eSYSPROC* = 12; |
eIMP* = 13; |
TYPE |
PATH* = PATHS.PATH; |
PARSER* = POINTER TO rPARSER; |
POSITION* = RECORD (SCAN.POSITION) |
parser*: PARSER |
END; |
EXPR* = RECORD |
obj*: INTEGER; |
_type*: PROG._TYPE; |
value*: ARITH.VALUE; |
stproc*: INTEGER; |
readOnly*: BOOLEAN; |
ident*: PROG.IDENT |
END; |
STATPROC = PROCEDURE (parser: PARSER); |
EXPRPROC = PROCEDURE (parser: PARSER; VAR e: EXPR); |
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG._TYPE; pos: POSITION): BOOLEAN; |
rPARSER = RECORD (C.ITEM) |
fname*: PATH; |
path: PATH; |
lib_path: PATH; |
ext: PATH; |
modname: PATH; |
scanner: SCAN.SCANNER; |
lex*: SCAN.LEX; |
sym*: INTEGER; |
unit*: PROG.UNIT; |
constexp*: BOOLEAN; |
main*: BOOLEAN; |
open*: PROCEDURE (parser: PARSER; modname, FileExt: ARRAY OF CHAR): BOOLEAN; |
parse*: PROCEDURE (parser: PARSER); |
StatSeq*: STATPROC; |
expression*: EXPRPROC; |
designator*: EXPRPROC; |
chkreturn: RETPROC; |
create*: PROCEDURE (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER |
END; |
VAR |
parsers: C.COLLECTION; |
lines*, modules: INTEGER; |
PROCEDURE destroy* (VAR parser: PARSER); |
BEGIN |
IF parser.scanner # NIL THEN |
SCAN.close(parser.scanner) |
END; |
C.push(parsers, parser); |
parser := NIL |
END destroy; |
PROCEDURE getpos (parser: PARSER; VAR pos: POSITION); |
BEGIN |
pos.line := parser.lex.pos.line; |
pos.col := parser.lex.pos.col; |
pos.parser := parser |
END getpos; |
PROCEDURE error* (pos: POSITION; errno: INTEGER); |
BEGIN |
ERRORS.ErrorMsg(pos.parser.fname, pos.line, pos.col, errno) |
END error; |
PROCEDURE check* (condition: BOOLEAN; pos: POSITION; errno: INTEGER); |
BEGIN |
IF ~condition THEN |
error(pos, errno) |
END |
END check; |
PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER); |
VAR |
pos: POSITION; |
BEGIN |
IF ~condition THEN |
getpos(parser, pos); |
error(pos, errno) |
END |
END check1; |
PROCEDURE Next* (parser: PARSER); |
VAR |
errno: INTEGER; |
BEGIN |
SCAN.Next(parser.scanner, parser.lex); |
errno := parser.lex.error; |
IF errno = 0 THEN |
IF (TARGETS.RealSize = 0) & (parser.lex.sym = SCAN.lxFLOAT) THEN |
errno := -SCAN.lxERROR13 |
ELSIF (TARGETS.BitDepth = 16) & (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN |
errno := -SCAN.lxERROR10 |
END |
END; |
IF errno # 0 THEN |
check1(FALSE, parser, errno) |
END; |
parser.sym := parser.lex.sym |
END Next; |
PROCEDURE NextPos (parser: PARSER; VAR pos: POSITION); |
BEGIN |
Next(parser); |
getpos(parser, pos) |
END NextPos; |
PROCEDURE checklex* (parser: PARSER; sym: INTEGER); |
VAR |
err: INTEGER; |
BEGIN |
IF parser.sym # sym THEN |
CASE sym OF |
|SCAN.lxCOMMA: err := 65 |
|SCAN.lxRROUND: err := 33 |
|SCAN.lxPOINT: err := 26 |
|SCAN.lxIDENT: err := 22 |
|SCAN.lxRSQUARE: err := 71 |
|SCAN.lxRCURLY: err := 35 |
|SCAN.lxUNDEF: err := 34 |
|SCAN.lxTHEN: err := 88 |
|SCAN.lxEND: err := 27 |
|SCAN.lxDO: err := 89 |
|SCAN.lxUNTIL: err := 90 |
|SCAN.lxCOLON: err := 53 |
|SCAN.lxOF: err := 67 |
|SCAN.lxASSIGN: err := 96 |
|SCAN.lxTO: err := 57 |
|SCAN.lxLROUND: err := 64 |
|SCAN.lxEQ: err := 32 |
|SCAN.lxSEMI: err := 24 |
|SCAN.lxRETURN: err := 38 |
|SCAN.lxMODULE: err := 21 |
END; |
check1(FALSE, parser, err) |
END |
END checklex; |
PROCEDURE ExpectSym* (parser: PARSER; sym: INTEGER); |
BEGIN |
Next(parser); |
checklex(parser, sym) |
END ExpectSym; |
PROCEDURE ImportList (parser: PARSER); |
VAR |
fname, path, ext, _name: PATH; |
name: SCAN.IDENT; |
parser2: PARSER; |
pos: POSITION; |
alias, _in: BOOLEAN; |
unit: PROG.UNIT; |
ident: PROG.IDENT; |
BEGIN |
alias := FALSE; |
REPEAT |
ExpectSym(parser, SCAN.lxIDENT); |
name := parser.lex.ident; |
getpos(parser, pos); |
IF ~alias THEN |
ident := PROG.addIdent(parser.unit, name, PROG.idMODULE); |
check(ident # NIL, pos, 30) |
END; |
Next(parser); |
path := parser.path; |
fname := ""; |
ext := UTILS.FILE_EXT; |
COPY(name.s, _name); |
_in := FALSE; |
IF parser.sym = SCAN.lxIN THEN |
_in := TRUE; |
Next(parser); |
IF parser.sym = SCAN.lxSTRING THEN |
STRINGS.trim(parser.lex.string.s, fname) |
ELSIF parser.sym = SCAN.lxCHAR THEN |
fname[0] := CHR(ARITH.Int(parser.lex.value)); |
fname[1] := 0X |
ELSE |
check1(FALSE, parser, 117) |
END; |
STRINGS.replace(fname, "/", UTILS.slash); |
STRINGS.replace(fname, "\", UTILS.slash); |
PATHS.DelSlashes(fname); |
PATHS.split(fname, path, _name, ext); |
IF PATHS.isRelative(path) THEN |
PATHS.RelPath(parser.path, path, fname); |
STRINGS.append(fname, _name); |
STRINGS.append(fname, ext); |
PATHS.split(fname, path, _name, ext) |
END; |
Next(parser) |
END; |
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN |
alias := FALSE; |
IF (fname = "") & ((_name = "SYSTEM") OR PROG.LowerCase & (_name = "system")) THEN |
unit := PROG.program.sysunit |
ELSE |
IF fname # "" THEN |
unit := PROG.getUnit(fname) |
ELSE |
fname := path; |
STRINGS.append(fname, _name); |
STRINGS.append(fname, UTILS.FILE_EXT); |
unit := PROG.getUnit(fname); |
IF unit = NIL THEN |
fname := parser.lib_path; |
STRINGS.append(fname, _name); |
STRINGS.append(fname, UTILS.FILE_EXT); |
unit := PROG.getUnit(fname) |
END |
END |
END; |
IF unit # NIL THEN |
check(unit.closed, pos, 31) |
ELSE |
parser2 := parser.create(path, parser.lib_path, |
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn); |
IF ~parser2.open(parser2, _name, ext) THEN |
IF (path # parser.lib_path) & ~_in THEN |
destroy(parser2); |
parser2 := parser.create(parser.lib_path, parser.lib_path, |
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn); |
check(parser2.open(parser2, _name, ext), pos, 29) |
ELSE |
error(pos, 29) |
END |
END; |
parser2.parse(parser2); |
unit := parser2.unit; |
unit.fname := parser2.fname; |
destroy(parser2) |
END; |
IF unit = PROG.program.sysunit THEN |
parser.unit.sysimport := TRUE |
END; |
ident.unit := unit |
ELSIF parser.sym = SCAN.lxASSIGN THEN |
alias := TRUE |
ELSE |
check1(FALSE, parser, 28) |
END |
UNTIL parser.sym = SCAN.lxSEMI; |
Next(parser) |
END ImportList; |
PROCEDURE QIdent (parser: PARSER; forward: BOOLEAN): PROG.IDENT; |
VAR |
ident: PROG.IDENT; |
unit: PROG.UNIT; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE); |
IF ~forward THEN |
check1(ident # NIL, parser, 48) |
END; |
IF (ident # NIL) & (ident.typ = PROG.idMODULE) THEN |
unit := ident.unit; |
ExpectSym(parser, SCAN.lxPOINT); |
ExpectSym(parser, SCAN.lxIDENT); |
ident := PROG.getIdent(unit, parser.lex.ident, FALSE); |
check1((ident # NIL) & ident.export, parser, 48) |
END |
RETURN ident |
END QIdent; |
PROCEDURE strcmp* (VAR v: ARITH.VALUE; v2: ARITH.VALUE; operator: INTEGER); |
VAR |
str: SCAN.TEXTSTR; |
string1, string2: SCAN.STRING; |
bool: BOOLEAN; |
BEGIN |
IF v.typ = ARITH.tCHAR THEN |
ASSERT(v2.typ = ARITH.tSTRING); |
ARITH.charToStr(v, str); |
string1 := SCAN.enterStr(str); |
string2 := v2.string(SCAN.STRING) |
END; |
IF v2.typ = ARITH.tCHAR THEN |
ASSERT(v.typ = ARITH.tSTRING); |
ARITH.charToStr(v2, str); |
string2 := SCAN.enterStr(str); |
string1 := v.string(SCAN.STRING) |
END; |
IF v.typ = v2.typ THEN |
string1 := v.string(SCAN.STRING); |
string2 := v2.string(SCAN.STRING) |
END; |
CASE operator OF |
|SCAN.lxEQ: bool := string1.s = string2.s |
|SCAN.lxNE: bool := string1.s # string2.s |
|SCAN.lxLT: bool := string1.s < string2.s |
|SCAN.lxGT: bool := string1.s > string2.s |
|SCAN.lxLE: bool := string1.s <= string2.s |
|SCAN.lxGE: bool := string1.s >= string2.s |
END; |
ARITH.setbool(v, bool) |
END strcmp; |
PROCEDURE ConstExpression* (parser: PARSER; VAR v: ARITH.VALUE); |
VAR |
e: EXPR; |
pos: POSITION; |
BEGIN |
getpos(parser, pos); |
parser.constexp := TRUE; |
parser.expression(parser, e); |
parser.constexp := FALSE; |
check(e.obj = eCONST, pos, 62); |
v := e.value |
END ConstExpression; |
PROCEDURE FieldList (parser: PARSER; rec: PROG._TYPE); |
VAR |
name: SCAN.IDENT; |
export: BOOLEAN; |
pos: POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
WHILE parser.sym = SCAN.lxIDENT DO |
getpos(parser, pos); |
name := parser.lex.ident; |
Next(parser); |
export := parser.sym = SCAN.lxMUL; |
IF export THEN |
check1(parser.unit.scopeLvl = 0, parser, 61); |
Next(parser) |
END; |
check(PROG.addField(rec, name, export), pos, 30); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
END |
END FieldList; |
PROCEDURE FormalParameters (parser: PARSER; _type: PROG._TYPE); |
VAR |
ident: PROG.IDENT; |
PROCEDURE FPSection (parser: PARSER; _type: PROG._TYPE); |
VAR |
ident: PROG.IDENT; |
exit: BOOLEAN; |
vPar: BOOLEAN; |
dim: INTEGER; |
t0, t1: PROG._TYPE; |
BEGIN |
vPar := parser.sym = SCAN.lxVAR; |
IF vPar THEN |
Next(parser) |
END; |
checklex(parser, SCAN.lxIDENT); |
exit := FALSE; |
WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO |
check1(PROG.addParam(_type, parser.lex.ident, vPar), parser, 30); |
Next(parser); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSIF parser.sym = SCAN.lxCOLON THEN |
Next(parser); |
dim := 0; |
WHILE parser.sym = SCAN.lxARRAY DO |
INC(dim); |
check1(dim <= PROG.MAXARRDIM, parser, 84); |
ExpectSym(parser, SCAN.lxOF); |
Next(parser) |
END; |
checklex(parser, SCAN.lxIDENT); |
ident := QIdent(parser, FALSE); |
check1(ident.typ = PROG.idTYPE, parser, 68); |
t0 := ident._type; |
t1 := t0; |
WHILE dim > 0 DO |
t1 := PROG.enterType(PROG.tARRAY, -1, 0, parser.unit); |
t1.base := t0; |
t0 := t1; |
DEC(dim) |
END; |
PROG.setParams(_type, t1); |
Next(parser); |
exit := TRUE |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
END |
END FPSection; |
BEGIN |
IF parser.sym = SCAN.lxLROUND THEN |
Next(parser); |
IF (parser.sym = SCAN.lxVAR) OR (parser.sym = SCAN.lxIDENT) THEN |
FPSection(parser, _type); |
WHILE parser.sym = SCAN.lxSEMI DO |
Next(parser); |
FPSection(parser, _type) |
END |
END; |
checklex(parser, SCAN.lxRROUND); |
Next(parser); |
IF parser.sym = SCAN.lxCOLON THEN |
ExpectSym(parser, SCAN.lxIDENT); |
ident := QIdent(parser, FALSE); |
check1(ident.typ = PROG.idTYPE, parser, 68); |
check1(~(ident._type.typ IN {PROG.tRECORD, PROG.tARRAY}), parser, 69); |
check1( ~(ODD(_type.call) & (ident._type.typ = PROG.tREAL)), parser, 113); |
_type.base := ident._type; |
Next(parser) |
ELSE |
_type.base := NIL |
END |
END |
END FormalParameters; |
PROCEDURE sysflag (parser: PARSER; proc: BOOLEAN): INTEGER; |
VAR |
res, sf: INTEGER; |
BEGIN |
checklex(parser, SCAN.lxIDENT); |
IF parser.lex.ident.s = "stdcall" THEN |
sf := PROG.sf_stdcall |
ELSIF parser.lex.ident.s = "cdecl" THEN |
sf := PROG.sf_cdecl |
ELSIF parser.lex.ident.s = "ccall" THEN |
sf := PROG.sf_ccall |
ELSIF parser.lex.ident.s = "win64" THEN |
sf := PROG.sf_win64 |
ELSIF parser.lex.ident.s = "systemv" THEN |
sf := PROG.sf_systemv |
ELSIF parser.lex.ident.s = "windows" THEN |
sf := PROG.sf_windows |
ELSIF parser.lex.ident.s = "linux" THEN |
sf := PROG.sf_linux |
ELSIF parser.lex.ident.s = "code" THEN |
sf := PROG.sf_code |
ELSIF parser.lex.ident.s = "oberon" THEN |
sf := PROG.sf_oberon |
ELSIF parser.lex.ident.s = "noalign" THEN |
sf := PROG.sf_noalign |
ELSE |
check1(FALSE, parser, 124) |
END; |
check1(sf IN PROG.program.sysflags, parser, 125); |
IF proc THEN |
check1(sf IN PROG.proc_flags, parser, 123) |
ELSE |
check1(sf IN PROG.rec_flags, parser, 123) |
END; |
CASE sf OF |
|PROG.sf_stdcall: |
res := PROG.stdcall |
|PROG.sf_cdecl: |
res := PROG.cdecl |
|PROG.sf_ccall: |
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN |
res := PROG.ccall |
ELSIF TARGETS.OS = TARGETS.osWIN64 THEN |
res := PROG.win64 |
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN |
res := PROG.systemv |
END |
|PROG.sf_win64: |
res := PROG.win64 |
|PROG.sf_systemv: |
res := PROG.systemv |
|PROG.sf_code: |
res := PROG.code |
|PROG.sf_oberon: |
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN |
res := PROG.default32 |
ELSIF TARGETS.OS IN {TARGETS.osWIN64, TARGETS.osLINUX64} THEN |
res := PROG.default64 |
END |
|PROG.sf_windows: |
IF TARGETS.OS = TARGETS.osWIN32 THEN |
res := PROG.stdcall |
ELSIF TARGETS.OS = TARGETS.osWIN64 THEN |
res := PROG.win64 |
END |
|PROG.sf_linux: |
IF TARGETS.OS = TARGETS.osLINUX32 THEN |
res := PROG.ccall |
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN |
res := PROG.systemv |
END |
|PROG.sf_noalign: |
res := PROG.noalign |
END |
RETURN res |
END sysflag; |
PROCEDURE procflag (parser: PARSER; VAR _import: IL.IMPORT_PROC; isProc: BOOLEAN): INTEGER; |
VAR |
call: INTEGER; |
dll, proc: SCAN.TEXTSTR; |
pos: POSITION; |
PROCEDURE getStr (parser: PARSER; VAR name: SCAN.TEXTSTR); |
VAR |
pos: POSITION; |
str: ARITH.VALUE; |
BEGIN |
getpos(parser, pos); |
ConstExpression(parser, str); |
IF str.typ = ARITH.tSTRING THEN |
name := str.string(SCAN.STRING).s |
ELSIF str.typ = ARITH.tCHAR THEN |
ARITH.charToStr(str, name) |
ELSE |
check(FALSE, pos, 117) |
END |
END getStr; |
BEGIN |
_import := NIL; |
IF parser.sym = SCAN.lxLSQUARE THEN |
getpos(parser, pos); |
check1(parser.unit.sysimport, parser, 54); |
Next(parser); |
call := sysflag(parser, TRUE); |
Next(parser); |
IF parser.sym = SCAN.lxMINUS THEN |
Next(parser); |
INC(call) |
END; |
IF isProc & (parser.sym = SCAN.lxCOMMA) THEN |
Next(parser); |
getStr(parser, dll); |
STRINGS.UpCase(dll); |
checklex(parser, SCAN.lxCOMMA); |
Next(parser); |
getStr(parser, proc); |
_import := IL.AddImp(dll, proc) |
END; |
checklex(parser, SCAN.lxRSQUARE); |
Next(parser) |
ELSE |
CASE TARGETS.BitDepth OF |
|16: call := PROG.default16 |
|32: IF TARGETS.CPU = TARGETS.cpuX86 THEN |
call := PROG.default32 |
ELSE |
call := PROG.cdecl |
END |
|64: IF TARGETS.CPU = TARGETS.cpuAMD64 THEN |
call := PROG.default64 |
ELSE |
call := PROG.cdecl |
END |
END |
END; |
IF _import # NIL THEN |
check(TARGETS.Import, pos, 70) |
END |
RETURN call |
END procflag; |
PROCEDURE _type (parser: PARSER; VAR t: PROG._TYPE; flags: SET); |
CONST |
comma = 0; |
closed = 1; |
forward = 2; |
VAR |
arrLen: ARITH.VALUE; |
typeSize: ARITH.VALUE; |
ident: PROG.IDENT; |
unit: PROG.UNIT; |
pos, pos2: POSITION; |
fieldType: PROG._TYPE; |
baseIdent: SCAN.IDENT; |
a, b: INTEGER; |
RecFlag: INTEGER; |
_import: IL.IMPORT_PROC; |
BEGIN |
unit := parser.unit; |
t := NIL; |
IF parser.sym = SCAN.lxIDENT THEN |
ident := QIdent(parser, forward IN flags); |
IF ident # NIL THEN |
check1(ident.typ = PROG.idTYPE, parser, 49); |
t := ident._type; |
check1(t # NIL, parser, 50); |
IF closed IN flags THEN |
check1(t.closed, parser, 50) |
END |
END; |
Next(parser) |
ELSIF (parser.sym = SCAN.lxARRAY) OR ((parser.sym = SCAN.lxCOMMA) & (comma IN flags)) THEN |
IF parser.sym = SCAN.lxARRAY THEN |
getpos(parser, pos2) |
END; |
NextPos(parser, pos); |
ConstExpression(parser, arrLen); |
check(arrLen.typ = ARITH.tINTEGER, pos, 43); |
check(ARITH.check(arrLen), pos, 39); |
check(ARITH.getInt(arrLen) > 0, pos, 51); |
t := PROG.enterType(PROG.tARRAY, -1, ARITH.getInt(arrLen), unit); |
IF parser.sym = SCAN.lxCOMMA THEN |
_type(parser, t.base, {comma, closed}) |
ELSIF parser.sym = SCAN.lxOF THEN |
Next(parser); |
_type(parser, t.base, {closed}) |
ELSE |
check1(FALSE, parser, 47) |
END; |
t.align := t.base.align; |
a := t.length; |
b := t.base.size; |
check(ARITH.mulInt(a, b), pos2, 104); |
check(ARITH.setInt(typeSize, a), pos2, 104); |
t.size := a; |
t.closed := TRUE |
ELSIF parser.sym = SCAN.lxRECORD THEN |
getpos(parser, pos2); |
Next(parser); |
t := PROG.enterType(PROG.tRECORD, 0, 0, unit); |
t.align := 1; |
IF parser.sym = SCAN.lxLSQUARE THEN |
check1(parser.unit.sysimport, parser, 54); |
Next(parser); |
RecFlag := sysflag(parser, FALSE); |
t.noalign := RecFlag = PROG.noalign; |
ExpectSym(parser, SCAN.lxRSQUARE); |
Next(parser) |
END; |
IF parser.sym = SCAN.lxLROUND THEN |
check1(~t.noalign, parser, 111); |
ExpectSym(parser, SCAN.lxIDENT); |
getpos(parser, pos); |
_type(parser, t.base, {closed}); |
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, pos, 52); |
IF t.base.typ = PROG.tPOINTER THEN |
t.base := t.base.base; |
check(t.base # NIL, pos, 55) |
END; |
check(~t.base.noalign, pos, 112); |
checklex(parser, SCAN.lxRROUND); |
Next(parser); |
t.size := t.base.size; |
IF t.base.align > t.align THEN |
t.align := t.base.align |
END |
ELSE |
t.base := PROG.program.stTypes.tANYREC |
END; |
WHILE parser.sym = SCAN.lxIDENT DO |
FieldList(parser, t); |
ASSERT(parser.sym = SCAN.lxCOLON); |
Next(parser); |
_type(parser, fieldType, {closed}); |
check(PROG.setFields(t, fieldType), pos2, 104); |
IF (fieldType.align > t.align) & ~t.noalign THEN |
t.align := fieldType.align |
END; |
IF parser.sym = SCAN.lxSEMI THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSE |
checklex(parser, SCAN.lxEND) |
END |
END; |
t.closed := TRUE; |
IL.AddRec(t.base.num); |
IF ~t.noalign THEN |
check(UTILS.Align(t.size, t.align), pos2, 104); |
check(ARITH.setInt(typeSize, t.size), pos2, 104) |
END; |
checklex(parser, SCAN.lxEND); |
Next(parser) |
ELSIF parser.sym = SCAN.lxPOINTER THEN |
ExpectSym(parser, SCAN.lxTO); |
Next(parser); |
t := PROG.enterType(PROG.tPOINTER, TARGETS.AdrSize, 0, unit); |
t.align := TARGETS.AdrSize; |
getpos(parser, pos); |
IF parser.sym = SCAN.lxIDENT THEN |
baseIdent := parser.lex.ident |
END; |
_type(parser, t.base, {forward}); |
IF t.base # NIL THEN |
check(t.base.typ = PROG.tRECORD, pos, 58) |
ELSE |
PROG.frwPtr(unit, t, baseIdent, pos) |
END |
ELSIF parser.sym = SCAN.lxPROCEDURE THEN |
NextPos(parser, pos); |
t := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit); |
t.align := TARGETS.AdrSize; |
t.call := procflag(parser, _import, FALSE); |
FormalParameters(parser, t) |
ELSE |
check1(FALSE, parser, 49) |
END |
END _type; |
PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT; |
VAR |
ident: PROG.IDENT; |
pos: POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
name := parser.lex.ident; |
getpos(parser, pos); |
ident := PROG.addIdent(parser.unit, name, typ); |
check(ident # NIL, pos, 30); |
ident.pos := pos; |
Next(parser); |
IF parser.sym = SCAN.lxMUL THEN |
check1(ident.global, parser, 61); |
ident.export := TRUE; |
Next(parser) |
END |
RETURN ident |
END IdentDef; |
PROCEDURE ConstTypeDeclaration (parser: PARSER; _const: BOOLEAN); |
VAR |
ident: PROG.IDENT; |
name: SCAN.IDENT; |
pos: POSITION; |
BEGIN |
IF _const THEN |
ident := IdentDef(parser, PROG.idNONE, name) |
ELSE |
ident := IdentDef(parser, PROG.idTYPE, name) |
END; |
checklex(parser, SCAN.lxEQ); |
NextPos(parser, pos); |
IF _const THEN |
ConstExpression(parser, ident.value); |
IF ident.value.typ = ARITH.tINTEGER THEN |
check(ARITH.check(ident.value), pos, 39) |
ELSIF ident.value.typ = ARITH.tREAL THEN |
check(ARITH.check(ident.value), pos, 40) |
END; |
ident.typ := PROG.idCONST; |
ident._type := PROG.getType(ident.value.typ) |
ELSE |
_type(parser, ident._type, {}) |
END; |
checklex(parser, SCAN.lxSEMI); |
Next(parser) |
END ConstTypeDeclaration; |
PROCEDURE VarDeclaration (parser: PARSER); |
VAR |
ident: PROG.IDENT; |
name: SCAN.IDENT; |
t: PROG._TYPE; |
BEGIN |
REPEAT |
ident := IdentDef(parser, PROG.idVAR, name); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSIF parser.sym = SCAN.lxCOLON THEN |
Next(parser); |
_type(parser, t, {}); |
PROG.setVarsType(parser.unit, t); |
checklex(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
UNTIL parser.sym # SCAN.lxIDENT |
END VarDeclaration; |
PROCEDURE DeclarationSequence (parser: PARSER): BOOLEAN; |
VAR |
ptr: PROG.FRWPTR; |
endmod: BOOLEAN; |
pos: POSITION; |
PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN; |
VAR |
proc: PROG.IDENT; |
endname, |
name: SCAN.IDENT; |
param: PROG.PARAM; |
unit: PROG.UNIT; |
ident: PROG.IDENT; |
e: EXPR; |
pos, pos1, |
pos2: POSITION; |
label: INTEGER; |
enter: IL.COMMAND; |
call: INTEGER; |
t: PROG._TYPE; |
_import: IL.IMPORT_PROC; |
endmod, b: BOOLEAN; |
fparams: SET; |
int, flt: INTEGER; |
comma: BOOLEAN; |
code, iv: ARITH.VALUE; |
codeProc, |
handler: BOOLEAN; |
line: INTEGER; |
BEGIN |
endmod := FALSE; |
handler := FALSE; |
unit := parser.unit; |
call := procflag(parser, _import, TRUE); |
getpos(parser, pos); |
pos1 := pos; |
checklex(parser, SCAN.lxIDENT); |
line := pos.line; |
IF _import # NIL THEN |
proc := IdentDef(parser, PROG.idIMP, name); |
proc._import := _import; |
IF _import.name = "" THEN |
COPY(name.s, _import.name) |
END; |
PROG.program.procs.last(PROG.PROC)._import := _import |
ELSE |
proc := IdentDef(parser, PROG.idPROC, name) |
END; |
check(PROG.openScope(unit, proc.proc), pos, 116); |
proc._type := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit); |
t := proc._type; |
t.align := TARGETS.AdrSize; |
t.call := call; |
FormalParameters(parser, t); |
IF parser.sym = SCAN.lxLSQUARE THEN |
getpos(parser, pos2); |
check((TARGETS.CPU = TARGETS.cpuTHUMB) & (TARGETS.OS = TARGETS.osNONE), pos2, 24); |
Next(parser); |
getpos(parser, pos2); |
ConstExpression(parser, iv); |
check(iv.typ = ARITH.tINTEGER, pos2, 43); |
check((0 <= ARITH.Int(iv)) & (ARITH.Int(iv) <= THUMB.maxIVT), pos2, 46); |
check(THUMB.SetIV(ARITH.Int(iv)), pos2, 121); |
checklex(parser, SCAN.lxRSQUARE); |
Next(parser); |
handler := TRUE |
END; |
codeProc := call IN {PROG.code, PROG._code}; |
IF call IN {PROG.systemv, PROG._systemv} THEN |
check(t.parSize <= PROG.MAXSYSVPARAM, pos, 120) |
END; |
param := t.params.first(PROG.PARAM); |
WHILE param # NIL DO |
ident := PROG.addIdent(unit, param.name, PROG.idPARAM); |
ASSERT(ident # NIL); |
ident._type := param._type; |
ident.offset := param.offset; |
IF param.vPar THEN |
ident.typ := PROG.idVPAR |
END; |
param := param.next(PROG.PARAM) |
END; |
IF _import = NIL THEN |
label := IL.NewLabel(); |
proc.proc.label := label; |
proc.proc.used := handler; |
IF handler THEN |
IL.AddCmd2(IL.opHANDLER, label, ARITH.Int(iv)) |
END |
END; |
IF codeProc THEN |
enter := IL.EnterC(label); |
comma := FALSE; |
WHILE (parser.sym # SCAN.lxSEMI) OR comma DO |
getpos(parser, pos2); |
ConstExpression(parser, code); |
check(code.typ = ARITH.tINTEGER, pos2, 43); |
IF TARGETS.WordSize > TARGETS.InstrSize THEN |
CASE TARGETS.InstrSize OF |
|1: check(ARITH.range(code, 0, 255), pos, 42) |
|2: check(ARITH.range(code, 0, 65535), pos, 110) |
END |
END; |
IL.AddCmd(IL.opCODE, ARITH.getInt(code)); |
comma := parser.sym = SCAN.lxCOMMA; |
IF comma THEN |
Next(parser) |
ELSE |
checklex(parser, SCAN.lxSEMI) |
END |
END |
END; |
checklex(parser, SCAN.lxSEMI); |
Next(parser); |
IF _import = NIL THEN |
IF parser.main & proc.export & TARGETS.Dll THEN |
IF TARGETS.target = TARGETS.KolibriOSDLL THEN |
check((proc.name.s # "lib_init") & (proc.name.s # "version"), pos, 114) |
END; |
IL.AddExp(label, proc.name.s); |
proc.proc.used := TRUE |
END; |
IF ~codeProc THEN |
b := DeclarationSequence(parser) |
END; |
PROG.ResetLocSize; |
IF call IN {PROG._win64, PROG.win64} THEN |
fparams := PROG.getFloatParamsPos(proc._type, 3, int, flt); |
enter := IL.Enter(label, LSL(ORD(fparams), 5) + MIN(proc._type.parSize, 4)) |
ELSIF call IN {PROG._systemv, PROG.systemv} THEN |
fparams := PROG.getFloatParamsPos(proc._type, PROG.MAXSYSVPARAM - 1, int, flt); |
enter := IL.Enter(label, -(LSL(ORD(fparams), 5) + proc._type.parSize)) |
ELSIF codeProc THEN |
ELSE |
enter := IL.Enter(label, 0) |
END; |
proc.proc.enter := enter; |
IF ~codeProc & (parser.sym = SCAN.lxBEGIN) THEN |
Next(parser); |
parser.StatSeq(parser) |
END; |
IF ~codeProc & (t.base # NIL) THEN |
checklex(parser, SCAN.lxRETURN); |
NextPos(parser, pos); |
parser.expression(parser, e); |
check(parser.chkreturn(parser, e, t.base, pos), pos, 87) |
END; |
IF ~codeProc THEN |
proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), PROG.program.locsize, |
t.parSize * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv}))); |
enter.param2 := PROG.program.locsize; |
checklex(parser, SCAN.lxEND) |
ELSE |
proc.proc.leave := IL.LeaveC() |
END; |
IF (TARGETS.CPU = TARGETS.cpuMSP430) & ~codeProc THEN |
check(MSP430.CheckProcDataSize(enter.param2 + proc._type.parSize, PROG.program.options.ram), pos1, 63); |
enter.param2 := enter.param2 * 65536 + line; |
enter.param3 := IL.codes.errlabels[10] |
END |
END; |
IF parser.sym = SCAN.lxEND THEN |
Next(parser); |
IF parser.sym = SCAN.lxIDENT THEN |
getpos(parser, pos); |
endname := parser.lex.ident; |
IF ~codeProc & (_import = NIL) THEN |
check(PROG.IdEq(endname, name), pos, 60); |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
IF PROG.IdEq(endname, parser.unit.name) THEN |
ExpectSym(parser, SCAN.lxPOINT); |
Next(parser); |
endmod := TRUE |
ELSIF PROG.IdEq(endname, name) THEN |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
error(pos, 60) |
END |
END |
ELSIF parser.sym = SCAN.lxSEMI THEN |
Next(parser) |
ELSE |
checklex(parser, SCAN.lxIDENT) |
END |
END; |
PROG.closeScope(unit); |
RETURN endmod |
END ProcDeclaration; |
BEGIN |
IF parser.sym = SCAN.lxCONST THEN |
Next(parser); |
WHILE parser.sym = SCAN.lxIDENT DO |
ConstTypeDeclaration(parser, TRUE) |
END |
END; |
IF parser.sym = SCAN.lxTYPE THEN |
Next(parser); |
WHILE parser.sym = SCAN.lxIDENT DO |
ConstTypeDeclaration(parser, FALSE) |
END |
END; |
ptr := PROG.linkPtr(parser.unit); |
IF ptr # NIL THEN |
pos.line := ptr.pos.line; |
pos.col := ptr.pos.col; |
pos.parser := parser; |
IF ptr.notRecord THEN |
error(pos, 58) |
ELSE |
error(pos, 48) |
END |
END; |
IF parser.sym = SCAN.lxVAR THEN |
Next(parser); |
IF parser.sym = SCAN.lxIDENT THEN |
VarDeclaration(parser) |
END |
END; |
endmod := FALSE; |
WHILE ~endmod & (parser.sym = SCAN.lxPROCEDURE) DO |
Next(parser); |
endmod := ProcDeclaration(parser) |
END |
RETURN endmod |
END DeclarationSequence; |
PROCEDURE parse (parser: PARSER); |
VAR |
unit: PROG.UNIT; |
label: INTEGER; |
name: INTEGER; |
endmod: BOOLEAN; |
errlabel: INTEGER; |
errno: INTEGER; |
BEGIN |
ASSERT(parser # NIL); |
ASSERT(parser.scanner # NIL); |
ExpectSym(parser, SCAN.lxMODULE); |
ExpectSym(parser, SCAN.lxIDENT); |
IF ~parser.main THEN |
check1(parser.lex.ident.s = parser.modname, parser, 23) |
END; |
unit := PROG.newUnit(parser.lex.ident); |
unit.fname := parser.fname; |
parser.unit := unit; |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser); |
IF parser.sym = SCAN.lxIMPORT THEN |
ImportList(parser) |
END; |
INC(modules); |
CONSOLE.String("compiling "); |
CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") "); |
CONSOLE.String(unit.name.s); |
IF parser.unit.sysimport THEN |
CONSOLE.String(" (SYSTEM)") |
END; |
CONSOLE.Ln; |
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN |
IL.fname(parser.fname) |
END; |
label := IL.NewLabel(); |
IL.Jmp(IL.opJMP, label); |
name := IL.putstr(unit.name.s); |
errlabel := IL.NewLabel(); |
IL.SetLabel(errlabel); |
IL.StrAdr(name); |
IL.Param1; |
IL.AddCmd(IL.opPUSHC, modules); |
IL.AddCmd0(IL.opERR); |
FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO |
IL.SetErrLabel(errno); |
IL.AddCmd(IL.opPUSHC, errno); |
IL.Jmp(IL.opJMP, errlabel) |
END; |
endmod := DeclarationSequence(parser); |
IL.SetLabel(label); |
IF ~endmod THEN |
IF parser.sym = SCAN.lxBEGIN THEN |
Next(parser); |
parser.StatSeq(parser) |
END; |
checklex(parser, SCAN.lxEND); |
ExpectSym(parser, SCAN.lxIDENT); |
check1(parser.lex.ident.s = unit.name.s, parser, 25); |
ExpectSym(parser, SCAN.lxPOINT) |
END; |
INC(lines, parser.lex.pos.line); |
PROG.closeUnit(unit) |
END parse; |
PROCEDURE open (parser: PARSER; modname, FileExt: ARRAY OF CHAR): BOOLEAN; |
BEGIN |
ASSERT(parser # NIL); |
STRINGS.append(parser.fname, modname); |
STRINGS.append(parser.fname, FileExt); |
STRINGS.append(parser.modname, modname); |
parser.scanner := SCAN.open(parser.fname) |
RETURN parser.scanner # NIL |
END open; |
PROCEDURE NewParser (): PARSER; |
VAR |
pars: PARSER; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(parsers); |
IF citem = NIL THEN |
NEW(pars) |
ELSE |
pars := citem(PARSER) |
END |
RETURN pars |
END NewParser; |
PROCEDURE create* (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER; |
VAR |
parser: PARSER; |
BEGIN |
parser := NewParser(); |
parser.path := path; |
parser.lib_path := lib_path; |
parser.ext := UTILS.FILE_EXT; |
parser.fname := path; |
parser.modname := ""; |
parser.scanner := NIL; |
parser.unit := NIL; |
parser.constexp := FALSE; |
parser.main := FALSE; |
parser.open := open; |
parser.parse := parse; |
parser.StatSeq := StatSeq; |
parser.expression := expression; |
parser.designator := designator; |
parser.chkreturn := chkreturn; |
parser.create := create |
RETURN parser |
END create; |
PROCEDURE init* (options: PROG.OPTIONS); |
BEGIN |
PROG.create(options); |
parsers := C.create(); |
lines := 0; |
modules := 0 |
END init; |
END PARS. |
/programs/develop/oberon07/source/PATHS.ob07 |
---|
0,0 → 1,151 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE PATHS; |
IMPORT STRINGS, UTILS; |
CONST |
slash = UTILS.slash; |
PATHLEN = 2048; |
TYPE |
PATH* = ARRAY PATHLEN OF CHAR; |
PROCEDURE split* (fname: ARRAY OF CHAR; VAR path, name, ext: ARRAY OF CHAR); |
VAR |
pos1, pos2, len: INTEGER; |
BEGIN |
len := LENGTH(fname); |
pos1 := len - 1; |
pos2 := pos1; |
STRINGS.search(fname, pos1, slash, FALSE); |
STRINGS.search(fname, pos2, ".", FALSE); |
path := fname; |
path[pos1 + 1] := 0X; |
IF (pos2 = -1) OR (pos2 < pos1) THEN |
pos2 := len |
END; |
INC(pos1); |
STRINGS.copy(fname, name, pos1, 0, pos2 - pos1); |
name[pos2 - pos1] := 0X; |
STRINGS.copy(fname, ext, pos2, 0, len - pos2); |
ext[len - pos2] := 0X |
END split; |
PROCEDURE RelPath* (absolute, relative: ARRAY OF CHAR; VAR res: ARRAY OF CHAR); |
VAR |
i, j: INTEGER; |
error: BOOLEAN; |
BEGIN |
COPY(absolute, res); |
i := LENGTH(res) - 1; |
WHILE (i >= 0) & (res[i] # slash) DO |
DEC(i) |
END; |
INC(i); |
res[i] := 0X; |
error := FALSE; |
j := 0; |
WHILE (relative[j] = ".") & (relative[j + 1] = slash) DO |
INC(j, 2) |
ELSIF relative[j] = slash DO |
INC(j) |
END; |
WHILE ~error & (relative[j] # 0X) DO |
IF (relative[j] = ".") & (relative[j + 1] = ".") & (relative[j + 2] = slash) & (i > 0) & (res[i - 1] = slash) THEN |
DEC(i, 2); |
WHILE (i >= 0) & (res[i] # slash) DO |
DEC(i) |
END; |
IF i < 0 THEN |
error := TRUE |
ELSE |
INC(i); |
INC(j, 3) |
END |
ELSE |
res[i] := relative[j]; |
INC(i); |
INC(j) |
END |
END; |
IF error THEN |
COPY(relative, res) |
ELSE |
res[i] := 0X |
END |
END RelPath; |
PROCEDURE DelSlashes* (VAR path: ARRAY OF CHAR); |
VAR |
i, j, k: INTEGER; |
c: CHAR; |
BEGIN |
i := 0; |
j := 0; |
k := 0; |
REPEAT |
c := path[j]; |
INC(j); |
IF c = slash THEN |
INC(k) |
ELSE |
k := 0 |
END; |
IF k <= 1 THEN |
path[i] := c; |
INC(i) |
END |
UNTIL c = 0X; |
i := 0; |
j := 0; |
REPEAT |
c := path[j]; |
INC(j); |
path[i] := c; |
INC(i); |
IF (c = slash) & (path[j] = ".") & (path[j + 1] = slash) THEN |
INC(j, 2) |
END |
UNTIL c = 0X |
END DelSlashes; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN UTILS.isRelative(path) |
END isRelative; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
BEGIN |
UTILS.GetCurrentDirectory(path) |
END GetCurrentDirectory; |
END PATHS. |
/programs/develop/oberon07/source/PROG.ob07 |
---|
0,0 → 1,1271 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE PROG; |
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS, PATHS; |
CONST |
MAXARRDIM* = 5; |
MAXSCOPE = 16; |
MAXSYSVPARAM* = 26; |
idNONE* = 0; idGUARD = 1; idMODULE* = 2; idCONST* = 3; |
idTYPE* = 4; idSTFUNC* = 5; idSTPROC* = 6; idVAR* = 7; |
idPROC* = 8; idVPAR* = 9; idPARAM* = 10; idSYSFUNC* = 11; |
idSYSPROC* = 12; idIMP* = 13; |
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4; |
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8; |
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12; |
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15; tNONE* = 16; |
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR}; |
stABS* = 1; stASR* = 2; stCHR* = 3; stFLOOR* = 4; |
stFLT* = 5; stLEN* = 6; stLSL* = 7; stODD* = 8; |
stORD* = 9; stROR* = 10; stASSERT* = 11; stDEC* = 12; |
stEXCL* = 13; stINC* = 14; stINCL* = 15; stNEW* = 16; |
stPACK* = 17; stUNPK* = 18; sysADR* = 19; sysSIZE* = 20; |
sysGET* = 21; sysPUT* = 22; |
stDISPOSE* = 23; stLSR* = 24; stBITS* = 25; sysCODE* = 26; |
sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30; |
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34; |
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38; |
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42; |
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46; |
default32* = 2; _default32* = default32 + 1; |
stdcall* = 4; _stdcall* = stdcall + 1; |
cdecl* = 6; _cdecl* = cdecl + 1; |
ccall* = 8; _ccall* = ccall + 1; |
win64* = 10; _win64* = win64 + 1; |
default64* = 12; _default64* = default64 + 1; |
systemv* = 14; _systemv* = systemv + 1; |
default16* = 16; _default16* = default16 + 1; |
code* = 18; _code* = code + 1; |
noalign* = 22; |
callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64}; |
sf_stdcall* = 0; sf_oberon* = 1; sf_cdecl* = 2; sf_ccall* = 3; |
sf_win64* = 4; sf_systemv* = 5; sf_windows* = 6; sf_linux* = 7; |
sf_code* = 8; |
sf_noalign* = 9; |
proc_flags* = {sf_stdcall, sf_cdecl, sf_ccall, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon}; |
rec_flags* = {sf_noalign}; |
STACK_FRAME = 2; |
TYPE |
OPTIONS* = RECORD |
version*, stack*, ram*, rom*: INTEGER; |
pic*, lower*: BOOLEAN; |
checking*: SET |
END; |
IDENT* = POINTER TO rIDENT; |
UNIT* = POINTER TO rUNIT; |
_TYPE* = POINTER TO rTYPE; |
FRWPTR* = POINTER TO RECORD (LISTS.ITEM) |
_type: _TYPE; |
baseIdent: SCAN.IDENT; |
linked: BOOLEAN; |
pos*: SCAN.POSITION; |
notRecord*: BOOLEAN |
END; |
PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
used*: BOOLEAN; |
processed*: BOOLEAN; |
_import*: LISTS.ITEM; |
using*: LISTS.LIST; |
enter*, |
leave*: LISTS.ITEM |
END; |
USED_PROC = POINTER TO RECORD (LISTS.ITEM) |
proc: PROC |
END; |
rUNIT = RECORD (LISTS.ITEM) |
fname*: PATHS.PATH; |
name*: SCAN.IDENT; |
idents*: LISTS.LIST; |
frwPointers: LISTS.LIST; |
gscope: IDENT; |
closed*: BOOLEAN; |
scopeLvl*: INTEGER; |
sysimport*: BOOLEAN; |
scopes*: ARRAY MAXSCOPE OF PROC |
END; |
FIELD* = POINTER TO rFIELD; |
PARAM* = POINTER TO rPARAM; |
rTYPE = RECORD (LISTS.ITEM) |
typ*: INTEGER; |
size*: INTEGER; |
parSize*: INTEGER; |
length*: INTEGER; |
align*: INTEGER; |
base*: _TYPE; |
fields*: LISTS.LIST; |
params*: LISTS.LIST; |
unit*: UNIT; |
closed*: BOOLEAN; |
num*: INTEGER; |
call*: INTEGER; |
_import*: BOOLEAN; |
noalign*: BOOLEAN |
END; |
rFIELD = RECORD (LISTS.ITEM) |
_type*: _TYPE; |
name*: SCAN.IDENT; |
export*: BOOLEAN; |
offset*: INTEGER |
END; |
rPARAM = RECORD (LISTS.ITEM) |
name*: SCAN.IDENT; |
_type*: _TYPE; |
vPar*: BOOLEAN; |
offset*: INTEGER |
END; |
rIDENT = RECORD (LISTS.ITEM) |
name*: SCAN.IDENT; |
typ*: INTEGER; |
export*: BOOLEAN; |
_import*: LISTS.ITEM; |
unit*: UNIT; |
value*: ARITH.VALUE; |
_type*: _TYPE; |
stproc*: INTEGER; |
global*: BOOLEAN; |
scopeLvl*: INTEGER; |
offset*: INTEGER; |
proc*: PROC; |
pos*: SCAN.POSITION |
END; |
PROGRAM = RECORD |
recCount: INTEGER; |
units*: LISTS.LIST; |
types*: LISTS.LIST; |
sysunit*: UNIT; |
rtl*: UNIT; |
bss*: INTEGER; |
locsize*: INTEGER; |
procs*: LISTS.LIST; |
sysflags*: SET; |
options*: OPTIONS; |
stTypes*: RECORD |
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, |
tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE |
END |
END; |
DELIMPORT = PROCEDURE (_import: LISTS.ITEM); |
VAR |
LowerCase*: BOOLEAN; |
idents: C.COLLECTION; |
program*: PROGRAM; |
PROCEDURE NewIdent (): IDENT; |
VAR |
ident: IDENT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(idents); |
IF citem = NIL THEN |
NEW(ident) |
ELSE |
ident := citem(IDENT) |
END |
RETURN ident |
END NewIdent; |
PROCEDURE getOffset* (varIdent: IDENT): INTEGER; |
VAR |
size: INTEGER; |
BEGIN |
IF varIdent.offset = -1 THEN |
size := varIdent._type.size; |
IF varIdent.global THEN |
IF UTILS.Align(program.bss, varIdent._type.align) THEN |
IF UTILS.maxint - program.bss >= size THEN |
varIdent.offset := program.bss; |
INC(program.bss, size) |
END |
END |
ELSE |
IF UTILS.Align(size, TARGETS.WordSize) THEN |
size := size DIV TARGETS.WordSize; |
IF UTILS.maxint - program.locsize >= size THEN |
INC(program.locsize, size); |
varIdent.offset := program.locsize |
END |
END |
END; |
IF varIdent.offset = -1 THEN |
ERRORS.Error(204) |
END |
END |
RETURN varIdent.offset |
END getOffset; |
PROCEDURE closeUnit* (unit: UNIT); |
VAR |
ident, prev: IDENT; |
offset: INTEGER; |
BEGIN |
ident := unit.idents.last(IDENT); |
WHILE (ident # NIL) & (ident.typ # idGUARD) DO |
IF (ident.typ = idVAR) & (ident.offset = -1) THEN |
ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0); |
IF ident.export THEN |
offset := getOffset(ident) |
END |
END; |
ident := ident.prev(IDENT) |
END; |
ident := unit.idents.last(IDENT); |
WHILE ident # NIL DO |
prev := ident.prev(IDENT); |
IF ~ident.export THEN |
LISTS.delete(unit.idents, ident); |
C.push(idents, ident) |
END; |
ident := prev |
END; |
unit.closed := TRUE |
END closeUnit; |
PROCEDURE IdEq* (a, b: SCAN.IDENT): BOOLEAN; |
RETURN (a.hash = b.hash) & (a.s = b.s) |
END IdEq; |
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN; |
VAR |
item: IDENT; |
BEGIN |
item := unit.idents.last(IDENT); |
WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO |
item := item.prev(IDENT) |
END |
RETURN item.typ = idGUARD |
END unique; |
PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT; |
VAR |
item: IDENT; |
res: BOOLEAN; |
proc: PROC; |
BEGIN |
ASSERT(unit # NIL); |
res := unique(unit, ident); |
IF res THEN |
item := NewIdent(); |
item.name := ident; |
item.typ := typ; |
item.unit := NIL; |
item.export := FALSE; |
item._import := NIL; |
item._type := NIL; |
item.value.typ := 0; |
item.stproc := 0; |
item.global := unit.scopeLvl = 0; |
item.scopeLvl := unit.scopeLvl; |
item.offset := -1; |
IF item.typ IN {idPROC, idIMP} THEN |
NEW(proc); |
proc._import := NIL; |
proc.label := 0; |
proc.used := FALSE; |
proc.processed := FALSE; |
proc.using := LISTS.create(NIL); |
LISTS.push(program.procs, proc); |
item.proc := proc |
END; |
LISTS.push(unit.idents, item) |
ELSE |
item := NIL |
END |
RETURN item |
END addIdent; |
PROCEDURE UseProc* (unit: UNIT; call_proc: PROC); |
VAR |
procs: LISTS.LIST; |
cur: LISTS.ITEM; |
proc: USED_PROC; |
BEGIN |
IF unit.scopeLvl = 0 THEN |
call_proc.used := TRUE |
ELSE |
procs := unit.scopes[unit.scopeLvl].using; |
cur := procs.first; |
WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO |
cur := cur.next |
END; |
IF cur = NIL THEN |
NEW(proc); |
proc.proc := call_proc; |
LISTS.push(procs, proc) |
END |
END |
END UseProc; |
PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE); |
VAR |
item: IDENT; |
BEGIN |
ASSERT(_type # NIL); |
item := unit.idents.last(IDENT); |
WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO |
item._type := _type; |
item := item.prev(IDENT) |
END |
END setVarsType; |
PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT; |
VAR |
item: IDENT; |
BEGIN |
item := unit.idents.last(IDENT); |
IF item # NIL THEN |
IF currentScope THEN |
WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO |
item := item.prev(IDENT) |
END; |
IF item.typ = idGUARD THEN |
item := NIL |
END |
ELSE |
WHILE (item # NIL) & ~IdEq(item.name, ident) DO |
item := item.prev(IDENT) |
END |
END |
END |
RETURN item |
END getIdent; |
PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN; |
VAR |
item: IDENT; |
res: BOOLEAN; |
BEGIN |
INC(unit.scopeLvl); |
res := unit.scopeLvl < MAXSCOPE; |
IF res THEN |
unit.scopes[unit.scopeLvl] := proc; |
NEW(item); |
item := NewIdent(); |
item.name.s := ""; |
item.name.hash := 0; |
item.typ := idGUARD; |
LISTS.push(unit.idents, item) |
END |
RETURN res |
END openScope; |
PROCEDURE closeScope* (unit: UNIT); |
VAR |
item: IDENT; |
del: IDENT; |
BEGIN |
item := unit.idents.last(IDENT); |
WHILE (item # NIL) & (item.typ # idGUARD) DO |
del := item; |
item := item.prev(IDENT); |
IF (del.typ = idVAR) & (del.offset = -1) THEN |
ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0) |
END; |
LISTS.delete(unit.idents, del); |
C.push(idents, del) |
END; |
IF (item # NIL) & (item.typ = idGUARD) THEN |
LISTS.delete(unit.idents, item); |
C.push(idents, item) |
END; |
DEC(unit.scopeLvl) |
END closeScope; |
PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION); |
VAR |
newptr: FRWPTR; |
BEGIN |
ASSERT(unit # NIL); |
ASSERT(_type # NIL); |
NEW(newptr); |
newptr._type := _type; |
newptr.baseIdent := baseIdent; |
newptr.pos := pos; |
newptr.linked := FALSE; |
newptr.notRecord := FALSE; |
LISTS.push(unit.frwPointers, newptr) |
END frwPtr; |
PROCEDURE linkPtr* (unit: UNIT): FRWPTR; |
VAR |
item: FRWPTR; |
ident: IDENT; |
res: FRWPTR; |
BEGIN |
res := NIL; |
item := unit.frwPointers.last(FRWPTR); |
WHILE (item # NIL) & ~item.linked & (res = NIL) DO |
ident := getIdent(unit, item.baseIdent, TRUE); |
IF (ident # NIL) THEN |
IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN |
item._type.base := ident._type; |
item.linked := TRUE |
ELSE |
item.notRecord := TRUE; |
res := item |
END |
ELSE |
item.notRecord := FALSE; |
res := item |
END; |
item := item.prev(FRWPTR) |
END |
RETURN res |
END linkPtr; |
PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN; |
VAR |
res: BOOLEAN; |
param1, param2: LISTS.ITEM; |
BEGIN |
IF t1 = t2 THEN |
res := TRUE |
ELSIF (t1 = NIL) OR (t2 = NIL) THEN |
res := FALSE |
ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN |
param1 := t1.params.first; |
param2 := t2.params.first; |
res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL)); |
WHILE res & (param1 # NIL) & (param2 # NIL) DO |
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM)._type, param2(PARAM)._type); |
param1 := param1.next; |
param2 := param2.next; |
res := res & ((param1 # NIL) = (param2 # NIL)) |
END; |
res := res & isTypeEq(t1.base, t2.base) |
ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN |
res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base) |
ELSE |
res := FALSE |
END |
RETURN res |
END isTypeEq; |
PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD}); |
IF res & (t0.typ = tPOINTER) THEN |
t0 := t0.base; |
t1 := t1.base |
END; |
IF res THEN |
WHILE (t1 # NIL) & (t1 # t0) DO |
t1 := t1.base |
END; |
res := t1 # NIL |
END |
RETURN res |
END isBaseOf; |
PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN; |
RETURN (t.typ = tARRAY) & (t.length = 0) |
END isOpenArray; |
PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN; |
RETURN (dst.typ = tARRAY) & isOpenArray(src) & |
~isOpenArray(src.base) & ~isOpenArray(dst.base) & |
isTypeEq(src.base, dst.base) |
END arrcomp; |
PROCEDURE getUnit* (name: PATHS.PATH): UNIT; |
VAR |
item: UNIT; |
BEGIN |
item := program.units.first(UNIT); |
WHILE (item # NIL) & (item.fname # name) DO |
item := item.next(UNIT) |
END; |
IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN |
item := program.sysunit |
END |
RETURN item |
END getUnit; |
PROCEDURE enterStTypes (unit: UNIT); |
PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE); |
VAR |
ident: IDENT; |
upper: SCAN.IDSTR; |
name: SCAN.IDENT; |
BEGIN |
IF LowerCase THEN |
SCAN.setIdent(name, nameStr); |
ident := addIdent(unit, name, idTYPE); |
ident._type := _type |
END; |
upper := nameStr; |
STRINGS.UpCase(upper); |
SCAN.setIdent(name, upper); |
ident := addIdent(unit, name, idTYPE); |
ident._type := _type |
END enter; |
BEGIN |
enter(unit, "integer", program.stTypes.tINTEGER); |
enter(unit, "byte", program.stTypes.tBYTE); |
enter(unit, "char", program.stTypes.tCHAR); |
enter(unit, "set", program.stTypes.tSET); |
enter(unit, "boolean", program.stTypes.tBOOLEAN); |
IF TARGETS.RealSize # 0 THEN |
enter(unit, "real", program.stTypes.tREAL) |
END; |
IF TARGETS.BitDepth >= 32 THEN |
enter(unit, "wchar", program.stTypes.tWCHAR) |
END |
END enterStTypes; |
PROCEDURE enterStProcs (unit: UNIT); |
PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER); |
VAR |
ident: IDENT; |
upper: SCAN.IDSTR; |
name: SCAN.IDENT; |
BEGIN |
IF LowerCase THEN |
SCAN.setIdent(name, nameStr); |
ident := addIdent(unit, name, tfunc); |
ident.stproc := nfunc; |
ident._type := program.stTypes.tNONE |
END; |
upper := nameStr; |
STRINGS.UpCase(upper); |
SCAN.setIdent(name, upper); |
ident := addIdent(unit, name, tfunc); |
ident.stproc := nfunc; |
ident._type := program.stTypes.tNONE |
END Enter; |
BEGIN |
Enter(unit, "assert", stASSERT, idSTPROC); |
Enter(unit, "dec", stDEC, idSTPROC); |
Enter(unit, "excl", stEXCL, idSTPROC); |
Enter(unit, "inc", stINC, idSTPROC); |
Enter(unit, "incl", stINCL, idSTPROC); |
Enter(unit, "new", stNEW, idSTPROC); |
Enter(unit, "copy", stCOPY, idSTPROC); |
Enter(unit, "abs", stABS, idSTFUNC); |
Enter(unit, "asr", stASR, idSTFUNC); |
Enter(unit, "chr", stCHR, idSTFUNC); |
Enter(unit, "len", stLEN, idSTFUNC); |
Enter(unit, "lsl", stLSL, idSTFUNC); |
Enter(unit, "odd", stODD, idSTFUNC); |
Enter(unit, "ord", stORD, idSTFUNC); |
Enter(unit, "ror", stROR, idSTFUNC); |
Enter(unit, "bits", stBITS, idSTFUNC); |
Enter(unit, "lsr", stLSR, idSTFUNC); |
Enter(unit, "length", stLENGTH, idSTFUNC); |
Enter(unit, "min", stMIN, idSTFUNC); |
Enter(unit, "max", stMAX, idSTFUNC); |
IF TARGETS.RealSize # 0 THEN |
Enter(unit, "pack", stPACK, idSTPROC); |
Enter(unit, "unpk", stUNPK, idSTPROC); |
Enter(unit, "floor", stFLOOR, idSTFUNC); |
Enter(unit, "flt", stFLT, idSTFUNC) |
END; |
IF TARGETS.BitDepth >= 32 THEN |
Enter(unit, "wchr", stWCHR, idSTFUNC) |
END; |
IF TARGETS.Dispose THEN |
Enter(unit, "dispose", stDISPOSE, idSTPROC) |
END |
END enterStProcs; |
PROCEDURE newUnit* (name: SCAN.IDENT): UNIT; |
VAR |
unit: UNIT; |
BEGIN |
NEW(unit); |
unit.name := name; |
unit.closed := FALSE; |
unit.idents := LISTS.create(NIL); |
unit.frwPointers := LISTS.create(NIL); |
ASSERT(openScope(unit, NIL)); |
enterStTypes(unit); |
enterStProcs(unit); |
ASSERT(openScope(unit, NIL)); |
unit.gscope := unit.idents.last(IDENT); |
LISTS.push(program.units, unit); |
unit.scopeLvl := 0; |
unit.scopes[0] := NIL; |
unit.sysimport := FALSE; |
IF unit.name.s = UTILS.RTL_NAME THEN |
program.rtl := unit |
END |
RETURN unit |
END newUnit; |
PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD; |
VAR |
field: FIELD; |
BEGIN |
ASSERT(self # NIL); |
ASSERT(unit # NIL); |
field := NIL; |
WHILE (self # NIL) & (field = NIL) DO |
field := self.fields.first(FIELD); |
WHILE (field # NIL) & ~IdEq(field.name, name) DO |
field := field.next(FIELD) |
END; |
IF field = NIL THEN |
self := self.base |
END |
END; |
IF (field # NIL) & (self.unit # unit) & ~field.export THEN |
field := NIL |
END |
RETURN field |
END getField; |
PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN; |
VAR |
field: FIELD; |
res: BOOLEAN; |
BEGIN |
res := getField(self, name, self.unit) = NIL; |
IF res THEN |
NEW(field); |
field.name := name; |
field.export := export; |
field._type := NIL; |
field.offset := self.size; |
LISTS.push(self.fields, field) |
END |
RETURN res |
END addField; |
PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN; |
VAR |
item: FIELD; |
res: BOOLEAN; |
BEGIN |
ASSERT(_type # NIL); |
item := self.fields.first(FIELD); |
WHILE (item # NIL) & (item._type # NIL) DO |
item := item.next(FIELD) |
END; |
res := TRUE; |
WHILE res & (item # NIL) & (item._type = NIL) DO |
item._type := _type; |
IF ~self.noalign THEN |
res := UTILS.Align(self.size, _type.align) |
ELSE |
res := TRUE |
END; |
item.offset := self.size; |
res := res & (UTILS.maxint - self.size >= _type.size); |
IF res THEN |
INC(self.size, _type.size) |
END; |
item := item.next(FIELD) |
END |
RETURN res |
END setFields; |
PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM; |
VAR |
item: PARAM; |
BEGIN |
item := self.params.first(PARAM); |
WHILE (item # NIL) & ~IdEq(item.name, name) DO |
item := item.next(PARAM) |
END |
RETURN item |
END getParam; |
PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN; |
VAR |
param: PARAM; |
res: BOOLEAN; |
BEGIN |
res := getParam(self, name) = NIL; |
IF res THEN |
NEW(param); |
param.name := name; |
param._type := NIL; |
param.vPar := vPar; |
LISTS.push(self.params, param) |
END |
RETURN res |
END addParam; |
PROCEDURE Dim* (t: _TYPE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
res := 0; |
WHILE isOpenArray(t) DO |
t := t.base; |
INC(res) |
END |
RETURN res |
END Dim; |
PROCEDURE OpenBase* (t: _TYPE): _TYPE; |
BEGIN |
WHILE isOpenArray(t) DO t := t.base END |
RETURN t |
END OpenBase; |
PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET; |
VAR |
res: SET; |
param: PARAM; |
BEGIN |
res := {}; |
int := 0; |
flt := 0; |
param := self.params.first(PARAM); |
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO |
IF ~param.vPar & (param._type.typ = tREAL) THEN |
INCL(res, param.offset - STACK_FRAME); |
INC(flt) |
END; |
param := param.next(PARAM) |
END; |
int := self.parSize - flt |
RETURN res |
END getFloatParamsPos; |
PROCEDURE setParams* (self: _TYPE; _type: _TYPE); |
VAR |
item: LISTS.ITEM; |
param: PARAM; |
word, size: INTEGER; |
BEGIN |
ASSERT(_type # NIL); |
word := UTILS.target.bit_depth DIV 8; |
item := self.params.first; |
WHILE (item # NIL) & (item(PARAM)._type # NIL) DO |
item := item.next |
END; |
WHILE (item # NIL) & (item(PARAM)._type = NIL) DO |
param := item(PARAM); |
param._type := _type; |
IF param.vPar THEN |
IF _type.typ = tRECORD THEN |
size := 2 |
ELSIF isOpenArray(_type) THEN |
size := Dim(_type) + 1 |
ELSE |
size := 1 |
END; |
param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME; |
INC(self.parSize, size) |
ELSE |
IF _type.typ IN {tRECORD, tARRAY} THEN |
IF isOpenArray(_type) THEN |
size := Dim(_type) + 1 |
ELSE |
size := 1 |
END |
ELSE |
size := _type.size; |
ASSERT(UTILS.Align(size, word)); |
size := size DIV word |
END; |
param.offset := self.parSize + Dim(_type) + STACK_FRAME; |
INC(self.parSize, size) |
END; |
item := item.next |
END |
END setParams; |
PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE; |
VAR |
t: _TYPE; |
BEGIN |
NEW(t); |
t.typ := typ; |
t.size := size; |
t.length := length; |
t.align := 0; |
t.base := NIL; |
t.fields := LISTS.create(NIL); |
t.params := LISTS.create(NIL); |
t.unit := unit; |
t.num := 0; |
CASE TARGETS.BitDepth OF |
|16: t.call := default16 |
|32: t.call := default32 |
|64: t.call := default64 |
END; |
t._import := FALSE; |
t.noalign := FALSE; |
t.parSize := 0; |
IF typ IN {tARRAY, tRECORD} THEN |
t.closed := FALSE; |
IF typ = tRECORD THEN |
INC(program.recCount); |
t.num := program.recCount |
END |
ELSE |
t.closed := TRUE |
END; |
LISTS.push(program.types, t) |
RETURN t |
END enterType; |
PROCEDURE getType* (typ: INTEGER): _TYPE; |
VAR |
res: _TYPE; |
BEGIN |
CASE typ OF |
|ARITH.tINTEGER: res := program.stTypes.tINTEGER |
|ARITH.tREAL: res := program.stTypes.tREAL |
|ARITH.tSET: res := program.stTypes.tSET |
|ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN |
|ARITH.tCHAR: res := program.stTypes.tCHAR |
|ARITH.tWCHAR: res := program.stTypes.tWCHAR |
|ARITH.tSTRING: res := program.stTypes.tSTRING |
END |
RETURN res |
END getType; |
PROCEDURE createSysUnit; |
VAR |
ident: IDENT; |
unit: UNIT; |
name: SCAN.IDENT; |
PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER); |
VAR |
ident: IDENT; |
upper: SCAN.IDSTR; |
name: SCAN.IDENT; |
BEGIN |
IF LowerCase THEN |
SCAN.setIdent(name, nameStr); |
ident := addIdent(sys, name, idtyp); |
ident.stproc := proc; |
ident._type := program.stTypes.tNONE; |
ident.export := TRUE |
END; |
upper := nameStr; |
STRINGS.UpCase(upper); |
SCAN.setIdent(name, upper); |
ident := addIdent(sys, name, idtyp); |
ident.stproc := proc; |
ident._type := program.stTypes.tNONE; |
ident.export := TRUE |
END EnterProc; |
BEGIN |
SCAN.setIdent(name, "$SYSTEM"); |
unit := newUnit(name); |
unit.fname := "SYSTEM"; |
EnterProc(unit, "adr", idSYSFUNC, sysADR); |
EnterProc(unit, "size", idSYSFUNC, sysSIZE); |
EnterProc(unit, "sadr", idSYSFUNC, sysSADR); |
EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID); |
EnterProc(unit, "get", idSYSPROC, sysGET); |
EnterProc(unit, "get8", idSYSPROC, sysGET8); |
EnterProc(unit, "put", idSYSPROC, sysPUT); |
EnterProc(unit, "put8", idSYSPROC, sysPUT8); |
EnterProc(unit, "code", idSYSPROC, sysCODE); |
EnterProc(unit, "move", idSYSPROC, sysMOVE); |
(* |
IF program.target.sys = mConst.Target_iMSP430 THEN |
EnterProc(unit, "nop", idSYSPROC, sysNOP); |
EnterProc(unit, "eint", idSYSPROC, sysEINT); |
EnterProc(unit, "dint", idSYSPROC, sysDINT) |
END; |
*) |
IF TARGETS.RealSize # 0 THEN |
EnterProc(unit, "inf", idSYSFUNC, sysINF); |
END; |
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN |
EnterProc(unit, "copy", idSYSPROC, sysCOPY) |
END; |
IF TARGETS.BitDepth >= 32 THEN |
EnterProc(unit, "wsadr", idSYSFUNC, sysWSADR); |
EnterProc(unit, "put16", idSYSPROC, sysPUT16); |
EnterProc(unit, "put32", idSYSPROC, sysPUT32); |
EnterProc(unit, "get16", idSYSPROC, sysGET16); |
EnterProc(unit, "get32", idSYSPROC, sysGET32); |
IF LowerCase THEN |
SCAN.setIdent(name, "card32"); |
ident := addIdent(unit, name, idTYPE); |
ident._type := program.stTypes.tCARD32; |
ident.export := TRUE |
END; |
SCAN.setIdent(name, "CARD32"); |
ident := addIdent(unit, name, idTYPE); |
ident._type := program.stTypes.tCARD32; |
ident.export := TRUE; |
END; |
closeUnit(unit); |
program.sysunit := unit |
END createSysUnit; |
PROCEDURE DelUnused* (DelImport: DELIMPORT); |
VAR |
proc: PROC; |
flag: BOOLEAN; |
PROCEDURE process (proc: PROC); |
VAR |
used_proc: LISTS.ITEM; |
BEGIN |
proc.processed := TRUE; |
used_proc := proc.using.first; |
WHILE used_proc # NIL DO |
used_proc(USED_PROC).proc.used := TRUE; |
used_proc := used_proc.next |
END |
END process; |
BEGIN |
REPEAT |
flag := FALSE; |
proc := program.procs.first(PROC); |
WHILE proc # NIL DO |
IF proc.used & ~proc.processed THEN |
process(proc); |
flag := TRUE |
END; |
proc := proc.next(PROC) |
END |
UNTIL ~flag; |
proc := program.procs.first(PROC); |
WHILE proc # NIL DO |
IF ~proc.used THEN |
IF proc._import = NIL THEN |
IL.delete2(proc.enter, proc.leave) |
ELSE |
DelImport(proc._import) |
END |
END; |
proc := proc.next(PROC) |
END |
END DelUnused; |
PROCEDURE ResetLocSize*; |
BEGIN |
program.locsize := 0 |
END ResetLocSize; |
PROCEDURE create* (options: OPTIONS); |
BEGIN |
LowerCase := options.lower; |
SCAN.init(options.lower); |
idents := C.create(); |
UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8); |
program.options := options; |
CASE TARGETS.OS OF |
|TARGETS.osWIN32: program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
|TARGETS.osLINUX32: program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
|TARGETS.osKOS: program.sysflags := {sf_oberon, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
|TARGETS.osWIN64: program.sysflags := {sf_oberon, sf_windows, sf_win64, sf_systemv, sf_ccall, sf_noalign} |
|TARGETS.osLINUX64: program.sysflags := {sf_oberon, sf_linux, sf_win64, sf_systemv, sf_ccall, sf_noalign} |
|TARGETS.osNONE: program.sysflags := {sf_code} |
END; |
program.recCount := -1; |
program.bss := 0; |
program.units := LISTS.create(NIL); |
program.types := LISTS.create(NIL); |
program.procs := LISTS.create(NIL); |
program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL); |
program.stTypes.tBYTE := enterType(tBYTE, 1, 0, NIL); |
program.stTypes.tCHAR := enterType(tCHAR, 1, 0, NIL); |
program.stTypes.tSET := enterType(tSET, TARGETS.WordSize, 0, NIL); |
program.stTypes.tBOOLEAN := enterType(tBOOLEAN, 1, 0, NIL); |
program.stTypes.tINTEGER.align := TARGETS.WordSize; |
program.stTypes.tBYTE.align := 1; |
program.stTypes.tCHAR.align := 1; |
program.stTypes.tSET.align := TARGETS.WordSize; |
program.stTypes.tBOOLEAN.align := 1; |
IF TARGETS.BitDepth >= 32 THEN |
program.stTypes.tWCHAR := enterType(tWCHAR, 2, 0, NIL); |
program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL); |
program.stTypes.tWCHAR.align := 2; |
program.stTypes.tCARD32.align := 4 |
END; |
IF TARGETS.RealSize # 0 THEN |
program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL); |
program.stTypes.tREAL.align := TARGETS.RealSize |
END; |
program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL); |
program.stTypes.tNIL := enterType(tNIL, TARGETS.WordSize, 0, NIL); |
program.stTypes.tNONE := enterType(tNONE, 0, 0, NIL); |
program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL); |
program.stTypes.tANYREC.closed := TRUE; |
createSysUnit |
END create; |
END PROG. |
/programs/develop/oberon07/source/REG.ob07 |
---|
0,0 → 1,286 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE REG; |
CONST |
N = 16; |
R0* = 0; R1* = 1; R2* = 2; R3* = 3; |
R4* = 4; R5* = 5; R6* = 6; R7* = 7; |
R8* = 8; R9* = 9; R10* = 10; R11* = 11; |
R12* = 12; R13* = 13; R14* = 14; R15* = 15; |
TYPE |
OP1 = PROCEDURE (arg: INTEGER); |
OP2 = PROCEDURE (arg1, arg2: INTEGER); |
REGS* = RECORD |
regs*: SET; |
stk*: ARRAY N OF INTEGER; |
top*: INTEGER; |
pushed*: INTEGER; |
push, pop: OP1; |
mov, xch: OP2 |
END; |
PROCEDURE push (VAR R: REGS); |
VAR |
i, reg: INTEGER; |
BEGIN |
reg := R.stk[0]; |
INCL(R.regs, reg); |
R.push(reg); |
FOR i := 0 TO R.top - 1 DO |
R.stk[i] := R.stk[i + 1] |
END; |
DEC(R.top); |
INC(R.pushed) |
END push; |
PROCEDURE pop (VAR R: REGS; reg: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := R.top + 1 TO 1 BY -1 DO |
R.stk[i] := R.stk[i - 1] |
END; |
R.stk[0] := reg; |
EXCL(R.regs, reg); |
R.pop(reg); |
INC(R.top); |
DEC(R.pushed) |
END pop; |
PROCEDURE InStk (R: REGS; reg: INTEGER): INTEGER; |
VAR |
i: INTEGER; |
BEGIN |
i := R.top; |
WHILE (i >= 0) & (R.stk[i] # reg) DO |
DEC(i) |
END |
RETURN i |
END InStk; |
PROCEDURE GetFreeReg (R: REGS): INTEGER; |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i < N) & ~(i IN R.regs) DO |
INC(i) |
END; |
IF i = N THEN |
i := -1 |
END |
RETURN i |
END GetFreeReg; |
PROCEDURE Put (VAR R: REGS; reg: INTEGER); |
BEGIN |
EXCL(R.regs, reg); |
INC(R.top); |
R.stk[R.top] := reg |
END Put; |
PROCEDURE PopAnyReg (VAR R: REGS): INTEGER; |
VAR |
reg: INTEGER; |
BEGIN |
reg := GetFreeReg(R); |
ASSERT(reg # -1); |
ASSERT(R.top < LEN(R.stk) - 1); |
ASSERT(R.pushed > 0); |
pop(R, reg) |
RETURN reg |
END PopAnyReg; |
PROCEDURE GetAnyReg* (VAR R: REGS): INTEGER; |
VAR |
reg: INTEGER; |
BEGIN |
reg := GetFreeReg(R); |
IF reg = -1 THEN |
ASSERT(R.top >= 0); |
reg := R.stk[0]; |
push(R) |
END; |
Put(R, reg) |
RETURN reg |
END GetAnyReg; |
PROCEDURE GetReg* (VAR R: REGS; reg: INTEGER): BOOLEAN; |
VAR |
free: INTEGER; |
res: BOOLEAN; |
PROCEDURE exch (VAR R: REGS; reg1, reg2: INTEGER); |
VAR |
n1, n2: INTEGER; |
BEGIN |
n1 := InStk(R, reg1); |
n2 := InStk(R, reg2); |
R.stk[n1] := reg2; |
R.stk[n2] := reg1; |
R.xch(reg1, reg2) |
END exch; |
BEGIN |
IF reg IN R.regs THEN |
Put(R, reg); |
res := TRUE |
ELSE |
res := InStk(R, reg) # -1; |
IF res THEN |
free := GetFreeReg(R); |
IF free # -1 THEN |
Put(R, free); |
exch(R, reg, free) |
ELSE |
push(R); |
free := GetFreeReg(R); |
ASSERT(free # -1); |
Put(R, free); |
IF free # reg THEN |
exch(R, reg, free) |
END |
END |
END |
END |
RETURN res |
END GetReg; |
PROCEDURE Exchange* (VAR R: REGS; reg1, reg2: INTEGER): BOOLEAN; |
VAR |
n1, n2: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
IF reg1 # reg2 THEN |
n1 := InStk(R, reg1); |
n2 := InStk(R, reg2); |
IF (n1 # -1) & (n2 # -1) THEN |
R.stk[n1] := reg2; |
R.stk[n2] := reg1; |
R.xch(reg2, reg1) |
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN |
R.stk[n1] := reg2; |
INCL(R.regs, reg1); |
EXCL(R.regs, reg2); |
R.mov(reg2, reg1) |
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN |
R.stk[n2] := reg1; |
EXCL(R.regs, reg1); |
INCL(R.regs, reg2); |
R.mov(reg1, reg2) |
ELSE |
res := FALSE |
END |
END |
RETURN res |
END Exchange; |
PROCEDURE Drop* (VAR R: REGS); |
BEGIN |
INCL(R.regs, R.stk[R.top]); |
DEC(R.top) |
END Drop; |
PROCEDURE BinOp* (VAR R: REGS; VAR reg1, reg2: INTEGER); |
BEGIN |
IF R.top > 0 THEN |
reg1 := R.stk[R.top - 1]; |
reg2 := R.stk[R.top] |
ELSIF R.top = 0 THEN |
reg1 := PopAnyReg(R); |
reg2 := R.stk[1] |
ELSE (* R.top = -1 *) |
reg2 := PopAnyReg(R); |
reg1 := PopAnyReg(R) |
END |
END BinOp; |
PROCEDURE UnOp* (VAR R: REGS; VAR reg: INTEGER); |
BEGIN |
IF R.top >= 0 THEN |
reg := R.stk[R.top] |
ELSE |
reg := PopAnyReg(R) |
END |
END UnOp; |
PROCEDURE PushAll* (VAR R: REGS); |
BEGIN |
WHILE R.top >= 0 DO |
push(R) |
END |
END PushAll; |
PROCEDURE PushAll_1* (VAR R: REGS); |
BEGIN |
WHILE R.top >= 1 DO |
push(R) |
END |
END PushAll_1; |
PROCEDURE Init* (VAR R: REGS; push, pop: OP1; mov, xch: OP2; regs: SET); |
BEGIN |
R.regs := regs; |
R.pushed := 0; |
R.top := -1; |
R.push := push; |
R.pop := pop; |
R.mov := mov; |
R.xch := xch; |
END Init; |
END REG. |
/programs/develop/oberon07/source/RVMxI.ob07 |
---|
0,0 → 1,1428 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE RVMxI; |
IMPORT |
PROG, WR := WRITER, IL, CHL := CHUNKLISTS, REG, UTILS, STRINGS, ERRORS, TARGETS; |
CONST |
LTypes = 0; |
LStrings = 1; |
LGlobal = 2; |
LHeap = 3; |
LStack = 4; |
numGPRs = 3; |
R0 = 0; R1 = 1; |
BP = 3; SP = 4; |
ACC = R0; |
GPRs = {0 .. 2} + {5 .. numGPRs + 1}; |
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opNOP = 5; |
opXCHG = 6; opLDB = 7; opLDH = 8; opLDW = 9; opPUSH = 10; opPUSHC = 11; |
opPOP = 12; opLABEL = 13; opLEA = 14; opLLA = 15; |
opLDD = 16; (* 17, 18 *) |
opJMP = 19; opCALL = 20; opCALLI = 21; |
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32; |
opSTB = 34; opSTH = 36; opSTW = 38; opSTD = 40; (* 42, 44 *) |
opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54; |
opLSL = 56; opROR = 58; (* 60, 62 *) opCMP = 64; |
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33; |
opSTBC = 35; opSTHC = 37; opSTWC = 39; opSTDC = 41; (* 43, 45 *) |
opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55; |
opLSLC = 57; opRORC = 59; (* 61, 63 *) opCMPC = 65; |
opBIT = 66; opSYSCALL = 67; opJBT = 68; opADDRC = 69; |
opJEQ = 70; opJNE = 71; opJLT = 72; opJGE = 73; opJGT = 74; opJLE = 75; |
opSEQ = 76; opSNE = 77; opSLT = 78; opSGE = 79; opSGT = 80; opSLE = 81; |
VAR |
R: REG.REGS; count, szWord: INTEGER; |
ldr, str: PROCEDURE (r1, r2: INTEGER); |
PROCEDURE OutByte (n: BYTE); |
BEGIN |
WR.WriteByte(n); |
INC(count) |
END OutByte; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
IF szWord = 8 THEN |
WR.Write64LE(n); |
INC(count, 8) |
ELSE (* szWord = 4 *) |
WR.Write32LE(n); |
INC(count, 4) |
END |
END OutInt; |
PROCEDURE Emit (op, par1, par2: INTEGER); |
BEGIN |
OutInt(op); |
OutInt(par1); |
OutInt(par2) |
END Emit; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE GetAcc; |
BEGIN |
ASSERT(REG.GetReg(R, ACC)) |
END GetAcc; |
PROCEDURE UnOp (VAR r: INTEGER); |
BEGIN |
REG.UnOp(R, r) |
END UnOp; |
PROCEDURE BinOp (VAR r1, r2: INTEGER); |
BEGIN |
REG.BinOp(R, r1, r2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE push (r: INTEGER); |
BEGIN |
Emit(opPUSH, r, 0) |
END push; |
PROCEDURE pop (r: INTEGER); |
BEGIN |
Emit(opPOP, r, 0) |
END pop; |
PROCEDURE mov (r1, r2: INTEGER); |
BEGIN |
Emit(opMOV, r1, r2) |
END mov; |
PROCEDURE xchg (r1, r2: INTEGER); |
BEGIN |
Emit(opXCHG, r1, r2) |
END xchg; |
PROCEDURE addrc (r, c: INTEGER); |
BEGIN |
Emit(opADDC, r, c) |
END addrc; |
PROCEDURE subrc (r, c: INTEGER); |
BEGIN |
Emit(opSUBC, r, c) |
END subrc; |
PROCEDURE movrc (r, c: INTEGER); |
BEGIN |
Emit(opMOVC, r, c) |
END movrc; |
PROCEDURE pushc (c: INTEGER); |
BEGIN |
Emit(opPUSHC, c, 0) |
END pushc; |
PROCEDURE add (r1, r2: INTEGER); |
BEGIN |
Emit(opADD, r1, r2) |
END add; |
PROCEDURE sub (r1, r2: INTEGER); |
BEGIN |
Emit(opSUB, r1, r2) |
END sub; |
PROCEDURE ldr64 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDD, r2 * 256 + r1, 0) |
END ldr64; |
PROCEDURE ldr32 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDW, r2 * 256 + r1, 0) |
END ldr32; |
PROCEDURE ldr16 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDH, r2 * 256 + r1, 0) |
END ldr16; |
PROCEDURE ldr8 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDB, r2 * 256 + r1, 0) |
END ldr8; |
PROCEDURE str64 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTD, r1 * 256 + r2, 0) |
END str64; |
PROCEDURE str32 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTW, r1 * 256 + r2, 0) |
END str32; |
PROCEDURE str16 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTH, r1 * 256 + r2, 0) |
END str16; |
PROCEDURE str8 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTB, r1 * 256 + r2, 0) |
END str8; |
PROCEDURE GlobalAdr (r, offset: INTEGER); |
BEGIN |
Emit(opLEA, r + 256 * LGlobal, offset) |
END GlobalAdr; |
PROCEDURE StrAdr (r, offset: INTEGER); |
BEGIN |
Emit(opLEA, r + 256 * LStrings, offset) |
END StrAdr; |
PROCEDURE ProcAdr (r, label: INTEGER); |
BEGIN |
Emit(opLLA, r, label) |
END ProcAdr; |
PROCEDURE jnz (r, label: INTEGER); |
BEGIN |
Emit(opCMPC, r, 0); |
Emit(opJNE, label, 0) |
END jnz; |
PROCEDURE CallRTL (proc, par: INTEGER); |
BEGIN |
Emit(opCALL, IL.codes.rtl[proc], 0); |
addrc(SP, par * szWord) |
END CallRTL; |
PROCEDURE jcc (cc: INTEGER): INTEGER; |
BEGIN |
CASE cc OF |
|IL.opEQ, IL.opEQC: cc := opJEQ |
|IL.opNE, IL.opNEC: cc := opJNE |
|IL.opLT, IL.opLTC: cc := opJLT |
|IL.opLE, IL.opLEC: cc := opJLE |
|IL.opGT, IL.opGTC: cc := opJGT |
|IL.opGE, IL.opGEC: cc := opJGE |
END |
RETURN cc |
END jcc; |
PROCEDURE shift1 (op, param: INTEGER); |
VAR |
r1, r2: INTEGER; |
BEGIN |
r2 := GetAnyReg(); |
Emit(opMOVC, r2, param); |
BinOp(r1, r2); |
Emit(op, r2, r1); |
mov(r1, r2); |
drop |
END shift1; |
PROCEDURE shift (op: INTEGER); |
VAR |
r1, r2: INTEGER; |
BEGIN |
BinOp(r1, r2); |
Emit(op, r1, r2); |
drop |
END shift; |
PROCEDURE translate (szWord: INTEGER); |
VAR |
cmd, next: IL.COMMAND; |
opcode, param1, param2, r1, r2, r3, |
a, b, label, opLD, opST, opSTC: INTEGER; |
BEGIN |
IF szWord = 8 THEN |
opLD := opLDD; |
opST := opSTD; |
opSTC := opSTDC |
ELSE |
opLD := opLDW; |
opST := opSTW; |
opSTC := opSTWC |
END; |
cmd := IL.codes.commands.first(IL.COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
Emit(opJMP, param1, 0) |
|IL.opLABEL: |
Emit(opLABEL, param1, 0) |
|IL.opCALL: |
Emit(opCALL, param1, 0) |
|IL.opCALLP: |
UnOp(r1); |
Emit(opCALLI, r1, 0); |
drop; |
ASSERT(R.top = -1) |
|IL.opPUSHC: |
pushc(param2) |
|IL.opCLEANUP: |
IF param2 # 0 THEN |
addrc(SP, param2 * szWord) |
END |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opSADR: |
StrAdr(GetAnyReg(), param2) |
|IL.opGADR: |
GlobalAdr(GetAnyReg(), param2) |
|IL.opLADR: |
param2 := param2 * szWord; |
next := cmd.next(IL.COMMAND); |
IF ((next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVEF)) & (szWord = 8) OR (next.opcode = IL.opSAVE64) THEN |
UnOp(r1); |
Emit(opSTD, BP * 256 + r1, param2); |
drop; |
cmd := next |
ELSIF ((next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVEF)) & (szWord = 4) OR (next.opcode = IL.opSAVE32) THEN |
UnOp(r1); |
Emit(opSTW, BP * 256 + r1, param2); |
drop; |
cmd := next |
ELSIF next.opcode = IL.opSAVE16 THEN |
UnOp(r1); |
Emit(opSTH, BP * 256 + r1, param2); |
drop; |
cmd := next |
ELSIF next.opcode = IL.opSAVE8 THEN |
UnOp(r1); |
Emit(opSTB, BP * 256 + r1, param2); |
drop; |
cmd := next |
ELSE |
Emit(opADDRC, BP * 256 + GetAnyReg(), param2) |
END |
|IL.opPARAM: |
IF param2 = 1 THEN |
UnOp(r1); |
push(r1); |
drop |
ELSE |
ASSERT(R.top + 1 <= param2); |
PushAll(param2) |
END |
|IL.opONERR: |
pushc(param2); |
Emit(opJMP, param1, 0) |
|IL.opPRECALL: |
PushAll(0) |
|IL.opRES, IL.opRESF: |
ASSERT(R.top = -1); |
GetAcc |
|IL.opENTER: |
ASSERT(R.top = -1); |
Emit(opLABEL, param1, 0); |
Emit(opENTER, param2, 0) |
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF: |
IF opcode # IL.opLEAVE THEN |
UnOp(r1); |
IF r1 # ACC THEN |
mov(ACC, r1) |
END; |
drop |
END; |
ASSERT(R.top = -1); |
IF param1 > 0 THEN |
mov(SP, BP) |
END; |
pop(BP); |
Emit(opRET, 0, 0) |
|IL.opLEAVEC: |
Emit(opRET, 0, 0) |
|IL.opCONST: |
next := cmd.next(IL.COMMAND); |
IF (next.opcode = IL.opPARAM) & (next.param2 = 1) THEN |
pushc(param2); |
cmd := next |
ELSE |
movrc(GetAnyReg(), param2) |
END |
|IL.opDROP: |
UnOp(r1); |
drop |
|IL.opSAVEC: |
UnOp(r1); |
Emit(opSTC, r1, param2); |
drop |
|IL.opSAVE8C: |
UnOp(r1); |
Emit(opSTBC, r1, param2 MOD 256); |
drop |
|IL.opSAVE16C: |
UnOp(r1); |
Emit(opSTHC, r1, param2 MOD 65536); |
drop |
|IL.opSAVE, IL.opSAVEF: |
BinOp(r2, r1); |
str(r1, r2); |
drop; |
drop |
|IL.opSAVE32: |
BinOp(r2, r1); |
str32(r1, r2); |
drop; |
drop |
|IL.opSAVE64: |
BinOp(r2, r1); |
str64(r1, r2); |
drop; |
drop |
|IL.opSAVEFI: |
BinOp(r2, r1); |
str(r2, r1); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(r2, r1); |
str8(r1, r2); |
drop; |
drop |
|IL.opSAVE16: |
BinOp(r2, r1); |
str16(r1, r2); |
drop; |
drop |
|IL.opGLOAD32: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr32(r1, r1) |
|IL.opGLOAD64: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr64(r1, r1) |
|IL.opVADR: |
Emit(opLD, BP * 256 + GetAnyReg(), param2 * szWord) |
|IL.opLLOAD32: |
Emit(opLDW, BP * 256 + GetAnyReg(), param2 * szWord) |
|IL.opLLOAD64: |
Emit(opLDD, BP * 256 + GetAnyReg(), param2 * szWord) |
|IL.opVLOAD32: |
r1 := GetAnyReg(); |
Emit(opLD, BP * 256 + r1, param2 * szWord); |
ldr32(r1, r1) |
|IL.opVLOAD64: |
r1 := GetAnyReg(); |
Emit(opLDD, BP * 256 + r1, param2 * szWord); |
ldr64(r1, r1) |
|IL.opGLOAD16: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr16(r1, r1) |
|IL.opLLOAD16: |
Emit(opLDH, BP * 256 + GetAnyReg(), param2 * szWord) |
|IL.opVLOAD16: |
r1 := GetAnyReg(); |
Emit(opLD, BP * 256 + r1, param2 * szWord); |
ldr16(r1, r1) |
|IL.opGLOAD8: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr8(r1, r1) |
|IL.opLLOAD8: |
Emit(opLDB, BP * 256 + GetAnyReg(), param2 * szWord) |
|IL.opVLOAD8: |
r1 := GetAnyReg(); |
Emit(opLD, BP * 256 + r1, param2 * szWord); |
ldr8(r1, r1) |
|IL.opLOAD8: |
UnOp(r1); |
ldr8(r1, r1) |
|IL.opLOAD16: |
UnOp(r1); |
ldr16(r1, r1) |
|IL.opLOAD32: |
UnOp(r1); |
ldr32(r1, r1) |
|IL.opLOAD64: |
UnOp(r1); |
ldr64(r1, r1) |
|IL.opLOADF: |
UnOp(r1); |
ldr(r1, r1) |
|IL.opUMINUS: |
UnOp(r1); |
Emit(opNEG, r1, 0) |
|IL.opADD: |
BinOp(r1, r2); |
add(r1, r2); |
drop |
|IL.opSUB: |
BinOp(r1, r2); |
sub(r1, r2); |
drop |
|IL.opADDC: |
UnOp(r1); |
next := cmd.next(IL.COMMAND); |
CASE next.opcode OF |
|IL.opLOADF: |
Emit(opLD, r1 * 256 + r1, param2); |
cmd := next |
|IL.opLOAD64: |
Emit(opLDD, r1 * 256 + r1, param2); |
cmd := next |
|IL.opLOAD32: |
Emit(opLDW, r1 * 256 + r1, param2); |
cmd := next |
|IL.opLOAD16: |
Emit(opLDH, r1 * 256 + r1, param2); |
cmd := next |
|IL.opLOAD8: |
Emit(opLDB, r1 * 256 + r1, param2); |
cmd := next |
ELSE |
addrc(r1, param2) |
END |
|IL.opSUBR: |
UnOp(r1); |
subrc(r1, param2) |
|IL.opSUBL: |
UnOp(r1); |
subrc(r1, param2); |
Emit(opNEG, r1, 0) |
|IL.opMULC: |
UnOp(r1); |
Emit(opMULC, r1, param2) |
|IL.opMUL: |
BinOp(r1, r2); |
Emit(opMUL, r1, r2); |
drop |
|IL.opDIV: |
BinOp(r1, r2); |
Emit(opDIV, r1, r2); |
drop |
|IL.opMOD: |
BinOp(r1, r2); |
Emit(opMOD, r1, r2); |
drop |
|IL.opDIVR: |
UnOp(r1); |
Emit(opDIVC, r1, param2) |
|IL.opMODR: |
UnOp(r1); |
Emit(opMODC, r1, param2) |
|IL.opDIVL: |
UnOp(r1); |
r2 := GetAnyReg(); |
movrc(r2, param2); |
Emit(opDIV, r2, r1); |
mov(r1, r2); |
drop |
|IL.opMODL: |
UnOp(r1); |
r2 := GetAnyReg(); |
movrc(r2, param2); |
Emit(opMOD, r2, r1); |
mov(r1, r2); |
drop |
|IL.opEQ .. IL.opGE, IL.opEQC .. IL.opGEC: |
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN |
BinOp(r1, r2); |
Emit(opCMP, r1, r2); |
drop |
ELSE |
UnOp(r1); |
Emit(opCMPC, r1, param2) |
END; |
next := cmd.next(IL.COMMAND); |
IF next.opcode = IL.opJZ THEN |
Emit(ORD(BITS(jcc(opcode)) / {0}), next.param1, 0); |
cmd := next; |
drop |
ELSIF next.opcode = IL.opJNZ THEN |
Emit(jcc(opcode), next.param1, 0); |
cmd := next; |
drop |
ELSE |
Emit(jcc(opcode) + 6, r1, 0) |
END |
|IL.opJNZ1: |
UnOp(r1); |
jnz(r1, param1) |
|IL.opJG: |
UnOp(r1); |
Emit(opCMPC, r1, 0); |
Emit(opJGT, param1, 0) |
|IL.opJNZ: |
UnOp(r1); |
jnz(r1, param1); |
drop |
|IL.opJZ: |
UnOp(r1); |
Emit(opCMPC, r1, 0); |
Emit(opJEQ, param1, 0); |
drop |
|IL.opMULS: |
BinOp(r1, r2); |
Emit(opAND, r1, r2); |
drop |
|IL.opMULSC: |
UnOp(r1); |
Emit(opANDC, r1, param2) |
|IL.opDIVS: |
BinOp(r1, r2); |
Emit(opXOR, r1, r2); |
drop |
|IL.opDIVSC: |
UnOp(r1); |
Emit(opXORC, r1, param2) |
|IL.opADDS: |
BinOp(r1, r2); |
Emit(opOR, r1, r2); |
drop |
|IL.opSUBS: |
BinOp(r1, r2); |
Emit(opNOT, r2, 0); |
Emit(opAND, r1, r2); |
drop |
|IL.opADDSC: |
UnOp(r1); |
Emit(opORC, r1, param2) |
|IL.opSUBSL: |
UnOp(r1); |
Emit(opNOT, r1, 0); |
Emit(opANDC, r1, param2) |
|IL.opSUBSR: |
UnOp(r1); |
Emit(opANDC, r1, ORD(-BITS(param2))) |
|IL.opUMINS: |
UnOp(r1); |
Emit(opNOT, r1, 0) |
|IL.opASR: |
shift(opASR) |
|IL.opLSL: |
shift(opLSL) |
|IL.opROR: |
shift(opROR) |
|IL.opLSR: |
shift(opLSR) |
|IL.opASR1: |
shift1(opASR, param2) |
|IL.opLSL1: |
shift1(opLSL, param2) |
|IL.opROR1: |
shift1(opROR, param2) |
|IL.opLSR1: |
shift1(opLSR, param2) |
|IL.opASR2: |
UnOp(r1); |
Emit(opASRC, r1, param2 MOD (szWord * 8)) |
|IL.opLSL2: |
UnOp(r1); |
Emit(opLSLC, r1, param2 MOD (szWord * 8)) |
|IL.opROR2: |
UnOp(r1); |
Emit(opRORC, r1, param2 MOD (szWord * 8)) |
|IL.opLSR2: |
UnOp(r1); |
Emit(opLSRC, r1, param2 MOD (szWord * 8)) |
|IL.opCHR: |
UnOp(r1); |
Emit(opANDC, r1, 255) |
|IL.opWCHR: |
UnOp(r1); |
Emit(opANDC, r1, 65535) |
|IL.opABS: |
UnOp(r1); |
Emit(opCMPC, r1, 0); |
label := IL.NewLabel(); |
Emit(opJGE, label, 0); |
Emit(opNEG, r1, 0); |
Emit(opLABEL, label, 0) |
|IL.opLEN: |
UnOp(r1); |
drop; |
EXCL(R.regs, r1); |
WHILE param2 > 0 DO |
UnOp(r2); |
drop; |
DEC(param2) |
END; |
INCL(R.regs, r1); |
ASSERT(REG.GetReg(R, r1)) |
|IL.opSWITCH: |
UnOp(r1); |
IF param2 = 0 THEN |
r2 := ACC |
ELSE |
r2 := R1 |
END; |
IF r1 # r2 THEN |
ASSERT(REG.GetReg(R, r2)); |
ASSERT(REG.Exchange(R, r1, r2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
Emit(opCMPC, ACC, param1); |
Emit(opJLT, param2, 0) |
|IL.opCASER: |
Emit(opCMPC, ACC, param1); |
Emit(opJGT, param2, 0) |
|IL.opCASELR: |
Emit(opCMPC, ACC, param1); |
IF param2 = cmd.param3 THEN |
Emit(opJNE, param2, 0) |
ELSE |
Emit(opJLT, param2, 0); |
Emit(opJGT, cmd.param3, 0) |
END |
|IL.opSBOOL: |
BinOp(r2, r1); |
Emit(opCMPC, r2, 0); |
Emit(opSNE, r2, 0); |
str8(r1, r2); |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(r1); |
Emit(opSTBC, r1, ORD(param2 # 0)); |
drop |
|IL.opINCC: |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr(r2, r1); |
addrc(r2, param2); |
str(r1, r2); |
drop; |
drop |
|IL.opINCCB, IL.opDECCB: |
IF opcode = IL.opDECCB THEN |
param2 := -param2 |
END; |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr8(r2, r1); |
addrc(r2, param2); |
str8(r1, r2); |
drop; |
drop |
|IL.opINCB, IL.opDECB: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
ldr8(r3, r1); |
IF opcode = IL.opINCB THEN |
add(r3, r2) |
ELSE |
sub(r3, r2) |
END; |
str8(r1, r3); |
drop; |
drop; |
drop |
|IL.opINC, IL.opDEC: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
ldr(r3, r1); |
IF opcode = IL.opINC THEN |
add(r3, r2) |
ELSE |
sub(r3, r2) |
END; |
str(r1, r3); |
drop; |
drop; |
drop |
|IL.opINCL, IL.opEXCL: |
BinOp(r2, r1); |
Emit(opBIT, r2, r2); |
r3 := GetAnyReg(); |
ldr(r3, r1); |
IF opcode = IL.opINCL THEN |
Emit(opOR, r3, r2) |
ELSE |
Emit(opNOT, r2, 0); |
Emit(opAND, r3, r2) |
END; |
str(r1, r3); |
drop; |
drop; |
drop |
|IL.opINCLC, IL.opEXCLC: |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr(r2, r1); |
IF opcode = IL.opINCLC THEN |
Emit(opORC, r2, ORD({param2})) |
ELSE |
Emit(opANDC, r2, ORD(-{param2})) |
END; |
str(r1, r2); |
drop; |
drop |
|IL.opEQB, IL.opNEB: |
BinOp(r1, r2); |
Emit(opCMPC, r1, 0); |
Emit(opSNE, r1, 0); |
Emit(opCMPC, r2, 0); |
Emit(opSNE, r2, 0); |
Emit(opCMP, r1, r2); |
IF opcode = IL.opEQB THEN |
Emit(opSEQ, r1, 0) |
ELSE |
Emit(opSNE, r1, 0) |
END; |
drop |
|IL.opCHKBYTE: |
BinOp(r1, r2); |
Emit(opCMPC, r1, 256); |
Emit(opJBT, param1, 0) |
|IL.opCHKIDX: |
UnOp(r1); |
Emit(opCMPC, r1, param2); |
Emit(opJBT, param1, 0) |
|IL.opCHKIDX2: |
BinOp(r1, r2); |
IF param2 # -1 THEN |
Emit(opCMP, r2, r1); |
Emit(opJBT, param1, 0) |
END; |
INCL(R.regs, r1); |
DEC(R.top); |
R.stk[R.top] := r2 |
|IL.opEQP, IL.opNEP: |
ProcAdr(GetAnyReg(), param1); |
BinOp(r1, r2); |
Emit(opCMP, r1, r2); |
IF opcode = IL.opEQP THEN |
Emit(opSEQ, r1, 0) |
ELSE |
Emit(opSNE, r1, 0) |
END; |
drop |
|IL.opSAVEP: |
UnOp(r1); |
r2 := GetAnyReg(); |
ProcAdr(r2, param2); |
str(r1, r2); |
drop; |
drop |
|IL.opPUSHP: |
ProcAdr(GetAnyReg(), param2) |
|IL.opPUSHT: |
UnOp(r1); |
Emit(opLD, r1 * 256 + GetAnyReg(), -szWord) |
|IL.opGET, IL.opGETC: |
IF opcode = IL.opGET THEN |
BinOp(r1, r2) |
ELSIF opcode = IL.opGETC THEN |
UnOp(r2); |
r1 := GetAnyReg(); |
movrc(r1, param1) |
END; |
drop; |
drop; |
CASE param2 OF |
|1: ldr8(r1, r1); str8(r2, r1) |
|2: ldr16(r1, r1); str16(r2, r1) |
|4: ldr32(r1, r1); str32(r2, r1) |
|8: ldr64(r1, r1); str64(r2, r1) |
END |
|IL.opNOT: |
UnOp(r1); |
Emit(opCMPC, r1, 0); |
Emit(opSEQ, r1, 0) |
|IL.opORD: |
UnOp(r1); |
Emit(opCMPC, r1, 0); |
Emit(opSNE, r1, 0) |
|IL.opMIN, IL.opMAX: |
BinOp(r1, r2); |
Emit(opCMP, r1, r2); |
label := IL.NewLabel(); |
IF opcode = IL.opMIN THEN |
Emit(opJLE, label, 0) |
ELSE |
Emit(opJGE, label, 0) |
END; |
Emit(opMOV, r1, r2); |
Emit(opLABEL, label, 0); |
drop |
|IL.opMINC, IL.opMAXC: |
UnOp(r1); |
Emit(opCMPC, r1, param2); |
label := IL.NewLabel(); |
IF opcode = IL.opMINC THEN |
Emit(opJLE, label, 0) |
ELSE |
Emit(opJGE, label, 0) |
END; |
Emit(opMOVC, r1, param2); |
Emit(opLABEL, label, 0) |
|IL.opIN: |
BinOp(r1, r2); |
Emit(opBIT, r1, r1); |
Emit(opAND, r1, r2); |
Emit(opCMPC, r1, 0); |
Emit(opSNE, r1, 0); |
drop |
|IL.opINL: |
UnOp(r1); |
Emit(opANDC, r1, ORD({param2})); |
Emit(opCMPC, r1, 0); |
Emit(opSNE, r1, 0) |
|IL.opINR: |
UnOp(r1); |
Emit(opBIT, r1, r1); |
Emit(opANDC, r1, param2); |
Emit(opCMPC, r1, 0); |
Emit(opSNE, r1, 0) |
|IL.opERR: |
CallRTL(IL._error, 4) |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
pushc(opcode - IL.opEQS); |
CallRTL(IL._strcmp, 5); |
GetAcc |
|IL.opEQSW .. IL.opGESW: |
PushAll(4); |
pushc(opcode - IL.opEQSW); |
CallRTL(IL._strcmpw, 5); |
GetAcc |
|IL.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(IL._move, 3) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(IL._move, 3) |
|IL.opCOPYA: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._arrcpy, 5); |
GetAcc |
|IL.opCOPYS: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._strcpy, 5) |
|IL.opROT: |
PushAll(0); |
mov(ACC, SP); |
push(ACC); |
pushc(param2); |
CallRTL(IL._rot, 2) |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(IL._length, 2); |
GetAcc |
|IL.opLENGTHW: |
PushAll(2); |
CallRTL(IL._lengthw, 2); |
GetAcc |
|IL.opSAVES: |
UnOp(r2); |
REG.PushAll_1(R); |
r1 := GetAnyReg(); |
StrAdr(r1, param2); |
push(r1); |
drop; |
push(r2); |
drop; |
pushc(param1); |
CallRTL(IL._move, 3) |
|IL.opRSET: |
PushAll(2); |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSETR: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSETL: |
UnOp(r1); |
REG.PushAll_1(R); |
pushc(param2); |
push(r1); |
drop; |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSET1: |
PushAll(1); |
CallRTL(IL._set1, 1); |
GetAcc |
|IL.opNEW: |
PushAll(1); |
INC(param2, szWord); |
ASSERT(UTILS.Align(param2, szWord)); |
pushc(param2); |
pushc(param1); |
CallRTL(IL._new, 3) |
|IL.opTYPEGP: |
UnOp(r1); |
PushAll(0); |
push(r1); |
pushc(param2); |
CallRTL(IL._guard, 2); |
GetAcc |
|IL.opIS: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._is, 2); |
GetAcc |
|IL.opISREC: |
PushAll(2); |
pushc(param2); |
CallRTL(IL._guardrec, 3); |
GetAcc |
|IL.opTYPEGR: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
GetAcc |
|IL.opTYPEGD: |
UnOp(r1); |
PushAll(0); |
subrc(r1, szWord); |
ldr(r1, r1); |
push(r1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
GetAcc |
|IL.opCASET: |
push(R1); |
push(R1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
pop(R1); |
jnz(ACC, param1) |
|IL.opCONSTF: |
IF szWord = 8 THEN |
movrc(GetAnyReg(), UTILS.splitf(cmd.float, a, b)) |
ELSE (* szWord = 4 *) |
movrc(GetAnyReg(), UTILS.d2s(cmd.float)) |
END |
|IL.opMULF: |
PushAll(2); |
CallRTL(IL._fmul, 2); |
GetAcc |
|IL.opDIVF: |
PushAll(2); |
CallRTL(IL._fdiv, 2); |
GetAcc |
|IL.opDIVFI: |
PushAll(2); |
CallRTL(IL._fdivi, 2); |
GetAcc |
|IL.opADDF: |
PushAll(2); |
CallRTL(IL._fadd, 2); |
GetAcc |
|IL.opSUBFI: |
PushAll(2); |
CallRTL(IL._fsubi, 2); |
GetAcc |
|IL.opSUBF: |
PushAll(2); |
CallRTL(IL._fsub, 2); |
GetAcc |
|IL.opEQF..IL.opGEF: |
PushAll(2); |
pushc(opcode - IL.opEQF); |
CallRTL(IL._fcmp, 3); |
GetAcc |
|IL.opFLOOR: |
PushAll(1); |
CallRTL(IL._floor, 1); |
GetAcc |
|IL.opFLT: |
PushAll(1); |
CallRTL(IL._flt, 1); |
GetAcc |
|IL.opUMINF: |
UnOp(r1); |
Emit(opRORC, r1, -1); |
Emit(opXORC, r1, 1); |
Emit(opRORC, r1, 1) |
|IL.opFABS: |
UnOp(r1); |
Emit(opLSLC, r1, 1); |
Emit(opLSRC, r1, 1) |
|IL.opINF: |
r1 := GetAnyReg(); |
Emit(opMOVC, r1, 1); |
Emit(opRORC, r1, 1); |
Emit(opASRC, r1, 7 + 3 * ORD(szWord = 8)); |
Emit(opLSRC, r1, 1) |
|IL.opPUSHF: |
UnOp(r1); |
push(r1); |
drop |
|IL.opPACK: |
PushAll(2); |
CallRTL(IL._pack, 2) |
|IL.opPACKC: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._pack, 2) |
|IL.opUNPK: |
PushAll(2); |
CallRTL(IL._unpk, 2) |
|IL.opCODE: |
OutInt(param2) |
|IL.opLADR_SAVE: |
UnOp(r1); |
Emit(opST, BP * 256 + r1, param2 * szWord); |
drop |
|IL.opLADR_INCC: |
r1 := GetAnyReg(); |
Emit(opLD, BP * 256 + r1, param1 * szWord); |
Emit(opADDC, r1, param2); |
Emit(opST, BP * 256 + r1, param1 * szWord); |
drop |
END; |
cmd := cmd.next(IL.COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1) |
END translate; |
PROCEDURE prolog; |
BEGIN |
Emit(opLEA, SP + LStack * 256, 0); |
Emit(opLEA, ACC + LTypes * 256, 0); |
push(ACC); |
Emit(opLEA, ACC + LHeap * 256, 0); |
push(ACC); |
pushc(CHL.Length(IL.codes.types)); |
CallRTL(IL._init, 3) |
END prolog; |
PROCEDURE epilog (ram, szWord: INTEGER); |
VAR |
tcount, dcount, i, offTypes, offStrings, |
szData, szGlobal, szHeapStack: INTEGER; |
BEGIN |
Emit(opSTOP, 0, 0); |
offTypes := count; |
tcount := CHL.Length(IL.codes.types); |
FOR i := 0 TO tcount - 1 DO |
OutInt(CHL.GetInt(IL.codes.types, i)) |
END; |
offStrings := count; |
dcount := CHL.Length(IL.codes.data); |
FOR i := 0 TO dcount - 1 DO |
OutByte(CHL.GetByte(IL.codes.data, i)) |
END; |
IF dcount MOD szWord # 0 THEN |
i := szWord - dcount MOD szWord; |
WHILE i > 0 DO |
OutByte(0); |
DEC(i) |
END |
END; |
szData := count - offTypes; |
szGlobal := (IL.codes.bss DIV szWord + 1) * szWord; |
szHeapStack := ram - szData - szGlobal; |
OutInt(offTypes); |
OutInt(offStrings); |
OutInt(szGlobal DIV szWord); |
OutInt(szHeapStack DIV szWord); |
FOR i := 1 TO 8 DO |
OutInt(0) |
END |
END epilog; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
CONST |
minRAM = 32*1024; |
maxRAM = 256*1024; |
VAR |
szData, szRAM: INTEGER; |
BEGIN |
szWord := TARGETS.WordSize; |
IF szWord = 8 THEN |
ldr := ldr64; |
str := str64 |
ELSE |
ldr := ldr32; |
str := str32 |
END; |
szData := (CHL.Length(IL.codes.types) + CHL.Length(IL.codes.data) DIV szWord + IL.codes.bss DIV szWord + 2) * szWord; |
szRAM := MIN(MAX(options.ram, minRAM), maxRAM) * 1024; |
IF szRAM - szData < 1024*1024 THEN |
ERRORS.Error(208) |
END; |
count := 0; |
WR.Create(outname); |
REG.Init(R, push, pop, mov, xchg, GPRs); |
prolog; |
translate(szWord); |
epilog(szRAM, szWord); |
WR.Close |
END CodeGen; |
END RVMxI. |
/programs/develop/oberon07/source/SCAN.ob07 |
---|
0,0 → 1,783 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE SCAN; |
IMPORT TXT := TEXTDRV, ARITH, S := STRINGS, ERRORS, LISTS; |
CONST |
NUMLEN = 256; |
IDLEN = 256; |
TEXTLEN = 512; |
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3; |
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7; |
lxEOF* = 8; |
lxPLUS* = 21; lxMINUS* = 22; lxMUL* = 23; lxSLASH* = 24; |
lxNOT* = 25; lxAND* = 26; lxPOINT* = 27; lxCOMMA* = 28; |
lxSEMI* = 29; lxBAR* = 30; lxLROUND* = 31; lxLSQUARE* = 32; |
lxLCURLY* = 33; lxCARET* = 34; lxEQ* = 35; lxNE* = 36; |
lxLT* = 37; lxGT* = 38; lxCOLON* = 39; lxRROUND* = 40; |
lxRSQUARE* = 41; lxRCURLY* = 42; lxLE* = 43; lxGE* = 44; |
lxASSIGN* = 45; lxRANGE* = 46; |
lxKW = 51; |
lxARRAY* = 51; lxBEGIN* = 52; lxBY* = 53; lxCASE* = 54; |
lxCONST* = 55; lxDIV* = 56; lxDO* = 57; lxELSE* = 58; |
lxELSIF* = 59; lxEND* = 60; lxFALSE* = 61; lxFOR* = 62; |
lxIF* = 63; lxIMPORT* = 64; lxIN* = 65; lxIS* = 66; |
lxMOD* = 67; lxMODULE* = 68; lxNIL* = 69; lxOF* = 70; |
lxOR* = 71; lxPOINTER* = 72; lxPROCEDURE* = 73; lxRECORD* = 74; |
lxREPEAT* = 75; lxRETURN* = 76; lxTHEN* = 77; lxTO* = 78; |
lxTRUE* = 79; lxTYPE* = 80; lxUNTIL* = 81; lxVAR* = 82; |
lxWHILE* = 83; |
lxERROR01* = -1; lxERROR02* = -2; lxERROR03* = -3; lxERROR04* = -4; |
lxERROR05* = -5; (*lxERROR06* = -6;*) lxERROR07* = -7; lxERROR08* = -8; |
lxERROR09* = -9; lxERROR10* = -10; lxERROR11* = -11; lxERROR12* = -12; |
lxERROR13* = -13; |
TYPE |
TEXTSTR* = ARRAY TEXTLEN OF CHAR; |
IDSTR* = ARRAY IDLEN OF CHAR; |
DEF = POINTER TO RECORD (LISTS.ITEM) |
ident: IDSTR |
END; |
STRING* = POINTER TO RECORD (LISTS.ITEM) |
s*: TEXTSTR; |
offset*, offsetW*, hash: INTEGER |
END; |
IDENT* = RECORD |
s*: IDSTR; |
hash*: INTEGER |
END; |
POSITION* = RECORD |
line*, col*: INTEGER |
END; |
LEX* = RECORD |
sym*: INTEGER; |
pos*: POSITION; |
ident*: IDENT; |
string*: STRING; |
value*: ARITH.VALUE; |
error*: INTEGER |
END; |
SCANNER* = TXT.TEXT; |
KEYWORD = ARRAY 10 OF CHAR; |
VAR |
delimiters: ARRAY 256 OF BOOLEAN; |
upto, LowerCase, _if: BOOLEAN; |
strings, def: LISTS.LIST; |
KW: ARRAY 33 OF RECORD upper, lower: KEYWORD; uhash, lhash: INTEGER END; |
PROCEDURE enterKW (s: KEYWORD; idx: INTEGER); |
BEGIN |
KW[idx].lower := s; |
KW[idx].upper := s; |
S.UpCase(KW[idx].upper); |
KW[idx].uhash := S.HashStr(KW[idx].upper); |
KW[idx].lhash := S.HashStr(KW[idx].lower); |
END enterKW; |
PROCEDURE checkKW (ident: IDENT): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := lxIDENT; |
i := 0; |
WHILE i < LEN(KW) DO |
IF (KW[i].uhash = ident.hash) & (KW[i].upper = ident.s) |
OR LowerCase & (KW[i].lhash = ident.hash) & (KW[i].lower = ident.s) THEN |
res := i + lxKW; |
i := LEN(KW) |
END; |
INC(i) |
END |
RETURN res |
END checkKW; |
PROCEDURE enterStr* (s: TEXTSTR): STRING; |
VAR |
str, res: STRING; |
hash: INTEGER; |
BEGIN |
hash := S.HashStr(s); |
str := strings.first(STRING); |
res := NIL; |
WHILE str # NIL DO |
IF (str.hash = hash) & (str.s = s) THEN |
res := str; |
str := NIL |
ELSE |
str := str.next(STRING) |
END |
END; |
IF res = NIL THEN |
NEW(res); |
res.s := s; |
res.offset := -1; |
res.offsetW := -1; |
res.hash := hash; |
LISTS.push(strings, res) |
END |
RETURN res |
END enterStr; |
PROCEDURE nextc (text: TXT.TEXT): CHAR; |
BEGIN |
TXT.next(text) |
RETURN text.peak |
END nextc; |
PROCEDURE setIdent* (VAR ident: IDENT; s: IDSTR); |
BEGIN |
ident.s := s; |
ident.hash := S.HashStr(s) |
END setIdent; |
PROCEDURE ident (text: TXT.TEXT; VAR lex: LEX); |
VAR |
c: CHAR; |
i: INTEGER; |
BEGIN |
c := text.peak; |
ASSERT(S.letter(c)); |
i := 0; |
WHILE (i < IDLEN - 1) & (S.letter(c) OR S.digit(c)) DO |
lex.ident.s[i] := c; |
INC(i); |
c := nextc(text) |
END; |
lex.ident.s[i] := 0X; |
lex.ident.hash := S.HashStr(lex.ident.s); |
lex.sym := checkKW(lex.ident); |
IF S.letter(c) OR S.digit(c) THEN |
ERRORS.WarningMsg(lex.pos.line, lex.pos.col, 2); |
WHILE S.letter(c) OR S.digit(c) DO |
c := nextc(text) |
END |
END |
END ident; |
PROCEDURE number (text: TXT.TEXT; VAR lex: LEX); |
TYPE |
NUMSTR = ARRAY NUMLEN OF CHAR; |
VAR |
c: CHAR; |
hex: BOOLEAN; |
error, sym, i: INTEGER; |
num: NUMSTR; |
PROCEDURE push (VAR num: NUMSTR; VAR i: INTEGER; c: CHAR); |
BEGIN |
IF i < NUMLEN - 1 THEN |
num[i] := c; |
INC(i) |
END |
END push; |
BEGIN |
c := text.peak; |
ASSERT(S.digit(c)); |
i := 0; |
error := 0; |
sym := lxINTEGER; |
hex := FALSE; |
WHILE S.digit(c) DO |
push(num, i, c); |
c := nextc(text) |
END; |
WHILE S.hexdigit(c) OR LowerCase & ("a" <= c) & (c <= "f") DO |
S.cap(c); |
push(num, i, c); |
c := nextc(text); |
hex := TRUE |
END; |
IF (c = "H") OR LowerCase & (c = "h") THEN |
push(num, i, c); |
TXT.next(text); |
sym := lxHEX |
ELSIF (c = "X") OR LowerCase & (c = "x") THEN |
push(num, i, c); |
TXT.next(text); |
sym := lxCHAR |
ELSIF c = "." THEN |
IF hex THEN |
sym := lxERROR01 |
ELSE |
c := nextc(text); |
IF c # "." THEN |
push(num, i, "."); |
sym := lxFLOAT |
ELSE |
sym := lxINTEGER; |
text.peak := 7FX; |
upto := TRUE |
END; |
WHILE S.digit(c) DO |
push(num, i, c); |
c := nextc(text) |
END; |
IF (c = "E") OR LowerCase & (c = "e") THEN |
push(num, i, c); |
c := nextc(text); |
IF (c = "+") OR (c = "-") THEN |
push(num, i, c); |
c := nextc(text) |
END; |
IF S.digit(c) THEN |
WHILE S.digit(c) DO |
push(num, i, c); |
c := nextc(text) |
END |
ELSE |
sym := lxERROR02 |
END |
END |
END |
ELSIF hex THEN |
sym := lxERROR01 |
END; |
IF (i = NUMLEN - 1) & (sym >= 0) THEN |
sym := lxERROR07 |
END; |
num[i] := 0X; |
IF sym = lxINTEGER THEN |
ARITH.iconv(num, lex.value, error) |
ELSIF (sym = lxHEX) OR (sym = lxCHAR) THEN |
ARITH.hconv(num, lex.value, error) |
ELSIF sym = lxFLOAT THEN |
ARITH.fconv(num, lex.value, error) |
END; |
CASE error OF |
|0: |
|1: sym := lxERROR08 |
|2: sym := lxERROR09 |
|3: sym := lxERROR10 |
|4: sym := lxERROR11 |
|5: sym := lxERROR12 |
END; |
lex.sym := sym |
END number; |
PROCEDURE string (text: TXT.TEXT; VAR lex: LEX; quot: CHAR); |
VAR |
c: CHAR; |
i: INTEGER; |
str: TEXTSTR; |
BEGIN |
c := nextc(text); |
i := 0; |
WHILE (i < LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO |
str[i] := c; |
c := nextc(text); |
INC(i) |
END; |
str[i] := 0X; |
IF (i = LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof THEN |
lex.sym := lxERROR05 |
END; |
IF c = quot THEN |
TXT.next(text); |
IF i # 1 THEN |
lex.sym := lxSTRING |
ELSE |
lex.sym := lxCHAR; |
ARITH.setChar(lex.value, ORD(str[0])) |
END |
ELSIF lex.sym # lxERROR05 THEN |
lex.sym := lxERROR03 |
END; |
IF lex.sym = lxSTRING THEN |
lex.string := enterStr(str); |
lex.value.typ := ARITH.tSTRING; |
lex.value.string := lex.string |
END |
END string; |
PROCEDURE comment (text: TXT.TEXT); |
VAR |
c: CHAR; |
cond, depth: INTEGER; |
BEGIN |
cond := 0; |
depth := 1; |
REPEAT |
c := text.peak; |
TXT.next(text); |
IF c = "*" THEN |
IF cond = 1 THEN |
cond := 0; |
INC(depth) |
ELSE |
cond := 2 |
END |
ELSIF c = ")" THEN |
IF cond = 2 THEN |
DEC(depth) |
END; |
cond := 0 |
ELSIF c = "(" THEN |
cond := 1 |
ELSE |
cond := 0 |
END |
UNTIL (depth = 0) OR text.eof |
END comment; |
PROCEDURE delimiter (text: TXT.TEXT; c: CHAR): INTEGER; |
VAR |
sym: INTEGER; |
c0: CHAR; |
BEGIN |
c0 := c; |
c := nextc(text); |
CASE c0 OF |
|"+": |
sym := lxPLUS |
|"-": |
sym := lxMINUS |
|"*": |
sym := lxMUL |
|"/": |
sym := lxSLASH; |
IF c = "/" THEN |
sym := lxCOMMENT; |
REPEAT |
TXT.next(text) |
UNTIL text.eol OR text.eof |
END |
|"~": |
sym := lxNOT |
|"&": |
sym := lxAND |
|".": |
sym := lxPOINT; |
IF c = "." THEN |
sym := lxRANGE; |
TXT.next(text) |
END |
|",": |
sym := lxCOMMA |
|";": |
sym := lxSEMI |
|"|": |
sym := lxBAR |
|"(": |
sym := lxLROUND; |
IF c = "*" THEN |
sym := lxCOMMENT; |
TXT.next(text); |
comment(text) |
END |
|"[": |
sym := lxLSQUARE |
|"{": |
sym := lxLCURLY |
|"^": |
sym := lxCARET |
|"=": |
sym := lxEQ |
|"#": |
sym := lxNE |
|"<": |
sym := lxLT; |
IF c = "=" THEN |
sym := lxLE; |
TXT.next(text) |
END |
|">": |
sym := lxGT; |
IF c = "=" THEN |
sym := lxGE; |
TXT.next(text) |
END |
|":": |
sym := lxCOLON; |
IF c = "=" THEN |
sym := lxASSIGN; |
TXT.next(text) |
END |
|")": |
sym := lxRROUND |
|"]": |
sym := lxRSQUARE |
|"}": |
sym := lxRCURLY |
END |
RETURN sym |
END delimiter; |
PROCEDURE Next* (text: SCANNER; VAR lex: LEX); |
VAR |
c: CHAR; |
PROCEDURE check (cond: BOOLEAN; text: SCANNER; lex: LEX; errno: INTEGER); |
BEGIN |
IF ~cond THEN |
ERRORS.ErrorMsg(text.fname, lex.pos.line, lex.pos.col, errno) |
END |
END check; |
PROCEDURE IsDef (str: ARRAY OF CHAR): BOOLEAN; |
VAR |
cur: DEF; |
BEGIN |
cur := def.first(DEF); |
WHILE (cur # NIL) & (cur.ident # str) DO |
cur := cur.next(DEF) |
END |
RETURN cur # NIL |
END IsDef; |
PROCEDURE Skip (text: SCANNER); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i <= text.ifc) & ~text._skip[i] DO |
INC(i) |
END; |
text.skip := i <= text.ifc |
END Skip; |
PROCEDURE prep_if (text: SCANNER; VAR lex: LEX); |
VAR |
skip: BOOLEAN; |
BEGIN |
INC(text.ifc); |
text._elsif[text.ifc] := lex.sym = lxELSIF; |
IF lex.sym = lxIF THEN |
INC(text.elsec); |
text._else[text.elsec] := FALSE |
END; |
_if := TRUE; |
skip := TRUE; |
text.skip := FALSE; |
Next(text, lex); |
check(lex.sym = lxLROUND, text, lex, 64); |
Next(text, lex); |
check(lex.sym = lxIDENT, text, lex, 22); |
REPEAT |
IF IsDef(lex.ident.s) THEN |
skip := FALSE |
END; |
Next(text, lex); |
IF lex.sym = lxBAR THEN |
Next(text, lex); |
check(lex.sym = lxIDENT, text, lex, 22) |
ELSE |
check(lex.sym = lxRROUND, text, lex, 33) |
END |
UNTIL lex.sym = lxRROUND; |
_if := FALSE; |
text._skip[text.ifc] := skip; |
Skip(text); |
Next(text, lex) |
END prep_if; |
PROCEDURE prep_end (text: SCANNER; VAR lex: LEX); |
BEGIN |
check(text.ifc > 0, text, lex, 118); |
IF lex.sym = lxEND THEN |
WHILE text._elsif[text.ifc] DO |
DEC(text.ifc) |
END; |
DEC(text.ifc); |
DEC(text.elsec) |
ELSIF (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN |
check(~text._else[text.elsec], text, lex, 118); |
text._skip[text.ifc] := ~text._skip[text.ifc]; |
text._else[text.elsec] := lex.sym = lxELSE |
END; |
Skip(text); |
IF lex.sym = lxELSIF THEN |
prep_if(text, lex) |
ELSE |
Next(text, lex) |
END |
END prep_end; |
BEGIN |
REPEAT |
c := text.peak; |
WHILE S.space(c) DO |
c := nextc(text) |
END; |
lex.pos.line := text.line; |
lex.pos.col := text.col; |
IF S.letter(c) THEN |
ident(text, lex) |
ELSIF S.digit(c) THEN |
number(text, lex) |
ELSIF (c = '"') OR (c = "'") THEN |
string(text, lex, c) |
ELSIF delimiters[ORD(c)] THEN |
lex.sym := delimiter(text, c) |
ELSIF c = "$" THEN |
IF S.letter(nextc(text)) THEN |
ident(text, lex); |
IF lex.sym = lxIF THEN |
IF ~_if THEN |
prep_if(text, lex) |
END |
ELSIF (lex.sym = lxEND) OR (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN |
IF ~_if THEN |
prep_end(text, lex) |
END |
ELSE |
check(FALSE, text, lex, 119) |
END |
ELSE |
check(FALSE, text, lex, 119) |
END |
ELSIF c = 0X THEN |
lex.sym := lxEOF; |
text.skip := FALSE; |
IF text.eof THEN |
INC(lex.pos.col) |
END |
ELSIF (c = 7FX) & upto THEN |
upto := FALSE; |
lex.sym := lxRANGE; |
DEC(lex.pos.col); |
TXT.next(text) |
ELSE |
TXT.next(text); |
lex.sym := lxERROR04 |
END; |
IF lex.sym < 0 THEN |
lex.error := -lex.sym |
ELSE |
lex.error := 0 |
END |
UNTIL (lex.sym # lxCOMMENT) & ~text.skip |
END Next; |
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER; |
RETURN TXT.open(name) |
END open; |
PROCEDURE close* (VAR scanner: SCANNER); |
BEGIN |
TXT.close(scanner) |
END close; |
PROCEDURE init* (lower: BOOLEAN); |
VAR |
i: INTEGER; |
delim: ARRAY 23 OF CHAR; |
BEGIN |
upto := FALSE; |
LowerCase := lower; |
FOR i := 0 TO 255 DO |
delimiters[i] := FALSE |
END; |
delim := "+-*/~&.,;|([{^=#<>:)]}"; |
FOR i := 0 TO LEN(delim) - 2 DO |
delimiters[ORD(delim[i])] := TRUE |
END; |
enterKW("array", 0); |
enterKW("begin", 1); |
enterKW("by", 2); |
enterKW("case", 3); |
enterKW("const", 4); |
enterKW("div", 5); |
enterKW("do", 6); |
enterKW("else", 7); |
enterKW("elsif", 8); |
enterKW("end", 9); |
enterKW("false", 10); |
enterKW("for", 11); |
enterKW("if", 12); |
enterKW("import", 13); |
enterKW("in", 14); |
enterKW("is", 15); |
enterKW("mod", 16); |
enterKW("module", 17); |
enterKW("nil", 18); |
enterKW("of", 19); |
enterKW("or", 20); |
enterKW("pointer", 21); |
enterKW("procedure", 22); |
enterKW("record", 23); |
enterKW("repeat", 24); |
enterKW("return", 25); |
enterKW("then", 26); |
enterKW("to", 27); |
enterKW("true", 28); |
enterKW("type", 29); |
enterKW("until", 30); |
enterKW("var", 31); |
enterKW("while", 32) |
END init; |
PROCEDURE NewDef* (str: ARRAY OF CHAR); |
VAR |
item: DEF; |
BEGIN |
NEW(item); |
COPY(str, item.ident); |
LISTS.push(def, item) |
END NewDef; |
BEGIN |
def := LISTS.create(NIL); |
strings := LISTS.create(NIL) |
END SCAN. |
/programs/develop/oberon07/source/STATEMENTS.ob07 |
---|
0,0 → 1,3406 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE STATEMENTS; |
IMPORT |
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB, RVMxI, |
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, TARGETS; |
CONST |
eCONST = PARS.eCONST; eTYPE = PARS.eTYPE; eVAR = PARS.eVAR; |
eEXPR = PARS.eEXPR; eVREC = PARS.eVREC; ePROC = PARS.ePROC; |
eVPAR = PARS.eVPAR; ePARAM = PARS.ePARAM; eSTPROC = PARS.eSTPROC; |
eSTFUNC = PARS.eSTFUNC; eSYSFUNC = PARS.eSYSFUNC; eSYSPROC = PARS.eSYSPROC; |
eIMP = PARS.eIMP; |
errASSERT = 1; errPTR = 2; errDIV = 3; errPROC = 4; |
errGUARD = 5; errIDX = 6; errCASE = 7; errCOPY = 8; |
errCHR = 9; errWCHR = 10; errBYTE = 11; |
chkIDX* = 0; chkGUARD* = 1; chkPTR* = 2; chkCHR* = 3; chkWCHR* = 4; chkBYTE* = 5; |
chkSTK* = MSP430.chkSTK; (* 6 *) |
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE, chkSTK}; |
TYPE |
isXXX = PROCEDURE (e: PARS.EXPR): BOOLEAN; |
RANGE = RECORD |
a, b: INTEGER |
END; |
CASE_LABEL = POINTER TO rCASE_LABEL; |
rCASE_LABEL = RECORD (AVL.DATA) |
range: RANGE; |
variant, self: INTEGER; |
_type: PROG._TYPE; |
prev: CASE_LABEL |
END; |
CASE_VARIANT = POINTER TO RECORD (LISTS.ITEM) |
label: INTEGER; |
cmd: IL.COMMAND; |
processed: BOOLEAN |
END; |
VAR |
Options: PROG.OPTIONS; |
begcall, endcall: IL.COMMAND; |
CaseLabels, CaseVar: C.COLLECTION; |
CaseVariants: LISTS.LIST; |
CPU: INTEGER; |
tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL: PROG._TYPE; |
PROCEDURE isExpr (e: PARS.EXPR): BOOLEAN; |
RETURN e.obj IN {eCONST, eVAR, eEXPR, eVPAR, ePARAM, eVREC} |
END isExpr; |
PROCEDURE isVar (e: PARS.EXPR): BOOLEAN; |
RETURN e.obj IN {eVAR, eVPAR, ePARAM, eVREC} |
END isVar; |
PROCEDURE isBoolean (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tBOOLEAN) |
END isBoolean; |
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tINTEGER) |
END isInteger; |
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tBYTE) |
END isByte; |
PROCEDURE isInt (e: PARS.EXPR): BOOLEAN; |
RETURN isByte(e) OR isInteger(e) |
END isInt; |
PROCEDURE isReal (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tREAL) |
END isReal; |
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tSET) |
END isSet; |
PROCEDURE isString (e: PARS.EXPR): BOOLEAN; |
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR}) |
END isString; |
PROCEDURE isStringW (e: PARS.EXPR): BOOLEAN; |
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR}) |
END isStringW; |
PROCEDURE isChar (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tCHAR) |
END isChar; |
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type = tWCHAR) |
END isCharW; |
PROCEDURE isPtr (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type.typ = PROG.tPOINTER) |
END isPtr; |
PROCEDURE isRec (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type.typ = PROG.tRECORD) |
END isRec; |
PROCEDURE isRecPtr (e: PARS.EXPR): BOOLEAN; |
RETURN isRec(e) OR isPtr(e) |
END isRecPtr; |
PROCEDURE isArr (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type.typ = PROG.tARRAY) |
END isArr; |
PROCEDURE isProc (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e._type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP}) |
END isProc; |
PROCEDURE isNil (e: PARS.EXPR): BOOLEAN; |
RETURN e._type.typ = PROG.tNIL |
END isNil; |
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN; |
RETURN isArr(e) & (e._type.base = tCHAR) |
END isCharArray; |
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN; |
RETURN isArr(e) & (e._type.base = tWCHAR) |
END isCharArrayW; |
PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN; |
RETURN isCharArray(e) OR isCharArrayW(e) |
END isCharArrayX; |
PROCEDURE getpos (parser: PARS.PARSER; VAR pos: PARS.POSITION); |
BEGIN |
pos.line := parser.lex.pos.line; |
pos.col := parser.lex.pos.col; |
pos.parser := parser |
END getpos; |
PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: PARS.POSITION); |
BEGIN |
PARS.Next(parser); |
getpos(parser, pos) |
END NextPos; |
PROCEDURE strlen (e: PARS.EXPR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
ASSERT(isString(e)); |
IF e._type = tCHAR THEN |
res := 1 |
ELSE |
res := LENGTH(e.value.string(SCAN.STRING).s) |
END |
RETURN res |
END strlen; |
PROCEDURE _length (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
i := 0; |
res := 0; |
WHILE (i < LEN(s)) & (s[i] # 0X) DO |
IF (s[i] <= CHR(127)) OR (s[i] >= CHR(192)) THEN |
INC(res) |
END; |
INC(i) |
END |
RETURN res |
END _length; |
PROCEDURE utf8strlen (e: PARS.EXPR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
ASSERT(isStringW(e)); |
IF e._type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN |
res := 1 |
ELSE |
res := _length(e.value.string(SCAN.STRING).s) |
END |
RETURN res |
END utf8strlen; |
PROCEDURE StrToWChar (s: ARRAY OF CHAR): INTEGER; |
VAR |
res: ARRAY 2 OF WCHAR; |
BEGIN |
ASSERT(STRINGS.Utf8To16(s, res) = 1) |
RETURN ORD(res[0]) |
END StrToWChar; |
PROCEDURE isStringW1 (e: PARS.EXPR): BOOLEAN; |
RETURN isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1) |
END isStringW1; |
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG._TYPE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN |
IF t = e._type THEN |
res := TRUE |
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN |
IF (e.obj = eCONST) & (t = tBYTE) THEN |
res := ARITH.range(e.value, 0, 255) |
ELSE |
res := TRUE |
END |
ELSIF |
(e.obj = eCONST) & isChar(e) & (t = tWCHAR) |
OR isStringW1(e) & (t = tWCHAR) |
OR PROG.isBaseOf(t, e._type) |
OR ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(t, e._type) |
OR isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) |
OR PROG.arrcomp(e._type, t) |
OR isString(e) & (t.typ = PROG.tARRAY) & (t.base = tCHAR) & (t.length > strlen(e)) |
OR isStringW(e) & (t.typ = PROG.tARRAY) & (t.base = tWCHAR) & (t.length > utf8strlen(e)) |
THEN |
res := TRUE |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END |
RETURN res |
END assigncomp; |
PROCEDURE String (e: PARS.EXPR): INTEGER; |
VAR |
offset: INTEGER; |
string: SCAN.STRING; |
BEGIN |
IF strlen(e) # 1 THEN |
string := e.value.string(SCAN.STRING); |
IF string.offset = -1 THEN |
string.offset := IL.putstr(string.s); |
END; |
offset := string.offset |
ELSE |
offset := IL.putstr1(ARITH.Int(e.value)) |
END |
RETURN offset |
END String; |
PROCEDURE StringW (e: PARS.EXPR): INTEGER; |
VAR |
offset: INTEGER; |
string: SCAN.STRING; |
BEGIN |
IF utf8strlen(e) # 1 THEN |
string := e.value.string(SCAN.STRING); |
IF string.offsetW = -1 THEN |
string.offsetW := IL.putstrW(string.s); |
END; |
offset := string.offsetW |
ELSE |
IF e._type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN |
offset := IL.putstrW1(ARITH.Int(e.value)) |
ELSE (* e._type.typ = PROG.tSTRING *) |
string := e.value.string(SCAN.STRING); |
IF string.offsetW = -1 THEN |
string.offsetW := IL.putstrW(string.s); |
END; |
offset := string.offsetW |
END |
END |
RETURN offset |
END StringW; |
PROCEDURE CheckRange (range, line, errno: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
label := IL.NewLabel(); |
IL.AddCmd2(IL.opCHKIDX, label, range); |
IL.OnError(line, errno); |
IL.SetLabel(label) |
END CheckRange; |
PROCEDURE Float (parser: PARS.PARSER; e: PARS.EXPR); |
VAR |
pos: PARS.POSITION; |
BEGIN |
getpos(parser, pos); |
IL.Float(ARITH.Float(e.value), pos.line, pos.col) |
END Float; |
PROCEDURE assign (parser: PARS.PARSER; e: PARS.EXPR; VarType: PROG._TYPE; line: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
label: INTEGER; |
BEGIN |
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN |
res := TRUE; |
IF PROG.arrcomp(e._type, VarType) THEN |
IF ~PROG.isOpenArray(VarType) THEN |
IL.Const(VarType.length) |
END; |
IL.AddCmd(IL.opCOPYA, VarType.base.size); |
label := IL.NewLabel(); |
IL.Jmp(IL.opJNZ, label); |
IL.OnError(line, errCOPY); |
IL.SetLabel(label) |
ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN |
IF VarType = tINTEGER THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSAVE) |
END |
ELSE |
IF e.obj = eCONST THEN |
res := ARITH.range(e.value, 0, 255); |
IF res THEN |
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value)) |
END |
ELSE |
IF chkBYTE IN Options.checking THEN |
label := IL.NewLabel(); |
IL.AddCmd2(IL.opCHKBYTE, label, 0); |
IL.OnError(line, errBYTE); |
IL.SetLabel(label) |
END; |
IL.AddCmd0(IL.opSAVE8) |
END |
END |
ELSIF isSet(e) & (VarType = tSET) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSAVE) |
END |
ELSIF isBoolean(e) & (VarType = tBOOLEAN) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSBOOLC, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSBOOL) |
END |
ELSIF isReal(e) & (VarType = tREAL) THEN |
IF e.obj = eCONST THEN |
Float(parser, e) |
END; |
IL.savef(e.obj = eCONST) |
ELSIF isChar(e) & (VarType = tCHAR) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSAVE8) |
END |
ELSIF (e.obj = eCONST) & isChar(e) & (VarType = tWCHAR) THEN |
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value)) |
ELSIF isStringW1(e) & (VarType = tWCHAR) THEN |
IL.AddCmd(IL.opSAVE16C, StrToWChar(e.value.string(SCAN.STRING).s)) |
ELSIF isCharW(e) & (VarType = tWCHAR) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSAVE16) |
END |
ELSIF PROG.isBaseOf(VarType, e._type) THEN |
IF VarType.typ = PROG.tPOINTER THEN |
IL.AddCmd0(IL.opSAVE) |
ELSE |
IL.AddCmd(IL.opCOPY, VarType.size) |
END |
ELSIF (e._type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN |
IL.AddCmd0(IL.opSAVE32) |
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(VarType, e._type) THEN |
IF e.obj = ePROC THEN |
IL.AssignProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
IL.AssignImpProc(e.ident._import) |
ELSE |
IF VarType.typ = PROG.tPROCEDURE THEN |
IL.AddCmd0(IL.opSAVE) |
ELSE |
IL.AddCmd(IL.opCOPY, VarType.size) |
END |
END |
ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN |
IL.AddCmd(IL.opSAVEC, 0) |
ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tCHAR) & (VarType.length > strlen(e))) THEN |
IL.saves(String(e), strlen(e) + 1) |
ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tWCHAR) & (VarType.length > utf8strlen(e))) THEN |
IL.saves(StringW(e), (utf8strlen(e) + 1) * 2) |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END |
RETURN res |
END assign; |
PROCEDURE LoadConst (e: PARS.EXPR); |
BEGIN |
IL.Const(ARITH.Int(e.value)) |
END LoadConst; |
PROCEDURE paramcomp (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR; p: PROG.PARAM); |
VAR |
stroffs: INTEGER; |
PROCEDURE arrcomp (e: PARS.EXPR; p: PROG.PARAM): BOOLEAN; |
VAR |
t1, t2: PROG._TYPE; |
BEGIN |
t1 := p._type; |
t2 := e._type; |
WHILE (t2.typ = PROG.tARRAY) & PROG.isOpenArray(t1) DO |
t1 := t1.base; |
t2 := t2.base |
END |
RETURN PROG.isTypeEq(t1, t2) |
END arrcomp; |
PROCEDURE ArrLen (t: PROG._TYPE; n: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
REPEAT |
res := t.length; |
t := t.base; |
DEC(n) |
UNTIL (n < 0) OR (t.typ # PROG.tARRAY); |
ASSERT(n < 0) |
RETURN res |
END ArrLen; |
PROCEDURE OpenArray (t, t2: PROG._TYPE); |
VAR |
n, d1, d2: INTEGER; |
BEGIN |
IF t.length # 0 THEN |
IL.Param1; |
n := PROG.Dim(t2) - 1; |
WHILE n >= 0 DO |
IL.Const(ArrLen(t, n)); |
IL.Param1; |
DEC(n) |
END |
ELSE |
d1 := PROG.Dim(t); |
d2 := PROG.Dim(t2); |
IF d1 # d2 THEN |
n := d2 - d1; |
WHILE d2 > d1 DO |
IL.Const(ArrLen(t, d2 - 1)); |
DEC(d2) |
END; |
d2 := PROG.Dim(t2); |
WHILE n > 0 DO |
IL.AddCmd(IL.opROT, d2); |
DEC(n) |
END |
END; |
IL.AddCmd(IL.opPARAM, PROG.Dim(t2) + 1) |
END |
END OpenArray; |
BEGIN |
IF p.vPar THEN |
PARS.check(isVar(e), pos, 93); |
IF p._type.typ = PROG.tRECORD THEN |
PARS.check(PROG.isBaseOf(p._type, e._type), pos, 66); |
IF e.obj = eVREC THEN |
IF e.ident # NIL THEN |
IL.AddCmd(IL.opVADR, e.ident.offset - 1) |
ELSE |
IL.AddCmd0(IL.opPUSHT) |
END |
ELSE |
IL.Const(e._type.num) |
END; |
IL.AddCmd(IL.opPARAM, 2) |
ELSIF PROG.isOpenArray(p._type) THEN |
PARS.check(arrcomp(e, p), pos, 66); |
OpenArray(e._type, p._type) |
ELSE |
PARS.check(PROG.isTypeEq(e._type, p._type), pos, 66); |
IL.Param1 |
END; |
PARS.check(~e.readOnly, pos, 94) |
ELSE |
PARS.check(isExpr(e) OR isProc(e), pos, 66); |
IF PROG.isOpenArray(p._type) THEN |
IF e._type.typ = PROG.tARRAY THEN |
PARS.check(arrcomp(e, p), pos, 66); |
OpenArray(e._type, p._type) |
ELSIF isString(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tCHAR) THEN |
IL.StrAdr(String(e)); |
IL.Param1; |
IL.Const(strlen(e) + 1); |
IL.Param1 |
ELSIF isStringW(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tWCHAR) THEN |
IL.StrAdr(StringW(e)); |
IL.Param1; |
IL.Const(utf8strlen(e) + 1); |
IL.Param1 |
ELSE |
PARS.error(pos, 66) |
END |
ELSE |
PARS.check(~PROG.isOpenArray(e._type), pos, 66); |
PARS.check(assigncomp(e, p._type), pos, 66); |
IF e.obj = eCONST THEN |
IF e._type = tREAL THEN |
Float(parser, e); |
IL.AddCmd0(IL.opPUSHF) |
ELSIF e._type.typ = PROG.tNIL THEN |
IL.Const(0); |
IL.Param1 |
ELSIF isStringW1(e) & (p._type = tWCHAR) THEN |
IL.Const(StrToWChar(e.value.string(SCAN.STRING).s)); |
IL.Param1 |
ELSIF (e._type.typ = PROG.tSTRING) OR |
(e._type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p._type.typ = PROG.tARRAY) & (p._type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN |
IF p._type.base = tCHAR THEN |
stroffs := String(e); |
IL.StrAdr(stroffs); |
IF (CPU = TARGETS.cpuMSP430) & (p._type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN |
ERRORS.WarningMsg(pos.line, pos.col, 0) |
END |
ELSE (* WCHAR *) |
stroffs := StringW(e); |
IL.StrAdr(stroffs) |
END; |
IL.set_dmin(stroffs + p._type.size); |
IL.Param1 |
ELSE |
LoadConst(e); |
IL.Param1 |
END |
ELSIF e.obj = ePROC THEN |
PARS.check(e.ident.global, pos, 85); |
IL.PushProc(e.ident.proc.label); |
IL.Param1 |
ELSIF e.obj = eIMP THEN |
IL.PushImpProc(e.ident._import); |
IL.Param1 |
ELSIF isExpr(e) & (e._type = tREAL) THEN |
IL.AddCmd0(IL.opPUSHF) |
ELSE |
IF (p._type = tBYTE) & (e._type = tINTEGER) & (chkBYTE IN Options.checking) THEN |
CheckRange(256, pos.line, errBYTE) |
END; |
IL.Param1 |
END |
END |
END |
END paramcomp; |
PROCEDURE PExpression (parser: PARS.PARSER; VAR e: PARS.EXPR); |
BEGIN |
parser.expression(parser, e) |
END PExpression; |
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e1, e2: PARS.EXPR; |
pos: PARS.POSITION; |
proc, |
label, |
size, |
n, i: INTEGER; |
code: ARITH.VALUE; |
wchar, |
comma: BOOLEAN; |
cmd1, |
cmd2: IL.COMMAND; |
PROCEDURE varparam (parser: PARS.PARSER; pos: PARS.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR); |
BEGIN |
parser.designator(parser, e); |
PARS.check(isVar(e), pos, 93); |
PARS.check(isfunc(e), pos, 66); |
IF readOnly THEN |
PARS.check(~e.readOnly, pos, 94) |
END |
END varparam; |
PROCEDURE shift_minmax (proc: INTEGER): CHAR; |
VAR |
res: CHAR; |
BEGIN |
CASE proc OF |
|PROG.stASR: res := "A" |
|PROG.stLSL: res := "L" |
|PROG.stROR: res := "O" |
|PROG.stLSR: res := "R" |
|PROG.stMIN: res := "m" |
|PROG.stMAX: res := "x" |
END |
RETURN res |
END shift_minmax; |
BEGIN |
ASSERT(e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC}); |
proc := e.stproc; |
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *) |
PARS.checklex(parser, SCAN.lxLROUND); |
PARS.Next(parser); |
(* END; *) |
getpos(parser, pos); |
IF e.obj IN {eSTPROC, eSYSPROC} THEN |
CASE proc OF |
|PROG.stASSERT: |
PExpression(parser, e); |
PARS.check(isBoolean(e), pos, 66); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
IL.OnError(pos.line, errASSERT) |
END |
ELSE |
label := IL.NewLabel(); |
IL.not; |
IL.AndOrOpt(label); |
IL.OnError(pos.line, errASSERT); |
IL.SetLabel(label) |
END |
|PROG.stINC, PROG.stDEC: |
IL.pushBegEnd(begcall, endcall); |
varparam(parser, pos, isInt, TRUE, e); |
IF e._type = tINTEGER THEN |
IF parser.sym = SCAN.lxCOMMA THEN |
NextPos(parser, pos); |
IL.setlast(begcall); |
PExpression(parser, e2); |
IL.setlast(endcall.prev(IL.COMMAND)); |
PARS.check(isInt(e2), pos, 66); |
IF e2.obj = eCONST THEN |
IL.AddCmd(IL.opINCC, ARITH.Int(e2.value) * (ORD(proc = PROG.stINC) * 2 - 1)) |
ELSE |
IL.AddCmd0(IL.opINC + ORD(proc = PROG.stDEC)) |
END |
ELSE |
IL.AddCmd(IL.opINCC, ORD(proc = PROG.stINC) * 2 - 1) |
END |
ELSE (* e._type = tBYTE *) |
IF parser.sym = SCAN.lxCOMMA THEN |
NextPos(parser, pos); |
IL.setlast(begcall); |
PExpression(parser, e2); |
IL.setlast(endcall.prev(IL.COMMAND)); |
PARS.check(isInt(e2), pos, 66); |
IF e2.obj = eCONST THEN |
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value)) |
ELSE |
IL.AddCmd0(IL.opINCB + ORD(proc = PROG.stDEC)) |
END |
ELSE |
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), 1) |
END |
END; |
IL.popBegEnd(begcall, endcall) |
|PROG.stINCL, PROG.stEXCL: |
IL.pushBegEnd(begcall, endcall); |
varparam(parser, pos, isSet, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
IL.setlast(begcall); |
PExpression(parser, e2); |
IL.setlast(endcall.prev(IL.COMMAND)); |
PARS.check(isInt(e2), pos, 66); |
IF e2.obj = eCONST THEN |
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 56); |
IL.AddCmd(IL.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value)) |
ELSE |
IL.AddCmd0(IL.opINCL + ORD(proc = PROG.stEXCL)) |
END; |
IL.popBegEnd(begcall, endcall) |
|PROG.stNEW: |
varparam(parser, pos, isPtr, TRUE, e); |
IF CPU = TARGETS.cpuMSP430 THEN |
PARS.check(e._type.base.size + 16 < Options.ram, pos, 63) |
END; |
IL.New(e._type.base.size, e._type.base.num) |
|PROG.stDISPOSE: |
varparam(parser, pos, isPtr, TRUE, e); |
IL.AddCmd0(IL.opDISP) |
|PROG.stPACK: |
varparam(parser, pos, isReal, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
PExpression(parser, e2); |
PARS.check(isInt(e2), pos, 66); |
IF e2.obj = eCONST THEN |
IL.AddCmd(IL.opPACKC, ARITH.Int(e2.value)) |
ELSE |
IL.AddCmd0(IL.opPACK) |
END |
|PROG.stUNPK: |
varparam(parser, pos, isReal, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
varparam(parser, pos, isInteger, TRUE, e2); |
IL.AddCmd0(IL.opUNPK) |
|PROG.stCOPY: |
IL.pushBegEnd(begcall, endcall); |
PExpression(parser, e); |
IF isString(e) OR isCharArray(e) THEN |
wchar := FALSE |
ELSIF isStringW(e) OR isCharArrayW(e) THEN |
wchar := TRUE |
ELSE |
PARS.error(pos, 66) |
END; |
IF isCharArrayX(e) & ~PROG.isOpenArray(e._type) THEN |
IL.Const(e._type.length) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
IL.setlast(begcall); |
IF wchar THEN |
varparam(parser, pos, isCharArrayW, TRUE, e1) |
ELSE |
IF e.obj = eCONST THEN |
varparam(parser, pos, isCharArrayX, TRUE, e1) |
ELSE |
varparam(parser, pos, isCharArray, TRUE, e1) |
END; |
wchar := e1._type.base = tWCHAR |
END; |
IF ~PROG.isOpenArray(e1._type) THEN |
IL.Const(e1._type.length) |
END; |
IL.setlast(endcall.prev(IL.COMMAND)); |
IF e.obj = eCONST THEN |
IF wchar THEN |
IL.StrAdr(StringW(e)); |
IL.Const(utf8strlen(e) + 1) |
ELSE |
IL.StrAdr(String(e)); |
IL.Const(strlen(e) + 1) |
END |
END; |
IL.AddCmd(IL.opCOPYS, e1._type.base.size); |
IL.popBegEnd(begcall, endcall) |
|PROG.sysGET, PROG.sysGET8, PROG.sysGET16, PROG.sysGET32: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
parser.designator(parser, e2); |
PARS.check(isVar(e2), pos, 93); |
IF proc = PROG.sysGET THEN |
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66) |
ELSE |
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66) |
END; |
CASE proc OF |
|PROG.sysGET: size := e2._type.size |
|PROG.sysGET8: size := 1 |
|PROG.sysGET16: size := 2 |
|PROG.sysGET32: size := 4 |
END; |
PARS.check(size <= e2._type.size, pos, 66); |
IF e.obj = eCONST THEN |
IL.AddCmd2(IL.opGETC, ARITH.Int(e.value), size) |
ELSE |
IL.AddCmd(IL.opGET, size) |
END |
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32: |
IL.pushBegEnd(begcall, endcall); |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
IL.setlast(begcall); |
PExpression(parser, e2); |
PARS.check(isExpr(e2), pos, 66); |
IF proc = PROG.sysPUT THEN |
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66); |
IF e2.obj = eCONST THEN |
IF e2._type = tREAL THEN |
Float(parser, e2); |
IL.setlast(endcall.prev(IL.COMMAND)); |
IL.savef(FALSE) |
ELSE |
LoadConst(e2); |
IL.setlast(endcall.prev(IL.COMMAND)); |
IL.SysPut(e2._type.size) |
END |
ELSE |
IL.setlast(endcall.prev(IL.COMMAND)); |
IF e2._type = tREAL THEN |
IL.savef(FALSE) |
ELSIF e2._type = tBYTE THEN |
IL.SysPut(tINTEGER.size) |
ELSE |
IL.SysPut(e2._type.size) |
END |
END |
ELSIF (proc = PROG.sysPUT8) OR (proc = PROG.sysPUT16) OR (proc = PROG.sysPUT32) THEN |
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66); |
IF e2.obj = eCONST THEN |
LoadConst(e2) |
END; |
IL.setlast(endcall.prev(IL.COMMAND)); |
CASE proc OF |
|PROG.sysPUT8: size := 1 |
|PROG.sysPUT16: size := 2 |
|PROG.sysPUT32: size := 4 |
END; |
IL.SysPut(size) |
END; |
IL.popBegEnd(begcall, endcall) |
|PROG.sysMOVE: |
FOR i := 1 TO 2 DO |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos) |
END; |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
IL.AddCmd0(IL.opMOVE) |
|PROG.sysCOPY: |
FOR i := 1 TO 2 DO |
parser.designator(parser, e); |
PARS.check(isVar(e), pos, 93); |
n := PROG.Dim(e._type); |
WHILE n > 0 DO |
IL.drop; |
DEC(n) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos) |
END; |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
IL.AddCmd0(IL.opMOVE) |
|PROG.sysCODE: |
REPEAT |
getpos(parser, pos); |
PARS.ConstExpression(parser, code); |
PARS.check(code.typ = ARITH.tINTEGER, pos, 43); |
IF TARGETS.WordSize > TARGETS.InstrSize THEN |
CASE TARGETS.InstrSize OF |
|1: PARS.check(ARITH.range(code, 0, 255), pos, 42) |
|2: PARS.check(ARITH.range(code, 0, 65535), pos, 110) |
END |
END; |
IL.AddCmd(IL.opCODE, ARITH.getInt(code)); |
comma := parser.sym = SCAN.lxCOMMA; |
IF comma THEN |
PARS.Next(parser) |
ELSE |
PARS.checklex(parser, SCAN.lxRROUND) |
END |
UNTIL (parser.sym = SCAN.lxRROUND) & ~comma |
(* |
|PROG.sysNOP, PROG.sysDINT, PROG.sysEINT: |
IF parser.sym = SCAN.lxLROUND THEN |
PARS.Next(parser); |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser) |
END; |
ASSERT(CPU = cpuMSP430); |
CASE proc OF |
|PROG.sysNOP: IL.AddCmd(IL.opCODE, 4303H) |
|PROG.sysDINT: IL.AddCmd(IL.opCODE, 0C232H); IL.AddCmd(IL.opCODE, 4303H) |
|PROG.sysEINT: IL.AddCmd(IL.opCODE, 0D232H) |
END |
*) |
END; |
e.obj := eEXPR; |
e._type := NIL |
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN |
CASE e.stproc OF |
|PROG.stABS: |
PExpression(parser, e); |
PARS.check(isInt(e) OR isReal(e), pos, 66); |
IF e.obj = eCONST THEN |
PARS.check(ARITH.abs(e.value), pos, 39) |
ELSE |
IL.abs(isReal(e)) |
END |
|PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
PExpression(parser, e2); |
PARS.check(isInt(e2), pos, 66); |
e._type := tINTEGER; |
IF (e.obj = eCONST) & (e2.obj = eCONST) THEN |
ASSERT(ARITH.opInt(e.value, e2.value, shift_minmax(proc))) |
ELSE |
IF e.obj = eCONST THEN |
IL.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value)) |
ELSIF e2.obj = eCONST THEN |
IL.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value)) |
ELSE |
IL.shift_minmax(shift_minmax(proc)) |
END; |
e.obj := eEXPR |
END |
|PROG.stCHR: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
e._type := tCHAR; |
IF e.obj = eCONST THEN |
ARITH.setChar(e.value, ARITH.getInt(e.value)); |
PARS.check(ARITH.check(e.value), pos, 107) |
ELSE |
IF chkCHR IN Options.checking THEN |
CheckRange(256, pos.line, errCHR) |
ELSE |
IL.AddCmd0(IL.opCHR) |
END |
END |
|PROG.stWCHR: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
e._type := tWCHAR; |
IF e.obj = eCONST THEN |
ARITH.setWChar(e.value, ARITH.getInt(e.value)); |
PARS.check(ARITH.check(e.value), pos, 101) |
ELSE |
IF chkWCHR IN Options.checking THEN |
CheckRange(65536, pos.line, errWCHR) |
ELSE |
IL.AddCmd0(IL.opWCHR) |
END |
END |
|PROG.stFLOOR: |
PExpression(parser, e); |
PARS.check(isReal(e), pos, 66); |
e._type := tINTEGER; |
IF e.obj = eCONST THEN |
PARS.check(ARITH.floor(e.value), pos, 39) |
ELSE |
IL.AddCmd0(IL.opFLOOR) |
END |
|PROG.stFLT: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
e._type := tREAL; |
IF e.obj = eCONST THEN |
ARITH.flt(e.value) |
ELSE |
IL.AddCmd2(IL.opFLT, pos.line, pos.col) |
END |
|PROG.stLEN: |
cmd1 := IL.getlast(); |
varparam(parser, pos, isArr, FALSE, e); |
IF e._type.length > 0 THEN |
cmd2 := IL.getlast(); |
IL.delete2(cmd1.next, cmd2); |
IL.setlast(cmd1); |
ASSERT(ARITH.setInt(e.value, e._type.length)); |
e.obj := eCONST |
ELSE |
IL.len(PROG.Dim(e._type)) |
END; |
e._type := tINTEGER |
|PROG.stLENGTH: |
PExpression(parser, e); |
IF isCharArray(e) THEN |
IF e._type.length > 0 THEN |
IL.Const(e._type.length) |
END; |
IL.AddCmd0(IL.opLENGTH) |
ELSIF isCharArrayW(e) THEN |
IF e._type.length > 0 THEN |
IL.Const(e._type.length) |
END; |
IL.AddCmd0(IL.opLENGTHW) |
ELSE |
PARS.error(pos, 66); |
END; |
e._type := tINTEGER |
|PROG.stODD: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
e._type := tBOOLEAN; |
IF e.obj = eCONST THEN |
ARITH.odd(e.value) |
ELSE |
IL.AddCmd(IL.opMODR, 2) |
END |
|PROG.stORD: |
IL.AddCmd(IL.opPRECALL, 0); |
PExpression(parser, e); |
PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), pos, 66); |
IF e.obj = eCONST THEN |
IF isStringW1(e) THEN |
ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.STRING).s))) |
ELSE |
ARITH.ord(e.value) |
END |
ELSE |
IF isBoolean(e) THEN |
IL._ord |
END |
END; |
e._type := tINTEGER |
|PROG.stBITS: |
PExpression(parser, e); |
PARS.check(isInt(e), pos, 66); |
IF e.obj = eCONST THEN |
ARITH.bits(e.value) |
END; |
e._type := tSET |
|PROG.sysADR: |
parser.designator(parser, e); |
IF isVar(e) THEN |
n := PROG.Dim(e._type); |
WHILE n > 0 DO |
IL.drop; |
DEC(n) |
END |
ELSIF e.obj = ePROC THEN |
IL.PushProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
IL.PushImpProc(e.ident._import) |
ELSE |
PARS.error(pos, 108) |
END; |
e._type := tINTEGER |
|PROG.sysSADR: |
PExpression(parser, e); |
PARS.check(isString(e), pos, 66); |
IL.StrAdr(String(e)); |
e._type := tINTEGER; |
e.obj := eEXPR |
|PROG.sysWSADR: |
PExpression(parser, e); |
PARS.check(isStringW(e), pos, 66); |
IL.StrAdr(StringW(e)); |
e._type := tINTEGER; |
e.obj := eEXPR |
|PROG.sysTYPEID: |
PExpression(parser, e); |
PARS.check(e.obj = eTYPE, pos, 68); |
IF e._type.typ = PROG.tRECORD THEN |
ASSERT(ARITH.setInt(e.value, e._type.num)) |
ELSIF e._type.typ = PROG.tPOINTER THEN |
ASSERT(ARITH.setInt(e.value, e._type.base.num)) |
ELSE |
PARS.error(pos, 52) |
END; |
e.obj := eCONST; |
e._type := tINTEGER |
|PROG.sysINF: |
IL.AddCmd2(IL.opINF, pos.line, pos.col); |
e.obj := eEXPR; |
e._type := tREAL |
|PROG.sysSIZE: |
PExpression(parser, e); |
PARS.check(e.obj = eTYPE, pos, 68); |
ASSERT(ARITH.setInt(e.value, e._type.size)); |
e.obj := eCONST; |
e._type := tINTEGER |
END |
END; |
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *) |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
(* END; *) |
IF e.obj # eCONST THEN |
e.obj := eEXPR |
END |
END stProc; |
PROCEDURE ActualParameters (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
proc: PROG._TYPE; |
param: LISTS.ITEM; |
e1: PARS.EXPR; |
pos: PARS.POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxLROUND); |
IF (e.obj IN {ePROC, eIMP}) OR isExpr(e) THEN |
proc := e._type; |
PARS.check1(proc.typ = PROG.tPROCEDURE, parser, 86); |
PARS.Next(parser); |
param := proc.params.first; |
WHILE param # NIL DO |
getpos(parser, pos); |
IL.setlast(begcall); |
IF param(PROG.PARAM).vPar THEN |
parser.designator(parser, e1) |
ELSE |
PExpression(parser, e1) |
END; |
paramcomp(parser, pos, e1, param(PROG.PARAM)); |
param := param.next; |
IF param # NIL THEN |
PARS.checklex(parser, SCAN.lxCOMMA); |
PARS.Next(parser) |
END |
END; |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
e.obj := eEXPR; |
e._type := proc.base |
ELSIF e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC} THEN |
stProc(parser, e) |
ELSE |
PARS.check1(FALSE, parser, 86) |
END |
END ActualParameters; |
PROCEDURE qualident (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
ident: PROG.IDENT; |
imp: BOOLEAN; |
pos: PARS.POSITION; |
BEGIN |
PARS.checklex(parser, SCAN.lxIDENT); |
getpos(parser, pos); |
imp := FALSE; |
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE); |
PARS.check1(ident # NIL, parser, 48); |
IF ident.typ = PROG.idMODULE THEN |
PARS.ExpectSym(parser, SCAN.lxPOINT); |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
ident := PROG.getIdent(ident.unit, parser.lex.ident, FALSE); |
PARS.check1((ident # NIL) & ident.export, parser, 48); |
imp := TRUE |
END; |
PARS.Next(parser); |
e.readOnly := FALSE; |
e.ident := ident; |
CASE ident.typ OF |
|PROG.idCONST: |
e.obj := eCONST; |
e._type := ident._type; |
e.value := ident.value |
|PROG.idTYPE: |
e.obj := eTYPE; |
e._type := ident._type |
|PROG.idVAR: |
e.obj := eVAR; |
e._type := ident._type; |
e.readOnly := imp |
|PROG.idPROC: |
e.obj := ePROC; |
e._type := ident._type |
|PROG.idIMP: |
e.obj := eIMP; |
e._type := ident._type |
|PROG.idVPAR: |
e._type := ident._type; |
IF e._type.typ = PROG.tRECORD THEN |
e.obj := eVREC |
ELSE |
e.obj := eVPAR |
END |
|PROG.idPARAM: |
e.obj := ePARAM; |
e._type := ident._type; |
e.readOnly := (e._type.typ IN {PROG.tRECORD, PROG.tARRAY}) |
|PROG.idSTPROC: |
e.obj := eSTPROC; |
e._type := ident._type; |
e.stproc := ident.stproc |
|PROG.idSTFUNC: |
e.obj := eSTFUNC; |
e._type := ident._type; |
e.stproc := ident.stproc |
|PROG.idSYSPROC: |
e.obj := eSYSPROC; |
e._type := ident._type; |
e.stproc := ident.stproc |
|PROG.idSYSFUNC: |
PARS.check(~parser.constexp, pos, 109); |
e.obj := eSYSFUNC; |
e._type := ident._type; |
e.stproc := ident.stproc |
|PROG.idNONE: |
PARS.error(pos, 115) |
END; |
IF isVar(e) THEN |
PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), pos, 105) |
END |
END qualident; |
PROCEDURE deref (pos: PARS.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
IF load THEN |
IL.load(e._type.size) |
END; |
IF chkPTR IN Options.checking THEN |
label := IL.NewLabel(); |
IL.Jmp(IL.opJNZ1, label); |
IL.OnError(pos.line, error); |
IL.SetLabel(label) |
END |
END deref; |
PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
field: PROG.FIELD; |
pos: PARS.POSITION; |
t, idx: PARS.EXPR; |
PROCEDURE LoadAdr (e: PARS.EXPR); |
VAR |
offset: INTEGER; |
PROCEDURE OpenArray (e: PARS.EXPR); |
VAR |
offset, n: INTEGER; |
BEGIN |
offset := e.ident.offset; |
n := PROG.Dim(e._type); |
WHILE n >= 0 DO |
IL.AddCmd(IL.opVADR, offset); |
DEC(offset); |
DEC(n) |
END |
END OpenArray; |
BEGIN |
IF e.obj = eVAR THEN |
offset := PROG.getOffset(e.ident); |
IF e.ident.global THEN |
IL.AddCmd(IL.opGADR, offset) |
ELSE |
IL.AddCmd(IL.opLADR, -offset) |
END |
ELSIF e.obj = ePARAM THEN |
IF (e._type.typ = PROG.tRECORD) OR ((e._type.typ = PROG.tARRAY) & (e._type.length > 0)) THEN |
IL.AddCmd(IL.opVADR, e.ident.offset) |
ELSIF PROG.isOpenArray(e._type) THEN |
OpenArray(e) |
ELSE |
IL.AddCmd(IL.opLADR, e.ident.offset) |
END |
ELSIF e.obj IN {eVPAR, eVREC} THEN |
IF PROG.isOpenArray(e._type) THEN |
OpenArray(e) |
ELSE |
IL.AddCmd(IL.opVADR, e.ident.offset) |
END |
END |
END LoadAdr; |
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR); |
VAR |
label, offset, n, k: INTEGER; |
_type: PROG._TYPE; |
BEGIN |
IF chkIDX IN Options.checking THEN |
label := IL.NewLabel(); |
IL.AddCmd2(IL.opCHKIDX2, label, 0); |
IL.OnError(pos.line, errIDX); |
IL.SetLabel(label) |
ELSE |
IL.AddCmd(IL.opCHKIDX2, -1) |
END; |
_type := PROG.OpenBase(e._type); |
IF _type.size # 1 THEN |
IL.AddCmd(IL.opMULC, _type.size) |
END; |
n := PROG.Dim(e._type) - 1; |
k := n; |
WHILE n > 0 DO |
IL.AddCmd0(IL.opMUL); |
DEC(n) |
END; |
IL.AddCmd0(IL.opADD); |
offset := e.ident.offset - 1; |
n := k; |
WHILE n > 0 DO |
IL.AddCmd(IL.opVADR, offset); |
DEC(offset); |
DEC(n) |
END |
END OpenIdx; |
BEGIN |
qualident(parser, e); |
IF e.obj IN {ePROC, eIMP} THEN |
PROG.UseProc(parser.unit, e.ident.proc) |
END; |
IF isVar(e) THEN |
LoadAdr(e) |
END; |
WHILE parser.sym = SCAN.lxPOINT DO |
getpos(parser, pos); |
PARS.check1(isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73); |
IF e._type.typ = PROG.tPOINTER THEN |
deref(pos, e, TRUE, errPTR) |
END; |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
IF e._type.typ = PROG.tPOINTER THEN |
e._type := e._type.base; |
e.readOnly := FALSE |
END; |
field := PROG.getField(e._type, parser.lex.ident, parser.unit); |
PARS.check1(field # NIL, parser, 74); |
e._type := field._type; |
IF e.obj = eVREC THEN |
e.obj := eVPAR |
END; |
IF field.offset # 0 THEN |
IL.AddCmd(IL.opADDC, field.offset) |
END; |
PARS.Next(parser); |
e.ident := NIL |
ELSIF parser.sym = SCAN.lxLSQUARE DO |
REPEAT |
PARS.check1(isArr(e), parser, 75); |
NextPos(parser, pos); |
PExpression(parser, idx); |
PARS.check(isInt(idx), pos, 76); |
IF idx.obj = eCONST THEN |
IF e._type.length > 0 THEN |
PARS.check(ARITH.range(idx.value, 0, e._type.length - 1), pos, 83); |
IF ARITH.Int(idx.value) > 0 THEN |
IL.AddCmd(IL.opADDC, ARITH.Int(idx.value) * e._type.base.size) |
END |
ELSE |
PARS.check(ARITH.range(idx.value, 0, UTILS.target.maxInt), pos, 83); |
LoadConst(idx); |
OpenIdx(parser, pos, e) |
END |
ELSE |
IF e._type.length > 0 THEN |
IF chkIDX IN Options.checking THEN |
CheckRange(e._type.length, pos.line, errIDX) |
END; |
IF e._type.base.size # 1 THEN |
IL.AddCmd(IL.opMULC, e._type.base.size) |
END; |
IL.AddCmd0(IL.opADD) |
ELSE |
OpenIdx(parser, pos, e) |
END |
END; |
e._type := e._type.base |
UNTIL parser.sym # SCAN.lxCOMMA; |
PARS.checklex(parser, SCAN.lxRSQUARE); |
PARS.Next(parser); |
IF ~(isArr(e) & (e._type.length = 0) & (parser.sym = SCAN.lxLSQUARE)) THEN |
e.ident := NIL |
END |
ELSIF parser.sym = SCAN.lxCARET DO |
getpos(parser, pos); |
PARS.check1(isPtr(e), parser, 77); |
deref(pos, e, TRUE, errPTR); |
e._type := e._type.base; |
e.readOnly := FALSE; |
PARS.Next(parser); |
e.ident := NIL; |
e.obj := eVREC |
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO |
IF e._type.typ = PROG.tRECORD THEN |
PARS.check1(e.obj = eVREC, parser, 78) |
END; |
NextPos(parser, pos); |
qualident(parser, t); |
PARS.check(t.obj = eTYPE, pos, 79); |
IF e._type.typ = PROG.tRECORD THEN |
PARS.check(t._type.typ = PROG.tRECORD, pos, 80); |
IF chkGUARD IN Options.checking THEN |
IF e.ident = NIL THEN |
IL.TypeGuard(IL.opTYPEGD, t._type.num, pos.line, errGUARD) |
ELSE |
IL.AddCmd(IL.opVADR, e.ident.offset - 1); |
IL.TypeGuard(IL.opTYPEGR, t._type.num, pos.line, errGUARD) |
END |
END; |
ELSE |
PARS.check(t._type.typ = PROG.tPOINTER, pos, 81); |
IF chkGUARD IN Options.checking THEN |
IL.TypeGuard(IL.opTYPEGP, t._type.base.num, pos.line, errGUARD) |
END |
END; |
PARS.check(PROG.isBaseOf(e._type, t._type), pos, 82); |
e._type := t._type; |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser) |
END |
END designator; |
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG._TYPE; isfloat: BOOLEAN; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN); |
VAR |
cconv, |
parSize, |
callconv, |
fparSize, |
int, flt, |
stk_par: INTEGER; |
BEGIN |
cconv := procType.call; |
parSize := procType.parSize; |
IF cconv IN {PROG._win64, PROG.win64} THEN |
callconv := IL.call_win64; |
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, 3, int, flt)), 5) + MIN(parSize, 4) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
callconv := IL.call_sysv; |
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + parSize; |
stk_par := MAX(0, int - 6) + MAX(0, flt - 8) |
ELSE |
callconv := IL.call_stack; |
fparSize := 0 |
END; |
IL.setlast(begcall); |
IL.AddCmd(IL.opPRECALL, ORD(isfloat)); |
IF cconv IN {PROG._ccall, PROG.ccall} THEN |
IL.AddCmd(IL.opALIGN16, parSize) |
ELSIF cconv IN {PROG._win64, PROG.win64} THEN |
IL.AddCmd(IL.opWIN64ALIGN16, parSize) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
IL.AddCmd(IL.opSYSVALIGN16, parSize + stk_par) |
END; |
IL.setlast(endcall.prev(IL.COMMAND)); |
IF e.obj = eIMP THEN |
IL.CallImp(e.ident._import, callconv, fparSize) |
ELSIF e.obj = ePROC THEN |
IL.Call(e.ident.proc.label, callconv, fparSize) |
ELSIF isExpr(e) THEN |
deref(pos, e, CallStat, errPROC); |
IL.CallP(callconv, fparSize) |
END; |
IF cconv IN {PROG._ccall, PROG.ccall} THEN |
IL.AddCmd(IL.opCLEANUP, parSize); |
IL.AddCmd0(IL.opPOPSP) |
ELSIF cconv IN {PROG._win64, PROG.win64} THEN |
IL.AddCmd(IL.opCLEANUP, MAX(parSize + parSize MOD 2, 4) + 1); |
IL.AddCmd0(IL.opPOPSP) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
IL.AddCmd(IL.opCLEANUP, parSize + stk_par); |
IL.AddCmd0(IL.opPOPSP) |
ELSIF cconv IN {PROG._cdecl, PROG.cdecl, PROG.default16, PROG.code, PROG._code} THEN |
IL.AddCmd(IL.opCLEANUP, parSize) |
END; |
IF CallStat THEN |
IL.AddCmd0(IL.opRES); |
IL.drop |
ELSE |
IF isfloat THEN |
IL.AddCmd2(IL.opRESF, pos.line, pos.col) |
ELSE |
IL.AddCmd0(IL.opRES) |
END |
END |
END ProcCall; |
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos, pos0, pos1: PARS.POSITION; |
e1: PARS.EXPR; |
op, cmp, error: INTEGER; |
constant, eq: BOOLEAN; |
PROCEDURE relation (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxEQ) OR (sym = SCAN.lxNE) OR |
(sym = SCAN.lxLT) OR (sym = SCAN.lxLE) OR |
(sym = SCAN.lxGT) OR (sym = SCAN.lxGE) OR |
(sym = SCAN.lxIN) OR (sym = SCAN.lxIS) |
END relation; |
PROCEDURE AddOperator (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxPLUS) OR (sym = SCAN.lxMINUS) OR |
(sym = SCAN.lxOR) |
END AddOperator; |
PROCEDURE MulOperator (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxMUL) OR (sym = SCAN.lxSLASH) OR |
(sym = SCAN.lxDIV) OR (sym = SCAN.lxMOD) OR |
(sym = SCAN.lxAND) |
END MulOperator; |
PROCEDURE element (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e1, e2: PARS.EXPR; |
pos: PARS.POSITION; |
range: BOOLEAN; |
BEGIN |
range := FALSE; |
getpos(parser, pos); |
expression(parser, e1); |
PARS.check(isInt(e1), pos, 76); |
IF e1.obj = eCONST THEN |
PARS.check(ARITH.range(e1.value, 0, UTILS.target.maxSet), pos, 44) |
END; |
range := parser.sym = SCAN.lxRANGE; |
IF range THEN |
NextPos(parser, pos); |
expression(parser, e2); |
PARS.check(isInt(e2), pos, 76); |
IF e2.obj = eCONST THEN |
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 44) |
END |
ELSE |
IF e1.obj = eCONST THEN |
e2 := e1 |
END |
END; |
e._type := tSET; |
IF (e1.obj = eCONST) & (e2.obj = eCONST) THEN |
ARITH.constrSet(e.value, e1.value, e2.value); |
e.obj := eCONST |
ELSE |
IF range THEN |
IF e1.obj = eCONST THEN |
IL.AddCmd(IL.opRSETL, ARITH.Int(e1.value)) |
ELSIF e2.obj = eCONST THEN |
IL.AddCmd(IL.opRSETR, ARITH.Int(e2.value)) |
ELSE |
IL.AddCmd0(IL.opRSET) |
END |
ELSE |
IL.AddCmd0(IL.opRSET1) |
END; |
e.obj := eEXPR |
END |
END element; |
PROCEDURE set (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e1: PARS.EXPR; |
BEGIN |
ASSERT(parser.sym = SCAN.lxLCURLY); |
e.obj := eCONST; |
e._type := tSET; |
ARITH.emptySet(e.value); |
PARS.Next(parser); |
IF parser.sym # SCAN.lxRCURLY THEN |
element(parser, e1); |
IF e1.obj = eCONST THEN |
ARITH.opSet(e.value, e1.value, "+") |
ELSE |
e.obj := eEXPR |
END; |
WHILE parser.sym = SCAN.lxCOMMA DO |
PARS.Next(parser); |
element(parser, e1); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
ARITH.opSet(e.value, e1.value, "+") |
ELSE |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opADDSC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opADDSC, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opADDS) |
END; |
e.obj := eEXPR |
END |
END; |
PARS.checklex(parser, SCAN.lxRCURLY) |
END; |
PARS.Next(parser); |
END set; |
PROCEDURE factor (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
sym: INTEGER; |
pos: PARS.POSITION; |
e1: PARS.EXPR; |
isfloat: BOOLEAN; |
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: PARS.POSITION); |
BEGIN |
IF ~(e._type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN |
IF e._type = tREAL THEN |
IL.AddCmd2(IL.opLOADF, pos.line, pos.col) |
ELSE |
IL.load(e._type.size) |
END |
END |
END LoadVar; |
BEGIN |
sym := parser.sym; |
IF (sym = SCAN.lxINTEGER) OR (sym = SCAN.lxHEX) OR (sym = SCAN.lxFLOAT) OR (sym = SCAN.lxCHAR) OR (sym = SCAN.lxSTRING) THEN |
e.obj := eCONST; |
e.value := parser.lex.value; |
e._type := PROG.getType(e.value.typ); |
PARS.Next(parser) |
ELSIF sym = SCAN.lxNIL THEN |
e.obj := eCONST; |
e._type := PROG.program.stTypes.tNIL; |
PARS.Next(parser) |
ELSIF (sym = SCAN.lxTRUE) OR (sym = SCAN.lxFALSE) THEN |
e.obj := eCONST; |
ARITH.setbool(e.value, sym = SCAN.lxTRUE); |
e._type := tBOOLEAN; |
PARS.Next(parser) |
ELSIF sym = SCAN.lxLCURLY THEN |
set(parser, e) |
ELSIF sym = SCAN.lxIDENT THEN |
getpos(parser, pos); |
IL.pushBegEnd(begcall, endcall); |
designator(parser, e); |
IF isVar(e) THEN |
LoadVar(e, parser, pos) |
END; |
IF parser.sym = SCAN.lxLROUND THEN |
e1 := e; |
ActualParameters(parser, e); |
PARS.check(e._type # NIL, pos, 59); |
isfloat := e._type = tREAL; |
IF e1.obj IN {ePROC, eIMP} THEN |
ProcCall(e1, e1.ident._type, isfloat, parser, pos, FALSE) |
ELSIF isExpr(e1) THEN |
ProcCall(e1, e1._type, isfloat, parser, pos, FALSE) |
END |
END; |
IL.popBegEnd(begcall, endcall) |
ELSIF sym = SCAN.lxLROUND THEN |
PARS.Next(parser); |
expression(parser, e); |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
IF isExpr(e) & (e.obj # eCONST) THEN |
e.obj := eEXPR |
END |
ELSIF sym = SCAN.lxNOT THEN |
NextPos(parser, pos); |
factor(parser, e); |
PARS.check(isBoolean(e), pos, 72); |
IF e.obj # eCONST THEN |
IL.not; |
e.obj := eEXPR |
ELSE |
ASSERT(ARITH.neg(e.value)) |
END |
ELSE |
PARS.check1(FALSE, parser, 34) |
END |
END factor; |
PROCEDURE term (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos: PARS.POSITION; |
e1: PARS.EXPR; |
op, label, label1: INTEGER; |
BEGIN |
factor(parser, e); |
label := -1; |
WHILE MulOperator(parser.sym) DO |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
IF op = SCAN.lxAND THEN |
IF ~parser.constexp THEN |
IF label = -1 THEN |
label := IL.NewLabel() |
END; |
IF (e.obj = eCONST) & isBoolean(e) THEN |
IL.Const(ORD(ARITH.getBool(e.value))) |
END; |
IL.Jmp(IL.opJZ, label) |
END |
END; |
factor(parser, e1); |
CASE op OF |
|SCAN.lxMUL: |
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, "*"), pos, 39) |
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), pos, 40) |
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "*") |
END |
ELSE |
IF isInt(e) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opMULC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opMULC, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opMUL) |
END |
ELSIF isReal(e) THEN |
IF e.obj = eCONST THEN |
Float(parser, e) |
ELSIF e1.obj = eCONST THEN |
Float(parser, e1) |
END; |
IL.AddCmd0(IL.opMULF) |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opMULSC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opMULSC, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opMULS) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxSLASH: |
PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37); |
IF (e1.obj = eCONST) & isReal(e1) THEN |
PARS.check(~ARITH.isZero(e1.value), pos, 45) |
END; |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "/"), pos, 40) |
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "/") |
END |
ELSE |
IF isReal(e) THEN |
IF e.obj = eCONST THEN |
Float(parser, e); |
IL.AddCmd0(IL.opDIVFI) |
ELSIF e1.obj = eCONST THEN |
Float(parser, e1); |
IL.AddCmd0(IL.opDIVF) |
ELSE |
IL.AddCmd0(IL.opDIVF) |
END |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opDIVSC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opDIVSC, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opDIVS) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxDIV, SCAN.lxMOD: |
PARS.check(isInt(e) & isInt(e1), pos, 37); |
IF e1.obj = eCONST THEN |
PARS.check(ARITH.Int(e1.value) > 0, pos, 122) |
END; |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
IF op = SCAN.lxDIV THEN |
PARS.check(ARITH.opInt(e.value, e1.value, "D"), pos, 39) |
ELSE |
ASSERT(ARITH.opInt(e.value, e1.value, "M")) |
END |
ELSE |
IF e1.obj # eCONST THEN |
label1 := IL.NewLabel(); |
IL.Jmp(IL.opJG, label1) |
END; |
IF e.obj = eCONST THEN |
IL.OnError(pos.line, errDIV); |
IL.SetLabel(label1); |
IL.AddCmd(IL.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value)) |
ELSE |
IL.OnError(pos.line, errDIV); |
IL.SetLabel(label1); |
IL.AddCmd0(IL.opDIV + ORD(op = SCAN.lxMOD)) |
END; |
e.obj := eEXPR |
END |
|SCAN.lxAND: |
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN |
ARITH.opBoolean(e.value, e1.value, "&") |
ELSE |
e.obj := eEXPR; |
IF e1.obj = eCONST THEN |
IL.Const(ORD(ARITH.getBool(e1.value))) |
END |
END |
END |
END; |
IF label # -1 THEN |
label1 := IL.NewLabel(); |
IL.Jmp(IL.opJNZ, label1); |
IL.SetLabel(label); |
IL.Const(0); |
IL.drop; |
label := IL.NewLabel(); |
IL.Jmp(IL.opJMP, label); |
IL.SetLabel(label1); |
IL.Const(1); |
IL.SetLabel(label); |
IL.AddCmd0(IL.opAND) |
END |
END term; |
PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos: PARS.POSITION; |
op: INTEGER; |
e1: PARS.EXPR; |
s, s1: SCAN.TEXTSTR; |
plus, minus: BOOLEAN; |
label, label1: INTEGER; |
BEGIN |
plus := parser.sym = SCAN.lxPLUS; |
minus := parser.sym = SCAN.lxMINUS; |
IF plus OR minus THEN |
getpos(parser, pos); |
PARS.Next(parser) |
END; |
term(parser, e); |
IF plus OR minus THEN |
PARS.check(isInt(e) OR isReal(e) OR isSet(e), pos, 36); |
IF minus & (e.obj = eCONST) THEN |
PARS.check(ARITH.neg(e.value), pos, 39) |
END; |
IF e.obj # eCONST THEN |
IF minus THEN |
IF isInt(e) THEN |
IL.AddCmd0(IL.opUMINUS) |
ELSIF isReal(e) THEN |
IL.AddCmd0(IL.opUMINF) |
ELSIF isSet(e) THEN |
IL.AddCmd0(IL.opUMINS) |
END |
END; |
e.obj := eEXPR |
END |
END; |
label := -1; |
WHILE AddOperator(parser.sym) DO |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
IF op = SCAN.lxOR THEN |
IF ~parser.constexp THEN |
IF label = -1 THEN |
label := IL.NewLabel() |
END; |
IF (e.obj = eCONST) & isBoolean(e) THEN |
IL.Const(ORD(ARITH.getBool(e.value))) |
END; |
IL.Jmp(IL.opJNZ, label) |
END |
END; |
term(parser, e1); |
CASE op OF |
|SCAN.lxPLUS, SCAN.lxMINUS: |
minus := op = SCAN.lxMINUS; |
IF minus THEN |
op := ORD("-") |
ELSE |
op := ORD("+") |
END; |
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1) OR isString(e) & isString(e1) & ~minus, pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tINTEGER: |
PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), pos, 39) |
|ARITH.tREAL: |
PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), pos, 40) |
|ARITH.tSET: |
ARITH.opSet(e.value, e1.value, CHR(op)) |
|ARITH.tCHAR, ARITH.tSTRING: |
IF e.value.typ = ARITH.tCHAR THEN |
ARITH.charToStr(e.value, s) |
ELSE |
s := e.value.string(SCAN.STRING).s |
END; |
IF e1.value.typ = ARITH.tCHAR THEN |
ARITH.charToStr(e1.value, s1) |
ELSE |
s1 := e1.value.string(SCAN.STRING).s |
END; |
PARS.check(ARITH.concat(s, s1), pos, 5); |
e.value.string := SCAN.enterStr(s); |
e.value.typ := ARITH.tSTRING; |
e._type := PROG.program.stTypes.tSTRING |
END |
ELSE |
IF isInt(e) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opADDC - ORD(minus), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opADDC + ORD(minus), ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opADD + ORD(minus)) |
END |
ELSIF isReal(e) THEN |
IF e.obj = eCONST THEN |
Float(parser, e); |
IL.AddCmd0(IL.opADDF - ORD(minus)) |
ELSIF e1.obj = eCONST THEN |
Float(parser, e1); |
IL.AddCmd0(IL.opADDF + ORD(minus)) |
ELSE |
IL.AddCmd0(IL.opADDF + ORD(minus)) |
END |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opADDSC - ORD(minus), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opADDSC + ORD(minus), ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opADDS + ORD(minus)) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxOR: |
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN |
ARITH.opBoolean(e.value, e1.value, "|") |
ELSE |
e.obj := eEXPR; |
IF e1.obj = eCONST THEN |
IL.Const(ORD(ARITH.getBool(e1.value))) |
END |
END |
END |
END; |
IF label # -1 THEN |
label1 := IL.NewLabel(); |
IL.Jmp(IL.opJZ, label1); |
IL.SetLabel(label); |
IL.Const(1); |
IL.drop; |
label := IL.NewLabel(); |
IL.Jmp(IL.opJMP, label); |
IL.SetLabel(label1); |
IL.Const(0); |
IL.SetLabel(label); |
IL.AddCmd0(IL.opOR) |
END |
END SimpleExpression; |
PROCEDURE cmpcode (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|SCAN.lxEQ: res := ARITH.opEQ |
|SCAN.lxNE: res := ARITH.opNE |
|SCAN.lxLT: res := ARITH.opLT |
|SCAN.lxLE: res := ARITH.opLE |
|SCAN.lxGT: res := ARITH.opGT |
|SCAN.lxGE: res := ARITH.opGE |
|SCAN.lxIN: res := ARITH.opIN |
|SCAN.lxIS: res := ARITH.opIS |
END |
RETURN res |
END cmpcode; |
PROCEDURE invcmpcode (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|SCAN.lxEQ: res := ARITH.opEQ |
|SCAN.lxNE: res := ARITH.opNE |
|SCAN.lxLT: res := ARITH.opGT |
|SCAN.lxLE: res := ARITH.opGE |
|SCAN.lxGT: res := ARITH.opLT |
|SCAN.lxGE: res := ARITH.opLE |
|SCAN.lxIN: res := ARITH.opIN |
|SCAN.lxIS: res := ARITH.opIS |
END |
RETURN res |
END invcmpcode; |
PROCEDURE BoolCmp (eq, val: BOOLEAN); |
BEGIN |
IF eq = val THEN |
IL.AddCmd0(IL.opNEC) |
ELSE |
IL.AddCmd0(IL.opEQC) |
END |
END BoolCmp; |
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
cmp: INTEGER; |
BEGIN |
res := TRUE; |
cmp := cmpcode(op); |
IF isString(e) & isCharArray(e1) THEN |
IL.StrAdr(String(e)); |
IL.Const(strlen(e) + 1); |
IL.AddCmd0(IL.opEQS + invcmpcode(op)) |
ELSIF (isString(e) OR isStringW(e)) & isCharArrayW(e1) THEN |
IL.StrAdr(StringW(e)); |
IL.Const(utf8strlen(e) + 1); |
IL.AddCmd0(IL.opEQSW + invcmpcode(op)) |
ELSIF isCharArray(e) & isString(e1) THEN |
IL.StrAdr(String(e1)); |
IL.Const(strlen(e1) + 1); |
IL.AddCmd0(IL.opEQS + cmp) |
ELSIF isCharArrayW(e) & (isString(e1) OR isStringW(e1)) THEN |
IL.StrAdr(StringW(e1)); |
IL.Const(utf8strlen(e1) + 1); |
IL.AddCmd0(IL.opEQSW + cmp) |
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN |
IL.AddCmd0(IL.opEQSW + cmp) |
ELSIF isCharArray(e) & isCharArray(e1) THEN |
IL.AddCmd0(IL.opEQS + cmp) |
ELSIF isString(e) & isString(e1) THEN |
PARS.strcmp(e.value, e1.value, op) |
ELSE |
res := FALSE |
END |
RETURN res |
END strcmp; |
BEGIN |
getpos(parser, pos0); |
SimpleExpression(parser, e); |
IF relation(parser.sym) THEN |
IF (isCharArray(e) OR isCharArrayW(e)) & (e._type.length # 0) THEN |
IL.Const(e._type.length) |
END; |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
getpos(parser, pos1); |
SimpleExpression(parser, e1); |
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1._type.length # 0) THEN |
IL.Const(e1._type.length) |
END; |
constant := (e.obj = eCONST) & (e1.obj = eCONST); |
error := 0; |
cmp := cmpcode(op); |
CASE op OF |
|SCAN.lxEQ, SCAN.lxNE: |
eq := op = SCAN.lxEQ; |
IF isInt(e) & isInt(e1) OR isSet(e) & isSet(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR |
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) OR |
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e._type, e1._type) OR PROG.isBaseOf(e1._type, e._type)) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, cmp, error) |
ELSE |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opEQ + cmp) |
END |
END |
ELSIF isStringW1(e) & isCharW(e1) THEN |
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e.value.string(SCAN.STRING).s)) |
ELSIF isStringW1(e1) & isCharW(e) THEN |
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s)) |
ELSIF isBoolean(e) & isBoolean(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, cmp, error) |
ELSE |
IF e.obj = eCONST THEN |
BoolCmp(eq, ARITH.Int(e.value) # 0) |
ELSIF e1.obj = eCONST THEN |
BoolCmp(eq, ARITH.Int(e1.value) # 0) |
ELSE |
IF eq THEN |
IL.AddCmd0(IL.opEQB) |
ELSE |
IL.AddCmd0(IL.opNEB) |
END |
END |
END |
ELSIF isReal(e) & isReal(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, cmp, error) |
ELSE |
IF e.obj = eCONST THEN |
Float(parser, e) |
ELSIF e1.obj = eCONST THEN |
Float(parser, e1) |
END; |
IL.AddCmd0(IL.opEQF + cmp) |
END |
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN |
IF ~strcmp(e, e1, op) THEN |
PARS.error(pos, 37) |
END |
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN |
IL.AddCmd0(IL.opEQC + cmp) |
ELSIF isProc(e) & isNil(e1) THEN |
IF e.obj IN {ePROC, eIMP} THEN |
PARS.check(e.ident.global, pos0, 85); |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, ~eq) |
ELSE |
IL.AddCmd0(IL.opEQC + cmp) |
END |
ELSIF isNil(e) & isProc(e1) THEN |
IF e1.obj IN {ePROC, eIMP} THEN |
PARS.check(e1.ident.global, pos1, 85); |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, ~eq) |
ELSE |
IL.AddCmd0(IL.opEQC + cmp) |
END |
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e._type, e1._type) THEN |
IF e.obj = ePROC THEN |
PARS.check(e.ident.global, pos0, 85) |
END; |
IF e1.obj = ePROC THEN |
PARS.check(e1.ident.global, pos1, 85) |
END; |
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN |
constant := TRUE; |
e.obj := eCONST; |
IF eq THEN |
ARITH.setbool(e.value, e.ident = e1.ident) |
ELSE |
ARITH.setbool(e.value, e.ident # e1.ident) |
END |
ELSIF e.obj = ePROC THEN |
IL.ProcCmp(e.ident.proc.label, eq) |
ELSIF e1.obj = ePROC THEN |
IL.ProcCmp(e1.ident.proc.label, eq) |
ELSIF e.obj = eIMP THEN |
IL.ProcImpCmp(e.ident._import, eq) |
ELSIF e1.obj = eIMP THEN |
IL.ProcImpCmp(e1.ident._import, eq) |
ELSE |
IL.AddCmd0(IL.opEQ + cmp) |
END |
ELSIF isNil(e) & isNil(e1) THEN |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, eq) |
ELSE |
PARS.error(pos, 37) |
END |
|SCAN.lxLT, SCAN.lxLE, SCAN.lxGT, SCAN.lxGE: |
IF isInt(e) & isInt(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR |
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, cmp, error) |
ELSE |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opEQC + invcmpcode(op), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opEQ + cmp) |
END |
END |
ELSIF isStringW1(e) & isCharW(e1) THEN |
IL.AddCmd(IL.opEQC + invcmpcode(op), StrToWChar(e.value.string(SCAN.STRING).s)) |
ELSIF isStringW1(e1) & isCharW(e) THEN |
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s)) |
ELSIF isReal(e) & isReal(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, cmp, error) |
ELSE |
IF e.obj = eCONST THEN |
Float(parser, e); |
IL.AddCmd0(IL.opEQF + invcmpcode(op)) |
ELSIF e1.obj = eCONST THEN |
Float(parser, e1); |
IL.AddCmd0(IL.opEQF + cmp) |
ELSE |
IL.AddCmd0(IL.opEQF + cmp) |
END |
END |
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN |
IF ~strcmp(e, e1, op) THEN |
PARS.error(pos, 37) |
END |
ELSE |
PARS.error(pos, 37) |
END |
|SCAN.lxIN: |
PARS.check(isInt(e) & isSet(e1), pos, 37); |
IF e.obj = eCONST THEN |
PARS.check(ARITH.range(e.value, 0, UTILS.target.maxSet), pos0, 56) |
END; |
IF constant THEN |
ARITH.relation(e.value, e1.value, ARITH.opIN, error) |
ELSE |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opINL, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
IL.AddCmd(IL.opINR, ARITH.Int(e1.value)) |
ELSE |
IL.AddCmd0(IL.opIN) |
END |
END |
|SCAN.lxIS: |
PARS.check(isRecPtr(e), pos, 73); |
PARS.check(e1.obj = eTYPE, pos1, 79); |
IF isRec(e) THEN |
PARS.check(e.obj = eVREC, pos0, 78); |
PARS.check(e1._type.typ = PROG.tRECORD, pos1, 80); |
IF e.ident = NIL THEN |
IL.TypeCheck(e1._type.num) |
ELSE |
IL.AddCmd(IL.opVADR, e.ident.offset - 1); |
IL.TypeCheckRec(e1._type.num) |
END |
ELSE |
PARS.check(e1._type.typ = PROG.tPOINTER, pos1, 81); |
IL.TypeCheck(e1._type.base.num) |
END; |
PARS.check(PROG.isBaseOf(e._type, e1._type), pos1, 82) |
END; |
ASSERT(error = 0); |
e._type := tBOOLEAN; |
IF ~constant THEN |
e.obj := eEXPR |
END |
END |
END expression; |
PROCEDURE ElementaryStatement (parser: PARS.PARSER); |
VAR |
e, e1: PARS.EXPR; |
pos: PARS.POSITION; |
line: INTEGER; |
call: BOOLEAN; |
BEGIN |
getpos(parser, pos); |
IL.pushBegEnd(begcall, endcall); |
designator(parser, e); |
IF parser.sym = SCAN.lxASSIGN THEN |
line := parser.lex.pos.line; |
PARS.check(isVar(e), pos, 93); |
PARS.check(~e.readOnly, pos, 94); |
IL.setlast(begcall); |
NextPos(parser, pos); |
expression(parser, e1); |
IL.setlast(endcall.prev(IL.COMMAND)); |
PARS.check(assign(parser, e1, e._type, line), pos, 91); |
IF e1.obj = ePROC THEN |
PARS.check(e1.ident.global, pos, 85) |
END; |
call := FALSE |
ELSIF parser.sym = SCAN.lxEQ THEN |
PARS.check1(FALSE, parser, 96) |
ELSIF parser.sym = SCAN.lxLROUND THEN |
e1 := e; |
ActualParameters(parser, e1); |
PARS.check((e1._type = NIL) OR ODD(e._type.call), pos, 92); |
call := TRUE |
ELSE |
IF e.obj IN {eSYSPROC, eSTPROC} THEN |
stProc(parser, e); |
call := FALSE |
ELSE |
PARS.check(isProc(e), pos, 86); |
PARS.check((e._type.base = NIL) OR ODD(e._type.call), pos, 92); |
PARS.check1(e._type.params.first = NIL, parser, 64); |
call := TRUE |
END |
END; |
IF call THEN |
IF e.obj IN {ePROC, eIMP} THEN |
ProcCall(e, e.ident._type, FALSE, parser, pos, TRUE) |
ELSIF isExpr(e) THEN |
ProcCall(e, e._type, FALSE, parser, pos, TRUE) |
END |
END; |
IL.popBegEnd(begcall, endcall) |
END ElementaryStatement; |
PROCEDURE IfStatement (parser: PARS.PARSER; _if: BOOLEAN); |
VAR |
e: PARS.EXPR; |
pos: PARS.POSITION; |
label, L: INTEGER; |
BEGIN |
L := IL.NewLabel(); |
IF ~_if THEN |
IL.AddCmd(IL.opNOP, IL.begin_loop); |
IL.SetLabel(L) |
END; |
REPEAT |
NextPos(parser, pos); |
label := IL.NewLabel(); |
expression(parser, e); |
PARS.check(isBoolean(e), pos, 72); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
IL.Jmp(IL.opJMP, label) |
END |
ELSE |
IL.AndOrOpt(label) |
END; |
IF _if THEN |
PARS.checklex(parser, SCAN.lxTHEN) |
ELSE |
PARS.checklex(parser, SCAN.lxDO) |
END; |
PARS.Next(parser); |
parser.StatSeq(parser); |
IF ~_if OR (parser.sym # SCAN.lxEND) THEN |
IL.Jmp(IL.opJMP, L) |
END; |
IL.SetLabel(label) |
UNTIL parser.sym # SCAN.lxELSIF; |
IF _if THEN |
IF parser.sym = SCAN.lxELSE THEN |
PARS.Next(parser); |
parser.StatSeq(parser) |
END; |
IL.SetLabel(L) |
ELSE |
IL.AddCmd(IL.opNOP, IL.end_loop) |
END; |
PARS.checklex(parser, SCAN.lxEND); |
PARS.Next(parser) |
END IfStatement; |
PROCEDURE RepeatStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos: PARS.POSITION; |
label: INTEGER; |
L: IL.COMMAND; |
BEGIN |
IL.AddCmd(IL.opNOP, IL.begin_loop); |
label := IL.NewLabel(); |
IL.SetLabel(label); |
L := IL.getlast(); |
PARS.Next(parser); |
parser.StatSeq(parser); |
PARS.checklex(parser, SCAN.lxUNTIL); |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isBoolean(e), pos, 72); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
IL.Jmp(IL.opJMP, label) |
END |
ELSE |
IL.AndOrOpt(label); |
L.param1 := label |
END; |
IL.AddCmd(IL.opNOP, IL.end_loop) |
END RepeatStatement; |
PROCEDURE LabelCmp (a, b: AVL.DATA): INTEGER; |
VAR |
La, Ra, Lb, Rb, res: INTEGER; |
BEGIN |
La := a(CASE_LABEL).range.a; |
Ra := a(CASE_LABEL).range.b; |
Lb := b(CASE_LABEL).range.a; |
Rb := b(CASE_LABEL).range.b; |
IF (Ra < Lb) OR (La > Rb) THEN |
res := ORD(La > Lb) - ORD(La < Lb) |
ELSE |
res := 0 |
END |
RETURN res |
END LabelCmp; |
PROCEDURE DestroyLabel (VAR label: AVL.DATA); |
BEGIN |
C.push(CaseLabels, label); |
label := NIL |
END DestroyLabel; |
PROCEDURE NewVariant (label: INTEGER; cmd: IL.COMMAND): CASE_VARIANT; |
VAR |
res: CASE_VARIANT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(CaseVar); |
IF citem = NIL THEN |
NEW(res) |
ELSE |
res := citem(CASE_VARIANT) |
END; |
res.label := label; |
res.cmd := cmd; |
res.processed := FALSE |
RETURN res |
END NewVariant; |
PROCEDURE CaseStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos: PARS.POSITION; |
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR _type: PROG._TYPE): INTEGER; |
VAR |
a: INTEGER; |
label: PARS.EXPR; |
pos: PARS.POSITION; |
value: ARITH.VALUE; |
BEGIN |
getpos(parser, pos); |
_type := NIL; |
IF isChar(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
PARS.check(value.typ = ARITH.tCHAR, pos, 99); |
a := ARITH.getInt(value) |
ELSIF isCharW(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.STRING).s) = 1) & (LENGTH(value.string(SCAN.STRING).s) > 1) THEN |
ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.STRING).s))) |
ELSE |
PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, pos, 99) |
END; |
a := ARITH.getInt(value) |
ELSIF isInt(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
PARS.check(value.typ = ARITH.tINTEGER, pos, 99); |
a := ARITH.getInt(value) |
ELSIF isRecPtr(caseExpr) THEN |
qualident(parser, label); |
PARS.check(label.obj = eTYPE, pos, 79); |
PARS.check(PROG.isBaseOf(caseExpr._type, label._type), pos, 99); |
IF isRec(caseExpr) THEN |
a := label._type.num |
ELSE |
a := label._type.base.num |
END; |
_type := label._type |
END |
RETURN a |
END Label; |
PROCEDURE CheckType (node: AVL.NODE; _type: PROG._TYPE; parser: PARS.PARSER; pos: PARS.POSITION); |
BEGIN |
IF node # NIL THEN |
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL)._type, _type) OR PROG.isBaseOf(_type, node.data(CASE_LABEL)._type)), pos, 100); |
CheckType(node.left, _type, parser, pos); |
CheckType(node.right, _type, parser, pos) |
END |
END CheckType; |
PROCEDURE LabelRange (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE; |
VAR |
label: CASE_LABEL; |
citem: C.ITEM; |
pos, pos1: PARS.POSITION; |
node: AVL.NODE; |
newnode: BOOLEAN; |
range: RANGE; |
BEGIN |
citem := C.pop(CaseLabels); |
IF citem = NIL THEN |
NEW(label) |
ELSE |
label := citem(CASE_LABEL) |
END; |
label.variant := variant; |
label.self := IL.NewLabel(); |
getpos(parser, pos1); |
range.a := Label(parser, caseExpr, label._type); |
IF parser.sym = SCAN.lxRANGE THEN |
PARS.check1(~isRecPtr(caseExpr), parser, 53); |
NextPos(parser, pos); |
range.b := Label(parser, caseExpr, label._type); |
PARS.check(range.a <= range.b, pos, 103) |
ELSE |
range.b := range.a |
END; |
label.range := range; |
IF isRecPtr(caseExpr) THEN |
CheckType(tree, label._type, parser, pos1) |
END; |
tree := AVL.insert(tree, label, LabelCmp, newnode, node); |
PARS.check(newnode, pos1, 100) |
RETURN node |
END LabelRange; |
PROCEDURE CaseLabelList (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE; |
VAR |
exit: BOOLEAN; |
res: AVL.NODE; |
BEGIN |
exit := FALSE; |
REPEAT |
res := LabelRange(parser, caseExpr, tree, variant); |
IF parser.sym = SCAN.lxCOMMA THEN |
PARS.check1(~isRecPtr(caseExpr), parser, 53); |
PARS.Next(parser) |
ELSE |
exit := TRUE |
END |
UNTIL exit |
RETURN res |
END CaseLabelList; |
PROCEDURE _case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; _end: INTEGER); |
VAR |
sym: INTEGER; |
t: PROG._TYPE; |
variant: INTEGER; |
node: AVL.NODE; |
last: IL.COMMAND; |
BEGIN |
sym := parser.sym; |
IF sym # SCAN.lxBAR THEN |
variant := IL.NewLabel(); |
node := CaseLabelList(parser, caseExpr, tree, variant); |
PARS.checklex(parser, SCAN.lxCOLON); |
PARS.Next(parser); |
IF isRecPtr(caseExpr) THEN |
t := caseExpr._type; |
caseExpr.ident._type := node.data(CASE_LABEL)._type |
END; |
last := IL.getlast(); |
IL.SetLabel(variant); |
IF ~isRecPtr(caseExpr) THEN |
LISTS.push(CaseVariants, NewVariant(variant, last)) |
END; |
parser.StatSeq(parser); |
IL.Jmp(IL.opJMP, _end); |
IF isRecPtr(caseExpr) THEN |
caseExpr.ident._type := t |
END |
END |
END _case; |
PROCEDURE Table (node: AVL.NODE; _else: INTEGER); |
VAR |
L, R: INTEGER; |
range: RANGE; |
left, right: AVL.NODE; |
last: IL.COMMAND; |
v: CASE_VARIANT; |
BEGIN |
IF node # NIL THEN |
range := node.data(CASE_LABEL).range; |
left := node.left; |
IF left # NIL THEN |
L := left.data(CASE_LABEL).self |
ELSE |
L := _else |
END; |
right := node.right; |
IF right # NIL THEN |
R := right.data(CASE_LABEL).self |
ELSE |
R := _else |
END; |
last := IL.getlast(); |
v := CaseVariants.last(CASE_VARIANT); |
WHILE (v # NIL) & (v.label # 0) & (v.label # node.data(CASE_LABEL).variant) DO |
v := v.prev(CASE_VARIANT) |
END; |
ASSERT((v # NIL) & (v.label # 0)); |
IL.setlast(v.cmd); |
IL.SetLabel(node.data(CASE_LABEL).self); |
IL._case(range.a, range.b, L, R); |
IF v.processed THEN |
IL.Jmp(IL.opJMP, node.data(CASE_LABEL).variant) |
END; |
v.processed := TRUE; |
IL.setlast(last); |
Table(left, _else); |
Table(right, _else) |
END |
END Table; |
PROCEDURE TableT (node: AVL.NODE); |
BEGIN |
IF node # NIL THEN |
IL.AddCmd2(IL.opCASET, node.data(CASE_LABEL).variant, node.data(CASE_LABEL).range.a); |
TableT(node.left); |
TableT(node.right) |
END |
END TableT; |
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: PARS.POSITION); |
VAR |
table, _end, _else: INTEGER; |
tree: AVL.NODE; |
item: LISTS.ITEM; |
BEGIN |
LISTS.push(CaseVariants, NewVariant(0, NIL)); |
_end := IL.NewLabel(); |
_else := IL.NewLabel(); |
table := IL.NewLabel(); |
IL.AddCmd(IL.opSWITCH, ORD(isRecPtr(e))); |
IL.Jmp(IL.opJMP, table); |
tree := NIL; |
_case(parser, e, tree, _end); |
WHILE parser.sym = SCAN.lxBAR DO |
PARS.Next(parser); |
_case(parser, e, tree, _end) |
END; |
IL.SetLabel(_else); |
IF parser.sym = SCAN.lxELSE THEN |
PARS.Next(parser); |
parser.StatSeq(parser); |
IL.Jmp(IL.opJMP, _end) |
ELSE |
IL.OnError(pos.line, errCASE) |
END; |
PARS.checklex(parser, SCAN.lxEND); |
PARS.Next(parser); |
IF isRecPtr(e) THEN |
IL.SetLabel(table); |
TableT(tree); |
IL.Jmp(IL.opJMP, _else) |
ELSE |
tree.data(CASE_LABEL).self := table; |
Table(tree, _else) |
END; |
AVL.destroy(tree, DestroyLabel); |
IL.SetLabel(_end); |
IL.AddCmd0(IL.opENDSW); |
REPEAT |
item := LISTS.pop(CaseVariants); |
C.push(CaseVar, item) |
UNTIL item(CASE_VARIANT).cmd = NIL |
END ParseCase; |
BEGIN |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isInt(e) OR isChar(e) OR isCharW(e) OR isPtr(e) OR isRec(e), pos, 95); |
IF isRecPtr(e) THEN |
PARS.check(isVar(e), pos, 93); |
PARS.check(e.ident # NIL, pos, 106) |
END; |
IF isRec(e) THEN |
PARS.check(e.obj = eVREC, pos, 78) |
END; |
IF e.obj = eCONST THEN |
LoadConst(e) |
ELSIF isRec(e) THEN |
IL.drop; |
IL.AddCmd(IL.opLADR, e.ident.offset - 1); |
IL.load(TARGETS.WordSize) |
ELSIF isPtr(e) THEN |
deref(pos, e, FALSE, errPTR); |
IL.AddCmd(IL.opSUBR, TARGETS.WordSize); |
IL.load(TARGETS.WordSize) |
END; |
PARS.checklex(parser, SCAN.lxOF); |
PARS.Next(parser); |
ParseCase(parser, e, pos) |
END CaseStatement; |
PROCEDURE ForStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos, pos2: PARS.POSITION; |
step: ARITH.VALUE; |
st: INTEGER; |
ident: PROG.IDENT; |
offset: INTEGER; |
L1, L2: INTEGER; |
BEGIN |
IL.AddCmd(IL.opNOP, IL.begin_loop); |
L1 := IL.NewLabel(); |
L2 := IL.NewLabel(); |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
ident := PROG.getIdent(parser.unit, parser.lex.ident, TRUE); |
PARS.check1(ident # NIL, parser, 48); |
PARS.check1(ident.typ = PROG.idVAR, parser, 93); |
PARS.check1(ident._type = tINTEGER, parser, 97); |
PARS.ExpectSym(parser, SCAN.lxASSIGN); |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isInt(e), pos, 76); |
offset := PROG.getOffset(ident); |
IF ident.global THEN |
IL.AddCmd(IL.opGADR, offset) |
ELSE |
IL.AddCmd(IL.opLADR, -offset) |
END; |
IF e.obj = eCONST THEN |
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value)) |
ELSE |
IL.AddCmd0(IL.opSAVE) |
END; |
IL.SetLabel(L1); |
IF ident.global THEN |
IL.AddCmd(IL.opGADR, offset) |
ELSE |
IL.AddCmd(IL.opLADR, -offset) |
END; |
IL.load(ident._type.size); |
PARS.checklex(parser, SCAN.lxTO); |
NextPos(parser, pos2); |
expression(parser, e); |
PARS.check(isInt(e), pos2, 76); |
IF parser.sym = SCAN.lxBY THEN |
NextPos(parser, pos); |
PARS.ConstExpression(parser, step); |
PARS.check(step.typ = ARITH.tINTEGER, pos, 76); |
st := ARITH.getInt(step); |
PARS.check(st # 0, pos, 98) |
ELSE |
st := 1 |
END; |
IF e.obj = eCONST THEN |
IF st > 0 THEN |
IL.AddCmd(IL.opLEC, ARITH.Int(e.value)); |
IF ARITH.Int(e.value) = UTILS.target.maxInt THEN |
ERRORS.WarningMsg(pos2.line, pos2.col, 1) |
END |
ELSE |
IL.AddCmd(IL.opGEC, ARITH.Int(e.value)); |
IF ARITH.Int(e.value) = UTILS.target.minInt THEN |
ERRORS.WarningMsg(pos2.line, pos2.col, 1) |
END |
END |
ELSE |
IF st > 0 THEN |
IL.AddCmd0(IL.opLE) |
ELSE |
IL.AddCmd0(IL.opGE) |
END |
END; |
IL.Jmp(IL.opJZ, L2); |
PARS.checklex(parser, SCAN.lxDO); |
PARS.Next(parser); |
parser.StatSeq(parser); |
IF ident.global THEN |
IL.AddCmd(IL.opGADR, offset) |
ELSE |
IL.AddCmd(IL.opLADR, -offset) |
END; |
IL.AddCmd(IL.opINCC, st); |
IL.Jmp(IL.opJMP, L1); |
PARS.checklex(parser, SCAN.lxEND); |
PARS.Next(parser); |
IL.SetLabel(L2); |
IL.AddCmd(IL.opNOP, IL.end_loop) |
END ForStatement; |
PROCEDURE statement (parser: PARS.PARSER); |
VAR |
sym: INTEGER; |
BEGIN |
sym := parser.sym; |
IF sym = SCAN.lxIDENT THEN |
ElementaryStatement(parser) |
ELSIF sym = SCAN.lxIF THEN |
IfStatement(parser, TRUE) |
ELSIF sym = SCAN.lxWHILE THEN |
IfStatement(parser, FALSE) |
ELSIF sym = SCAN.lxREPEAT THEN |
RepeatStatement(parser) |
ELSIF sym = SCAN.lxCASE THEN |
CaseStatement(parser) |
ELSIF sym = SCAN.lxFOR THEN |
ForStatement(parser) |
END |
END statement; |
PROCEDURE StatSeq (parser: PARS.PARSER); |
BEGIN |
statement(parser); |
WHILE parser.sym = SCAN.lxSEMI DO |
PARS.Next(parser); |
statement(parser) |
END |
END StatSeq; |
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG._TYPE; pos: PARS.POSITION): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := assigncomp(e, t); |
IF res THEN |
IF e.obj = eCONST THEN |
IF e._type = tREAL THEN |
Float(parser, e) |
ELSIF e._type.typ = PROG.tNIL THEN |
IL.Const(0) |
ELSE |
LoadConst(e) |
END |
ELSIF (e._type = tINTEGER) & (t = tBYTE) & (chkBYTE IN Options.checking) THEN |
CheckRange(256, pos.line, errBYTE) |
ELSIF e.obj = ePROC THEN |
PARS.check(e.ident.global, pos, 85); |
IL.PushProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
IL.PushImpProc(e.ident._import) |
END |
END |
RETURN res |
END chkreturn; |
PROCEDURE setrtl; |
VAR |
rtl: PROG.UNIT; |
PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.IDSTR; idx: INTEGER); |
VAR |
id: PROG.IDENT; |
ident: SCAN.IDENT; |
BEGIN |
SCAN.setIdent(ident, name); |
id := PROG.getIdent(rtl, ident, FALSE); |
IF (id # NIL) & (id._import # NIL) THEN |
IL.set_rtl(idx, -id._import(IL.IMPORT_PROC).label); |
id.proc.used := TRUE |
ELSIF (id # NIL) & (id.proc # NIL) THEN |
IL.set_rtl(idx, id.proc.label); |
id.proc.used := TRUE |
ELSE |
ERRORS.WrongRTL(name) |
END |
END getproc; |
BEGIN |
rtl := PROG.program.rtl; |
ASSERT(rtl # NIL); |
getproc(rtl, "_strcmp", IL._strcmp); |
getproc(rtl, "_length", IL._length); |
getproc(rtl, "_arrcpy", IL._arrcpy); |
getproc(rtl, "_is", IL._is); |
getproc(rtl, "_guard", IL._guard); |
getproc(rtl, "_guardrec", IL._guardrec); |
getproc(rtl, "_new", IL._new); |
getproc(rtl, "_rot", IL._rot); |
getproc(rtl, "_strcpy", IL._strcpy); |
getproc(rtl, "_move", IL._move); |
getproc(rtl, "_set", IL._set); |
getproc(rtl, "_set1", IL._set1); |
getproc(rtl, "_lengthw", IL._lengthw); |
getproc(rtl, "_strcmpw", IL._strcmpw); |
getproc(rtl, "_init", IL._init); |
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN |
getproc(rtl, "_error", IL._error); |
getproc(rtl, "_divmod", IL._divmod); |
getproc(rtl, "_exit", IL._exit); |
getproc(rtl, "_dispose", IL._dispose); |
getproc(rtl, "_isrec", IL._isrec); |
getproc(rtl, "_dllentry", IL._dllentry); |
getproc(rtl, "_sofinit", IL._sofinit) |
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN |
getproc(rtl, "_fmul", IL._fmul); |
getproc(rtl, "_fdiv", IL._fdiv); |
getproc(rtl, "_fdivi", IL._fdivi); |
getproc(rtl, "_fadd", IL._fadd); |
getproc(rtl, "_fsub", IL._fsub); |
getproc(rtl, "_fsubi", IL._fsubi); |
getproc(rtl, "_fcmp", IL._fcmp); |
getproc(rtl, "_floor", IL._floor); |
getproc(rtl, "_flt", IL._flt); |
getproc(rtl, "_pack", IL._pack); |
getproc(rtl, "_unpk", IL._unpk); |
IF CPU IN {TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN |
getproc(rtl, "_error", IL._error) |
END |
END |
END setrtl; |
PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target: INTEGER; options: PROG.OPTIONS); |
VAR |
parser: PARS.PARSER; |
ext: PARS.PATH; |
BEGIN |
tINTEGER := PROG.program.stTypes.tINTEGER; |
tBYTE := PROG.program.stTypes.tBYTE; |
tCHAR := PROG.program.stTypes.tCHAR; |
tSET := PROG.program.stTypes.tSET; |
tBOOLEAN := PROG.program.stTypes.tBOOLEAN; |
tWCHAR := PROG.program.stTypes.tWCHAR; |
tREAL := PROG.program.stTypes.tREAL; |
Options := options; |
CPU := TARGETS.CPU; |
ext := UTILS.FILE_EXT; |
CaseLabels := C.create(); |
CaseVar := C.create(); |
CaseVariants := LISTS.create(NIL); |
LISTS.push(CaseVariants, NewVariant(0, NIL)); |
IL.init(CPU); |
IF TARGETS.RTL THEN |
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); |
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN |
parser.parse(parser); |
PARS.destroy(parser) |
ELSE |
PARS.destroy(parser); |
parser := PARS.create(lib_path, lib_path, StatSeq, expression, designator, chkreturn); |
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN |
parser.parse(parser); |
PARS.destroy(parser) |
ELSE |
ERRORS.FileNotFound(lib_path, UTILS.RTL_NAME, UTILS.FILE_EXT) |
END |
END |
END; |
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); |
parser.main := TRUE; |
IF parser.open(parser, modname, UTILS.FILE_EXT) THEN |
parser.parse(parser) |
ELSE |
ERRORS.FileNotFound(path, modname, UTILS.FILE_EXT) |
END; |
PARS.destroy(parser); |
IF PROG.program.bss > UTILS.MAX_GLOBAL_SIZE THEN |
ERRORS.Error(204) |
END; |
IF TARGETS.RTL THEN |
setrtl |
END; |
PROG.DelUnused(IL.DelImport); |
IL.set_bss(PROG.program.bss); |
CASE CPU OF |
|TARGETS.cpuAMD64: AMD64.CodeGen(outname, target, options) |
|TARGETS.cpuX86: X86.CodeGen(outname, target, options) |
|TARGETS.cpuMSP430: MSP430.CodeGen(outname, target, options) |
|TARGETS.cpuTHUMB: THUMB.CodeGen(outname, target, options) |
|TARGETS.cpuRVM32I, |
TARGETS.cpuRVM64I: RVMxI.CodeGen(outname, target, options) |
END |
END compile; |
END STATEMENTS. |
/programs/develop/oberon07/source/STRINGS.ob07 |
---|
0,0 → 1,342 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE STRINGS; |
IMPORT UTILS; |
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER); |
BEGIN |
WHILE count > 0 DO |
dst[dpos] := src[spos]; |
INC(spos); |
INC(dpos); |
DEC(count) |
END |
END copy; |
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2: INTEGER; |
BEGIN |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
copy(s2, s1, 0, n1, n2); |
s1[n1 + n2] := 0X |
END append; |
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
BEGIN |
IF x = UTILS.minint THEN |
IF UTILS.bit_depth = 32 THEN |
COPY("-2147483648", str) |
ELSIF UTILS.bit_depth = 64 THEN |
COPY("-9223372036854775808", str) |
END |
ELSE |
i := 0; |
IF x < 0 THEN |
x := -x; |
i := 1; |
str[0] := "-" |
END; |
a := x; |
REPEAT |
INC(i); |
a := a DIV 10 |
UNTIL a = 0; |
str[i] := 0X; |
REPEAT |
DEC(i); |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10 |
UNTIL x = 0 |
END |
END IntToStr; |
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN); |
VAR |
length: INTEGER; |
BEGIN |
length := LENGTH(s); |
IF (0 <= pos) & (pos < length) THEN |
IF forward THEN |
WHILE (pos < length) & (s[pos] # c) DO |
INC(pos) |
END; |
IF pos = length THEN |
pos := -1 |
END |
ELSE |
WHILE (pos >= 0) & (s[pos] # c) DO |
DEC(pos) |
END |
END |
ELSE |
pos := -1 |
END |
END search; |
PROCEDURE replace* (VAR s: ARRAY OF CHAR; find, repl: CHAR); |
VAR |
i, strlen: INTEGER; |
BEGIN |
strlen := LENGTH(s) - 1; |
FOR i := 0 TO strlen DO |
IF s[i] = find THEN |
s[i] := repl |
END |
END |
END replace; |
PROCEDURE trim* (source: ARRAY OF CHAR; VAR result: ARRAY OF CHAR); |
VAR |
LenS, start, _end, i, j: INTEGER; |
BEGIN |
LenS := LENGTH(source) - 1; |
j := 0; |
IF LenS >= 0 THEN |
start := 0; |
WHILE (start <= LenS) & (source[start] <= 20X) DO |
INC(start) |
END; |
_end := LenS; |
WHILE (_end >= 0) & (source[_end] <= 20X) DO |
DEC(_end) |
END; |
FOR i := start TO _end DO |
result[j] := source[i]; |
INC(j) |
END |
END; |
result[j] := 0X |
END trim; |
PROCEDURE letter* (c: CHAR): BOOLEAN; |
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z") OR (c = "_") |
END letter; |
PROCEDURE digit* (c: CHAR): BOOLEAN; |
RETURN ("0" <= c) & (c <= "9") |
END digit; |
PROCEDURE hexdigit* (c: CHAR): BOOLEAN; |
RETURN ("0" <= c) & (c <= "9") OR ("A" <= c) & (c <= "F") |
END hexdigit; |
PROCEDURE space* (c: CHAR): BOOLEAN; |
RETURN (0X < c) & (c <= 20X) |
END space; |
PROCEDURE cap* (VAR c: CHAR); |
BEGIN |
IF ("a" <= c) & (c <= "z") THEN |
c := CHR(ORD(c) - 32) |
END |
END cap; |
PROCEDURE UpCase* (VAR str: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := LENGTH(str) - 1; |
WHILE i >= 0 DO |
cap(str[i]); |
DEC(i) |
END |
END UpCase; |
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN; |
VAR |
i, k: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
i := 0; |
x := 0; |
k := LENGTH(str); |
WHILE i < k DO |
IF digit(str[i]) THEN |
x := x * 10 + ORD(str[i]) - ORD("0") |
ELSE |
i := k; |
res := FALSE |
END; |
INC(i) |
END |
RETURN res |
END StrToInt; |
PROCEDURE CheckVer (str: ARRAY OF CHAR): BOOLEAN; |
VAR |
i, k: INTEGER; |
res: BOOLEAN; |
BEGIN |
k := LENGTH(str); |
res := k < LEN(str); |
IF res & digit(str[0]) THEN |
i := 0; |
WHILE (i < k) & digit(str[i]) DO |
INC(i) |
END; |
IF (i < k) & (str[i] = ".") THEN |
INC(i); |
IF i < k THEN |
WHILE (i < k) & digit(str[i]) DO |
INC(i) |
END |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END; |
res := res & (i = k) |
ELSE |
res := FALSE |
END |
RETURN res |
END CheckVer; |
PROCEDURE StrToVer* (str: ARRAY OF CHAR; VAR major, minor: INTEGER): BOOLEAN; |
VAR |
i: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := CheckVer(str); |
IF res THEN |
i := 0; |
minor := 0; |
major := 0; |
WHILE digit(str[i]) DO |
major := major * 10 + ORD(str[i]) - ORD("0"); |
INC(i) |
END; |
INC(i); |
WHILE digit(str[i]) DO |
minor := minor * 10 + ORD(str[i]) - ORD("0"); |
INC(i) |
END |
END |
RETURN res |
END StrToVer; |
PROCEDURE Utf8To16* (src: ARRAY OF CHAR; VAR dst: ARRAY OF WCHAR): INTEGER; |
VAR |
i, j, u, srclen, dstlen: INTEGER; |
c: CHAR; |
BEGIN |
srclen := LEN(src); |
dstlen := LEN(dst); |
i := 0; |
j := 0; |
WHILE (i < srclen) & (j < dstlen) & (src[i] # 0X) DO |
c := src[i]; |
CASE c OF |
|00X..7FX: |
u := ORD(c) |
|0C1X..0DFX: |
u := (ORD(c) - 0C0H) * 64; |
IF i + 1 < srclen THEN |
INC(i); |
INC(u, ORD(src[i]) MOD 64) |
END |
|0E1X..0EFX: |
u := (ORD(c) - 0E0H) * 4096; |
IF i + 1 < srclen THEN |
INC(i); |
INC(u, (ORD(src[i]) MOD 64) * 64) |
END; |
IF i + 1 < srclen THEN |
INC(i); |
INC(u, ORD(src[i]) MOD 64) |
END |
(* |
|0F1X..0F7X: |
|0F9X..0FBX: |
|0FDX: |
*) |
ELSE |
END; |
INC(i); |
dst[j] := WCHR(u); |
INC(j) |
END; |
IF j < dstlen THEN |
dst[j] := WCHR(0) |
END |
RETURN j |
END Utf8To16; |
PROCEDURE HashStr* (name: ARRAY OF CHAR): INTEGER; |
VAR |
i, h: INTEGER; |
g: SET; |
BEGIN |
h := 0; |
i := 0; |
WHILE name[i] # 0X DO |
h := h * 16 + ORD(name[i]); |
g := BITS(h) * {28..31}; |
h := ORD(BITS(h) / BITS(LSR(ORD(g), 24)) - g); |
INC(i) |
END |
RETURN h |
END HashStr; |
END STRINGS. |
/programs/develop/oberon07/source/TARGETS.ob07 |
---|
0,0 → 1,153 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE TARGETS; |
IMPORT UTILS; |
CONST |
MSP430* = 0; |
Win32C* = 1; |
Win32GUI* = 2; |
Win32DLL* = 3; |
KolibriOS* = 4; |
KolibriOSDLL* = 5; |
Win64C* = 6; |
Win64GUI* = 7; |
Win64DLL* = 8; |
Linux32* = 9; |
Linux32SO* = 10; |
Linux64* = 11; |
Linux64SO* = 12; |
STM32CM3* = 13; |
RVM32I* = 14; |
RVM64I* = 15; |
cpuX86* = 0; cpuAMD64* = 1; cpuMSP430* = 2; cpuTHUMB* = 3; |
cpuRVM32I* = 4; cpuRVM64I* = 5; |
osNONE* = 0; osWIN32* = 1; osWIN64* = 2; |
osLINUX32* = 3; osLINUX64* = 4; osKOS* = 5; |
noDISPOSE = {MSP430, STM32CM3, RVM32I, RVM64I}; |
noRTL = {MSP430}; |
libRVM32I = "RVMxI" + UTILS.slash + "32"; |
libRVM64I = "RVMxI" + UTILS.slash + "64"; |
TYPE |
STRING = ARRAY 32 OF CHAR; |
TARGET = RECORD |
target, CPU, OS, RealSize: INTEGER; |
ComLinePar*, LibDir, FileExt: STRING |
END; |
VAR |
Targets*: ARRAY 16 OF TARGET; |
CPUs: ARRAY 6 OF |
RECORD |
BitDepth, InstrSize: INTEGER; |
LittleEndian: BOOLEAN |
END; |
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER; |
ComLinePar*, LibDir*, FileExt*: STRING; |
Import*, Dispose*, RTL*, Dll*, LittleEndian*: BOOLEAN; |
PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING); |
BEGIN |
Targets[idx].target := idx; |
Targets[idx].CPU := CPU; |
Targets[idx].RealSize := RealSize; |
Targets[idx].OS := OS; |
Targets[idx].ComLinePar := ComLinePar; |
Targets[idx].LibDir := LibDir; |
Targets[idx].FileExt := FileExt; |
END Enter; |
PROCEDURE Select* (ComLineParam: ARRAY OF CHAR): BOOLEAN; |
VAR |
i: INTEGER; |
res: BOOLEAN; |
BEGIN |
i := 0; |
WHILE (i < LEN(Targets)) & (Targets[i].ComLinePar # ComLineParam) DO |
INC(i) |
END; |
res := i < LEN(Targets); |
IF res THEN |
target := Targets[i].target; |
CPU := Targets[i].CPU; |
BitDepth := CPUs[CPU].BitDepth; |
InstrSize := CPUs[CPU].InstrSize; |
LittleEndian := CPUs[CPU].LittleEndian; |
RealSize := Targets[i].RealSize; |
OS := Targets[i].OS; |
ComLinePar := Targets[i].ComLinePar; |
LibDir := Targets[i].LibDir; |
FileExt := Targets[i].FileExt; |
Import := OS IN {osWIN32, osWIN64, osKOS}; |
Dispose := ~(target IN noDISPOSE); |
RTL := ~(target IN noRTL); |
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL}; |
WordSize := BitDepth DIV 8; |
AdrSize := WordSize |
END |
RETURN res |
END Select; |
PROCEDURE EnterCPU (cpu, BitDepth, InstrSize: INTEGER; LittleEndian: BOOLEAN); |
BEGIN |
CPUs[cpu].BitDepth := BitDepth; |
CPUs[cpu].InstrSize := InstrSize; |
CPUs[cpu].LittleEndian := LittleEndian |
END EnterCPU; |
BEGIN |
EnterCPU(cpuX86, 32, 1, TRUE); |
EnterCPU(cpuAMD64, 64, 1, TRUE); |
EnterCPU(cpuMSP430, 16, 2, TRUE); |
EnterCPU(cpuTHUMB, 32, 2, TRUE); |
EnterCPU(cpuRVM32I, 32, 4, TRUE); |
EnterCPU(cpuRVM64I, 64, 8, TRUE); |
Enter( MSP430, cpuMSP430, 0, osNONE, "msp430", "MSP430", ".hex"); |
Enter( Win32C, cpuX86, 8, osWIN32, "win32con", "Windows", ".exe"); |
Enter( Win32GUI, cpuX86, 8, osWIN32, "win32gui", "Windows", ".exe"); |
Enter( Win32DLL, cpuX86, 8, osWIN32, "win32dll", "Windows", ".dll"); |
Enter( KolibriOS, cpuX86, 8, osKOS, "kosexe", "KolibriOS", ""); |
Enter( KolibriOSDLL, cpuX86, 8, osKOS, "kosdll", "KolibriOS", ".obj"); |
Enter( Win64C, cpuAMD64, 8, osWIN64, "win64con", "Windows", ".exe"); |
Enter( Win64GUI, cpuAMD64, 8, osWIN64, "win64gui", "Windows", ".exe"); |
Enter( Win64DLL, cpuAMD64, 8, osWIN64, "win64dll", "Windows", ".dll"); |
Enter( Linux32, cpuX86, 8, osLINUX32, "linux32exe", "Linux", ""); |
Enter( Linux32SO, cpuX86, 8, osLINUX32, "linux32so", "Linux", ".so"); |
Enter( Linux64, cpuAMD64, 8, osLINUX64, "linux64exe", "Linux", ""); |
Enter( Linux64SO, cpuAMD64, 8, osLINUX64, "linux64so", "Linux", ".so"); |
Enter( STM32CM3, cpuTHUMB, 4, osNONE, "stm32cm3", "STM32CM3", ".hex"); |
Enter( RVM32I, cpuRVM32I, 4, osNONE, "rvm32i", libRVM32I, ".bin"); |
Enter( RVM64I, cpuRVM64I, 8, osNONE, "rvm64i", libRVM64I, ".bin"); |
END TARGETS. |
/programs/develop/oberon07/source/THUMB.ob07 |
---|
0,0 → 1,2466 |
(* |
BSD 2-Clause License |
Copyright (c) 2019-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE THUMB; |
IMPORT PROG, LISTS, CHL := CHUNKLISTS, BIN, REG, IL, C := CONSOLE, |
UTILS, WR := WRITER, HEX, ERRORS, TARGETS; |
CONST |
R0 = 0; R1 = 1; R2 = 2; R3 = 3; R4 = 4; |
SP = 13; LR = 14; PC = 15; |
ACC = R0; |
je = 0; jne = 1; jnb = 2; jb = 3; jge = 10; jl = 11; jg = 12; jle = 13; |
inf = 7F800000H; |
minROM* = 16; maxROM* = 65536; |
minRAM* = 4; maxRAM* = 65536; |
maxIVT* = 1023; |
_THUMB2 = 0; _IT = 1; _SDIV = 2; _CBXZ = 3; |
CortexM0 = {}; |
CortexM1 = {}; |
CortexM3 = {_THUMB2, _IT, _SDIV, _CBXZ}; |
CortexM23 = {_SDIV, _CBXZ}; |
TYPE |
COMMAND = IL.COMMAND; |
ANYCODE = POINTER TO RECORD (LISTS.ITEM) |
offset: INTEGER |
END; |
CODE = POINTER TO RECORD (ANYCODE) |
code: INTEGER |
END; |
LABEL = POINTER TO RECORD (ANYCODE) |
label: INTEGER |
END; |
JUMP = POINTER TO RECORD (ANYCODE) |
label, diff, len, cond: INTEGER; |
short: BOOLEAN |
END; |
JMP = POINTER TO RECORD (JUMP) |
END; |
JCC = POINTER TO RECORD (JUMP) |
END; |
CBXZ = POINTER TO RECORD (JUMP) |
reg: INTEGER |
END; |
CALL = POINTER TO RECORD (JUMP) |
END; |
RELOC = POINTER TO RECORD (ANYCODE) |
reg, rel, value: INTEGER |
END; |
RELOCCODE = ARRAY 7 OF INTEGER; |
VAR |
R: REG.REGS; |
tcount: INTEGER; |
CodeList: LISTS.LIST; |
program: BIN.PROGRAM; |
StkCount: INTEGER; |
Target: RECORD |
FlashAdr, |
SRAMAdr, |
IVTLen, |
MinStack, |
Reserved: INTEGER; |
InstrSet: SET; |
isNXP: BOOLEAN |
END; |
IVT: ARRAY maxIVT + 1 OF INTEGER; |
sdivProc, trap, genTrap, entry, emptyProc, int0, genInt: INTEGER; |
PROCEDURE Code (code: INTEGER); |
VAR |
c: CODE; |
BEGIN |
NEW(c); |
c.code := code; |
LISTS.push(CodeList, c) |
END Code; |
PROCEDURE Label (label: INTEGER); |
VAR |
L: LABEL; |
BEGIN |
NEW(L); |
L.label := label; |
LISTS.push(CodeList, L) |
END Label; |
PROCEDURE jcc (cond, label: INTEGER); |
VAR |
j: JCC; |
BEGIN |
NEW(j); |
j.label := label; |
j.cond := cond; |
j.short := FALSE; |
j.len := 3; |
LISTS.push(CodeList, j) |
END jcc; |
PROCEDURE cbxz (cond, reg, label: INTEGER); |
VAR |
j: CBXZ; |
BEGIN |
NEW(j); |
j.label := label; |
j.cond := cond; |
j.reg := reg; |
j.short := FALSE; |
j.len := 4; |
LISTS.push(CodeList, j) |
END cbxz; |
PROCEDURE jmp (label: INTEGER); |
VAR |
j: JMP; |
BEGIN |
NEW(j); |
j.label := label; |
j.short := FALSE; |
j.len := 2; |
LISTS.push(CodeList, j) |
END jmp; |
PROCEDURE call (label: INTEGER); |
VAR |
c: CALL; |
BEGIN |
NEW(c); |
c.label := label; |
c.short := FALSE; |
c.len := 2; |
LISTS.push(CodeList, c) |
END call; |
PROCEDURE reloc (reg, rel, value: INTEGER); |
VAR |
r: RELOC; |
BEGIN |
NEW(r); |
r.reg := reg; |
r.rel := rel; |
r.value := value; |
LISTS.push(CodeList, r) |
END reloc; |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
BIN.NewLabel(program) |
RETURN IL.NewLabel() |
END NewLabel; |
PROCEDURE range (x, n: INTEGER): BOOLEAN; |
RETURN (0 <= x) & (x < LSL(1, n)) |
END range; |
PROCEDURE srange (x, n: INTEGER): BOOLEAN; |
RETURN (-LSL(1, n - 1) <= x) & (x < LSL(1, n - 1)) |
END srange; |
PROCEDURE gen1 (op, imm, rs, rd: INTEGER); |
BEGIN |
ASSERT(op IN {0..2}); |
ASSERT(range(imm, 5)); |
ASSERT(range(rs, 3)); |
ASSERT(range(rd, 3)); |
Code(LSL(op, 11) + LSL(imm, 6) + LSL(rs, 3) + rd) |
END gen1; |
PROCEDURE gen2 (i, op: BOOLEAN; imm, rs, rd: INTEGER); |
BEGIN |
ASSERT(range(imm, 3)); |
ASSERT(range(rs, 3)); |
ASSERT(range(rd, 3)); |
Code(1800H + LSL(ORD(i), 10) + LSL(ORD(op), 9) + LSL(imm, 6) + LSL(rs, 3) + rd) |
END gen2; |
PROCEDURE gen3 (op, rd, imm: INTEGER); |
BEGIN |
ASSERT(range(op, 2)); |
ASSERT(range(rd, 3)); |
ASSERT(range(imm, 8)); |
Code(2000H + LSL(op, 11) + LSL(rd, 8) + imm) |
END gen3; |
PROCEDURE gen4 (op, rs, rd: INTEGER); |
BEGIN |
ASSERT(range(op, 4)); |
ASSERT(range(rs, 3)); |
ASSERT(range(rd, 3)); |
Code(4000H + LSL(op, 6) + LSL(rs, 3) + rd) |
END gen4; |
PROCEDURE gen5 (op: INTEGER; h1, h2: BOOLEAN; rs, rd: INTEGER); |
BEGIN |
ASSERT(range(op, 2)); |
ASSERT(range(rs, 3)); |
ASSERT(range(rd, 3)); |
Code(4400H + LSL(op, 8) + LSL(ORD(h1), 7) + LSL(ORD(h2), 6) + LSL(rs, 3) + rd) |
END gen5; |
PROCEDURE gen7 (l, b: BOOLEAN; ro, rb, rd: INTEGER); |
BEGIN |
ASSERT(range(ro, 3)); |
ASSERT(range(rb, 3)); |
ASSERT(range(rd, 3)); |
Code(5000H + LSL(ORD(l), 11) + LSL(ORD(b), 10) + LSL(ro, 6) + LSL(rb, 3) + rd) |
END gen7; |
PROCEDURE gen8 (h, s: BOOLEAN; ro, rb, rd: INTEGER); |
BEGIN |
ASSERT(range(ro, 3)); |
ASSERT(range(rb, 3)); |
ASSERT(range(rd, 3)); |
Code(5200H + LSL(ORD(h), 11) + LSL(ORD(s), 10) + LSL(ro, 6) + LSL(rb, 3) + rd) |
END gen8; |
PROCEDURE gen9 (b, l: BOOLEAN; imm, rb, rd: INTEGER); |
BEGIN |
ASSERT(range(imm, 5)); |
ASSERT(range(rb, 3)); |
ASSERT(range(rd, 3)); |
Code(6000H + LSL(ORD(b), 12) + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd) |
END gen9; |
PROCEDURE gen10 (l: BOOLEAN; imm, rb, rd: INTEGER); |
BEGIN |
ASSERT(range(imm, 5)); |
ASSERT(range(rb, 3)); |
ASSERT(range(rd, 3)); |
Code(8000H + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd) |
END gen10; |
PROCEDURE gen11 (l: BOOLEAN; rd, imm: INTEGER); |
BEGIN |
ASSERT(range(rd, 3)); |
ASSERT(range(imm, 8)); |
Code(9000H + LSL(ORD(l), 11) + LSL(rd, 8) + imm) |
END gen11; |
PROCEDURE gen12 (sp: BOOLEAN; rd, imm: INTEGER); |
BEGIN |
ASSERT(range(rd, 3)); |
ASSERT(range(imm, 8)); |
Code(0A000H + LSL(ORD(sp), 11) + LSL(rd, 8) + imm) |
END gen12; |
PROCEDURE gen14 (l, r: BOOLEAN; rlist: SET); |
VAR |
i, n: INTEGER; |
BEGIN |
ASSERT(range(ORD(rlist), 8)); |
n := ORD(r); |
FOR i := 0 TO 7 DO |
IF i IN rlist THEN |
INC(n) |
END |
END; |
IF l THEN |
n := -n |
END; |
INC(StkCount, n); |
Code(0B400H + LSL(ORD(l), 11) + LSL(ORD(r), 8) + ORD(rlist)) |
END gen14; |
PROCEDURE split16 (imm16: INTEGER; VAR imm4, imm1, imm3, imm8: INTEGER); |
BEGIN |
ASSERT(range(imm16, 16)); |
imm8 := imm16 MOD 256; |
imm4 := LSR(imm16, 12); |
imm3 := LSR(imm16, 8) MOD 8; |
imm1 := LSR(imm16, 11) MOD 2; |
END split16; |
PROCEDURE LslImm (r, imm5: INTEGER); |
BEGIN |
gen1(0, imm5, r, r) |
END LslImm; |
PROCEDURE LsrImm (r, imm5: INTEGER); |
BEGIN |
gen1(1, imm5, r, r) |
END LsrImm; |
PROCEDURE AsrImm (r, imm5: INTEGER); |
BEGIN |
gen1(2, imm5, r, r) |
END AsrImm; |
PROCEDURE AddReg (rd, rs, rn: INTEGER); |
BEGIN |
gen2(FALSE, FALSE, rn, rs, rd) |
END AddReg; |
PROCEDURE SubReg (rd, rs, rn: INTEGER); |
BEGIN |
gen2(FALSE, TRUE, rn, rs, rd) |
END SubReg; |
PROCEDURE AddImm8 (rd, imm8: INTEGER); |
BEGIN |
IF imm8 # 0 THEN |
gen3(2, rd, imm8) |
END |
END AddImm8; |
PROCEDURE SubImm8 (rd, imm8: INTEGER); |
BEGIN |
IF imm8 # 0 THEN |
gen3(3, rd, imm8) |
END |
END SubImm8; |
PROCEDURE AddSubImm12 (r, imm12: INTEGER; sub: BOOLEAN); |
VAR |
imm4, imm1, imm3, imm8: INTEGER; |
BEGIN |
split16(imm12, imm4, imm1, imm3, imm8); |
Code(0F200H + LSL(imm1, 10) + r + 0A0H * ORD(sub)); (* addw/subw r, r, imm12 *) |
Code(LSL(imm3, 12) + LSL(r, 8) + imm8) |
END AddSubImm12; |
PROCEDURE MovImm8 (rd, imm8: INTEGER); |
BEGIN |
gen3(0, rd, imm8) |
END MovImm8; |
PROCEDURE CmpImm8 (rd, imm8: INTEGER); |
BEGIN |
gen3(1, rd, imm8) |
END CmpImm8; |
PROCEDURE Neg (r: INTEGER); |
BEGIN |
gen4(9, r, r) |
END Neg; |
PROCEDURE Mul (rd, rs: INTEGER); |
BEGIN |
gen4(13, rs, rd) |
END Mul; |
PROCEDURE Str32 (rs, rb: INTEGER); |
BEGIN |
gen9(FALSE, FALSE, 0, rb, rs) |
END Str32; |
PROCEDURE Ldr32 (rd, rb: INTEGER); |
BEGIN |
gen9(FALSE, TRUE, 0, rb, rd) |
END Ldr32; |
PROCEDURE Str16 (rs, rb: INTEGER); |
BEGIN |
gen10(FALSE, 0, rb, rs) |
END Str16; |
PROCEDURE Ldr16 (rd, rb: INTEGER); |
BEGIN |
gen10(TRUE, 0, rb, rd) |
END Ldr16; |
PROCEDURE Str8 (rs, rb: INTEGER); |
BEGIN |
gen9(TRUE, FALSE, 0, rb, rs) |
END Str8; |
PROCEDURE Ldr8 (rd, rb: INTEGER); |
BEGIN |
gen9(TRUE, TRUE, 0, rb, rd) |
END Ldr8; |
PROCEDURE Cmp (r1, r2: INTEGER); |
BEGIN |
gen4(10, r2, r1) |
END Cmp; |
PROCEDURE Tst (r: INTEGER); |
BEGIN |
gen3(1, r, 0) (* cmp r, 0 *) |
END Tst; |
PROCEDURE LdrSp (r, offset: INTEGER); |
BEGIN |
gen11(TRUE, r, offset) |
END LdrSp; |
PROCEDURE MovImm32 (r, imm32: INTEGER); |
BEGIN |
MovImm8(r, LSR(imm32, 24) MOD 256); |
LslImm(r, 8); |
AddImm8(r, LSR(imm32, 16) MOD 256); |
LslImm(r, 8); |
AddImm8(r, LSR(imm32, 8) MOD 256); |
LslImm(r, 8); |
AddImm8(r, imm32 MOD 256) |
END MovImm32; |
PROCEDURE low (x: INTEGER): INTEGER; |
RETURN x MOD 65536 |
END low; |
PROCEDURE high (x: INTEGER): INTEGER; |
RETURN (x DIV 65536) MOD 65536 |
END high; |
PROCEDURE movwt (r, imm16, t: INTEGER); |
VAR |
imm1, imm3, imm4, imm8: INTEGER; |
BEGIN |
ASSERT(range(r, 3)); |
ASSERT(range(imm16, 16)); |
ASSERT(range(t, 1)); |
split16(imm16, imm4, imm1, imm3, imm8); |
Code(0F240H + imm1 * 1024 + t * 128 + imm4); |
Code(imm3 * 4096 + r * 256 + imm8); |
END movwt; |
PROCEDURE inv0 (cond: INTEGER): INTEGER; |
RETURN ORD(BITS(cond) / {0}) |
END inv0; |
PROCEDURE fixup (CodeAdr, DataAdr, BssAdr: INTEGER); |
VAR |
code: ANYCODE; |
count: INTEGER; |
shorted: BOOLEAN; |
jump: JUMP; |
reloc, i, diff, len: INTEGER; |
RelocCode: RELOCCODE; |
PROCEDURE genjcc (cond, offset: INTEGER): INTEGER; |
BEGIN |
ASSERT(range(cond, 4)); |
ASSERT(srange(offset, 8)) |
RETURN 0D000H + cond * 256 + offset MOD 256 |
END genjcc; |
PROCEDURE genjmp (offset: INTEGER): INTEGER; |
BEGIN |
ASSERT(srange(offset, 11)) |
RETURN 0E000H + offset MOD 2048 |
END genjmp; |
PROCEDURE movwt (r, imm16, t: INTEGER; VAR code: RELOCCODE); |
VAR |
imm1, imm3, imm4, imm8: INTEGER; |
BEGIN |
split16(imm16, imm4, imm1, imm3, imm8); |
code[t * 2] := 0F240H + imm1 * 1024 + t * 128 + imm4; |
code[t * 2 + 1] := imm3 * 4096 + r * 256 + imm8 |
END movwt; |
PROCEDURE genmovimm32 (r, value: INTEGER; VAR code: RELOCCODE); |
BEGIN |
IF _THUMB2 IN Target.InstrSet THEN |
movwt(r, low(value), 0, code); |
movwt(r, high(value), 1, code) |
ELSE |
code[0] := 2000H + r * 256 + UTILS.Byte(value, 3); (* movs r, imm8 *) |
code[1] := 0200H + r * 9; (* lsls r, 8 *) |
code[2] := 3000H + r * 256 + UTILS.Byte(value, 2); (* adds r, imm8 *) |
code[3] := code[1]; (* lsls r, 8 *) |
code[4] := 3000H + r * 256 + UTILS.Byte(value, 1); (* adds r, imm8 *) |
code[5] := code[1]; (* lsls r, 8 *) |
code[6] := 3000H + r * 256 + UTILS.Byte(value, 0) (* adds r, imm8 *) |
END |
END genmovimm32; |
PROCEDURE PutCode (code: INTEGER); |
BEGIN |
BIN.PutCode16LE(program, code) |
END PutCode; |
PROCEDURE genlongjmp (offset: INTEGER); |
BEGIN |
ASSERT(srange(offset, 22)); |
PutCode(0F000H + ASR(offset, 11) MOD 2048); |
PutCode(0F800H + offset MOD 2048) |
END genlongjmp; |
PROCEDURE genbc (code: JUMP); |
BEGIN |
CASE code.len OF |
|1: PutCode(genjcc(code.cond, code.diff)) |
|2: PutCode(genjcc(inv0(code.cond), 0)); |
PutCode(genjmp(code.diff)) |
|3: PutCode(genjcc(inv0(code.cond), 1)); |
genlongjmp(code.diff) |
END |
END genbc; |
PROCEDURE SetIV (idx, label, CodeAdr: INTEGER); |
VAR |
l, h: LISTS.ITEM; |
BEGIN |
l := CodeList.first; |
h := l.next; |
WHILE idx > 0 DO |
l := h.next; |
h := l.next; |
DEC(idx) |
END; |
label := BIN.GetLabel(program, label) * 2 + CodeAdr + 1; |
l(CODE).code := low(label); |
h(CODE).code := high(label) |
END SetIV; |
BEGIN |
REPEAT |
shorted := FALSE; |
count := 0; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
code.offset := count; |
CASE code OF |
|CODE: INC(count) |
|LABEL: BIN.SetLabel(program, code.label, count) |
|JUMP: INC(count, code.len); code.offset := count + ORD(code.short) |
|RELOC: INC(count, 7 - ORD(_THUMB2 IN Target.InstrSet) * 3 + code.rel MOD 2) |
END; |
code := code.next(ANYCODE) |
END; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
IF code IS JUMP THEN |
jump := code(JUMP); |
jump.diff := BIN.GetLabel(program, jump.label) - jump.offset; |
len := jump.len; |
diff := jump.diff; |
CASE jump OF |
|JMP: |
IF (len = 2) & srange(diff, 11) THEN |
len := 1 |
END |
|JCC: |
CASE len OF |
|1: |
|2: IF srange(diff, 8) THEN DEC(len) END |
|3: IF srange(diff, 11) THEN DEC(len) END |
END |
|CBXZ: |
CASE len OF |
|1: |
|2: IF range(diff, 6) THEN DEC(len) END |
|3: IF srange(diff, 8) THEN DEC(len) END |
|4: IF srange(diff, 11) THEN DEC(len) END |
END |
|CALL: |
END; |
IF len # jump.len THEN |
jump.len := len; |
jump.short := TRUE; |
shorted := TRUE |
END |
END; |
code := code.next(ANYCODE) |
END |
UNTIL ~shorted; |
FOR i := 1 TO Target.IVTLen - 1 DO |
SetIV(i, IVT[i], CodeAdr) |
END; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
CASE code OF |
|CODE: BIN.PutCode16LE(program, code.code) |
|LABEL: |
|JMP: |
IF code.len = 1 THEN |
PutCode(genjmp(code.diff)) |
ELSE |
genlongjmp(code.diff) |
END |
|JCC: genbc(code) |
|CBXZ: |
IF code.len > 1 THEN |
PutCode(2800H + code.reg * 256); (* cmp code.reg, 0 *) |
DEC(code.len); |
genbc(code) |
ELSE |
(* cb(n)z code.reg, L *) |
PutCode(0B100H + 800H * ORD(code.cond = jne) + 200H * (code.diff DIV 32) + (code.diff MOD 32) * 8 + code.reg) |
END |
|CALL: genlongjmp(code.diff) |
|RELOC: |
CASE code.rel OF |
|BIN.RCODE, BIN.PICCODE: reloc := BIN.GetLabel(program, code.value) * 2 + CodeAdr |
|BIN.RDATA, BIN.PICDATA: reloc := code.value + DataAdr |
|BIN.RBSS, BIN.PICBSS: reloc := code.value + BssAdr |
END; |
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN |
DEC(reloc, CodeAdr + 2 * (code.offset - 3 * ORD(_THUMB2 IN Target.InstrSet) + 9)) |
END; |
genmovimm32(code.reg, reloc, RelocCode); |
FOR i := 0 TO 6 - 3 * ORD(_THUMB2 IN Target.InstrSet) DO |
PutCode(RelocCode[i]) |
END; |
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN |
PutCode(4478H + code.reg) (* add code.reg, pc *) |
END |
END; |
code := code.next(ANYCODE) |
END |
END fixup; |
PROCEDURE push (r: INTEGER); |
BEGIN |
gen14(FALSE, FALSE, {r}) |
END push; |
PROCEDURE pop (r: INTEGER); |
BEGIN |
gen14(TRUE, FALSE, {r}) |
END pop; |
PROCEDURE mov (r1, r2: INTEGER); |
BEGIN |
IF (r1 < 8) & (r2 < 8) THEN |
gen1(0, 0, r2, r1) |
ELSE |
gen5(2, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8) |
END |
END mov; |
PROCEDURE xchg (r1, r2: INTEGER); |
BEGIN |
push(r1); |
mov(r1, r2); |
pop(r2) |
END xchg; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE UnOp (VAR r: INTEGER); |
BEGIN |
REG.UnOp(R, r) |
END UnOp; |
PROCEDURE BinOp (VAR r1, r2: INTEGER); |
BEGIN |
REG.BinOp(R, r1, r2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE cond (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|IL.opGT, IL.opGTC: res := jg |
|IL.opGE, IL.opGEC: res := jge |
|IL.opLT, IL.opLTC: res := jl |
|IL.opLE, IL.opLEC: res := jle |
|IL.opEQ, IL.opEQC: res := je |
|IL.opNE, IL.opNEC: res := jne |
END |
RETURN res |
END cond; |
PROCEDURE GetRegA; |
BEGIN |
ASSERT(REG.GetReg(R, ACC)) |
END GetRegA; |
PROCEDURE MovConst (r, c: INTEGER); |
BEGIN |
IF (0 <= c) & (c <= 255) THEN |
MovImm8(r, c) |
ELSIF (-255 <= c) & (c < 0) THEN |
MovImm8(r, -c); |
Neg(r) |
ELSIF UTILS.Log2(c) >= 0 THEN |
MovImm8(r, 1); |
LslImm(r, UTILS.Log2(c)) |
ELSIF c = UTILS.min32 THEN |
MovImm8(r, 1); |
LslImm(r, 31) |
ELSE |
IF _THUMB2 IN Target.InstrSet THEN |
movwt(r, low(c), 0); |
IF (c < 0) OR (c > 65535) THEN |
movwt(r, high(c), 1) |
END |
ELSE |
MovImm32(r, c) |
END |
END |
END MovConst; |
PROCEDURE CmpConst (r, c: INTEGER); |
VAR |
r2: INTEGER; |
BEGIN |
IF (0 <= c) & (c <= 255) THEN |
CmpImm8(r, c) |
ELSE |
r2 := GetAnyReg(); |
ASSERT(r2 # r); |
MovConst(r2, c); |
Cmp(r, r2); |
drop |
END |
END CmpConst; |
PROCEDURE LocalOffset (offset: INTEGER): INTEGER; |
RETURN offset + StkCount - ORD(offset > 0) |
END LocalOffset; |
PROCEDURE SetCC (cc, r: INTEGER); |
VAR |
L1, L2: INTEGER; |
BEGIN |
IF _IT IN Target.InstrSet THEN |
Code(0BF00H + cc * 16 + ((cc + 1) MOD 2) * 8 + 4); (* ite cc *) |
MovConst(r, 1); |
MovConst(r, 0) |
ELSE |
L1 := NewLabel(); |
L2 := NewLabel(); |
jcc(cc, L1); |
MovConst(r, 0); |
jmp(L2); |
Label(L1); |
MovConst(r, 1); |
Label(L2) |
END |
END SetCC; |
PROCEDURE PushConst (n: INTEGER); |
VAR |
r: INTEGER; |
BEGIN |
r := GetAnyReg(); |
MovConst(r, n); |
push(r); |
drop |
END PushConst; |
PROCEDURE AddConst (r, n: INTEGER); |
VAR |
r2: INTEGER; |
BEGIN |
IF n # 0 THEN |
IF (-255 <= n) & (n <= 255) THEN |
IF n > 0 THEN |
AddImm8(r, n) |
ELSE |
SubImm8(r, -n) |
END |
ELSIF (_THUMB2 IN Target.InstrSet) & (-4095 <= n) & (n <= 4095) THEN |
AddSubImm12(r, ABS(n), n < 0) |
ELSE |
r2 := GetAnyReg(); |
ASSERT(r2 # r); |
IF n > 0 THEN |
MovConst(r2, n); |
AddReg(r, r, r2) |
ELSE |
MovConst(r2, -n); |
SubReg(r, r, r2) |
END; |
drop |
END |
END |
END AddConst; |
PROCEDURE AddHH (r1, r2: INTEGER); |
BEGIN |
ASSERT((r1 >= 8) OR (r2 >= 8)); |
gen5(0, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8) |
END AddHH; |
PROCEDURE AddSP (n: INTEGER); |
BEGIN |
IF n > 0 THEN |
IF n < 127 THEN |
Code(0B000H + n) (* add sp, n*4 *) |
ELSE |
ASSERT(R2 IN R.regs); |
MovConst(R2, n * 4); |
AddHH(SP, R2) |
END; |
DEC(StkCount, n) |
END |
END AddSP; |
PROCEDURE cbxz2 (c, r, label: INTEGER); |
BEGIN |
IF _CBXZ IN Target.InstrSet THEN |
cbxz(c, r, label) |
ELSE |
Tst(r); |
jcc(c, label) |
END |
END cbxz2; |
PROCEDURE cbz (r, label: INTEGER); |
BEGIN |
cbxz2(je, r, label) |
END cbz; |
PROCEDURE cbnz (r, label: INTEGER); |
BEGIN |
cbxz2(jne, r, label) |
END cbnz; |
PROCEDURE Shift (op, r1, r2: INTEGER); |
VAR |
L: INTEGER; |
BEGIN |
LslImm(r2, 27); |
LsrImm(r2, 27); |
L := NewLabel(); |
cbz(r2, L); |
CASE op OF |
|IL.opLSL, IL.opLSL1: gen4(2, r2, r1) |
|IL.opLSR, IL.opLSR1: gen4(3, r2, r1) |
|IL.opASR, IL.opASR1: gen4(4, r2, r1) |
|IL.opROR, IL.opROR1: gen4(7, r2, r1) |
END; |
Label(L) |
END Shift; |
PROCEDURE LocAdr (offs: INTEGER); |
VAR |
r1, n: INTEGER; |
BEGIN |
r1 := GetAnyReg(); |
n := LocalOffset(offs); |
IF n <= 255 THEN |
gen12(TRUE, r1, n) |
ELSE |
MovConst(r1, n * 4); |
AddHH(r1, SP) |
END |
END LocAdr; |
PROCEDURE CallRTL (proc, par: INTEGER); |
BEGIN |
call(IL.codes.rtl[proc]); |
AddSP(par) |
END CallRTL; |
PROCEDURE divmod; |
BEGIN |
call(sdivProc); |
AddSP(2) |
END divmod; |
PROCEDURE cpsid_i; |
BEGIN |
Code(0B672H) (* cpsid i *) |
END cpsid_i; |
PROCEDURE cpsie_i; |
BEGIN |
Code(0B662H) (* cpsie i *) |
END cpsie_i; |
PROCEDURE translate (pic, stroffs: INTEGER); |
VAR |
cmd, next: COMMAND; |
opcode, param1, param2: INTEGER; |
r1, r2, r3: INTEGER; |
a, n, cc, L, L2: INTEGER; |
BEGIN |
cmd := IL.codes.commands.first(COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
jmp(param1) |
|IL.opLABEL: |
Label(param1) |
|IL.opHANDLER: |
IF param2 = 0 THEN |
int0 := param1 |
ELSIF param2 = 1 THEN |
trap := param1 |
ELSE |
IVT[param2] := param1 |
END |
|IL.opCALL: |
call(param1) |
|IL.opCALLP: |
UnOp(r1); |
AddImm8(r1, 1); (* Thumb mode *) |
gen5(3, TRUE, FALSE, r1, 0); (* blx r1 *) |
drop; |
ASSERT(R.top = -1) |
|IL.opENTER: |
ASSERT(R.top = -1); |
Label(param1); |
gen14(FALSE, TRUE, {}); (* push {lr} *) |
n := param2; |
IF n >= 5 THEN |
MovConst(ACC, 0); |
MovConst(R2, n); |
L := NewLabel(); |
Label(L); |
push(ACC); |
SubImm8(R2, 1); |
Tst(R2); |
jcc(jne, L) |
ELSIF n > 0 THEN |
MovConst(ACC, 0); |
WHILE n > 0 DO |
push(ACC); |
DEC(n) |
END |
END; |
StkCount := param2 |
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF: |
IF opcode # IL.opLEAVE THEN |
UnOp(r1); |
IF r1 # ACC THEN |
mov(ACC, r1) |
END; |
drop |
END; |
ASSERT(R.top = -1); |
ASSERT(StkCount = param1); |
AddSP(param1); |
gen14(TRUE, TRUE, {}) (* pop {pc} *) |
|IL.opLEAVEC: |
gen5(3, FALSE, TRUE, 6, 0) (* bx lr *) |
|IL.opPRECALL: |
PushAll(0) |
|IL.opPARAM: |
n := param2; |
IF n = 1 THEN |
UnOp(r1); |
push(r1); |
drop |
ELSE |
ASSERT(R.top + 1 <= n); |
PushAll(n) |
END |
|IL.opCLEANUP: |
AddSP(param2) |
|IL.opRES, IL.opRESF: |
ASSERT(R.top = -1); |
GetRegA |
|IL.opPUSHC: |
PushConst(param2) |
|IL.opONERR: |
cpsid_i; |
MovConst(R0, param2); |
push(R0); |
DEC(StkCount); |
jmp(param1) |
|IL.opERR: |
call(genTrap) |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opSADR: |
reloc(GetAnyReg(), BIN.RDATA + pic, stroffs + param2) |
|IL.opGADR: |
reloc(GetAnyReg(), BIN.RBSS + pic, param2) |
|IL.opLADR: |
LocAdr(param2) |
|IL.opGLOAD32: |
r1 := GetAnyReg(); |
reloc(r1, BIN.RBSS + pic, param2); |
Ldr32(r1, r1) |
|IL.opGLOAD16: |
r1 := GetAnyReg(); |
reloc(r1, BIN.RBSS + pic, param2); |
Ldr16(r1, r1) |
|IL.opGLOAD8: |
r1 := GetAnyReg(); |
reloc(r1, BIN.RBSS + pic, param2); |
Ldr8(r1, r1) |
|IL.opLADR_SAVE: |
UnOp(r1); |
n := LocalOffset(param2); |
IF n <= 255 THEN |
gen11(FALSE, r1, n) (* str r1, [sp, n*4] *) |
ELSE |
LocAdr(param2); |
BinOp(r1, r2); |
Str32(r1, r2); |
drop |
END; |
drop |
|IL.opLADR_INCC: |
n := LocalOffset(param1); |
IF n <= 255 THEN |
r1 := GetAnyReg(); |
LdrSp(r1, n); |
AddConst(r1, param2); |
gen11(FALSE, r1, n) (* str r1, [sp, n*4] *) |
ELSE |
LocAdr(param1); |
r1 := GetAnyReg(); |
BinOp(r2, r1); |
Ldr32(r1, r2); |
AddConst(r1, param2); |
BinOp(r2, r1); |
Str32(r1, r2); |
drop |
END; |
drop |
|IL.opLLOAD32, IL.opVADR, IL.opVLOAD32: |
r1 := GetAnyReg(); |
n := LocalOffset(param2); |
IF n <= 255 THEN |
LdrSp(r1, n) |
ELSE |
drop; |
LocAdr(param2); |
UnOp(r1); |
Ldr32(r1, r1) |
END; |
IF opcode = IL.opVLOAD32 THEN |
Ldr32(r1, r1) |
END |
|IL.opLLOAD16: |
LocAdr(param2); |
UnOp(r1); |
Ldr16(r1, r1) |
|IL.opLLOAD8: |
LocAdr(param2); |
UnOp(r1); |
Ldr8(r1, r1) |
|IL.opLOAD32, IL.opLOADF: |
UnOp(r1); |
Ldr32(r1, r1) |
|IL.opLOAD16: |
UnOp(r1); |
Ldr16(r1, r1) |
|IL.opLOAD8: |
UnOp(r1); |
Ldr8(r1, r1) |
|IL.opVLOAD16: |
LocAdr(param2); |
UnOp(r1); |
Ldr32(r1, r1); |
Ldr16(r1, r1) |
|IL.opVLOAD8: |
LocAdr(param2); |
UnOp(r1); |
Ldr32(r1, r1); |
Ldr8(r1, r1) |
|IL.opSBOOL: |
BinOp(r2, r1); |
Tst(r2); |
SetCC(jne, r2); |
Str8(r2, r1); |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, ORD(param2 # 0)); |
Str8(r2, r1); |
drop; |
drop |
|IL.opSAVEC: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, param2); |
Str32(r2, r1); |
drop; |
drop |
|IL.opSAVE16C: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, low(param2)); |
Str16(r2, r1); |
drop; |
drop |
|IL.opSAVE8C: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, param2 MOD 256); |
Str8(r2, r1); |
drop; |
drop |
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF: |
BinOp(r2, r1); |
Str32(r2, r1); |
drop; |
drop |
|IL.opSAVEFI: |
BinOp(r2, r1); |
Str32(r1, r2); |
drop; |
drop |
|IL.opSAVE16: |
BinOp(r2, r1); |
Str16(r2, r1); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(r2, r1); |
Str8(r2, r1); |
drop; |
drop |
|IL.opSAVEP: |
UnOp(r1); |
r2 := GetAnyReg(); |
reloc(r2, BIN.RCODE + pic, param2); |
Str32(r2, r1); |
drop; |
drop |
|IL.opPUSHP: |
reloc(GetAnyReg(), BIN.RCODE + pic, param2) |
|IL.opEQB, IL.opNEB: |
BinOp(r1, r2); |
drop; |
L := NewLabel(); |
cbz(r1, L); |
MovConst(r1, 1); |
Label(L); |
L := NewLabel(); |
cbz(r2, L); |
MovConst(r2, 1); |
Label(L); |
Cmp(r1, r2); |
IF opcode = IL.opEQB THEN |
SetCC(je, r1) |
ELSE |
SetCC(jne, r1) |
END |
|IL.opDROP: |
UnOp(r1); |
drop |
|IL.opJNZ1: |
UnOp(r1); |
cbnz(r1, param1) |
|IL.opJG: |
UnOp(r1); |
Tst(r1); |
jcc(jg, param1) |
|IL.opJNZ: |
UnOp(r1); |
cbnz(r1, param1); |
drop |
|IL.opJZ: |
UnOp(r1); |
cbz(r1, param1); |
drop |
|IL.opSWITCH: |
UnOp(r1); |
IF param2 = 0 THEN |
r2 := ACC |
ELSE |
r2 := R2 |
END; |
IF r1 # r2 THEN |
ASSERT(REG.GetReg(R, r2)); |
ASSERT(REG.Exchange(R, r1, r2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
GetRegA; |
CmpConst(ACC, param1); |
jcc(jl, param2); |
drop |
|IL.opCASER: |
GetRegA; |
CmpConst(ACC, param1); |
jcc(jg, param2); |
drop |
|IL.opCASELR: |
GetRegA; |
CmpConst(ACC, param1); |
IF param2 = cmd.param3 THEN |
jcc(jne, param2) |
ELSE |
jcc(jl, param2); |
jcc(jg, cmd.param3) |
END; |
drop |
|IL.opCODE: |
Code(param2) |
|IL.opEQ..IL.opGE, |
IL.opEQC..IL.opGEC: |
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN |
BinOp(r1, r2); |
Cmp(r1, r2); |
drop |
ELSE |
UnOp(r1); |
CmpConst(r1, param2) |
END; |
drop; |
cc := cond(opcode); |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opJNZ THEN |
jcc(cc, next.param1); |
cmd := next |
ELSIF next.opcode = IL.opJZ THEN |
jcc(inv0(cc), next.param1); |
cmd := next |
ELSE |
SetCC(cc, GetAnyReg()) |
END |
|IL.opINCC: |
UnOp(r1); |
r2 := GetAnyReg(); |
Ldr32(r2, r1); |
AddConst(r2, param2); |
Str32(r2, r1); |
drop; |
drop |
|IL.opINCCB, IL.opDECCB: |
IF opcode = IL.opDECCB THEN |
param2 := -param2 |
END; |
UnOp(r1); |
r2 := GetAnyReg(); |
Ldr8(r2, r1); |
AddConst(r2, param2); |
Str8(r2, r1); |
drop; |
drop |
|IL.opUMINUS: |
UnOp(r1); |
Neg(r1) |
|IL.opADD: |
BinOp(r1, r2); |
CASE cmd.next(COMMAND).opcode OF |
|IL.opLOAD32, IL.opLOADF: |
gen7(TRUE, FALSE, r2, r1, r1); (* ldr r1, [r1, r2] *) |
cmd := cmd.next(COMMAND) |
|IL.opLOAD8: |
gen7(TRUE, TRUE, r2, r1, r1); (* ldrb r1, [r1, r2] *) |
cmd := cmd.next(COMMAND) |
|IL.opLOAD16: |
gen8(TRUE, FALSE, r2, r1, r1); (* ldrh r1, [r1, r2] *) |
cmd := cmd.next(COMMAND) |
ELSE |
AddReg(r1, r1, r2) |
END; |
drop |
|IL.opADDC: |
UnOp(r1); |
AddConst(r1, param2) |
|IL.opSUB: |
BinOp(r1, r2); |
SubReg(r1, r1, r2); |
drop |
|IL.opSUBL, IL.opSUBR: |
UnOp(r1); |
AddConst(r1, -param2); |
IF opcode = IL.opSUBL THEN |
Neg(r1) |
END |
|IL.opMUL: |
BinOp(r1, r2); |
Mul(r1, r2); |
drop |
|IL.opMULC: |
UnOp(r1); |
a := param2; |
IF a > 1 THEN |
n := UTILS.Log2(a) |
ELSIF a < -1 THEN |
n := UTILS.Log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
Neg(r1) |
ELSIF a = 0 THEN |
MovConst(r1, 0) |
ELSE |
IF n > 0 THEN |
IF a < 0 THEN |
Neg(r1) |
END; |
LslImm(r1, n) |
ELSE |
r2 := GetAnyReg(); |
MovConst(r2, a); |
Mul(r1, r2); |
drop |
END |
END |
|IL.opABS: |
UnOp(r1); |
Tst(r1); |
L := NewLabel(); |
jcc(jge, L); |
Neg(r1); |
Label(L) |
|IL.opNOT: |
UnOp(r1); |
Tst(r1); |
SetCC(je, r1) |
|IL.opORD: |
UnOp(r1); |
Tst(r1); |
SetCC(jne, r1) |
|IL.opCHR: |
UnOp(r1); |
Code(0B2C0H + r1 * 9) (* uxtb r1, r1 *) |
|IL.opWCHR: |
UnOp(r1); |
Code(0B280H + r1 * 9) (* uxth r1, r1 *) |
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR: |
BinOp(r1, r2); |
Shift(opcode, r1, r2); |
drop |
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1: |
MovConst(GetAnyReg(), param2); |
BinOp(r2, r1); |
Shift(opcode, r1, r2); |
INCL(R.regs, r2); |
DEC(R.top); |
R.stk[R.top] := r1 |
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2: |
n := param2 MOD 32; |
IF n # 0 THEN |
UnOp(r1); |
CASE opcode OF |
|IL.opASR2: AsrImm(r1, n) |
|IL.opROR2: r2 := GetAnyReg(); MovConst(r2, n); Shift(IL.opROR, r1, r2); drop |
|IL.opLSL2: LslImm(r1, n) |
|IL.opLSR2: LsrImm(r1, n) |
END |
END |
|IL.opCHKBYTE: |
BinOp(r1, r2); |
CmpConst(r1, 256); |
jcc(jb, param1) |
|IL.opCHKIDX: |
UnOp(r1); |
CmpConst(r1, param2); |
jcc(jb, param1) |
|IL.opCHKIDX2: |
BinOp(r1, r2); |
IF param2 # -1 THEN |
Cmp(r2, r1); |
jcc(jb, param1) |
END; |
INCL(R.regs, r1); |
DEC(R.top); |
R.stk[R.top] := r2 |
|IL.opLEN: |
n := param2; |
UnOp(r1); |
drop; |
EXCL(R.regs, r1); |
WHILE n > 0 DO |
UnOp(r2); |
drop; |
DEC(n) |
END; |
INCL(R.regs, r1); |
ASSERT(REG.GetReg(R, r1)) |
|IL.opINF: |
MovConst(GetAnyReg(), inf) |
|IL.opPUSHF: |
UnOp(r1); |
push(r1); |
drop |
|IL.opCONST: |
MovConst(GetAnyReg(), param2) |
|IL.opEQP, IL.opNEP: |
reloc(GetAnyReg(), BIN.RCODE + pic, param1); |
BinOp(r1, r2); |
Cmp(r1, r2); |
drop; |
IF opcode = IL.opEQP THEN |
SetCC(je, r1) |
ELSE |
SetCC(jne, r1) |
END |
|IL.opPUSHT: |
UnOp(r1); |
r2 := GetAnyReg(); |
mov(r2, r1); |
SubImm8(r2, 4); |
Ldr32(r2, r2) |
|IL.opGET, IL.opGETC: |
IF opcode = IL.opGET THEN |
BinOp(r1, r2) |
ELSIF opcode = IL.opGETC THEN |
UnOp(r2); |
r1 := GetAnyReg(); |
MovConst(r1, param1) |
END; |
drop; |
drop; |
CASE param2 OF |
|1: Ldr8(r1, r1); Str8(r1, r2) |
|2: Ldr16(r1, r1); Str16(r1, r2) |
|4: Ldr32(r1, r1); Str32(r1, r2) |
END |
|IL.opINC, IL.opDEC: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
Ldr32(r3, r1); |
IF opcode = IL.opINC THEN |
AddReg(r3, r3, r2) |
ELSE |
SubReg(r3, r3, r2) |
END; |
Str32(r3, r1); |
drop; |
drop; |
drop |
|IL.opINCB, IL.opDECB: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
Ldr8(r3, r1); |
IF opcode = IL.opINCB THEN |
AddReg(r3, r3, r2) |
ELSE |
SubReg(r3, r3, r2) |
END; |
Str8(r3, r1); |
drop; |
drop; |
drop |
|IL.opMIN, IL.opMAX: |
BinOp(r1, r2); |
Cmp(r1, r2); |
L := NewLabel(); |
IF opcode = IL.opMIN THEN |
cc := jle |
ELSE |
cc := jge |
END; |
jcc(cc, L); |
mov(r1, r2); |
Label(L); |
drop |
|IL.opMINC, IL.opMAXC: |
UnOp(r1); |
CmpConst(r1, param2); |
L := NewLabel(); |
IF opcode = IL.opMINC THEN |
cc := jle |
ELSE |
cc := jge |
END; |
jcc(cc, L); |
MovConst(r1, param2); |
Label(L) |
|IL.opMULS: |
BinOp(r1, r2); |
gen4(0, r2, r1); (* ands r1, r2 *) |
drop |
|IL.opMULSC: |
MovConst(GetAnyReg(), param2); |
BinOp(r1, r2); |
gen4(0, r2, r1); (* ands r1, r2 *) |
drop |
|IL.opDIVS: |
BinOp(r1, r2); |
gen4(1, r2, r1); (* eors r1, r2 *) |
drop |
|IL.opDIVSC: |
MovConst(GetAnyReg(), param2); |
BinOp(r1, r2); |
gen4(1, r2, r1); (* eors r1, r2 *) |
drop |
|IL.opADDS: |
BinOp(r1, r2); |
gen4(12, r2, r1); (* orrs r1, r2 *) |
drop |
|IL.opSUBS: |
BinOp(r1, r2); |
gen4(14, r2, r1); (* bics r1, r2 *) |
drop |
|IL.opADDSC: |
MovConst(GetAnyReg(), param2); |
BinOp(r1, r2); |
gen4(12, r2, r1); (* orrs r1, r2 *) |
drop |
|IL.opSUBSL: |
MovConst(GetAnyReg(), param2); |
BinOp(r1, r2); |
gen4(14, r1, r2); (* bics r2, r1 *) |
INCL(R.regs, r1); |
DEC(R.top); |
R.stk[R.top] := r2 |
|IL.opSUBSR: |
MovConst(GetAnyReg(), param2); |
BinOp(r1, r2); |
gen4(14, r2, r1); (* bics r1, r2 *) |
drop |
|IL.opUMINS: |
UnOp(r1); |
gen4(15, r1, r1) (* mvns r1, r1 *) |
|IL.opINCL, IL.opEXCL: |
BinOp(r1, r2); |
r3 := GetAnyReg(); |
MovConst(r3, 1); |
CmpConst(r1, 32); |
L := NewLabel(); |
jcc(jnb, L); |
gen4(2, r1, r3); (* lsls r3, r1 *) |
Ldr32(r1, r2); |
IF opcode = IL.opINCL THEN |
gen4(12, r3, r1) (* orrs r1, r3 *) |
ELSE |
gen4(14, r3, r1) (* bics r1, r3 *) |
END; |
Str32(r1, r2); |
Label(L); |
drop; |
drop; |
drop |
|IL.opINCLC, IL.opEXCLC: |
UnOp(r2); |
r1 := GetAnyReg(); |
r3 := GetAnyReg(); |
MovConst(r3, 1); |
LslImm(r3, param2); |
Ldr32(r1, r2); |
IF opcode = IL.opINCLC THEN |
gen4(12, r3, r1) (* orrs r1, r3 *) |
ELSE |
gen4(14, r3, r1) (* bics r1, r3 *) |
END; |
Str32(r1, r2); |
drop; |
drop; |
drop |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(IL._length, 2); |
GetRegA |
|IL.opLENGTHW: |
PushAll(2); |
CallRTL(IL._lengthw, 2); |
GetRegA |
|IL.opSAVES: |
UnOp(r2); |
REG.PushAll_1(R); |
r1 := GetAnyReg(); |
reloc(r1, BIN.RDATA + pic, stroffs + param2); |
push(r1); |
drop; |
push(r2); |
drop; |
PushConst(param1); |
CallRTL(IL._move, 3) |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
PushConst(opcode - IL.opEQS); |
CallRTL(IL._strcmp, 5); |
GetRegA |
|IL.opEQSW .. IL.opGESW: |
PushAll(4); |
PushConst(opcode - IL.opEQSW); |
CallRTL(IL._strcmpw, 5); |
GetRegA |
|IL.opCOPY: |
PushAll(2); |
PushConst(param2); |
CallRTL(IL._move, 3) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(IL._move, 3) |
|IL.opCOPYA: |
PushAll(4); |
PushConst(param2); |
CallRTL(IL._arrcpy, 5); |
GetRegA |
|IL.opCOPYS: |
PushAll(4); |
PushConst(param2); |
CallRTL(IL._strcpy, 5) |
|IL.opDIV: |
PushAll(2); |
divmod; |
GetRegA |
|IL.opDIVL: |
UnOp(r1); |
REG.PushAll_1(R); |
PushConst(param2); |
push(r1); |
drop; |
divmod; |
GetRegA |
|IL.opDIVR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(r1); |
AsrImm(r1, n) |
ELSIF n < 0 THEN |
PushAll(1); |
PushConst(param2); |
divmod; |
GetRegA |
END |
|IL.opMOD: |
PushAll(2); |
divmod; |
mov(R0, R1); |
GetRegA |
|IL.opMODR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(r1); |
IF n = 8 THEN |
Code(0B2C0H + r1 * 9) (* uxtb r1, r1 *) |
ELSIF n = 16 THEN |
Code(0B280H + r1 * 9) (* uxth r1, r1 *) |
ELSE |
LslImm(r1, 32 - n); |
LsrImm(r1, 32 - n) |
END |
ELSIF n < 0 THEN |
PushAll(1); |
PushConst(param2); |
divmod; |
mov(R0, R1); |
GetRegA |
ELSE |
UnOp(r1); |
MovConst(r1, 0) |
END |
|IL.opMODL: |
UnOp(r1); |
REG.PushAll_1(R); |
PushConst(param2); |
push(r1); |
drop; |
divmod; |
mov(R0, R1); |
GetRegA |
|IL.opIN, IL.opINR: |
IF opcode = IL.opINR THEN |
r2 := GetAnyReg(); |
MovConst(r2, param2) |
END; |
L := NewLabel(); |
L2 := NewLabel(); |
BinOp(r1, r2); |
r3 := GetAnyReg(); |
CmpConst(r1, 32); |
jcc(jb, L); |
MovConst(r1, 0); |
jmp(L2); |
Label(L); |
MovConst(r3, 1); |
Shift(IL.opLSL, r3, r1); |
gen4(0, r3, r2); (* ands r2, r3 *) |
SetCC(jne, r1); |
Label(L2); |
drop; |
drop |
|IL.opINL: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, LSL(1, param2)); |
gen4(0, r2, r1); (* ands r1, r2 *) |
SetCC(jne, r1); |
drop |
|IL.opRSET: |
PushAll(2); |
CallRTL(IL._set, 2); |
GetRegA |
|IL.opRSETR: |
PushAll(1); |
PushConst(param2); |
CallRTL(IL._set, 2); |
GetRegA |
|IL.opRSETL: |
UnOp(r1); |
REG.PushAll_1(R); |
PushConst(param2); |
push(r1); |
drop; |
CallRTL(IL._set, 2); |
GetRegA |
|IL.opRSET1: |
PushAll(1); |
CallRTL(IL._set1, 1); |
GetRegA |
|IL.opCONSTF: |
MovConst(GetAnyReg(), UTILS.d2s(cmd.float)) |
|IL.opMULF: |
PushAll(2); |
CallRTL(IL._fmul, 2); |
GetRegA |
|IL.opDIVF: |
PushAll(2); |
CallRTL(IL._fdiv, 2); |
GetRegA |
|IL.opDIVFI: |
PushAll(2); |
CallRTL(IL._fdivi, 2); |
GetRegA |
|IL.opADDF: |
PushAll(2); |
CallRTL(IL._fadd, 2); |
GetRegA |
|IL.opSUBFI: |
PushAll(2); |
CallRTL(IL._fsubi, 2); |
GetRegA |
|IL.opSUBF: |
PushAll(2); |
CallRTL(IL._fsub, 2); |
GetRegA |
|IL.opEQF..IL.opGEF: |
PushAll(2); |
PushConst(opcode - IL.opEQF); |
CallRTL(IL._fcmp, 3); |
GetRegA |
|IL.opFLOOR: |
PushAll(1); |
CallRTL(IL._floor, 1); |
GetRegA |
|IL.opFLT: |
PushAll(1); |
CallRTL(IL._flt, 1); |
GetRegA |
|IL.opUMINF: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, 1); |
LslImm(r2, 31); |
gen4(1, r2, r1); (* eors r1, r2 *) |
drop |
|IL.opFABS: |
UnOp(r1); |
r2 := GetAnyReg(); |
MovConst(r2, 1); |
LslImm(r2, 31); |
gen4(14, r2, r1); (* bics r1, r2 *) |
drop |
|IL.opNEW: |
cpsid_i; |
PushAll(1); |
n := param2 + 4; |
ASSERT(UTILS.Align(n, 4)); |
PushConst(n); |
PushConst(param1); |
CallRTL(IL._new, 3); |
cpsie_i |
|IL.opTYPEGP: |
UnOp(r1); |
PushAll(0); |
push(r1); |
PushConst(param2); |
CallRTL(IL._guard, 2); |
GetRegA |
|IL.opIS: |
PushAll(1); |
PushConst(param2); |
CallRTL(IL._is, 2); |
GetRegA |
|IL.opISREC: |
PushAll(2); |
PushConst(param2); |
CallRTL(IL._guardrec, 3); |
GetRegA |
|IL.opTYPEGR: |
PushAll(1); |
PushConst(param2); |
CallRTL(IL._guardrec, 2); |
GetRegA |
|IL.opTYPEGD: |
UnOp(r1); |
PushAll(0); |
SubImm8(r1, 4); |
Ldr32(r1, r1); |
push(r1); |
PushConst(param2); |
CallRTL(IL._guardrec, 2); |
GetRegA |
|IL.opCASET: |
push(R2); |
push(R2); |
PushConst(param2); |
CallRTL(IL._guardrec, 2); |
pop(R2); |
cbnz(ACC, param1) |
|IL.opROT: |
PushAll(0); |
mov(R2, SP); |
push(R2); |
PushConst(param2); |
CallRTL(IL._rot, 2) |
|IL.opPACK: |
PushAll(2); |
CallRTL(IL._pack, 2) |
|IL.opPACKC: |
PushAll(1); |
PushConst(param2); |
CallRTL(IL._pack, 2) |
|IL.opUNPK: |
PushAll(2); |
CallRTL(IL._unpk, 2) |
END; |
cmd := cmd.next(COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1) |
END translate; |
PROCEDURE prolog (GlobSize, tcount, pic, sp, ivt_len: INTEGER); |
VAR |
r1, r2, i, dcount: INTEGER; |
BEGIN |
entry := NewLabel(); |
emptyProc := NewLabel(); |
genInt := NewLabel(); |
genTrap := NewLabel(); |
sdivProc := NewLabel(); |
trap := emptyProc; |
int0 := emptyProc; |
IVT[0] := sp; |
IVT[1] := entry; |
FOR i := 2 TO ivt_len - 1 DO |
IVT[i] := genInt |
END; |
FOR i := 0 TO ivt_len - 1 DO |
Code(low(IVT[i])); |
Code(high(IVT[i])) |
END; |
Label(entry); |
cpsie_i; |
r1 := GetAnyReg(); |
r2 := GetAnyReg(); |
reloc(r1, BIN.RDATA + pic, 0); |
FOR i := 0 TO tcount - 1 DO |
MovConst(r2, CHL.GetInt(IL.codes.types, i)); |
Str32(r2, r1); |
AddImm8(r1, 4) |
END; |
dcount := CHL.Length(IL.codes.data); |
FOR i := 0 TO dcount - 1 BY 4 DO |
MovConst(r2, BIN.get32le(IL.codes.data, i)); |
Str32(r2, r1); |
AddImm8(r1, 4) |
END; |
drop; |
drop; |
r1 := GetAnyReg(); |
MovConst(r1, sp); |
mov(SP, r1); |
reloc(r1, BIN.RDATA + pic, 0); |
push(r1); |
reloc(r1, BIN.RBSS + pic, 0); |
r2 := GetAnyReg(); |
MovConst(r2, GlobSize); |
AddReg(r1, r1, r2); |
drop; |
push(r1); |
drop; |
PushConst(tcount); |
CallRTL(IL._init, 3) |
END prolog; |
PROCEDURE epilog; |
VAR |
L1, L2, L3, L4: INTEGER; |
BEGIN |
(* L2: *) |
Code(0E7FEH); (* b L2 *) |
Label(genInt); |
Code(0F3EFH); Code(08005H); (* mrs r0, ipsr *) |
gen14(FALSE, TRUE, {R0}); (* push {lr, r0} *) |
call(int0); |
gen14(TRUE, TRUE, {R0}); (* pop {pc, r0} *) |
Label(emptyProc); |
Code(04770H); (* bx lr *) |
Label(genTrap); |
call(trap); |
call(entry); |
Label(sdivProc); |
IF _SDIV IN Target.InstrSet THEN |
Code(09800H); (* ldr r0, [sp] *) |
Code(09901H); (* ldr r1, [sp, 4] *) |
Code(0FB91H); (* sdiv r2, r1, r0 *) |
Code(0F2F0H); |
Code(00013H); (* movs r3, r2 *) |
Code(04343H); (* muls r3, r0, r3 *) |
Code(01AC9H); (* subs r1, r1, r3 *) |
Code(0DA01H); (* bge L *) |
Code(01809H); (* adds r1, r1, r0 *) |
Code(03A01H); (* subs r2, 1 *) |
(* L: *) |
Code(00010H); (* movs r0, r2 *) |
Code(04770H); (* bx lr *) |
ELSE |
(* a / b; a >= 0 *) |
L1 := NewLabel(); |
L2 := NewLabel(); |
L3 := NewLabel(); |
L4 := NewLabel(); |
LdrSp(R1, 1); |
LdrSp(R2, 0); |
MovConst(R0, 0); |
push(R4); |
Label(L4); |
Cmp(R1, R2); |
jcc(jl, L1); |
MovConst(R3, 2); |
mov(R4, R2); |
LslImm(R4, 1); |
Label(L3); |
Cmp(R1, R4); |
jcc(jl, L2); |
CmpConst(R4, 0); |
jcc(jle, L2); |
LslImm(R4, 1); |
LslImm(R3, 1); |
jmp(L3); |
Label(L2); |
LsrImm(R4, 1); |
LsrImm(R3, 1); |
SubReg(R1, R1, R4); |
AddReg(R0, R0, R3); |
jmp(L4); |
Label(L1); |
(* a / b; a < 0 *) |
L1 := NewLabel(); |
L2 := NewLabel(); |
L3 := NewLabel(); |
L4 := NewLabel(); |
Label(L4); |
CmpConst(R1, 0); |
jcc(jge, L1); |
MovConst(R3, 2); |
mov(R4, R2); |
LslImm(R4, 1); |
Neg(R1); |
Label(L3); |
Cmp(R1, R4); |
jcc(jl, L2); |
CmpConst(R4, 0); |
jcc(jle, L2); |
LslImm(R4, 1); |
LslImm(R3, 1); |
jmp(L3); |
Label(L2); |
Neg(R1); |
LsrImm(R4, 1); |
LsrImm(R3, 1); |
AddReg(R1, R1, R4); |
SubReg(R0, R0, R3); |
jmp(L4); |
Label(L1); |
pop(R4); |
Code(04770H); (* bx lr *) |
END |
END epilog; |
PROCEDURE SetTarget (FlashStart, SRAMStart: INTEGER; InstrSet: SET; isNXP: BOOLEAN); |
BEGIN |
Target.FlashAdr := FlashStart; |
Target.SRAMAdr := SRAMStart; |
Target.InstrSet := InstrSet; |
Target.isNXP := isNXP; |
Target.IVTLen := 256; (* >= 192 *) |
Target.Reserved := 0; |
Target.MinStack := 512; |
END SetTarget; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
VAR |
opt: PROG.OPTIONS; |
ram, rom, i, j: INTEGER; |
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER; |
BEGIN |
ram := MIN(MAX(options.ram, minRAM), maxRAM) * 1024; |
rom := MIN(MAX(options.rom, minROM), maxROM) * 1024; |
IF target = TARGETS.STM32CM3 THEN |
SetTarget(08000000H, 20000000H, CortexM3, FALSE) |
END; |
tcount := CHL.Length(IL.codes.types); |
opt := options; |
CodeList := LISTS.create(NIL); |
program := BIN.create(IL.codes.lcount); |
REG.Init(R, push, pop, mov, xchg, {R0, R1, R2, R3}); |
StkCount := 0; |
DataAdr := Target.SRAMAdr + Target.Reserved; |
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.Reserved; |
WHILE DataSize MOD 4 # 0 DO |
CHL.PushByte(IL.codes.data, 0); |
INC(DataSize) |
END; |
BssAdr := DataAdr + DataSize - Target.Reserved; |
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4))); |
BssSize := IL.codes.bss; |
ASSERT(UTILS.Align(BssSize, 4)); |
prolog(BssSize, tcount, ORD(opt.pic), Target.SRAMAdr + ram, Target.IVTLen); |
translate(ORD(opt.pic), tcount * 4); |
epilog; |
fixup(Target.FlashAdr, DataAdr, BssAdr); |
INC(DataSize, BssSize); |
CodeSize := CHL.Length(program.code); |
IF CodeSize > rom THEN |
ERRORS.Error(203) |
END; |
IF DataSize > ram - Target.MinStack THEN |
ERRORS.Error(204) |
END; |
IF Target.isNXP THEN |
BIN.put32le(program.code, 2FCH, 0H); (* code read protection (CRP) *) |
(* NXP checksum *) |
j := 0; |
FOR i := 0 TO 6 DO |
INC(j, BIN.get32le(program.code, i * 4)) |
END; |
BIN.put32le(program.code, 1CH, -j) |
END; |
WR.Create(outname); |
HEX.Data2(program.code, 0, CodeSize, high(Target.FlashAdr)); |
HEX.End; |
WR.Close; |
C.Dashes; |
C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(CodeSize * 100 DIV rom); C.StringLn("%)"); |
C.Ln; |
C.String( " ram: "); C.Int(DataSize); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(DataSize * 100 DIV ram); C.StringLn("%)") |
END CodeGen; |
PROCEDURE SetIV* (idx: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := IVT[idx] = 0; |
IVT[idx] := 1 |
RETURN res |
END SetIV; |
PROCEDURE init; |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO LEN(IVT) - 1 DO |
IVT[i] := 0 |
END |
END init; |
BEGIN |
init |
END THUMB. |
/programs/develop/oberon07/source/UTILS.ob07 |
---|
0,0 → 1,216 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE UTILS; |
IMPORT HOST; |
CONST |
slash* = HOST.slash; |
eol* = HOST.eol; |
bit_depth* = HOST.bit_depth; |
maxint* = HOST.maxint; |
minint* = HOST.minint; |
min32* = -2147483647-1; |
max32* = 2147483647; |
vMajor* = 1; |
vMinor* = 52; |
Date* = "07-may-2021"; |
FILE_EXT* = ".ob07"; |
RTL_NAME* = "RTL"; |
MAX_GLOBAL_SIZE* = 1600000000; |
VAR |
time*: INTEGER; |
maxreal*: REAL; |
target*: |
RECORD |
bit_depth*, |
maxInt*, |
minInt*, |
maxSet*, |
maxHex*: INTEGER; |
maxReal*: REAL |
END; |
bit_diff*: INTEGER; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER; |
RETURN HOST.FileRead(F, Buffer, bytes) |
END FileRead; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN HOST.FileWrite(F, Buffer, bytes) |
END FileWrite; |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN HOST.FileCreate(FName) |
END FileCreate; |
PROCEDURE FileClose* (F: INTEGER); |
BEGIN |
HOST.FileClose(F) |
END FileClose; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN HOST.FileOpen(FName) |
END FileOpen; |
PROCEDURE chmod* (FName: ARRAY OF CHAR); |
BEGIN |
HOST.chmod(FName) |
END chmod; |
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR); |
BEGIN |
HOST.GetArg(i, str) |
END GetArg; |
PROCEDURE Exit* (code: INTEGER); |
BEGIN |
HOST.ExitProcess(code) |
END Exit; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN HOST.GetTickCount() |
END GetTickCount; |
PROCEDURE OutChar* (c: CHAR); |
BEGIN |
HOST.OutChar(c) |
END OutChar; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
RETURN HOST.splitf(x, a, b) |
END splitf; |
PROCEDURE d2s* (x: REAL): INTEGER; |
RETURN HOST.d2s(x) |
END d2s; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN HOST.isRelative(path) |
END isRelative; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
BEGIN |
HOST.GetCurrentDirectory(path) |
END GetCurrentDirectory; |
PROCEDURE UnixTime* (): INTEGER; |
RETURN HOST.UnixTime() |
END UnixTime; |
PROCEDURE SetBitDepth* (BitDepth: INTEGER; Double: BOOLEAN); |
BEGIN |
ASSERT((BitDepth = 16) OR (BitDepth = 32) OR (BitDepth = 64)); |
bit_diff := bit_depth - BitDepth; |
ASSERT(bit_diff >= 0); |
target.bit_depth := BitDepth; |
target.maxSet := BitDepth - 1; |
target.maxHex := BitDepth DIV 4; |
target.minInt := ASR(minint, bit_diff); |
target.maxInt := ASR(maxint, bit_diff); |
IF Double THEN |
target.maxReal := maxreal |
ELSE |
target.maxReal := 1.9; |
PACK(target.maxReal, 127) |
END |
END SetBitDepth; |
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE; |
RETURN ASR(n, 8 * idx) MOD 256 |
END Byte; |
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN; |
BEGIN |
INC(bytes, (-bytes) MOD align) |
RETURN bytes >= 0 |
END Align; |
PROCEDURE Long* (value: INTEGER): INTEGER; |
RETURN ASR(LSL(value, bit_diff), bit_diff) |
END Long; |
PROCEDURE Short* (value: INTEGER): INTEGER; |
RETURN LSR(LSL(value, bit_diff), bit_diff) |
END Short; |
PROCEDURE Log2* (x: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
BEGIN |
n := 0; |
WHILE ~ODD(x) DO |
x := x DIV 2; |
INC(n) |
END; |
IF x # 1 THEN |
n := -1 |
END |
RETURN n |
END Log2; |
PROCEDURE hexdgt* (n: BYTE): BYTE; |
BEGIN |
IF n < 10 THEN |
INC(n, ORD("0")) |
ELSE |
INC(n, ORD("A") - 10) |
END |
RETURN n |
END hexdgt; |
BEGIN |
time := HOST.GetTickCount(); |
maxreal := HOST.maxreal |
END UTILS. |
/programs/develop/oberon07/source/WRITER.ob07 |
---|
0,0 → 1,104 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE WRITER; |
IMPORT FILES, ERRORS, UTILS; |
VAR |
counter*: INTEGER; |
file: FILES.FILE; |
PROCEDURE align* (n, _align: INTEGER): INTEGER; |
BEGIN |
ASSERT(UTILS.Align(n, _align)) |
RETURN n |
END align; |
PROCEDURE WriteByte* (n: BYTE); |
BEGIN |
IF FILES.WriteByte(file, n) THEN |
INC(counter) |
ELSE |
ERRORS.Error(201) |
END |
END WriteByte; |
PROCEDURE Write* (chunk: ARRAY OF BYTE; bytes: INTEGER); |
VAR |
n: INTEGER; |
BEGIN |
n := FILES.write(file, chunk, bytes); |
IF n # bytes THEN |
ERRORS.Error(201) |
END; |
INC(counter, n) |
END Write; |
PROCEDURE Write64LE* (n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 7 DO |
WriteByte(UTILS.Byte(n, i)) |
END |
END Write64LE; |
PROCEDURE Write32LE* (n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
WriteByte(UTILS.Byte(n, i)) |
END |
END Write32LE; |
PROCEDURE Write16LE* (n: INTEGER); |
BEGIN |
WriteByte(UTILS.Byte(n, 0)); |
WriteByte(UTILS.Byte(n, 1)) |
END Write16LE; |
PROCEDURE Padding* (FileAlignment: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
i := align(counter, FileAlignment) - counter; |
WHILE i > 0 DO |
WriteByte(0); |
DEC(i) |
END |
END Padding; |
PROCEDURE Create* (FileName: ARRAY OF CHAR); |
BEGIN |
counter := 0; |
file := FILES.create(FileName) |
END Create; |
PROCEDURE Close*; |
BEGIN |
FILES.close(file) |
END Close; |
END WRITER. |
/programs/develop/oberon07/source/X86.ob07 |
---|
0,0 → 1,2403 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2021, Anton Krotov |
All rights reserved. |
*) |
MODULE X86; |
IMPORT IL, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, PROG, |
CHL := CHUNKLISTS, PATHS, TARGETS, ERRORS; |
CONST |
eax = REG.R0; ecx = REG.R1; edx = REG.R2; |
al = eax; cl = ecx; dl = edx; ah = 4; |
ax = eax; cx = ecx; dx = edx; |
esp = 4; |
ebp = 5; |
MAX_FR = 7; |
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H; |
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H; |
CODECHUNK = 8; |
FPR_ERR = 41; |
TYPE |
COMMAND = IL.COMMAND; |
ANYCODE = POINTER TO RECORD (LISTS.ITEM) |
offset: INTEGER |
END; |
CODE = POINTER TO RECORD (ANYCODE) |
code: ARRAY CODECHUNK OF BYTE; |
length: INTEGER |
END; |
LABEL = POINTER TO RECORD (ANYCODE) |
label: INTEGER |
END; |
JUMP = POINTER TO RECORD (ANYCODE) |
label, diff: INTEGER; |
short: BOOLEAN |
END; |
JMP = POINTER TO RECORD (JUMP) |
END; |
JCC = POINTER TO RECORD (JUMP) |
jmp: INTEGER |
END; |
CALL = POINTER TO RECORD (JUMP) |
END; |
RELOC = POINTER TO RECORD (ANYCODE) |
op, value: INTEGER |
END; |
VAR |
R: REG.REGS; |
program: BIN.PROGRAM; |
CodeList: LISTS.LIST; |
tcount: INTEGER; |
FR: ARRAY 1000 OF INTEGER; |
fname: PATHS.PATH; |
PROCEDURE OutByte* (n: BYTE); |
VAR |
c: CODE; |
last: ANYCODE; |
BEGIN |
last := CodeList.last(ANYCODE); |
IF (last IS CODE) & (last(CODE).length < CODECHUNK) THEN |
c := last(CODE); |
c.code[c.length] := n; |
INC(c.length) |
ELSE |
NEW(c); |
c.code[0] := n; |
c.length := 1; |
LISTS.push(CodeList, c) |
END |
END OutByte; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
OutByte(n MOD 256); |
OutByte(UTILS.Byte(n, 1)); |
OutByte(UTILS.Byte(n, 2)); |
OutByte(UTILS.Byte(n, 3)) |
END OutInt; |
PROCEDURE OutByte2 (a, b: BYTE); |
BEGIN |
OutByte(a); |
OutByte(b) |
END OutByte2; |
PROCEDURE OutByte3 (a, b, c: BYTE); |
BEGIN |
OutByte(a); |
OutByte(b); |
OutByte(c) |
END OutByte3; |
PROCEDURE OutWord (n: INTEGER); |
BEGIN |
ASSERT((0 <= n) & (n <= 65535)); |
OutByte2(n MOD 256, n DIV 256) |
END OutWord; |
PROCEDURE isByte* (n: INTEGER): BOOLEAN; |
RETURN (-128 <= n) & (n <= 127) |
END isByte; |
PROCEDURE short (n: INTEGER): INTEGER; |
RETURN 2 * ORD(isByte(n)) |
END short; |
PROCEDURE long (n: INTEGER): INTEGER; |
RETURN 40H * ORD(~isByte(n)) |
END long; |
PROCEDURE OutIntByte (n: INTEGER); |
BEGIN |
IF isByte(n) THEN |
OutByte(n MOD 256) |
ELSE |
OutInt(n) |
END |
END OutIntByte; |
PROCEDURE shift* (op, reg: INTEGER); |
BEGIN |
CASE op OF |
|IL.opASR, IL.opASR1, IL.opASR2: OutByte(0F8H + reg) |
|IL.opROR, IL.opROR1, IL.opROR2: OutByte(0C8H + reg) |
|IL.opLSL, IL.opLSL1, IL.opLSL2: OutByte(0E0H + reg) |
|IL.opLSR, IL.opLSR1, IL.opLSR2: OutByte(0E8H + reg) |
END |
END shift; |
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *) |
BEGIN |
OutByte2(op, 0C0H + 8 * reg2 + reg1) |
END oprr; |
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *) |
BEGIN |
oprr(89H, reg1, reg2) |
END mov; |
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *) |
BEGIN |
IF eax IN {reg1, reg2} THEN |
OutByte(90H + reg1 + reg2) |
ELSE |
oprr(87H, reg1, reg2) |
END |
END xchg; |
PROCEDURE pop (reg: INTEGER); |
BEGIN |
OutByte(58H + reg) (* pop reg *) |
END pop; |
PROCEDURE push (reg: INTEGER); |
BEGIN |
OutByte(50H + reg) (* push reg *) |
END push; |
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *) |
BEGIN |
oprr(31H, reg1, reg2) |
END xor; |
PROCEDURE movrc (reg, n: INTEGER); |
BEGIN |
IF n = 0 THEN |
xor(reg, reg) |
ELSE |
OutByte(0B8H + reg); (* mov reg, n *) |
OutInt(n) |
END |
END movrc; |
PROCEDURE pushc* (n: INTEGER); |
BEGIN |
OutByte(68H + short(n)); (* push n *) |
OutIntByte(n) |
END pushc; |
PROCEDURE test (reg: INTEGER); |
BEGIN |
OutByte2(85H, 0C0H + reg * 9) (* test reg, reg *) |
END test; |
PROCEDURE neg (reg: INTEGER); |
BEGIN |
OutByte2(0F7H, 0D8H + reg) (* neg reg *) |
END neg; |
PROCEDURE not (reg: INTEGER); |
BEGIN |
OutByte2(0F7H, 0D0H + reg) (* not reg *) |
END not; |
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *) |
BEGIN |
oprr(01H, reg1, reg2) |
END add; |
PROCEDURE oprc* (op, reg, n: INTEGER); |
BEGIN |
IF (reg = eax) & ~isByte(n) THEN |
CASE op OF |
|0C0H: op := 05H (* add *) |
|0E8H: op := 2DH (* sub *) |
|0F8H: op := 3DH (* cmp *) |
|0E0H: op := 25H (* and *) |
|0C8H: op := 0DH (* or *) |
|0F0H: op := 35H (* xor *) |
END; |
OutByte(op); |
OutInt(n) |
ELSE |
OutByte2(81H + short(n), op + reg MOD 8); |
OutIntByte(n) |
END |
END oprc; |
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *) |
BEGIN |
oprc(0E0H, reg, n) |
END andrc; |
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *) |
BEGIN |
oprc(0C8H, reg, n) |
END orrc; |
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *) |
BEGIN |
oprc(0F0H, reg, n) |
END xorrc; |
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *) |
BEGIN |
oprc(0C0H, reg, n) |
END addrc; |
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *) |
BEGIN |
oprc(0E8H, reg, n) |
END subrc; |
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *) |
BEGIN |
IF n = 0 THEN |
test(reg) |
ELSE |
oprc(0F8H, reg, n) |
END |
END cmprc; |
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *) |
BEGIN |
oprr(39H, reg1, reg2) |
END cmprr; |
PROCEDURE setcc* (cc, reg: INTEGER); (* setcc reg *) |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0FH, cc, 0C0H + reg MOD 8) |
END setcc; |
PROCEDURE ret*; |
BEGIN |
OutByte(0C3H) |
END ret; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE cond* (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|IL.opGT, IL.opGTC: res := jg |
|IL.opGE, IL.opGEC: res := jge |
|IL.opLT, IL.opLTC: res := jl |
|IL.opLE, IL.opLEC: res := jle |
|IL.opEQ, IL.opEQC: res := je |
|IL.opNE, IL.opNEC: res := jne |
END |
RETURN res |
END cond; |
PROCEDURE inv0* (op: INTEGER): INTEGER; |
RETURN ORD(BITS(op) / {0}) |
END inv0; |
PROCEDURE Reloc* (op, value: INTEGER); |
VAR |
reloc: RELOC; |
BEGIN |
NEW(reloc); |
reloc.op := op; |
reloc.value := value; |
LISTS.push(CodeList, reloc) |
END Reloc; |
PROCEDURE jcc* (cc, label: INTEGER); |
VAR |
j: JCC; |
BEGIN |
NEW(j); |
j.label := label; |
j.jmp := cc; |
j.short := FALSE; |
LISTS.push(CodeList, j) |
END jcc; |
PROCEDURE jmp* (label: INTEGER); |
VAR |
j: JMP; |
BEGIN |
NEW(j); |
j.label := label; |
j.short := FALSE; |
LISTS.push(CodeList, j) |
END jmp; |
PROCEDURE call* (label: INTEGER); |
VAR |
c: CALL; |
BEGIN |
NEW(c); |
c.label := label; |
c.short := TRUE; |
LISTS.push(CodeList, c) |
END call; |
PROCEDURE Pic (reg, opcode, value: INTEGER); |
BEGIN |
OutByte(0E8H); OutInt(0); (* call L |
L: *) |
pop(reg); |
OutByte2(081H, 0C0H + reg); (* add reg, ... *) |
Reloc(opcode, value) |
END Pic; |
PROCEDURE CallRTL (pic: BOOLEAN; proc: INTEGER); |
VAR |
label: INTEGER; |
reg1: INTEGER; |
BEGIN |
label := IL.codes.rtl[proc]; |
IF label < 0 THEN |
label := -label; |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICIMP, label); |
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *) |
drop |
ELSE |
OutByte2(0FFH, 015H); (* call dword[label] *) |
Reloc(BIN.RIMP, label) |
END |
ELSE |
call(label) |
END |
END CallRTL; |
PROCEDURE SetLabel* (label: INTEGER); |
VAR |
L: LABEL; |
BEGIN |
NEW(L); |
L.label := label; |
LISTS.push(CodeList, L) |
END SetLabel; |
PROCEDURE fixup*; |
VAR |
code: ANYCODE; |
count, i: INTEGER; |
shorted: BOOLEAN; |
jump: JUMP; |
BEGIN |
REPEAT |
shorted := FALSE; |
count := 0; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
code.offset := count; |
CASE code OF |
|CODE: INC(count, code.length) |
|LABEL: BIN.SetLabel(program, code.label, count) |
|JMP: IF code.short THEN INC(count, 2) ELSE INC(count, 5) END; code.offset := count |
|JCC: IF code.short THEN INC(count, 2) ELSE INC(count, 6) END; code.offset := count |
|CALL: INC(count, 5); code.offset := count |
|RELOC: INC(count, 4) |
END; |
code := code.next(ANYCODE) |
END; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
IF code IS JUMP THEN |
jump := code(JUMP); |
jump.diff := BIN.GetLabel(program, jump.label) - code.offset; |
IF ~jump.short & isByte(jump.diff) THEN |
jump.short := TRUE; |
shorted := TRUE |
END |
END; |
code := code.next(ANYCODE) |
END |
UNTIL ~shorted; |
code := CodeList.first(ANYCODE); |
WHILE code # NIL DO |
CASE code OF |
|CODE: |
FOR i := 0 TO code.length - 1 DO |
BIN.PutCode(program, code.code[i]) |
END |
|LABEL: |
|JMP: |
IF code.short THEN |
BIN.PutCode(program, 0EBH); |
BIN.PutCode(program, code.diff MOD 256) |
ELSE |
BIN.PutCode(program, 0E9H); |
BIN.PutCode32LE(program, code.diff) |
END |
|JCC: |
IF code.short THEN |
BIN.PutCode(program, code.jmp - 16); |
BIN.PutCode(program, code.diff MOD 256) |
ELSE |
BIN.PutCode(program, 0FH); |
BIN.PutCode(program, code.jmp); |
BIN.PutCode32LE(program, code.diff) |
END |
|CALL: |
BIN.PutCode(program, 0E8H); |
BIN.PutCode32LE(program, code.diff) |
|RELOC: |
BIN.PutReloc(program, code.op); |
BIN.PutCode32LE(program, code.value) |
END; |
code := code.next(ANYCODE) |
END |
END fixup; |
PROCEDURE UnOp (VAR reg: INTEGER); |
BEGIN |
REG.UnOp(R, reg) |
END UnOp; |
PROCEDURE BinOp (VAR reg1, reg2: INTEGER); |
BEGIN |
REG.BinOp(R, reg1, reg2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
BIN.NewLabel(program) |
RETURN IL.NewLabel() |
END NewLabel; |
PROCEDURE GetRegA; |
BEGIN |
ASSERT(REG.GetReg(R, eax)) |
END GetRegA; |
PROCEDURE fcmp; |
BEGIN |
GetRegA; |
OutByte2(0DAH, 0E9H); (* fucompp *) |
OutByte3(09BH, 0DFH, 0E0H); (* fstsw ax *) |
OutByte(09EH); (* sahf *) |
OutByte(0B8H); OutInt(0) (* mov eax, 0 *) |
END fcmp; |
PROCEDURE movzx* (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *) |
VAR |
b: BYTE; |
BEGIN |
OutByte2(0FH, 0B6H + ORD(word)); |
IF (offs = 0) & (reg2 # ebp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8); |
IF reg2 = esp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END movzx; |
PROCEDURE _movrm* (reg1, reg2, offs, size: INTEGER; mr: BOOLEAN); |
VAR |
b: BYTE; |
BEGIN |
IF size = 16 THEN |
OutByte(66H) |
END; |
IF (reg1 >= 8) OR (reg2 >= 8) OR (size = 64) THEN |
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8) + 8 * ORD(size = 64)) |
END; |
OutByte(8BH - 2 * ORD(mr) - ORD(size = 8)); |
IF (offs = 0) & (reg2 # ebp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8); |
IF reg2 = esp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END _movrm; |
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_8 *) |
BEGIN |
_movrm(reg2, reg1, offs, 32, TRUE) |
END movmr; |
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, dword[reg2 + offs] *) |
BEGIN |
_movrm(reg1, reg2, offs, 32, FALSE) |
END movrm; |
PROCEDURE movmr8* (reg1, offs, reg2: INTEGER); (* mov byte[reg1+offs], reg2_8 *) |
BEGIN |
_movrm(reg2, reg1, offs, 8, TRUE) |
END movmr8; |
PROCEDURE movrm8* (reg1, reg2, offs: INTEGER); (* mov reg1_8, byte[reg2+offs] *) |
BEGIN |
_movrm(reg1, reg2, offs, 8, FALSE) |
END movrm8; |
PROCEDURE movmr16* (reg1, offs, reg2: INTEGER); (* mov word[reg1+offs], reg2_16 *) |
BEGIN |
_movrm(reg2, reg1, offs, 16, TRUE) |
END movmr16; |
PROCEDURE movrm16* (reg1, reg2, offs: INTEGER); (* mov reg1_16, word[reg2+offs] *) |
BEGIN |
_movrm(reg1, reg2, offs, 16, FALSE) |
END movrm16; |
PROCEDURE pushm* (reg, offs: INTEGER); (* push qword[reg+offs] *) |
VAR |
b: BYTE; |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(0FFH); |
IF (offs = 0) & (reg # ebp) THEN |
b := 30H |
ELSE |
b := 70H + long(offs) |
END; |
OutByte(b + reg MOD 8); |
IF reg = esp THEN |
OutByte(24H) |
END; |
IF b # 30H THEN |
OutIntByte(offs) |
END |
END pushm; |
PROCEDURE translate (pic: BOOLEAN; stroffs: INTEGER); |
VAR |
cmd, next: COMMAND; |
reg1, reg2, fr: INTEGER; |
n, a, b, label, cc: INTEGER; |
opcode, param1, param2: INTEGER; |
float: REAL; |
BEGIN |
cmd := IL.codes.commands.first(COMMAND); |
fr := -1; |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
jmp(param1) |
|IL.opCALL: |
call(param1) |
|IL.opCALLI: |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICIMP, param1); |
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *) |
drop |
ELSE |
OutByte2(0FFH, 015H); (* call dword[L] *) |
Reloc(BIN.RIMP, param1) |
END |
|IL.opCALLP: |
UnOp(reg1); |
OutByte2(0FFH, 0D0H + reg1); (* call reg1 *) |
drop; |
ASSERT(R.top = -1) |
|IL.opPRECALL: |
PushAll(0); |
IF (param2 # 0) & (fr >= 0) THEN |
subrc(esp, 8) |
END; |
INC(FR[0]); |
FR[FR[0]] := fr + 1; |
WHILE fr >= 0 DO |
subrc(esp, 8); |
OutByte3(0DDH, 01CH, 024H); (* fstp qword[esp] *) |
DEC(fr) |
END; |
ASSERT(fr = -1) |
|IL.opALIGN16: |
ASSERT(eax IN R.regs); |
mov(eax, esp); |
andrc(esp, -16); |
n := (3 - param2 MOD 4) * 4; |
IF n > 0 THEN |
subrc(esp, n) |
END; |
push(eax) |
|IL.opRESF, IL.opRES: |
ASSERT(R.top = -1); |
ASSERT(fr = -1); |
n := FR[FR[0]]; DEC(FR[0]); |
IF opcode = IL.opRESF THEN |
INC(fr); |
IF n > 0 THEN |
OutByte3(0DDH, 5CH + long(n * 8), 24H); |
OutIntByte(n * 8); (* fstp qword[esp + n*8] *) |
DEC(fr); |
INC(n) |
END; |
IF fr + n > MAX_FR THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END |
ELSE |
GetRegA |
END; |
WHILE n > 0 DO |
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *) |
addrc(esp, 8); |
INC(fr); |
DEC(n) |
END |
|IL.opENTER: |
ASSERT(R.top = -1); |
SetLabel(param1); |
push(ebp); |
mov(ebp, esp); |
n := param2; |
IF n > 4 THEN |
movrc(ecx, n); |
pushc(0); (* L: push 0 *) |
OutByte2(0E2H, 0FCH) (* loop L *) |
ELSE |
WHILE n > 0 DO |
pushc(0); |
DEC(n) |
END |
END |
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF: |
IF opcode = IL.opLEAVER THEN |
UnOp(reg1); |
IF reg1 # eax THEN |
mov(eax, reg1) |
END; |
drop |
END; |
ASSERT(R.top = -1); |
IF opcode = IL.opLEAVEF THEN |
DEC(fr) |
END; |
ASSERT(fr = -1); |
IF param1 > 0 THEN |
mov(esp, ebp) |
END; |
pop(ebp); |
IF param2 > 0 THEN |
OutByte(0C2H); OutWord(param2 * 4 MOD 65536) (* ret param2*4 *) |
ELSE |
ret |
END |
|IL.opPUSHC: |
pushc(param2) |
|IL.opONERR: |
pushc(param2); |
jmp(param1) |
|IL.opPARAM: |
n := param2; |
IF n = 1 THEN |
UnOp(reg1); |
push(reg1); |
drop |
ELSE |
ASSERT(R.top + 1 <= n); |
PushAll(n) |
END |
|IL.opCLEANUP: |
IF param2 # 0 THEN |
addrc(esp, param2 * 4) |
END |
|IL.opPOPSP: |
pop(esp) |
|IL.opCONST: |
movrc(GetAnyReg(), param2) |
|IL.opLABEL: |
SetLabel(param1) (* L: *) |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opGADR: |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opADDC THEN |
INC(param2, next.param2); |
cmd := next |
END; |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICBSS, param2) |
ELSE |
OutByte(0B8H + reg1); (* mov reg1, _bss + param2 *) |
Reloc(BIN.RBSS, param2) |
END |
|IL.opLADR: |
next := cmd.next(COMMAND); |
n := param2 * 4; |
IF next.opcode = IL.opADDC THEN |
INC(n, next.param2); |
cmd := next |
END; |
OutByte2(8DH, 45H + GetAnyReg() * 8 + long(n)); (* lea reg1, dword[ebp + n] *) |
OutIntByte(n) |
|IL.opVADR, IL.opLLOAD32: |
movrm(GetAnyReg(), ebp, param2 * 4) |
|IL.opSADR: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICDATA, stroffs + param2); |
ELSE |
OutByte(0B8H + reg1); (* mov reg1, _data + stroffs + param2 *) |
Reloc(BIN.RDATA, stroffs + param2) |
END |
|IL.opSAVEC: |
UnOp(reg1); |
OutByte2(0C7H, reg1); OutInt(param2); (* mov dword[reg1], param2 *) |
drop |
|IL.opSAVE8C: |
UnOp(reg1); |
OutByte3(0C6H, reg1, param2 MOD 256); (* mov byte[reg1], param2 *) |
drop |
|IL.opSAVE16C: |
UnOp(reg1); |
OutByte3(66H, 0C7H, reg1); OutWord(param2 MOD 65536); (* mov word[reg1], param2 *) |
drop |
|IL.opVLOAD32: |
reg1 := GetAnyReg(); |
movrm(reg1, ebp, param2 * 4); |
movrm(reg1, reg1, 0) |
|IL.opGLOAD32: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICBSS, param2); |
movrm(reg1, reg1, 0) |
ELSE |
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[_bss + param2] *) |
Reloc(BIN.RBSS, param2) |
END |
|IL.opLOAD32: |
UnOp(reg1); |
movrm(reg1, reg1, 0) |
|IL.opVLOAD8: |
reg1 := GetAnyReg(); |
movrm(reg1, ebp, param2 * 4); |
movzx(reg1, reg1, 0, FALSE) |
|IL.opGLOAD8: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICBSS, param2); |
movzx(reg1, reg1, 0, FALSE) |
ELSE |
OutByte3(00FH, 0B6H, 05H + reg1 * 8); (* movzx reg1, byte[_bss + param2] *) |
Reloc(BIN.RBSS, param2) |
END |
|IL.opLLOAD8: |
movzx(GetAnyReg(), ebp, param2 * 4, FALSE) |
|IL.opLOAD8: |
UnOp(reg1); |
movzx(reg1, reg1, 0, FALSE) |
|IL.opVLOAD16: |
reg1 := GetAnyReg(); |
movrm(reg1, ebp, param2 * 4); |
movzx(reg1, reg1, 0, TRUE) |
|IL.opGLOAD16: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICBSS, param2); |
movzx(reg1, reg1, 0, TRUE) |
ELSE |
OutByte3(00FH, 0B7H, 05H + reg1 * 8); (* movzx reg1, word[_bss + param2] *) |
Reloc(BIN.RBSS, param2) |
END |
|IL.opLLOAD16: |
movzx(GetAnyReg(), ebp, param2 * 4, TRUE) |
|IL.opLOAD16: |
UnOp(reg1); |
movzx(reg1, reg1, 0, TRUE) |
|IL.opUMINUS: |
UnOp(reg1); |
neg(reg1) |
|IL.opADD: |
BinOp(reg1, reg2); |
add(reg1, reg2); |
drop |
|IL.opADDC: |
IF param2 # 0 THEN |
UnOp(reg1); |
next := cmd.next(COMMAND); |
CASE next.opcode OF |
|IL.opLOAD32: |
movrm(reg1, reg1, param2); |
cmd := next |
|IL.opLOAD16: |
movzx(reg1, reg1, param2, TRUE); |
cmd := next |
|IL.opLOAD8: |
movzx(reg1, reg1, param2, FALSE); |
cmd := next |
|IL.opLOAD32_PARAM: |
pushm(reg1, param2); |
drop; |
cmd := next |
ELSE |
IF param2 = 1 THEN |
OutByte(40H + reg1) (* inc reg1 *) |
ELSIF param2 = -1 THEN |
OutByte(48H + reg1) (* dec reg1 *) |
ELSE |
addrc(reg1, param2) |
END |
END |
END |
|IL.opSUB: |
BinOp(reg1, reg2); |
oprr(29H, reg1, reg2); (* sub reg1, reg2 *) |
drop |
|IL.opSUBR, IL.opSUBL: |
UnOp(reg1); |
IF param2 = 1 THEN |
OutByte(48H + reg1) (* dec reg1 *) |
ELSIF param2 = -1 THEN |
OutByte(40H + reg1) (* inc reg1 *) |
ELSIF param2 # 0 THEN |
subrc(reg1, param2) |
END; |
IF opcode = IL.opSUBL THEN |
neg(reg1) |
END |
|IL.opMULC: |
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN |
BinOp(reg1, reg2); |
OutByte3(8DH, 04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2)); (* lea reg1, [reg1 + reg2 * param2] *) |
drop; |
cmd := cmd.next(COMMAND) |
ELSE |
UnOp(reg1); |
a := param2; |
IF a > 1 THEN |
n := UTILS.Log2(a) |
ELSIF a < -1 THEN |
n := UTILS.Log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
neg(reg1) |
ELSIF a = 0 THEN |
xor(reg1, reg1) |
ELSE |
IF n > 0 THEN |
IF a < 0 THEN |
neg(reg1) |
END; |
IF n # 1 THEN |
OutByte3(0C1H, 0E0H + reg1, n) (* shl reg1, n *) |
ELSE |
OutByte2(0D1H, 0E0H + reg1) (* shl reg1, 1 *) |
END |
ELSE |
OutByte2(69H + short(a), 0C0H + reg1 * 9); (* imul reg1, a *) |
OutIntByte(a) |
END |
END |
END |
|IL.opMUL: |
BinOp(reg1, reg2); |
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); (* imul reg1, reg2 *) |
drop |
|IL.opSAVE, IL.opSAVE32: |
BinOp(reg2, reg1); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(reg2, reg1); |
movmr8(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVE16: |
BinOp(reg2, reg1); |
movmr16(reg1, 0, reg2); |
drop; |
drop |
|IL.opSAVEP: |
UnOp(reg1); |
IF pic THEN |
reg2 := GetAnyReg(); |
Pic(reg2, BIN.PICCODE, param2); |
movmr(reg1, 0, reg2); |
drop |
ELSE |
OutByte2(0C7H, reg1); (* mov dword[reg1], L *) |
Reloc(BIN.RCODE, param2) |
END; |
drop |
|IL.opSAVEIP: |
UnOp(reg1); |
IF pic THEN |
reg2 := GetAnyReg(); |
Pic(reg2, BIN.PICIMP, param2); |
pushm(reg2, 0); |
OutByte2(08FH, reg1); (* pop dword[reg1] *) |
drop |
ELSE |
OutByte2(0FFH, 035H); (* push dword[L] *) |
Reloc(BIN.RIMP, param2); |
OutByte2(08FH, reg1) (* pop dword[reg1] *) |
END; |
drop |
|IL.opPUSHP: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICCODE, param2) |
ELSE |
OutByte(0B8H + reg1); (* mov reg1, L *) |
Reloc(BIN.RCODE, param2) |
END |
|IL.opPUSHIP: |
reg1 := GetAnyReg(); |
IF pic THEN |
Pic(reg1, BIN.PICIMP, param2); |
movrm(reg1, reg1, 0) |
ELSE |
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[L] *) |
Reloc(BIN.RIMP, param2) |
END |
|IL.opNOT: |
UnOp(reg1); |
test(reg1); |
setcc(sete, reg1); |
andrc(reg1, 1) |
|IL.opORD: |
UnOp(reg1); |
test(reg1); |
setcc(setne, reg1); |
andrc(reg1, 1) |
|IL.opSBOOL: |
BinOp(reg2, reg1); |
test(reg2); |
OutByte3(0FH, 95H, reg1); (* setne byte[reg1] *) |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(reg1); |
OutByte3(0C6H, reg1, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *) |
drop |
|IL.opEQ..IL.opGE, |
IL.opEQC..IL.opGEC: |
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
drop |
ELSE |
UnOp(reg1); |
cmprc(reg1, param2) |
END; |
drop; |
cc := cond(opcode); |
next := cmd.next(COMMAND); |
IF next.opcode = IL.opJNZ THEN |
jcc(cc, next.param1); |
cmd := next |
ELSIF next.opcode = IL.opJZ THEN |
jcc(inv0(cc), next.param1); |
cmd := next |
ELSE |
reg1 := GetAnyReg(); |
setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END |
|IL.opEQB, IL.opNEB: |
BinOp(reg1, reg2); |
drop; |
test(reg1); |
OutByte2(74H, 5); (* je @f *) |
movrc(reg1, 1); (* mov reg1, 1 |
@@: *) |
test(reg2); |
OutByte2(74H, 5); (* je @f *) |
movrc(reg2, 1); (* mov reg2, 1 |
@@: *) |
cmprr(reg1, reg2); |
IF opcode = IL.opEQB THEN |
setcc(sete, reg1) |
ELSE |
setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|IL.opDROP: |
UnOp(reg1); |
drop |
|IL.opJNZ1: |
UnOp(reg1); |
test(reg1); |
jcc(jne, param1) |
|IL.opJG: |
UnOp(reg1); |
test(reg1); |
jcc(jg, param1) |
|IL.opJNZ: |
UnOp(reg1); |
test(reg1); |
jcc(jne, param1); |
drop |
|IL.opJZ: |
UnOp(reg1); |
test(reg1); |
jcc(je, param1); |
drop |
|IL.opSWITCH: |
UnOp(reg1); |
IF param2 = 0 THEN |
reg2 := eax |
ELSE |
reg2 := ecx |
END; |
IF reg1 # reg2 THEN |
ASSERT(REG.GetReg(R, reg2)); |
ASSERT(REG.Exchange(R, reg1, reg2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
cmprc(eax, param1); |
jcc(jl, param2) |
|IL.opCASER: |
cmprc(eax, param1); |
jcc(jg, param2) |
|IL.opCASELR: |
cmprc(eax, param1); |
IF param2 = cmd.param3 THEN |
jcc(jne, param2) |
ELSE |
jcc(jl, param2); |
jcc(jg, cmd.param3) |
END |
|IL.opCODE: |
OutByte(param2) |
|IL.opGET, IL.opGETC: |
IF opcode = IL.opGET THEN |
BinOp(reg1, reg2) |
ELSIF opcode = IL.opGETC THEN |
UnOp(reg2); |
reg1 := GetAnyReg(); |
movrc(reg1, param1) |
END; |
drop; |
drop; |
IF param2 # 8 THEN |
_movrm(reg1, reg1, 0, param2 * 8, FALSE); |
_movrm(reg1, reg2, 0, param2 * 8, TRUE) |
ELSE |
PushAll(0); |
push(reg1); |
push(reg2); |
pushc(8); |
CallRTL(pic, IL._move) |
END |
|IL.opSAVES: |
UnOp(reg2); |
REG.PushAll_1(R); |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICDATA, stroffs + param2); |
push(reg1); |
drop |
ELSE |
OutByte(068H); (* push _data + stroffs + param2 *) |
Reloc(BIN.RDATA, stroffs + param2); |
END; |
push(reg2); |
drop; |
pushc(param1); |
CallRTL(pic, IL._move) |
|IL.opCHKBYTE: |
BinOp(reg1, reg2); |
cmprc(reg1, 256); |
jcc(jb, param1) |
|IL.opCHKIDX: |
UnOp(reg1); |
cmprc(reg1, param2); |
jcc(jb, param1) |
|IL.opCHKIDX2: |
BinOp(reg1, reg2); |
IF param2 # -1 THEN |
cmprr(reg2, reg1); |
jcc(jb, param1) |
END; |
INCL(R.regs, reg1); |
DEC(R.top); |
R.stk[R.top] := reg2 |
|IL.opLEN: |
n := param2; |
UnOp(reg1); |
drop; |
EXCL(R.regs, reg1); |
WHILE n > 0 DO |
UnOp(reg2); |
drop; |
DEC(n) |
END; |
INCL(R.regs, reg1); |
ASSERT(REG.GetReg(R, reg1)) |
|IL.opINCC: |
UnOp(reg1); |
IF param2 = 1 THEN |
OutByte2(0FFH, reg1) (* inc dword[reg1] *) |
ELSIF param2 = -1 THEN |
OutByte2(0FFH, reg1 + 8) (* dec dword[reg1] *) |
ELSE |
OutByte2(81H + short(param2), reg1); OutIntByte(param2) (* add dword[reg1], param2 *) |
END; |
drop |
|IL.opINC, IL.opDEC: |
BinOp(reg1, reg2); |
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg1 * 8 + reg2); (* add/sub dword[reg2], reg1 *) |
drop; |
drop |
|IL.opINCCB, IL.opDECCB: |
UnOp(reg1); |
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1, param2 MOD 256); (* add/sub byte[reg1], n *) |
drop |
|IL.opINCB, IL.opDECB: |
BinOp(reg1, reg2); |
OutByte2(28H * ORD(opcode = IL.opDECB), reg1 * 8 + reg2); (* add/sub byte[reg2], reg1 *) |
drop; |
drop |
|IL.opMULS: |
BinOp(reg1, reg2); |
oprr(21H, reg1, reg2); (* and reg1, reg2 *) |
drop |
|IL.opMULSC: |
UnOp(reg1); |
andrc(reg1, param2) |
|IL.opDIVS: |
BinOp(reg1, reg2); |
xor(reg1, reg2); |
drop |
|IL.opDIVSC: |
UnOp(reg1); |
xorrc(reg1, param2) |
|IL.opADDS: |
BinOp(reg1, reg2); |
oprr(9H, reg1, reg2); (* or reg1, reg2 *) |
drop |
|IL.opSUBS: |
BinOp(reg1, reg2); |
not(reg2); |
oprr(21H, reg1, reg2); (* and reg1, reg2 *) |
drop |
|IL.opADDSC: |
UnOp(reg1); |
orrc(reg1, param2) |
|IL.opSUBSL: |
UnOp(reg1); |
not(reg1); |
andrc(reg1, param2) |
|IL.opSUBSR: |
UnOp(reg1); |
andrc(reg1, ORD(-BITS(param2))) |
|IL.opUMINS: |
UnOp(reg1); |
not(reg1) |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(pic, IL._length); |
GetRegA |
|IL.opLENGTHW: |
PushAll(2); |
CallRTL(pic, IL._lengthw); |
GetRegA |
|IL.opCHR: |
UnOp(reg1); |
andrc(reg1, 255) |
|IL.opWCHR: |
UnOp(reg1); |
andrc(reg1, 65535) |
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR: |
UnOp(reg1); |
IF reg1 # ecx THEN |
ASSERT(REG.GetReg(R, ecx)); |
ASSERT(REG.Exchange(R, reg1, ecx)); |
drop |
END; |
BinOp(reg1, reg2); |
ASSERT(reg2 = ecx); |
OutByte(0D3H); |
shift(opcode, reg1); (* shift reg1, cl *) |
drop |
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1: |
UnOp(reg1); |
IF reg1 # ecx THEN |
ASSERT(REG.GetReg(R, ecx)); |
ASSERT(REG.Exchange(R, reg1, ecx)); |
drop |
END; |
reg1 := GetAnyReg(); |
movrc(reg1, param2); |
BinOp(reg1, reg2); |
ASSERT(reg1 = ecx); |
OutByte(0D3H); |
shift(opcode, reg2); (* shift reg2, cl *) |
drop; |
drop; |
ASSERT(REG.GetReg(R, reg2)) |
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2: |
UnOp(reg1); |
n := param2 MOD 32; |
IF n # 1 THEN |
OutByte(0C1H) |
ELSE |
OutByte(0D1H) |
END; |
shift(opcode, reg1); (* shift reg1, n *) |
IF n # 1 THEN |
OutByte(n) |
END |
|IL.opMAX, IL.opMIN: |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
OutByte2(07DH + ORD(opcode = IL.opMIN), 2); (* jge/jle L *) |
mov(reg1, reg2); |
(* L: *) |
drop |
|IL.opMAXC, IL.opMINC: |
UnOp(reg1); |
cmprc(reg1, param2); |
label := NewLabel(); |
IF opcode = IL.opMINC THEN |
cc := jle |
ELSE |
cc := jge |
END; |
jcc(cc, label); |
movrc(reg1, param2); |
SetLabel(label) |
|IL.opIN, IL.opINR: |
IF opcode = IL.opINR THEN |
reg2 := GetAnyReg(); |
movrc(reg2, param2) |
END; |
label := NewLabel(); |
BinOp(reg1, reg2); |
cmprc(reg1, 32); |
OutByte2(72H, 4); (* jb L *) |
xor(reg1, reg1); |
jmp(label); |
(* L: *) |
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); (* bt reg2, reg1 *) |
setcc(setc, reg1); |
andrc(reg1, 1); |
SetLabel(label); |
drop |
|IL.opINL: |
UnOp(reg1); |
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); (* bt reg1, param2 *) |
setcc(setc, reg1); |
andrc(reg1, 1) |
|IL.opRSET: |
PushAll(2); |
CallRTL(pic, IL._set); |
GetRegA |
|IL.opRSETR: |
PushAll(1); |
pushc(param2); |
CallRTL(pic, IL._set); |
GetRegA |
|IL.opRSETL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(pic, IL._set); |
GetRegA |
|IL.opRSET1: |
PushAll(1); |
CallRTL(pic, IL._set1); |
GetRegA |
|IL.opINCL, IL.opEXCL: |
BinOp(reg1, reg2); |
cmprc(reg1, 32); |
OutByte2(73H, 03H); (* jnb L *) |
OutByte(0FH); |
IF opcode = IL.opINCL THEN |
OutByte(0ABH) (* bts dword[reg2], reg1 *) |
ELSE |
OutByte(0B3H) (* btr dword[reg2], reg1 *) |
END; |
OutByte(reg2 + 8 * reg1); |
(* L: *) |
drop; |
drop |
|IL.opINCLC: |
UnOp(reg1); |
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); (* bts dword[reg1], param2 *) |
drop |
|IL.opEXCLC: |
UnOp(reg1); |
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); (* btr dword[reg1], param2 *) |
drop |
|IL.opDIV: |
PushAll(2); |
CallRTL(pic, IL._divmod); |
GetRegA |
|IL.opDIVR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(reg1); |
IF n # 1 THEN |
OutByte3(0C1H, 0F8H + reg1, n) (* sar reg1, n *) |
ELSE |
OutByte2(0D1H, 0F8H + reg1) (* sar reg1, 1 *) |
END |
ELSIF n < 0 THEN |
PushAll(1); |
pushc(param2); |
CallRTL(pic, IL._divmod); |
GetRegA |
END |
|IL.opDIVL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(pic, IL._divmod); |
GetRegA |
|IL.opMOD: |
PushAll(2); |
CallRTL(pic, IL._divmod); |
mov(eax, edx); |
GetRegA |
|IL.opMODR: |
n := UTILS.Log2(param2); |
IF n > 0 THEN |
UnOp(reg1); |
andrc(reg1, param2 - 1); |
ELSIF n < 0 THEN |
PushAll(1); |
pushc(param2); |
CallRTL(pic, IL._divmod); |
mov(eax, edx); |
GetRegA |
ELSE |
UnOp(reg1); |
xor(reg1, reg1) |
END |
|IL.opMODL: |
UnOp(reg1); |
REG.PushAll_1(R); |
pushc(param2); |
push(reg1); |
drop; |
CallRTL(pic, IL._divmod); |
mov(eax, edx); |
GetRegA |
|IL.opERR: |
CallRTL(pic, IL._error) |
|IL.opABS: |
UnOp(reg1); |
test(reg1); |
OutByte2(07DH, 002H); (* jge L *) |
neg(reg1) (* neg reg1 |
L: *) |
|IL.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(pic, IL._move) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(pic, IL._move) |
|IL.opCOPYA: |
PushAll(4); |
pushc(param2); |
CallRTL(pic, IL._arrcpy); |
GetRegA |
|IL.opCOPYS: |
PushAll(4); |
pushc(param2); |
CallRTL(pic, IL._strcpy) |
|IL.opROT: |
PushAll(0); |
push(esp); |
pushc(param2); |
CallRTL(pic, IL._rot) |
|IL.opNEW: |
PushAll(1); |
n := param2 + 8; |
ASSERT(UTILS.Align(n, 32)); |
pushc(n); |
pushc(param1); |
CallRTL(pic, IL._new) |
|IL.opDISP: |
PushAll(1); |
CallRTL(pic, IL._dispose) |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
pushc(opcode - IL.opEQS); |
CallRTL(pic, IL._strcmp); |
GetRegA |
|IL.opEQSW .. IL.opGESW: |
PushAll(4); |
pushc(opcode - IL.opEQSW); |
CallRTL(pic, IL._strcmpw); |
GetRegA |
|IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP: |
UnOp(reg1); |
CASE opcode OF |
|IL.opEQP, IL.opNEP: |
IF pic THEN |
reg2 := GetAnyReg(); |
Pic(reg2, BIN.PICCODE, param1); |
cmprr(reg1, reg2); |
drop |
ELSE |
OutByte2(081H, 0F8H + reg1); (* cmp reg1, L *) |
Reloc(BIN.RCODE, param1) |
END |
|IL.opEQIP, IL.opNEIP: |
IF pic THEN |
reg2 := GetAnyReg(); |
Pic(reg2, BIN.PICIMP, param1); |
OutByte2(03BH, reg1 * 8 + reg2); (* cmp reg1, dword [reg2] *) |
drop |
ELSE |
OutByte2(3BH, 05H + reg1 * 8); (* cmp reg1, dword[L] *) |
Reloc(BIN.RIMP, param1) |
END |
END; |
drop; |
reg1 := GetAnyReg(); |
CASE opcode OF |
|IL.opEQP, IL.opEQIP: setcc(sete, reg1) |
|IL.opNEP, IL.opNEIP: setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|IL.opPUSHT: |
UnOp(reg1); |
movrm(GetAnyReg(), reg1, -4) |
|IL.opISREC: |
PushAll(2); |
pushc(param2 * tcount); |
CallRTL(pic, IL._isrec); |
GetRegA |
|IL.opIS: |
PushAll(1); |
pushc(param2 * tcount); |
CallRTL(pic, IL._is); |
GetRegA |
|IL.opTYPEGR: |
PushAll(1); |
pushc(param2 * tcount); |
CallRTL(pic, IL._guardrec); |
GetRegA |
|IL.opTYPEGP: |
UnOp(reg1); |
PushAll(0); |
push(reg1); |
pushc(param2 * tcount); |
CallRTL(pic, IL._guard); |
GetRegA |
|IL.opTYPEGD: |
UnOp(reg1); |
PushAll(0); |
pushm(reg1, -4); |
pushc(param2 * tcount); |
CallRTL(pic, IL._guardrec); |
GetRegA |
|IL.opCASET: |
push(ecx); |
push(ecx); |
pushc(param2 * tcount); |
CallRTL(pic, IL._guardrec); |
pop(ecx); |
test(eax); |
jcc(jne, param1) |
|IL.opPACK: |
BinOp(reg1, reg2); |
push(reg2); |
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *) |
OutByte2(0DDH, reg1); (* fld qword[reg1] *) |
OutByte2(0D9H, 0FDH); (* fscale *) |
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *) |
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *) |
pop(reg2); |
drop; |
drop |
|IL.opPACKC: |
UnOp(reg1); |
pushc(param2); |
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *) |
OutByte2(0DDH, reg1); (* fld qword[reg1] *) |
OutByte2(0D9H, 0FDH); (* fscale *) |
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *) |
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *) |
pop(reg1); |
drop |
|IL.opUNPK: |
BinOp(reg1, reg2); |
OutByte2(0DDH, reg1); (* fld qword[reg1] *) |
OutByte2(0D9H, 0F4H); (* fxtract *) |
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *) |
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *) |
drop; |
drop |
|IL.opPUSHF: |
ASSERT(fr >= 0); |
DEC(fr); |
subrc(esp, 8); |
OutByte3(0DDH, 01CH, 024H) (* fstp qword[esp] *) |
|IL.opLOADF: |
INC(fr); |
IF fr > MAX_FR THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
UnOp(reg1); |
OutByte2(0DDH, reg1); (* fld qword[reg1] *) |
drop |
|IL.opCONSTF: |
INC(fr); |
IF fr > MAX_FR THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
float := cmd.float; |
IF float = 0.0 THEN |
OutByte2(0D9H, 0EEH) (* fldz *) |
ELSIF float = 1.0 THEN |
OutByte2(0D9H, 0E8H) (* fld1 *) |
ELSIF float = -1.0 THEN |
OutByte2(0D9H, 0E8H); (* fld1 *) |
OutByte2(0D9H, 0E0H) (* fchs *) |
ELSE |
n := UTILS.splitf(float, a, b); |
pushc(b); |
pushc(a); |
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *) |
addrc(esp, 8) |
END |
|IL.opSAVEF, IL.opSAVEFI: |
ASSERT(fr >= 0); |
DEC(fr); |
UnOp(reg1); |
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *) |
drop |
|IL.opADDF: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0C1H) (* faddp st1, st *) |
|IL.opSUBF: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0E9H) (* fsubp st1, st *) |
|IL.opSUBFI: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0E1H) (* fsubrp st1, st *) |
|IL.opMULF: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0C9H) (* fmulp st1, st *) |
|IL.opDIVF: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0F9H) (* fdivp st1, st *) |
|IL.opDIVFI: |
ASSERT(fr >= 1); |
DEC(fr); |
OutByte2(0DEH, 0F1H) (* fdivrp st1, st *) |
|IL.opUMINF: |
ASSERT(fr >= 0); |
OutByte2(0D9H, 0E0H) (* fchs *) |
|IL.opFABS: |
ASSERT(fr >= 0); |
OutByte2(0D9H, 0E1H) (* fabs *) |
|IL.opFLT: |
INC(fr); |
IF fr > MAX_FR THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
UnOp(reg1); |
push(reg1); |
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *) |
pop(reg1); |
drop |
|IL.opFLOOR: |
ASSERT(fr >= 0); |
DEC(fr); |
subrc(esp, 8); |
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); (* fstcw word[esp+4] *) |
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); (* fstcw word[esp+6] *) |
OutByte2(066H, 081H); OutByte3(064H, 024H, 004H); OutWord(0F3FFH); (* and word[esp+4], 1111001111111111b *) |
OutByte2(066H, 081H); OutByte3(04CH, 024H, 004H); OutWord(00400H); (* or word[esp+4], 0000010000000000b *) |
OutByte2(0D9H, 06CH); OutByte2(024H, 004H); (* fldcw word[esp+4] *) |
OutByte2(0D9H, 0FCH); (* frndint *) |
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *) |
pop(GetAnyReg()); |
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); (* fldcw word[esp+2] *) |
addrc(esp, 4) |
|IL.opEQF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 003H); (* jp L *) |
setcc(sete, al) |
(* L: *) |
|IL.opNEF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 003H); (* jp L *) |
setcc(setne, al) |
(* L: *) |
|IL.opLTF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 00EH); (* jp L *) |
setcc(setc, al); |
setcc(sete, ah); |
test(eax); |
setcc(sete, al); |
andrc(eax, 1) |
(* L: *) |
|IL.opGTF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 00FH); (* jp L *) |
setcc(setc, al); |
setcc(sete, ah); |
cmprc(eax, 1); |
setcc(sete, al); |
andrc(eax, 1) |
(* L: *) |
|IL.opLEF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 003H); (* jp L *) |
setcc(setnc, al) |
(* L: *) |
|IL.opGEF: |
ASSERT(fr >= 1); |
DEC(fr, 2); |
fcmp; |
OutByte2(07AH, 010H); (* jp L *) |
setcc(setc, al); |
setcc(sete, ah); |
OutByte2(000H, 0E0H); (* add al, ah *) |
OutByte2(03CH, 001H); (* cmp al, 1 *) |
setcc(sete, al); |
andrc(eax, 1) |
(* L: *) |
|IL.opINF: |
INC(fr); |
IF fr > MAX_FR THEN |
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR) |
END; |
pushc(7FF00000H); |
pushc(0); |
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *) |
addrc(esp, 8) |
|IL.opLADR_UNPK: |
n := param2 * 4; |
reg1 := GetAnyReg(); |
OutByte2(8DH, 45H + reg1 * 8 + long(n)); (* lea reg1, dword[ebp + n] *) |
OutIntByte(n); |
BinOp(reg1, reg2); |
OutByte2(0DDH, reg1); (* fld qword[reg1] *) |
OutByte2(0D9H, 0F4H); (* fxtract *) |
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *) |
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *) |
drop; |
drop |
|IL.opSADR_PARAM: |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICDATA, stroffs + param2); |
push(reg1); |
drop |
ELSE |
OutByte(068H); (* push _data + stroffs + param2 *) |
Reloc(BIN.RDATA, stroffs + param2) |
END |
|IL.opVADR_PARAM, IL.opLLOAD32_PARAM: |
pushm(ebp, param2 * 4) |
|IL.opCONST_PARAM: |
pushc(param2) |
|IL.opGLOAD32_PARAM: |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICBSS, param2); |
pushm(reg1, 0); |
drop |
ELSE |
OutByte2(0FFH, 035H); (* push dword[_bss + param2] *) |
Reloc(BIN.RBSS, param2) |
END |
|IL.opLOAD32_PARAM: |
UnOp(reg1); |
pushm(reg1, 0); |
drop |
|IL.opGADR_SAVEC: |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICBSS, param1); |
OutByte2(0C7H, reg1); (* mov dword[reg1], param2 *) |
OutInt(param2); |
drop |
ELSE |
OutByte2(0C7H, 05H); (* mov dword[_bss + param1], param2 *) |
Reloc(BIN.RBSS, param1); |
OutInt(param2) |
END |
|IL.opLADR_SAVEC: |
n := param1 * 4; |
OutByte2(0C7H, 45H + long(n)); (* mov dword[ebp + n], param2 *) |
OutIntByte(n); |
OutInt(param2) |
|IL.opLADR_SAVE: |
UnOp(reg1); |
movmr(ebp, param2 * 4, reg1); |
drop |
|IL.opLADR_INCC: |
n := param1 * 4; |
IF ABS(param2) = 1 THEN |
OutByte2(0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec dword[ebp + n] *) |
OutIntByte(n) |
ELSE |
OutByte2(81H + short(param2), 45H + long(n)); (* add dword[ebp + n], param2 *) |
OutIntByte(n); |
OutIntByte(param2) |
END |
|IL.opLADR_INCCB, IL.opLADR_DECCB: |
n := param1 * 4; |
IF param2 = 1 THEN |
OutByte2(0FEH, 45H + 8 * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* inc/dec byte[ebp + n] *) |
OutIntByte(n) |
ELSE |
OutByte2(80H, 45H + 28H * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* add/sub byte[ebp + n], param2 *) |
OutIntByte(n); |
OutByte(param2 MOD 256) |
END |
|IL.opLADR_INC, IL.opLADR_DEC: |
n := param2 * 4; |
UnOp(reg1); |
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + reg1 * 8); (* add/sub dword[ebp + n], reg1 *) |
OutIntByte(n); |
drop |
|IL.opLADR_INCB, IL.opLADR_DECB: |
n := param2 * 4; |
UnOp(reg1); |
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + reg1 * 8); (* add/sub byte[ebp + n], reg1 *) |
OutIntByte(n); |
drop |
|IL.opLADR_INCL, IL.opLADR_EXCL: |
n := param2 * 4; |
UnOp(reg1); |
cmprc(reg1, 32); |
label := NewLabel(); |
jcc(jnb, label); |
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + reg1 * 8); (* bts(r) dword[ebp + n], reg1 *) |
OutIntByte(n); |
SetLabel(label); |
drop |
|IL.opLADR_INCLC, IL.opLADR_EXCLC: |
n := param1 * 4; |
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC)); (* bts(r) dword[ebp + n], param2 *) |
OutIntByte(n); |
OutByte(param2) |
|IL.opFNAME: |
fname := cmd(IL.FNAMECMD).fname |
END; |
cmd := cmd.next(COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1); |
ASSERT(fr = -1) |
END translate; |
PROCEDURE prolog (pic: BOOLEAN; target, stack, dllinit, dllret: INTEGER); |
VAR |
reg1, entry, L, dcount: INTEGER; |
BEGIN |
entry := NewLabel(); |
SetLabel(entry); |
dcount := CHL.Length(IL.codes.data); |
IF target = TARGETS.Win32DLL THEN |
push(ebp); |
mov(ebp, esp); |
pushm(ebp, 16); |
pushm(ebp, 12); |
pushm(ebp, 8); |
CallRTL(pic, IL._dllentry); |
test(eax); |
jcc(je, dllret); |
pushc(0) |
ELSIF target = TARGETS.KolibriOSDLL THEN |
SetLabel(dllinit); |
OutByte(68H); (* push IMPORT *) |
Reloc(BIN.IMPTAB, 0) |
ELSIF target = TARGETS.KolibriOS THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.IMPTAB, 0); |
push(reg1); (* push IMPORT *) |
drop |
ELSIF target = TARGETS.Linux32 THEN |
push(esp) |
ELSE |
pushc(0) |
END; |
IF pic THEN |
reg1 := GetAnyReg(); |
Pic(reg1, BIN.PICCODE, entry); |
push(reg1); (* push CODE *) |
Pic(reg1, BIN.PICDATA, 0); |
push(reg1); (* push _data *) |
pushc(tcount); |
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount); |
push(reg1); (* push _data + tcount * 4 + dcount *) |
drop |
ELSE |
OutByte(68H); (* push CODE *) |
Reloc(BIN.RCODE, entry); |
OutByte(68H); (* push _data *) |
Reloc(BIN.RDATA, 0); |
pushc(tcount); |
OutByte(68H); (* push _data + tcount * 4 + dcount *) |
Reloc(BIN.RDATA, tcount * 4 + dcount) |
END; |
CallRTL(pic, IL._init); |
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.Linux32} THEN |
L := NewLabel(); |
pushc(0); |
push(esp); |
pushc(1024 * 1024 * stack); |
pushc(0); |
CallRTL(pic, IL._new); |
pop(eax); |
test(eax); |
jcc(je, L); |
addrc(eax, 1024 * 1024 * stack - 4); |
mov(esp, eax); |
SetLabel(L) |
END |
END prolog; |
PROCEDURE epilog (pic: BOOLEAN; modname: ARRAY OF CHAR; target, stack, ver, dllinit, dllret, sofinit: INTEGER); |
VAR |
exp: IL.EXPORT_PROC; |
path, name, ext: PATHS.PATH; |
dcount, i: INTEGER; |
PROCEDURE _import (imp: LISTS.LIST); |
VAR |
lib: IL.IMPORT_LIB; |
proc: IL.IMPORT_PROC; |
BEGIN |
lib := imp.first(IL.IMPORT_LIB); |
WHILE lib # NIL DO |
BIN.Import(program, lib.name, 0); |
proc := lib.procs.first(IL.IMPORT_PROC); |
WHILE proc # NIL DO |
BIN.Import(program, proc.name, proc.label); |
proc := proc.next(IL.IMPORT_PROC) |
END; |
lib := lib.next(IL.IMPORT_LIB) |
END |
END _import; |
BEGIN |
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.KolibriOS, TARGETS.Linux32} THEN |
pushc(0); |
CallRTL(pic, IL._exit); |
ELSIF target = TARGETS.Win32DLL THEN |
SetLabel(dllret); |
movrc(eax, 1); |
OutByte(0C9H); (* leave *) |
OutByte3(0C2H, 0CH, 0) (* ret 12 *) |
ELSIF target = TARGETS.KolibriOSDLL THEN |
movrc(eax, 1); |
ret |
ELSIF target = TARGETS.Linux32SO THEN |
ret; |
SetLabel(sofinit); |
CallRTL(pic, IL._sofinit); |
ret |
END; |
fixup; |
dcount := CHL.Length(IL.codes.data); |
FOR i := 0 TO tcount - 1 DO |
BIN.PutData32LE(program, CHL.GetInt(IL.codes.types, i)) |
END; |
FOR i := 0 TO dcount - 1 DO |
BIN.PutData(program, CHL.GetByte(IL.codes.data, i)) |
END; |
program.modname := CHL.Length(program.data); |
PATHS.split(modname, path, name, ext); |
BIN.PutDataStr(program, name); |
BIN.PutDataStr(program, ext); |
BIN.PutData(program, 0); |
IF target = TARGETS.KolibriOSDLL THEN |
BIN.Export(program, "lib_init", dllinit); |
END; |
exp := IL.codes.export.first(IL.EXPORT_PROC); |
WHILE exp # NIL DO |
BIN.Export(program, exp.name, exp.label); |
exp := exp.next(IL.EXPORT_PROC) |
END; |
_import(IL.codes._import); |
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4))); |
BIN.SetParams(program, IL.codes.bss, stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536)) |
END epilog; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
VAR |
dllret, dllinit, sofinit: INTEGER; |
opt: PROG.OPTIONS; |
BEGIN |
FR[0] := 0; |
tcount := CHL.Length(IL.codes.types); |
opt := options; |
CodeList := LISTS.create(NIL); |
program := BIN.create(IL.codes.lcount); |
dllinit := NewLabel(); |
dllret := NewLabel(); |
sofinit := NewLabel(); |
IF target = TARGETS.KolibriOSDLL THEN |
opt.pic := FALSE |
END; |
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32} THEN |
opt.pic := TRUE |
END; |
REG.Init(R, push, pop, mov, xchg, {eax, ecx, edx}); |
prolog(opt.pic, target, opt.stack, dllinit, dllret); |
translate(opt.pic, tcount * 4); |
epilog(opt.pic, outname, target, opt.stack, opt.version, dllinit, dllret, sofinit); |
BIN.fixup(program); |
IF TARGETS.OS = TARGETS.osWIN32 THEN |
PE32.write(program, outname, target = TARGETS.Win32C, target = TARGETS.Win32DLL, FALSE) |
ELSIF target = TARGETS.KolibriOS THEN |
KOS.write(program, outname) |
ELSIF target = TARGETS.KolibriOSDLL THEN |
MSCOFF.write(program, outname, opt.version) |
ELSIF TARGETS.OS = TARGETS.osLINUX32 THEN |
ELF.write(program, outname, sofinit, target = TARGETS.Linux32SO, FALSE) |
END |
END CodeGen; |
PROCEDURE SetProgram* (prog: BIN.PROGRAM); |
BEGIN |
program := prog; |
CodeList := LISTS.create(NIL) |
END SetProgram; |
END X86. |
/programs/develop/oberon07/source/BIN.ob07 |
---|
0,0 → 1,384 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE BIN; |
IMPORT LISTS, CHL := CHUNKLISTS, ARITH, UTILS; |
CONST |
RCODE* = 0; PICCODE* = RCODE + 1; |
RDATA* = 2; PICDATA* = RDATA + 1; |
RBSS* = 4; PICBSS* = RBSS + 1; |
RIMP* = 6; PICIMP* = RIMP + 1; |
IMPTAB* = 8; |
TYPE |
RELOC* = POINTER TO RECORD (LISTS.ITEM) |
opcode*: INTEGER; |
offset*: INTEGER |
END; |
IMPRT* = POINTER TO RECORD (LISTS.ITEM) |
nameoffs*: INTEGER; |
label*: INTEGER; |
OriginalFirstThunk*, |
FirstThunk*: INTEGER |
END; |
EXPRT* = POINTER TO RECORD (LISTS.ITEM) |
nameoffs*: INTEGER; |
label*: INTEGER |
END; |
PROGRAM* = POINTER TO RECORD |
code*: CHL.BYTELIST; |
data*: CHL.BYTELIST; |
labels: CHL.INTLIST; |
bss*: INTEGER; |
stack*: INTEGER; |
vmajor*, |
vminor*: WCHAR; |
modname*: INTEGER; |
_import*: CHL.BYTELIST; |
export*: CHL.BYTELIST; |
rel_list*: LISTS.LIST; |
imp_list*: LISTS.LIST; |
exp_list*: LISTS.LIST |
END; |
PROCEDURE create* (NumberOfLabels: INTEGER): PROGRAM; |
VAR |
program: PROGRAM; |
i: INTEGER; |
BEGIN |
NEW(program); |
program.bss := 0; |
program.labels := CHL.CreateIntList(); |
FOR i := 0 TO NumberOfLabels - 1 DO |
CHL.PushInt(program.labels, 0) |
END; |
program.rel_list := LISTS.create(NIL); |
program.imp_list := LISTS.create(NIL); |
program.exp_list := LISTS.create(NIL); |
program.data := CHL.CreateByteList(); |
program.code := CHL.CreateByteList(); |
program._import := CHL.CreateByteList(); |
program.export := CHL.CreateByteList() |
RETURN program |
END create; |
PROCEDURE SetParams* (program: PROGRAM; bss, stack: INTEGER; vmajor, vminor: WCHAR); |
BEGIN |
program.bss := bss; |
program.stack := stack; |
program.vmajor := vmajor; |
program.vminor := vminor |
END SetParams; |
PROCEDURE PutReloc* (program: PROGRAM; opcode: INTEGER); |
VAR |
cmd: RELOC; |
BEGIN |
NEW(cmd); |
cmd.opcode := opcode; |
cmd.offset := CHL.Length(program.code); |
LISTS.push(program.rel_list, cmd) |
END PutReloc; |
PROCEDURE PutData* (program: PROGRAM; b: BYTE); |
BEGIN |
CHL.PushByte(program.data, b) |
END PutData; |
PROCEDURE get32le* (_array: CHL.BYTELIST; idx: INTEGER): INTEGER; |
VAR |
i: INTEGER; |
x: INTEGER; |
BEGIN |
x := 0; |
FOR i := 3 TO 0 BY -1 DO |
x := LSL(x, 8) + CHL.GetByte(_array, idx + i) |
END; |
IF UTILS.bit_depth = 64 THEN |
x := LSL(x, 16); |
x := LSL(x, 16); |
x := ASR(x, 16); |
x := ASR(x, 16) |
END |
RETURN x |
END get32le; |
PROCEDURE put32le* (_array: CHL.BYTELIST; idx: INTEGER; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.SetByte(_array, idx + i, UTILS.Byte(x, i)) |
END |
END put32le; |
PROCEDURE PutData32LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.PushByte(program.data, UTILS.Byte(x, i)) |
END |
END PutData32LE; |
PROCEDURE PutData64LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 7 DO |
CHL.PushByte(program.data, UTILS.Byte(x, i)) |
END |
END PutData64LE; |
PROCEDURE PutDataStr* (program: PROGRAM; s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE s[i] # 0X DO |
PutData(program, ORD(s[i])); |
INC(i) |
END |
END PutDataStr; |
PROCEDURE PutCode* (program: PROGRAM; b: BYTE); |
BEGIN |
CHL.PushByte(program.code, b) |
END PutCode; |
PROCEDURE PutCode32LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.PushByte(program.code, UTILS.Byte(x, i)) |
END |
END PutCode32LE; |
PROCEDURE PutCode16LE* (program: PROGRAM; x: INTEGER); |
BEGIN |
CHL.PushByte(program.code, UTILS.Byte(x, 0)); |
CHL.PushByte(program.code, UTILS.Byte(x, 1)) |
END PutCode16LE; |
PROCEDURE SetLabel* (program: PROGRAM; label, offset: INTEGER); |
BEGIN |
CHL.SetInt(program.labels, label, offset) |
END SetLabel; |
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER); |
VAR |
imp: IMPRT; |
BEGIN |
CHL.PushByte(program._import, 0); |
CHL.PushByte(program._import, 0); |
IF ODD(CHL.Length(program._import)) THEN |
CHL.PushByte(program._import, 0) |
END; |
NEW(imp); |
imp.nameoffs := CHL.PushStr(program._import, name); |
imp.label := label; |
LISTS.push(program.imp_list, imp) |
END Import; |
PROCEDURE less (bytes: CHL.BYTELIST; a, b: EXPRT): BOOLEAN; |
VAR |
i, j: INTEGER; |
BEGIN |
i := a.nameoffs; |
j := b.nameoffs; |
WHILE (CHL.GetByte(bytes, i) # 0) & (CHL.GetByte(bytes, j) # 0) & |
(CHL.GetByte(bytes, i) = CHL.GetByte(bytes, j)) DO |
INC(i); |
INC(j) |
END |
RETURN CHL.GetByte(bytes, i) < CHL.GetByte(bytes, j) |
END less; |
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER); |
VAR |
exp, cur: EXPRT; |
BEGIN |
NEW(exp); |
exp.label := CHL.GetInt(program.labels, label); |
exp.nameoffs := CHL.PushStr(program.export, name); |
cur := program.exp_list.first(EXPRT); |
WHILE (cur # NIL) & less(program.export, cur, exp) DO |
cur := cur.next(EXPRT) |
END; |
IF cur # NIL THEN |
IF cur.prev # NIL THEN |
LISTS.insert(program.exp_list, cur.prev, exp) |
ELSE |
LISTS.insertL(program.exp_list, cur, exp) |
END |
ELSE |
LISTS.push(program.exp_list, exp) |
END |
END Export; |
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT; |
VAR |
_import, res: IMPRT; |
BEGIN |
_import := program.imp_list.first(IMPRT); |
res := NIL; |
WHILE (_import # NIL) & (n >= 0) DO |
IF _import.label # 0 THEN |
res := _import; |
DEC(n) |
END; |
_import := _import.next(IMPRT) |
END; |
ASSERT(n = -1) |
RETURN res |
END GetIProc; |
PROCEDURE GetLabel* (program: PROGRAM; label: INTEGER): INTEGER; |
RETURN CHL.GetInt(program.labels, label) |
END GetLabel; |
PROCEDURE NewLabel* (program: PROGRAM); |
BEGIN |
CHL.PushInt(program.labels, 0) |
END NewLabel; |
PROCEDURE fixup* (program: PROGRAM); |
VAR |
rel: RELOC; |
imp: IMPRT; |
nproc: INTEGER; |
L: INTEGER; |
BEGIN |
nproc := 0; |
imp := program.imp_list.first(IMPRT); |
WHILE imp # NIL DO |
IF imp.label # 0 THEN |
CHL.SetInt(program.labels, imp.label, nproc); |
INC(nproc) |
END; |
imp := imp.next(IMPRT) |
END; |
rel := program.rel_list.first(RELOC); |
WHILE rel # NIL DO |
IF rel.opcode IN {RIMP, PICIMP} THEN |
L := get32le(program.code, rel.offset); |
put32le(program.code, rel.offset, GetLabel(program, L)) |
END; |
rel := rel.next(RELOC) |
END |
END fixup; |
PROCEDURE InitArray* (VAR _array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR); |
VAR |
i, k: INTEGER; |
PROCEDURE hexdgt (dgt: CHAR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF dgt < "A" THEN |
res := ORD(dgt) - ORD("0") |
ELSE |
res := ORD(dgt) - ORD("A") + 10 |
END |
RETURN res |
END hexdgt; |
BEGIN |
k := LENGTH(hex); |
ASSERT(~ODD(k)); |
k := k DIV 2; |
FOR i := 0 TO k - 1 DO |
_array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1]) |
END; |
INC(idx, k) |
END InitArray; |
END BIN. |
/programs/develop/oberon07/source/HEX.ob07 |
---|
0,0 → 1,117 |
(* |
BSD 2-Clause License |
Copyright (c) 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE HEX; |
IMPORT WRITER, CHL := CHUNKLISTS, UTILS; |
VAR |
chksum: INTEGER; |
PROCEDURE Byte (byte: BYTE); |
BEGIN |
WRITER.WriteByte(UTILS.hexdgt(byte DIV 16)); |
WRITER.WriteByte(UTILS.hexdgt(byte MOD 16)); |
INC(chksum, byte) |
END Byte; |
PROCEDURE Byte4 (a, b, c, d: BYTE); |
BEGIN |
Byte(a); |
Byte(b); |
Byte(c); |
Byte(d) |
END Byte4; |
PROCEDURE NewLine; |
BEGIN |
Byte((-chksum) MOD 256); |
chksum := 0; |
WRITER.WriteByte(0DH); |
WRITER.WriteByte(0AH) |
END NewLine; |
PROCEDURE StartCode; |
BEGIN |
WRITER.WriteByte(ORD(":")); |
chksum := 0 |
END StartCode; |
PROCEDURE Data* (mem: ARRAY OF BYTE; idx, cnt: INTEGER); |
VAR |
i, len: INTEGER; |
BEGIN |
WHILE cnt > 0 DO |
len := MIN(cnt, 16); |
StartCode; |
Byte4(len, idx DIV 256, idx MOD 256, 0); |
FOR i := 1 TO len DO |
Byte(mem[idx]); |
INC(idx) |
END; |
DEC(cnt, len); |
NewLine |
END |
END Data; |
PROCEDURE ExtLA* (LA: INTEGER); |
BEGIN |
ASSERT((0 <= LA) & (LA <= 0FFFFH)); |
StartCode; |
Byte4(2, 0, 0, 4); |
Byte(LA DIV 256); |
Byte(LA MOD 256); |
NewLine |
END ExtLA; |
PROCEDURE Data2* (mem: CHL.BYTELIST; idx, cnt, LA: INTEGER); |
VAR |
i, len, offset: INTEGER; |
BEGIN |
ExtLA(LA); |
offset := 0; |
WHILE cnt > 0 DO |
ASSERT(offset <= 65536); |
IF offset = 65536 THEN |
INC(LA); |
ExtLA(LA); |
offset := 0 |
END; |
len := MIN(cnt, 16); |
StartCode; |
Byte4(len, offset DIV 256, offset MOD 256, 0); |
FOR i := 1 TO len DO |
Byte(CHL.GetByte(mem, idx)); |
INC(idx); |
INC(offset) |
END; |
DEC(cnt, len); |
NewLine |
END |
END Data2; |
PROCEDURE End*; |
BEGIN |
StartCode; |
Byte4(0, 0, 0, 1); |
NewLine |
END End; |
END HEX. |
/programs/develop/oberon07/source/KOS.ob07 |
---|
0,0 → 1,206 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE KOS; |
IMPORT BIN, WR := WRITER, LISTS, CHL := CHUNKLISTS; |
CONST |
HEADER_SIZE = 36; |
SIZE_OF_DWORD = 4; |
TYPE |
HEADER = RECORD |
menuet01: ARRAY 9 OF CHAR; |
ver, start, size, mem, sp, param, path: INTEGER |
END; |
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER); |
VAR |
i: INTEGER; |
imp: BIN.IMPRT; |
BEGIN |
libcount := 0; |
imp := program.imp_list.first(BIN.IMPRT); |
WHILE imp # NIL DO |
IF imp.label = 0 THEN |
INC(libcount) |
END; |
imp := imp.next(BIN.IMPRT) |
END; |
len := libcount * 2 + 2; |
size := (LISTS.count(program.imp_list) + len + 1) * SIZE_OF_DWORD; |
ImportTable := CHL.CreateIntList(); |
FOR i := 0 TO size DIV SIZE_OF_DWORD - 1 DO |
CHL.PushInt(ImportTable, 0) |
END; |
i := 0; |
imp := program.imp_list.first(BIN.IMPRT); |
WHILE imp # NIL DO |
IF imp.label = 0 THEN |
CHL.SetInt(ImportTable, len, 0); |
INC(len); |
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD); |
INC(i); |
CHL.SetInt(ImportTable, i, imp.nameoffs + size + idata); |
INC(i) |
ELSE |
CHL.SetInt(ImportTable, len, imp.nameoffs + size + idata); |
imp.label := len * SIZE_OF_DWORD; |
INC(len) |
END; |
imp := imp.next(BIN.IMPRT) |
END; |
CHL.SetInt(ImportTable, len, 0); |
CHL.SetInt(ImportTable, i, 0); |
CHL.SetInt(ImportTable, i + 1, 0); |
INC(len); |
INC(size, CHL.Length(program._import)) |
END Import; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR); |
CONST |
PARAM_SIZE = 2048; |
FileAlignment = 16; |
VAR |
header: HEADER; |
base, text, data, idata, bss, offset: INTEGER; |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
L: INTEGER; |
delta: INTEGER; |
i: INTEGER; |
ImportTable: CHL.INTLIST; |
ILen, libcount, isize: INTEGER; |
icount, dcount, ccount: INTEGER; |
code: CHL.BYTELIST; |
BEGIN |
base := 0; |
icount := CHL.Length(program._import); |
dcount := CHL.Length(program.data); |
ccount := CHL.Length(program.code); |
text := base + HEADER_SIZE; |
data := WR.align(text + ccount, FileAlignment); |
idata := WR.align(data + dcount, FileAlignment); |
Import(program, idata, ImportTable, ILen, libcount, isize); |
bss := WR.align(idata + isize, FileAlignment); |
header.menuet01 := "MENUET01"; |
header.ver := 1; |
header.start := text; |
header.size := idata + isize - base; |
header.mem := WR.align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment); |
header.sp := base + header.mem - PARAM_SIZE * 2; |
header.param := header.sp; |
header.path := header.param + PARAM_SIZE; |
code := program.code; |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
offset := reloc.offset; |
L := BIN.get32le(code, offset); |
delta := 3 - offset - text; |
CASE reloc.opcode OF |
|BIN.RIMP: |
iproc := BIN.GetIProc(program, L); |
delta := idata + iproc.label |
|BIN.RBSS: |
delta := L + bss |
|BIN.RDATA: |
delta := L + data |
|BIN.RCODE: |
delta := BIN.GetLabel(program, L) + text |
|BIN.PICDATA: |
INC(delta, L + data) |
|BIN.PICCODE: |
INC(delta, BIN.GetLabel(program, L) + text) |
|BIN.PICBSS: |
INC(delta, L + bss) |
|BIN.PICIMP: |
iproc := BIN.GetIProc(program, L); |
INC(delta, idata + iproc.label) |
|BIN.IMPTAB: |
INC(delta, idata) |
END; |
BIN.put32le(code, offset, delta); |
reloc := reloc.next(BIN.RELOC) |
END; |
WR.Create(FileName); |
FOR i := 0 TO 7 DO |
WR.WriteByte(ORD(header.menuet01[i])) |
END; |
WR.Write32LE(header.ver); |
WR.Write32LE(header.start); |
WR.Write32LE(header.size); |
WR.Write32LE(header.mem); |
WR.Write32LE(header.sp); |
WR.Write32LE(header.param); |
WR.Write32LE(header.path); |
CHL.WriteToFile(code); |
WR.Padding(FileAlignment); |
CHL.WriteToFile(program.data); |
WR.Padding(FileAlignment); |
FOR i := 0 TO ILen - 1 DO |
WR.Write32LE(CHL.GetInt(ImportTable, i)) |
END; |
CHL.WriteToFile(program._import); |
WR.Close |
END write; |
END KOS. |
/programs/develop/oberon07/source/MSCOFF.ob07 |
---|
0,0 → 1,309 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE MSCOFF; |
IMPORT BIN, PE32, KOS, WR := WRITER, UTILS, ERRORS, LISTS, CHL := CHUNKLISTS; |
CONST |
SIZE_OF_DWORD = 4; |
(* SectionHeader.Characteristics *) |
SHC_flat = 040500020H; |
SHC_data = 0C0500040H; |
SHC_bss = 0C03000C0H; |
TYPE |
FH = PE32.IMAGE_FILE_HEADER; |
SH = PE32.IMAGE_SECTION_HEADER; |
PROCEDURE WriteReloc (VirtualAddress, SymbolTableIndex, Type: INTEGER); |
BEGIN |
WR.Write32LE(VirtualAddress); |
WR.Write32LE(SymbolTableIndex); |
WR.Write16LE(Type) |
END WriteReloc; |
PROCEDURE Reloc (program: BIN.PROGRAM); |
VAR |
reloc: BIN.RELOC; |
offset: INTEGER; |
BEGIN |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
offset := reloc.offset; |
CASE reloc.opcode OF |
|BIN.RIMP, |
BIN.IMPTAB: WriteReloc(offset, 4, 6) |
|BIN.RBSS: WriteReloc(offset, 5, 6) |
|BIN.RDATA: WriteReloc(offset, 2, 6) |
|BIN.RCODE: WriteReloc(offset, 1, 6) |
END; |
reloc := reloc.next(BIN.RELOC) |
END; |
END Reloc; |
PROCEDURE RelocCount (program: BIN.PROGRAM): INTEGER; |
VAR |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
res, L: INTEGER; |
offset: INTEGER; |
code: CHL.BYTELIST; |
BEGIN |
res := 0; |
code := program.code; |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
INC(res); |
offset := reloc.offset; |
IF reloc.opcode = BIN.RIMP THEN |
L := BIN.get32le(code, offset); |
iproc := BIN.GetIProc(program, L); |
BIN.put32le(code, offset, iproc.label) |
END; |
IF reloc.opcode = BIN.RCODE THEN |
L := BIN.get32le(code, offset); |
BIN.put32le(code, offset, BIN.GetLabel(program, L)) |
END; |
reloc := reloc.next(BIN.RELOC) |
END |
RETURN res |
END RelocCount; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER); |
VAR |
exp: BIN.EXPRT; |
n, i: INTEGER; |
szversion: PE32.NAME; |
ImportTable: CHL.INTLIST; |
ILen, LibCount, isize: INTEGER; |
ExpCount: INTEGER; |
icount, ecount, dcount, ccount: INTEGER; |
FileHeader: FH; |
flat, data, edata, idata, bss: SH; |
PROCEDURE ICount (ImportTable: CHL.INTLIST; ILen: INTEGER): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := 0; |
FOR i := 0 TO ILen - 1 DO |
IF CHL.GetInt(ImportTable, i) # 0 THEN |
INC(res) |
END |
END |
RETURN res |
END ICount; |
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER); |
BEGIN |
IF NumberOfRelocations >= 65536 THEN |
ERRORS.Error(202) |
END; |
section.NumberOfRelocations := WCHR(NumberOfRelocations) |
END SetNumberOfRelocations; |
BEGIN |
szversion := "version"; |
ASSERT(LENGTH(szversion) = 7); |
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize); |
ExpCount := LISTS.count(program.exp_list); |
icount := CHL.Length(program._import); |
dcount := CHL.Length(program.data); |
ccount := CHL.Length(program.code); |
ecount := CHL.Length(program.export); |
FileHeader.Machine := 014CX; |
FileHeader.NumberOfSections := 5X; |
FileHeader.TimeDateStamp := UTILS.UnixTime(); |
(* FileHeader.PointerToSymbolTable := 0; *) |
FileHeader.NumberOfSymbols := 6; |
FileHeader.SizeOfOptionalHeader := 0X; |
FileHeader.Characteristics := 0184X; |
flat.Name := ".flat"; |
flat.VirtualSize := 0; |
flat.VirtualAddress := 0; |
flat.SizeOfRawData := ccount; |
flat.PointerToRawData := ORD(FileHeader.NumberOfSections) * PE32.SIZE_OF_IMAGE_SECTION_HEADER + PE32.SIZE_OF_IMAGE_FILE_HEADER; |
(* flat.PointerToRelocations := 0; *) |
flat.PointerToLinenumbers := 0; |
SetNumberOfRelocations(flat, RelocCount(program)); |
flat.NumberOfLinenumbers := 0X; |
flat.Characteristics := SHC_flat; |
data.Name := ".data"; |
data.VirtualSize := 0; |
data.VirtualAddress := 0; |
data.SizeOfRawData := dcount; |
data.PointerToRawData := flat.PointerToRawData + flat.SizeOfRawData; |
data.PointerToRelocations := 0; |
data.PointerToLinenumbers := 0; |
data.NumberOfRelocations := 0X; |
data.NumberOfLinenumbers := 0X; |
data.Characteristics := SHC_data; |
edata.Name := ".edata"; |
edata.VirtualSize := 0; |
edata.VirtualAddress := 0; |
edata.SizeOfRawData := ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD + LENGTH(szversion) + 1 + ecount; |
edata.PointerToRawData := data.PointerToRawData + data.SizeOfRawData; |
(* edata.PointerToRelocations := 0; *) |
edata.PointerToLinenumbers := 0; |
SetNumberOfRelocations(edata, ExpCount * 2 + 1); |
edata.NumberOfLinenumbers := 0X; |
edata.Characteristics := SHC_data; |
idata.Name := ".idata"; |
idata.VirtualSize := 0; |
idata.VirtualAddress := 0; |
idata.SizeOfRawData := isize; |
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData; |
(* idata.PointerToRelocations := 0; *) |
idata.PointerToLinenumbers := 0; |
SetNumberOfRelocations(idata, ICount(ImportTable, ILen)); |
idata.NumberOfLinenumbers := 0X; |
idata.Characteristics := SHC_data; |
bss.Name := ".bss"; |
bss.VirtualSize := 0; |
bss.VirtualAddress := 0; |
bss.SizeOfRawData := program.bss; |
bss.PointerToRawData := 0; |
bss.PointerToRelocations := 0; |
bss.PointerToLinenumbers := 0; |
bss.NumberOfRelocations := 0X; |
bss.NumberOfLinenumbers := 0X; |
bss.Characteristics := SHC_bss; |
flat.PointerToRelocations := idata.PointerToRawData + idata.SizeOfRawData; |
edata.PointerToRelocations := flat.PointerToRelocations + ORD(flat.NumberOfRelocations) * 10; |
idata.PointerToRelocations := edata.PointerToRelocations + ORD(edata.NumberOfRelocations) * 10; |
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10; |
WR.Create(FileName); |
PE32.WriteFileHeader(FileHeader); |
PE32.WriteSectionHeader(flat); |
PE32.WriteSectionHeader(data); |
PE32.WriteSectionHeader(edata); |
PE32.WriteSectionHeader(idata); |
PE32.WriteSectionHeader(bss); |
CHL.WriteToFile(program.code); |
CHL.WriteToFile(program.data); |
exp := program.exp_list.first(BIN.EXPRT); |
WHILE exp # NIL DO |
WR.Write32LE(exp.nameoffs + edata.SizeOfRawData - ecount); |
WR.Write32LE(exp.label); |
exp := exp.next(BIN.EXPRT) |
END; |
WR.Write32LE(((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD); |
WR.Write32LE(ver); |
WR.Write32LE(0); |
PE32.WriteName(szversion); |
CHL.WriteToFile(program.export); |
FOR i := 0 TO ILen - 1 DO |
WR.Write32LE(CHL.GetInt(ImportTable, i)) |
END; |
CHL.WriteToFile(program._import); |
Reloc(program); |
n := 0; |
exp := program.exp_list.first(BIN.EXPRT); |
WHILE exp # NIL DO |
WriteReloc(n, 3, 6); |
INC(n, 4); |
WriteReloc(n, 1, 6); |
INC(n, 4); |
exp := exp.next(BIN.EXPRT) |
END; |
WriteReloc(n, 3, 6); |
FOR i := 0 TO LibCount * 2 - 1 DO |
WriteReloc(i * SIZE_OF_DWORD, 4, 6) |
END; |
FOR i := LibCount * 2 TO ILen - 1 DO |
IF CHL.GetInt(ImportTable, i) # 0 THEN |
WriteReloc(i * SIZE_OF_DWORD, 4, 6) |
END |
END; |
PE32.WriteName("EXPORTS"); |
WriteReloc(0, 3, 2); |
PE32.WriteName(".flat"); |
WriteReloc(0, 1, 3); |
PE32.WriteName(".data"); |
WriteReloc(0, 2, 3); |
PE32.WriteName(".edata"); |
WriteReloc(0, 3, 3); |
PE32.WriteName(".idata"); |
WriteReloc(0, 4, 3); |
PE32.WriteName(".bss"); |
WriteReloc(0, 5, 3); |
WR.Write32LE(4); |
WR.Close |
END write; |
END MSCOFF. |
/programs/develop/oberon07/source/PE32.ob07 |
---|
0,0 → 1,695 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE PE32; |
IMPORT BIN, LISTS, UTILS, WR := WRITER, CHL := CHUNKLISTS; |
CONST |
SIZE_OF_DWORD = 4; |
SIZE_OF_WORD = 2; |
SIZE_OF_IMAGE_EXPORT_DIRECTORY = 40; |
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16; |
IMAGE_SIZEOF_SHORT_NAME = 8; |
SIZE_OF_IMAGE_FILE_HEADER* = 20; |
SIZE_OF_IMAGE_SECTION_HEADER* = 40; |
(* SectionHeader.Characteristics *) |
SHC_text = 060000020H; |
SHC_data = 040000040H; |
SHC_bss = 0C0000080H; |
SectionAlignment = 1000H; |
FileAlignment = 200H; |
TYPE |
WORD = WCHAR; |
DWORD = INTEGER; |
NAME* = ARRAY IMAGE_SIZEOF_SHORT_NAME OF CHAR; |
IMAGE_DATA_DIRECTORY = RECORD |
VirtualAddress: DWORD; |
Size: DWORD |
END; |
IMAGE_OPTIONAL_HEADER = RECORD |
Magic: WORD; |
MajorLinkerVersion: BYTE; |
MinorLinkerVersion: BYTE; |
SizeOfCode: DWORD; |
SizeOfInitializedData: DWORD; |
SizeOfUninitializedData: DWORD; |
AddressOfEntryPoint: DWORD; |
BaseOfCode: DWORD; |
BaseOfData: DWORD; |
ImageBase: DWORD; |
SectionAlignment: DWORD; |
FileAlignment: DWORD; |
MajorOperatingSystemVersion: WORD; |
MinorOperatingSystemVersion: WORD; |
MajorImageVersion: WORD; |
MinorImageVersion: WORD; |
MajorSubsystemVersion: WORD; |
MinorSubsystemVersion: WORD; |
Win32VersionValue: DWORD; |
SizeOfImage: DWORD; |
SizeOfHeaders: DWORD; |
CheckSum: DWORD; |
Subsystem: WORD; |
DllCharacteristics: WORD; |
SizeOfStackReserve: DWORD; |
SizeOfStackCommit: DWORD; |
SizeOfHeapReserve: DWORD; |
SizeOfHeapCommit: DWORD; |
LoaderFlags: DWORD; |
NumberOfRvaAndSizes: DWORD; |
DataDirectory: ARRAY IMAGE_NUMBEROF_DIRECTORY_ENTRIES OF IMAGE_DATA_DIRECTORY |
END; |
IMAGE_FILE_HEADER* = RECORD |
Machine*: WORD; |
NumberOfSections*: WORD; |
TimeDateStamp*: DWORD; |
PointerToSymbolTable*: DWORD; |
NumberOfSymbols*: DWORD; |
SizeOfOptionalHeader*: WORD; |
Characteristics*: WORD |
END; |
IMAGE_SECTION_HEADER* = RECORD |
Name*: NAME; |
VirtualSize*, |
VirtualAddress*, |
SizeOfRawData*, |
PointerToRawData*, |
PointerToRelocations*, |
PointerToLinenumbers*: DWORD; |
NumberOfRelocations*, |
NumberOfLinenumbers*: WORD; |
Characteristics*: DWORD |
END; |
IMAGE_EXPORT_DIRECTORY = RECORD |
Characteristics: DWORD; |
TimeDateStamp: DWORD; |
MajorVersion: WORD; |
MinorVersion: WORD; |
Name, |
Base, |
NumberOfFunctions, |
NumberOfNames, |
AddressOfFunctions, |
AddressOfNames, |
AddressOfNameOrdinals: DWORD |
END; |
VIRTUAL_ADDR* = RECORD |
Code*, Data*, Bss*, Import*: INTEGER |
END; |
VAR |
Signature: ARRAY 4 OF BYTE; |
FileHeader: IMAGE_FILE_HEADER; |
OptionalHeader: IMAGE_OPTIONAL_HEADER; |
msdos: ARRAY 128 OF BYTE; |
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER; |
libcnt: INTEGER; |
SizeOfWord: INTEGER; |
PROCEDURE Export (program: BIN.PROGRAM; name: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER; |
BEGIN |
ExportDir.Characteristics := 0; |
ExportDir.TimeDateStamp := FileHeader.TimeDateStamp; |
ExportDir.MajorVersion := 0X; |
ExportDir.MinorVersion := 0X; |
ExportDir.Name := name; |
ExportDir.Base := 0; |
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list); |
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions; |
ExportDir.AddressOfFunctions := SIZE_OF_IMAGE_EXPORT_DIRECTORY; |
ExportDir.AddressOfNames := ExportDir.AddressOfFunctions + ExportDir.NumberOfFunctions * SIZE_OF_DWORD; |
ExportDir.AddressOfNameOrdinals := ExportDir.AddressOfNames + ExportDir.NumberOfFunctions * SIZE_OF_DWORD |
RETURN SIZE_OF_IMAGE_EXPORT_DIRECTORY + ExportDir.NumberOfFunctions * (2 * SIZE_OF_DWORD + SIZE_OF_WORD) |
END Export; |
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER; |
VAR |
imp: BIN.IMPRT; |
res: INTEGER; |
BEGIN |
res := 0; |
imp := lib.next(BIN.IMPRT); |
WHILE (imp # NIL) & (imp.label # 0) DO |
INC(res); |
imp := imp.next(BIN.IMPRT) |
END |
RETURN res |
END GetProcCount; |
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER; |
VAR |
imp: BIN.IMPRT; |
proccnt: INTEGER; |
procoffs: INTEGER; |
OriginalCurrentThunk, |
CurrentThunk: INTEGER; |
BEGIN |
libcnt := 0; |
proccnt := 0; |
imp := imp_list.first(BIN.IMPRT); |
WHILE imp # NIL DO |
IF imp.label = 0 THEN |
INC(libcnt) |
ELSE |
INC(proccnt) |
END; |
imp := imp.next(BIN.IMPRT) |
END; |
procoffs := 0; |
imp := imp_list.first(BIN.IMPRT); |
WHILE imp # NIL DO |
IF imp.label = 0 THEN |
imp.OriginalFirstThunk := procoffs; |
imp.FirstThunk := procoffs + (GetProcCount(imp) + 1); |
OriginalCurrentThunk := imp.OriginalFirstThunk; |
CurrentThunk := imp.FirstThunk; |
INC(procoffs, (GetProcCount(imp) + 1) * 2) |
ELSE |
imp.OriginalFirstThunk := OriginalCurrentThunk; |
imp.FirstThunk := CurrentThunk; |
INC(OriginalCurrentThunk); |
INC(CurrentThunk) |
END; |
imp := imp.next(BIN.IMPRT) |
END |
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord |
END GetImportSize; |
PROCEDURE fixup* (program: BIN.PROGRAM; Address: VIRTUAL_ADDR; amd64: BOOLEAN); |
VAR |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
code: CHL.BYTELIST; |
L, delta, delta0, AdrImp, offset: INTEGER; |
BEGIN |
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD; |
code := program.code; |
reloc := program.rel_list.first(BIN.RELOC); |
delta0 := 3 - 7 * ORD(amd64) - Address.Code; |
WHILE reloc # NIL DO |
offset := reloc.offset; |
L := BIN.get32le(code, offset); |
delta := delta0 - offset; |
CASE reloc.opcode OF |
|BIN.PICDATA: |
INC(delta, L + Address.Data) |
|BIN.PICCODE: |
INC(delta, BIN.GetLabel(program, L) + Address.Code) |
|BIN.PICBSS: |
INC(delta, L + Address.Bss) |
|BIN.PICIMP: |
iproc := BIN.GetIProc(program, L); |
INC(delta, iproc.FirstThunk * SizeOfWord + AdrImp) |
END; |
BIN.put32le(code, offset, delta); |
reloc := reloc.next(BIN.RELOC) |
END |
END fixup; |
PROCEDURE WriteWord (w: WORD); |
BEGIN |
WR.Write16LE(ORD(w)) |
END WriteWord; |
PROCEDURE WriteName* (name: NAME); |
VAR |
i, nameLen: INTEGER; |
BEGIN |
nameLen := LENGTH(name); |
FOR i := 0 TO nameLen - 1 DO |
WR.WriteByte(ORD(name[i])) |
END; |
i := LEN(name) - nameLen; |
WHILE i > 0 DO |
WR.WriteByte(0); |
DEC(i) |
END |
END WriteName; |
PROCEDURE WriteSectionHeader* (h: IMAGE_SECTION_HEADER); |
VAR |
i, nameLen: INTEGER; |
BEGIN |
nameLen := LENGTH(h.Name); |
FOR i := 0 TO nameLen - 1 DO |
WR.WriteByte(ORD(h.Name[i])) |
END; |
i := LEN(h.Name) - nameLen; |
WHILE i > 0 DO |
WR.WriteByte(0); |
DEC(i) |
END; |
WR.Write32LE(h.VirtualSize); |
WR.Write32LE(h.VirtualAddress); |
WR.Write32LE(h.SizeOfRawData); |
WR.Write32LE(h.PointerToRawData); |
WR.Write32LE(h.PointerToRelocations); |
WR.Write32LE(h.PointerToLinenumbers); |
WriteWord(h.NumberOfRelocations); |
WriteWord(h.NumberOfLinenumbers); |
WR.Write32LE(h.Characteristics) |
END WriteSectionHeader; |
PROCEDURE WriteFileHeader* (h: IMAGE_FILE_HEADER); |
BEGIN |
WriteWord(h.Machine); |
WriteWord(h.NumberOfSections); |
WR.Write32LE(h.TimeDateStamp); |
WR.Write32LE(h.PointerToSymbolTable); |
WR.Write32LE(h.NumberOfSymbols); |
WriteWord(h.SizeOfOptionalHeader); |
WriteWord(h.Characteristics) |
END WriteFileHeader; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; console, dll, amd64: BOOLEAN); |
VAR |
i, n, temp: INTEGER; |
Size: RECORD |
Code, Data, Bss, Import, Reloc, Export: INTEGER |
END; |
BaseAddress: INTEGER; |
Address: VIRTUAL_ADDR; |
_import: BIN.IMPRT; |
ImportTable: CHL.INTLIST; |
ExportDir: IMAGE_EXPORT_DIRECTORY; |
export: BIN.EXPRT; |
PROCEDURE WriteExportDir (e: IMAGE_EXPORT_DIRECTORY); |
BEGIN |
WR.Write32LE(e.Characteristics); |
WR.Write32LE(e.TimeDateStamp); |
WriteWord(e.MajorVersion); |
WriteWord(e.MinorVersion); |
WR.Write32LE(e.Name); |
WR.Write32LE(e.Base); |
WR.Write32LE(e.NumberOfFunctions); |
WR.Write32LE(e.NumberOfNames); |
WR.Write32LE(e.AddressOfFunctions); |
WR.Write32LE(e.AddressOfNames); |
WR.Write32LE(e.AddressOfNameOrdinals) |
END WriteExportDir; |
PROCEDURE WriteOptHeader (h: IMAGE_OPTIONAL_HEADER; amd64: BOOLEAN); |
VAR |
i: INTEGER; |
BEGIN |
WriteWord(h.Magic); |
WR.WriteByte(h.MajorLinkerVersion); |
WR.WriteByte(h.MinorLinkerVersion); |
WR.Write32LE(h.SizeOfCode); |
WR.Write32LE(h.SizeOfInitializedData); |
WR.Write32LE(h.SizeOfUninitializedData); |
WR.Write32LE(h.AddressOfEntryPoint); |
WR.Write32LE(h.BaseOfCode); |
IF amd64 THEN |
WR.Write64LE(h.ImageBase) |
ELSE |
WR.Write32LE(h.BaseOfData); |
WR.Write32LE(h.ImageBase) |
END; |
WR.Write32LE(h.SectionAlignment); |
WR.Write32LE(h.FileAlignment); |
WriteWord(h.MajorOperatingSystemVersion); |
WriteWord(h.MinorOperatingSystemVersion); |
WriteWord(h.MajorImageVersion); |
WriteWord(h.MinorImageVersion); |
WriteWord(h.MajorSubsystemVersion); |
WriteWord(h.MinorSubsystemVersion); |
WR.Write32LE(h.Win32VersionValue); |
WR.Write32LE(h.SizeOfImage); |
WR.Write32LE(h.SizeOfHeaders); |
WR.Write32LE(h.CheckSum); |
WriteWord(h.Subsystem); |
WriteWord(h.DllCharacteristics); |
IF amd64 THEN |
WR.Write64LE(h.SizeOfStackReserve); |
WR.Write64LE(h.SizeOfStackCommit); |
WR.Write64LE(h.SizeOfHeapReserve); |
WR.Write64LE(h.SizeOfHeapCommit) |
ELSE |
WR.Write32LE(h.SizeOfStackReserve); |
WR.Write32LE(h.SizeOfStackCommit); |
WR.Write32LE(h.SizeOfHeapReserve); |
WR.Write32LE(h.SizeOfHeapCommit) |
END; |
WR.Write32LE(h.LoaderFlags); |
WR.Write32LE(h.NumberOfRvaAndSizes); |
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO |
WR.Write32LE(h.DataDirectory[i].VirtualAddress); |
WR.Write32LE(h.DataDirectory[i].Size) |
END |
END WriteOptHeader; |
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; VirtualSize: INTEGER; Characteristics: DWORD); |
BEGIN |
section.Name := Name; |
section.VirtualSize := VirtualSize; |
section.SizeOfRawData := WR.align(VirtualSize, FileAlignment); |
section.PointerToRelocations := 0; |
section.PointerToLinenumbers := 0; |
section.NumberOfRelocations := 0X; |
section.NumberOfLinenumbers := 0X; |
section.Characteristics := Characteristics |
END InitSection; |
BEGIN |
SizeOfWord := SIZE_OF_DWORD * (ORD(amd64) + 1); |
Size.Code := CHL.Length(program.code); |
Size.Data := CHL.Length(program.data); |
Size.Bss := program.bss; |
IF dll THEN |
BaseAddress := 10000000H |
ELSE |
BaseAddress := 400000H |
END; |
Signature[0] := 50H; |
Signature[1] := 45H; |
Signature[2] := 0; |
Signature[3] := 0; |
IF amd64 THEN |
FileHeader.Machine := 08664X |
ELSE |
FileHeader.Machine := 014CX |
END; |
FileHeader.NumberOfSections := WCHR(4 + ORD(dll)); |
FileHeader.TimeDateStamp := UTILS.UnixTime(); |
FileHeader.PointerToSymbolTable := 0H; |
FileHeader.NumberOfSymbols := 0H; |
FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64)); |
FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll)); |
OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64)); |
OptionalHeader.MajorLinkerVersion := UTILS.vMajor; |
OptionalHeader.MinorLinkerVersion := UTILS.vMinor; |
OptionalHeader.SizeOfCode := WR.align(Size.Code, FileAlignment); |
OptionalHeader.SizeOfInitializedData := 0; |
OptionalHeader.SizeOfUninitializedData := 0; |
OptionalHeader.AddressOfEntryPoint := SectionAlignment; |
OptionalHeader.BaseOfCode := SectionAlignment; |
OptionalHeader.BaseOfData := OptionalHeader.BaseOfCode + WR.align(Size.Code, SectionAlignment); |
OptionalHeader.ImageBase := BaseAddress; |
OptionalHeader.SectionAlignment := SectionAlignment; |
OptionalHeader.FileAlignment := FileAlignment; |
OptionalHeader.MajorOperatingSystemVersion := 1X; |
OptionalHeader.MinorOperatingSystemVersion := 0X; |
OptionalHeader.MajorImageVersion := 0X; |
OptionalHeader.MinorImageVersion := 0X; |
OptionalHeader.MajorSubsystemVersion := 4X; |
OptionalHeader.MinorSubsystemVersion := 0X; |
OptionalHeader.Win32VersionValue := 0H; |
OptionalHeader.SizeOfImage := SectionAlignment; |
OptionalHeader.SizeOfHeaders := 400H; |
OptionalHeader.CheckSum := 0; |
OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll)); |
OptionalHeader.DllCharacteristics := 0040X; |
OptionalHeader.SizeOfStackReserve := 100000H; |
OptionalHeader.SizeOfStackCommit := 10000H; |
OptionalHeader.SizeOfHeapReserve := 100000H; |
OptionalHeader.SizeOfHeapCommit := 10000H; |
OptionalHeader.LoaderFlags := 0; |
OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES; |
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO |
OptionalHeader.DataDirectory[i].VirtualAddress := 0; |
OptionalHeader.DataDirectory[i].Size := 0 |
END; |
InitSection(SectionHeaders[0], ".text", Size.Code, SHC_text); |
SectionHeaders[0].VirtualAddress := SectionAlignment; |
SectionHeaders[0].PointerToRawData := OptionalHeader.SizeOfHeaders; |
InitSection(SectionHeaders[1], ".data", Size.Data, SHC_data); |
SectionHeaders[1].VirtualAddress := WR.align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment); |
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData; |
InitSection(SectionHeaders[2], ".bss", Size.Bss, SHC_bss); |
SectionHeaders[2].VirtualAddress := WR.align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment); |
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData; |
SectionHeaders[2].SizeOfRawData := 0; |
Size.Import := GetImportSize(program.imp_list); |
InitSection(SectionHeaders[3], ".idata", Size.Import + CHL.Length(program._import), SHC_data); |
SectionHeaders[3].VirtualAddress := WR.align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment); |
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData; |
Address.Code := SectionHeaders[0].VirtualAddress + OptionalHeader.ImageBase; |
Address.Data := SectionHeaders[1].VirtualAddress + OptionalHeader.ImageBase; |
Address.Bss := SectionHeaders[2].VirtualAddress + OptionalHeader.ImageBase; |
Address.Import := SectionHeaders[3].VirtualAddress + OptionalHeader.ImageBase; |
fixup(program, Address, amd64); |
IF dll THEN |
Size.Export := Export(program, SectionHeaders[1].VirtualAddress + program.modname, ExportDir); |
InitSection(SectionHeaders[4], ".edata", Size.Export + CHL.Length(program.export), SHC_data); |
SectionHeaders[4].VirtualAddress := WR.align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment); |
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData; |
OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress; |
OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize |
END; |
OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress; |
OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize; |
FOR i := 1 TO ORD(FileHeader.NumberOfSections) - 1 DO |
INC(OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData) |
END; |
OptionalHeader.SizeOfUninitializedData := WR.align(SectionHeaders[2].VirtualSize, FileAlignment); |
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO |
INC(OptionalHeader.SizeOfImage, WR.align(SectionHeaders[i].VirtualSize, SectionAlignment)) |
END; |
n := 0; |
BIN.InitArray(msdos, n, "4D5A80000100000004001000FFFF000040010000000000004000000000000000"); |
BIN.InitArray(msdos, n, "0000000000000000000000000000000000000000000000000000000080000000"); |
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F"); |
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000"); |
WR.Create(FileName); |
WR.Write(msdos, LEN(msdos)); |
WR.Write(Signature, LEN(Signature)); |
WriteFileHeader(FileHeader); |
WriteOptHeader(OptionalHeader, amd64); |
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO |
WriteSectionHeader(SectionHeaders[i]) |
END; |
WR.Padding(FileAlignment); |
CHL.WriteToFile(program.code); |
WR.Padding(FileAlignment); |
CHL.WriteToFile(program.data); |
WR.Padding(FileAlignment); |
n := (libcnt + 1) * 5; |
ImportTable := CHL.CreateIntList(); |
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SizeOfWord + n - 1 DO |
CHL.PushInt(ImportTable, 0) |
END; |
i := 0; |
_import := program.imp_list.first(BIN.IMPRT); |
WHILE _import # NIL DO |
IF _import.label = 0 THEN |
CHL.SetInt(ImportTable, i + 0, _import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD); |
CHL.SetInt(ImportTable, i + 1, 0); |
CHL.SetInt(ImportTable, i + 2, 0); |
CHL.SetInt(ImportTable, i + 3, _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress); |
CHL.SetInt(ImportTable, i + 4, _import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD); |
INC(i, 5) |
END; |
_import := _import.next(BIN.IMPRT) |
END; |
CHL.SetInt(ImportTable, i + 0, 0); |
CHL.SetInt(ImportTable, i + 1, 0); |
CHL.SetInt(ImportTable, i + 2, 0); |
CHL.SetInt(ImportTable, i + 3, 0); |
CHL.SetInt(ImportTable, i + 4, 0); |
_import := program.imp_list.first(BIN.IMPRT); |
WHILE _import # NIL DO |
IF _import.label # 0 THEN |
temp := _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2; |
CHL.SetInt(ImportTable, _import.OriginalFirstThunk + n, temp); |
CHL.SetInt(ImportTable, _import.FirstThunk + n, temp) |
END; |
_import := _import.next(BIN.IMPRT) |
END; |
FOR i := 0 TO n - 1 DO |
WR.Write32LE(CHL.GetInt(ImportTable, i)) |
END; |
FOR i := n TO CHL.Length(ImportTable) - 1 DO |
IF amd64 THEN |
WR.Write64LE(CHL.GetInt(ImportTable, i)) |
ELSE |
WR.Write32LE(CHL.GetInt(ImportTable, i)) |
END |
END; |
CHL.WriteToFile(program._import); |
WR.Padding(FileAlignment); |
IF dll THEN |
INC(ExportDir.AddressOfFunctions, SectionHeaders[4].VirtualAddress); |
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress); |
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress); |
WriteExportDir(ExportDir); |
export := program.exp_list.first(BIN.EXPRT); |
WHILE export # NIL DO |
WR.Write32LE(export.label + SectionHeaders[0].VirtualAddress); |
export := export.next(BIN.EXPRT) |
END; |
export := program.exp_list.first(BIN.EXPRT); |
WHILE export # NIL DO |
WR.Write32LE(export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress); |
export := export.next(BIN.EXPRT) |
END; |
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO |
WriteWord(WCHR(i)) |
END; |
CHL.WriteToFile(program.export); |
WR.Padding(FileAlignment) |
END; |
WR.Close |
END write; |
END PE32. |
/programs/develop/oberon07/source/RVM32I.ob07 |
---|
0,0 → 1,1302 |
(* |
BSD 2-Clause License |
Copyright (c) 2020, Anton Krotov |
All rights reserved. |
*) |
MODULE RVM32I; |
IMPORT |
PROG, WR := WRITER, IL, CHL := CHUNKLISTS, REG, UTILS, STRINGS, ERRORS; |
CONST |
LTypes = 0; |
LStrings = 1; |
LGlobal = 2; |
LHeap = 3; |
LStack = 4; |
numGPRs = 3; |
R0 = 0; R1 = 1; |
BP = 3; SP = 4; |
ACC = R0; |
GPRs = {0 .. 2} + {5 .. numGPRs + 1}; |
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opABS = 5; |
opXCHG = 6; opLDR8 = 7; opLDR16 = 8; opLDR32 = 9; opPUSH = 10; opPUSHC = 11; |
opPOP = 12; opJGZ = 13; opJZ = 14; opJNZ = 15; opLLA = 16; opJGA = 17; |
opJLA = 18; opJMP = 19; opCALL = 20; opCALLI = 21; |
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32; |
opSTR8 = 34; opSTR16 = 36; opSTR32 = 38; opINCL = 40; opEXCL = 42; |
opIN = 44; opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54; |
opLSL = 56; opROR = 58; opMIN = 60; opMAX = 62; opEQ = 64; opNE = 66; |
opLT = 68; opLE = 70; opGT = 72; opGE = 74; opBT = 76; |
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33; |
opSTR8C = 35; opSTR16C = 37; opSTR32C = 39; opINCLC = 41; opEXCLC = 43; |
opINC = 45; opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55; |
opLSLC = 57; opRORC = 59; opMINC = 61; opMAXC = 63; opEQC = 65; opNEC = 67; |
opLTC = 69; opLEC = 71; opGTC = 73; opGEC = 75; opBTC = 77; |
opLEA = 78; opLABEL = 79; |
inf = 7F800000H; |
VAR |
R: REG.REGS; count: INTEGER; |
PROCEDURE OutByte (n: BYTE); |
BEGIN |
WR.WriteByte(n); |
INC(count) |
END OutByte; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
WR.Write32LE(n); |
INC(count, 4) |
END OutInt; |
PROCEDURE Emit (op, par1, par2: INTEGER); |
BEGIN |
OutInt(op); |
OutInt(par1); |
OutInt(par2) |
END Emit; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE GetAnyReg (): INTEGER; |
RETURN REG.GetAnyReg(R) |
END GetAnyReg; |
PROCEDURE GetAcc; |
BEGIN |
ASSERT(REG.GetReg(R, ACC)) |
END GetAcc; |
PROCEDURE UnOp (VAR r: INTEGER); |
BEGIN |
REG.UnOp(R, r) |
END UnOp; |
PROCEDURE BinOp (VAR r1, r2: INTEGER); |
BEGIN |
REG.BinOp(R, r1, r2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
DEC(R.pushed, NumberOfParameters) |
END PushAll; |
PROCEDURE push (r: INTEGER); |
BEGIN |
Emit(opPUSH, r, 0) |
END push; |
PROCEDURE pop (r: INTEGER); |
BEGIN |
Emit(opPOP, r, 0) |
END pop; |
PROCEDURE mov (r1, r2: INTEGER); |
BEGIN |
Emit(opMOV, r1, r2) |
END mov; |
PROCEDURE xchg (r1, r2: INTEGER); |
BEGIN |
Emit(opXCHG, r1, r2) |
END xchg; |
PROCEDURE addrc (r, c: INTEGER); |
BEGIN |
Emit(opADDC, r, c) |
END addrc; |
PROCEDURE subrc (r, c: INTEGER); |
BEGIN |
Emit(opSUBC, r, c) |
END subrc; |
PROCEDURE movrc (r, c: INTEGER); |
BEGIN |
Emit(opMOVC, r, c) |
END movrc; |
PROCEDURE pushc (c: INTEGER); |
BEGIN |
Emit(opPUSHC, c, 0) |
END pushc; |
PROCEDURE add (r1, r2: INTEGER); |
BEGIN |
Emit(opADD, r1, r2) |
END add; |
PROCEDURE sub (r1, r2: INTEGER); |
BEGIN |
Emit(opSUB, r1, r2) |
END sub; |
PROCEDURE ldr32 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDR32, r1, r2) |
END ldr32; |
PROCEDURE ldr16 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDR16, r1, r2) |
END ldr16; |
PROCEDURE ldr8 (r1, r2: INTEGER); |
BEGIN |
Emit(opLDR8, r1, r2) |
END ldr8; |
PROCEDURE str32 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTR32, r1, r2) |
END str32; |
PROCEDURE str16 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTR16, r1, r2) |
END str16; |
PROCEDURE str8 (r1, r2: INTEGER); |
BEGIN |
Emit(opSTR8, r1, r2) |
END str8; |
PROCEDURE GlobalAdr (r, offset: INTEGER); |
BEGIN |
Emit(opLEA, r + 256 * LGlobal, offset) |
END GlobalAdr; |
PROCEDURE StrAdr (r, offset: INTEGER); |
BEGIN |
Emit(opLEA, r + 256 * LStrings, offset) |
END StrAdr; |
PROCEDURE ProcAdr (r, label: INTEGER); |
BEGIN |
Emit(opLLA, r, label) |
END ProcAdr; |
PROCEDURE jnz (r, label: INTEGER); |
BEGIN |
Emit(opJNZ, r, label) |
END jnz; |
PROCEDURE CallRTL (proc, par: INTEGER); |
BEGIN |
Emit(opCALL, IL.codes.rtl[proc], 0); |
addrc(SP, par * 4) |
END CallRTL; |
PROCEDURE translate; |
VAR |
cmd: IL.COMMAND; |
opcode, param1, param2: INTEGER; |
r1, r2, r3: INTEGER; |
BEGIN |
cmd := IL.codes.commands.first(IL.COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
opcode := cmd.opcode; |
CASE opcode OF |
|IL.opJMP: |
Emit(opJMP, param1, 0) |
|IL.opLABEL: |
Emit(opLABEL, param1, 0) |
|IL.opCALL: |
Emit(opCALL, param1, 0) |
|IL.opCALLP: |
UnOp(r1); |
Emit(opCALLI, r1, 0); |
drop; |
ASSERT(R.top = -1) |
|IL.opPUSHC: |
pushc(param2) |
|IL.opCLEANUP: |
IF param2 # 0 THEN |
addrc(SP, param2 * 4) |
END |
|IL.opNOP, IL.opAND, IL.opOR: |
|IL.opSADR: |
StrAdr(GetAnyReg(), param2) |
|IL.opGADR: |
GlobalAdr(GetAnyReg(), param2) |
|IL.opLADR: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4) |
|IL.opPARAM: |
IF param2 = 1 THEN |
UnOp(r1); |
push(r1); |
drop |
ELSE |
ASSERT(R.top + 1 <= param2); |
PushAll(param2) |
END |
|IL.opONERR: |
pushc(param2); |
Emit(opJMP, param1, 0) |
|IL.opPRECALL: |
PushAll(0) |
|IL.opRES, IL.opRESF: |
ASSERT(R.top = -1); |
GetAcc |
|IL.opENTER: |
ASSERT(R.top = -1); |
Emit(opLABEL, param1, 0); |
Emit(opENTER, param2, 0) |
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF: |
IF opcode # IL.opLEAVE THEN |
UnOp(r1); |
IF r1 # ACC THEN |
GetAcc; |
ASSERT(REG.Exchange(R, r1, ACC)); |
drop |
END; |
drop |
END; |
ASSERT(R.top = -1); |
IF param1 > 0 THEN |
mov(SP, BP) |
END; |
pop(BP); |
Emit(opRET, 0, 0) |
|IL.opLEAVEC: |
Emit(opRET, 0, 0) |
|IL.opCONST: |
movrc(GetAnyReg(), param2) |
|IL.opDROP: |
UnOp(r1); |
drop |
|IL.opSAVEC: |
UnOp(r1); |
Emit(opSTR32C, r1, param2); |
drop |
|IL.opSAVE8C: |
UnOp(r1); |
Emit(opSTR8C, r1, param2 MOD 256); |
drop |
|IL.opSAVE16C: |
UnOp(r1); |
Emit(opSTR16C, r1, param2 MOD 65536); |
drop |
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF: |
BinOp(r2, r1); |
str32(r1, r2); |
drop; |
drop |
|IL.opSAVEFI: |
BinOp(r2, r1); |
str32(r2, r1); |
drop; |
drop |
|IL.opSAVE8: |
BinOp(r2, r1); |
str8(r1, r2); |
drop; |
drop |
|IL.opSAVE16: |
BinOp(r2, r1); |
str16(r1, r2); |
drop; |
drop |
|IL.opGLOAD32: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr32(r1, r1) |
|IL.opVADR, IL.opLLOAD32: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr32(r1, r1) |
|IL.opVLOAD32: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr32(r1, r1); |
ldr32(r1, r1) |
|IL.opGLOAD16: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr16(r1, r1) |
|IL.opLLOAD16: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr16(r1, r1) |
|IL.opVLOAD16: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr32(r1, r1); |
ldr16(r1, r1) |
|IL.opGLOAD8: |
r1 := GetAnyReg(); |
GlobalAdr(r1, param2); |
ldr8(r1, r1) |
|IL.opLLOAD8: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr8(r1, r1) |
|IL.opVLOAD8: |
r1 := GetAnyReg(); |
mov(r1, BP); |
addrc(r1, param2 * 4); |
ldr32(r1, r1); |
ldr8(r1, r1) |
|IL.opLOAD8: |
UnOp(r1); |
ldr8(r1, r1) |
|IL.opLOAD16: |
UnOp(r1); |
ldr16(r1, r1) |
|IL.opLOAD32, IL.opLOADF: |
UnOp(r1); |
ldr32(r1, r1) |
|IL.opLOOP, IL.opENDLOOP: |
|IL.opUMINUS: |
UnOp(r1); |
Emit(opNEG, r1, 0) |
|IL.opADD: |
BinOp(r1, r2); |
add(r1, r2); |
drop |
|IL.opSUB: |
BinOp(r1, r2); |
sub(r1, r2); |
drop |
|IL.opADDC: |
UnOp(r1); |
addrc(r1, param2) |
|IL.opSUBR: |
UnOp(r1); |
subrc(r1, param2) |
|IL.opSUBL: |
UnOp(r1); |
subrc(r1, param2); |
Emit(opNEG, r1, 0) |
|IL.opMULC: |
UnOp(r1); |
Emit(opMULC, r1, param2) |
|IL.opMUL: |
BinOp(r1, r2); |
Emit(opMUL, r1, r2); |
drop |
|IL.opDIV: |
BinOp(r1, r2); |
Emit(opDIV, r1, r2); |
drop |
|IL.opMOD: |
BinOp(r1, r2); |
Emit(opMOD, r1, r2); |
drop |
|IL.opDIVR: |
UnOp(r1); |
Emit(opDIVC, r1, param2) |
|IL.opMODR: |
UnOp(r1); |
Emit(opMODC, r1, param2) |
|IL.opDIVL: |
UnOp(r1); |
r2 := GetAnyReg(); |
movrc(r2, param2); |
Emit(opDIV, r2, r1); |
mov(r1, r2); |
drop |
|IL.opMODL: |
UnOp(r1); |
r2 := GetAnyReg(); |
movrc(r2, param2); |
Emit(opMOD, r2, r1); |
mov(r1, r2); |
drop |
|IL.opEQ: |
BinOp(r1, r2); |
Emit(opEQ, r1, r2); |
drop |
|IL.opNE: |
BinOp(r1, r2); |
Emit(opNE, r1, r2); |
drop |
|IL.opLT: |
BinOp(r1, r2); |
Emit(opLT, r1, r2); |
drop |
|IL.opLE: |
BinOp(r1, r2); |
Emit(opLE, r1, r2); |
drop |
|IL.opGT: |
BinOp(r1, r2); |
Emit(opGT, r1, r2); |
drop |
|IL.opGE: |
BinOp(r1, r2); |
Emit(opGE, r1, r2); |
drop |
|IL.opEQC: |
UnOp(r1); |
Emit(opEQC, r1, param2) |
|IL.opNEC: |
UnOp(r1); |
Emit(opNEC, r1, param2) |
|IL.opLTC: |
UnOp(r1); |
Emit(opLTC, r1, param2) |
|IL.opLEC: |
UnOp(r1); |
Emit(opLEC, r1, param2) |
|IL.opGTC: |
UnOp(r1); |
Emit(opGTC, r1, param2) |
|IL.opGEC: |
UnOp(r1); |
Emit(opGEC, r1, param2) |
|IL.opJNZ1: |
UnOp(r1); |
jnz(r1, param1) |
|IL.opJG: |
UnOp(r1); |
Emit(opJGZ, r1, param1) |
|IL.opJNZ: |
UnOp(r1); |
jnz(r1, param1); |
drop |
|IL.opJZ: |
UnOp(r1); |
Emit(opJZ, r1, param1); |
drop |
|IL.opMULS: |
BinOp(r1, r2); |
Emit(opAND, r1, r2); |
drop |
|IL.opMULSC: |
UnOp(r1); |
Emit(opANDC, r1, param2) |
|IL.opDIVS: |
BinOp(r1, r2); |
Emit(opXOR, r1, r2); |
drop |
|IL.opDIVSC: |
UnOp(r1); |
Emit(opXORC, r1, param2) |
|IL.opADDS: |
BinOp(r1, r2); |
Emit(opOR, r1, r2); |
drop |
|IL.opSUBS: |
BinOp(r1, r2); |
Emit(opNOT, r2, 0); |
Emit(opAND, r1, r2); |
drop |
|IL.opADDSC: |
UnOp(r1); |
Emit(opORC, r1, param2) |
|IL.opSUBSL: |
UnOp(r1); |
Emit(opNOT, r1, 0); |
Emit(opANDC, r1, param2) |
|IL.opSUBSR: |
UnOp(r1); |
Emit(opANDC, r1, ORD(-BITS(param2))) |
|IL.opUMINS: |
UnOp(r1); |
Emit(opNOT, r1, 0) |
|IL.opASR: |
BinOp(r1, r2); |
Emit(opASR, r1, r2); |
drop |
|IL.opLSL: |
BinOp(r1, r2); |
Emit(opLSL, r1, r2); |
drop |
|IL.opROR: |
BinOp(r1, r2); |
Emit(opROR, r1, r2); |
drop |
|IL.opLSR: |
BinOp(r1, r2); |
Emit(opLSR, r1, r2); |
drop |
|IL.opASR1: |
r2 := GetAnyReg(); |
Emit(opMOVC, r2, param2); |
BinOp(r1, r2); |
Emit(opASR, r2, r1); |
mov(r1, r2); |
drop |
|IL.opLSL1: |
r2 := GetAnyReg(); |
Emit(opMOVC, r2, param2); |
BinOp(r1, r2); |
Emit(opLSL, r2, r1); |
mov(r1, r2); |
drop |
|IL.opROR1: |
r2 := GetAnyReg(); |
Emit(opMOVC, r2, param2); |
BinOp(r1, r2); |
Emit(opROR, r2, r1); |
mov(r1, r2); |
drop |
|IL.opLSR1: |
r2 := GetAnyReg(); |
Emit(opMOVC, r2, param2); |
BinOp(r1, r2); |
Emit(opLSR, r2, r1); |
mov(r1, r2); |
drop |
|IL.opASR2: |
UnOp(r1); |
Emit(opASRC, r1, param2 MOD 32) |
|IL.opLSL2: |
UnOp(r1); |
Emit(opLSLC, r1, param2 MOD 32) |
|IL.opROR2: |
UnOp(r1); |
Emit(opRORC, r1, param2 MOD 32) |
|IL.opLSR2: |
UnOp(r1); |
Emit(opLSRC, r1, param2 MOD 32) |
|IL.opCHR: |
UnOp(r1); |
Emit(opANDC, r1, 255) |
|IL.opWCHR: |
UnOp(r1); |
Emit(opANDC, r1, 65535) |
|IL.opABS: |
UnOp(r1); |
Emit(opABS, r1, 0) |
|IL.opLEN: |
UnOp(r1); |
drop; |
EXCL(R.regs, r1); |
WHILE param2 > 0 DO |
UnOp(r2); |
drop; |
DEC(param2) |
END; |
INCL(R.regs, r1); |
ASSERT(REG.GetReg(R, r1)) |
|IL.opSWITCH: |
UnOp(r1); |
IF param2 = 0 THEN |
r2 := ACC |
ELSE |
r2 := R1 |
END; |
IF r1 # r2 THEN |
ASSERT(REG.GetReg(R, r2)); |
ASSERT(REG.Exchange(R, r1, r2)); |
drop |
END; |
drop |
|IL.opENDSW: |
|IL.opCASEL: |
GetAcc; |
Emit(opJLA, param1, param2); |
drop |
|IL.opCASER: |
GetAcc; |
Emit(opJGA, param1, param2); |
drop |
|IL.opCASELR: |
GetAcc; |
Emit(opJLA, param1, param2); |
Emit(opJGA, param1, cmd.param3); |
drop |
|IL.opSBOOL: |
BinOp(r2, r1); |
Emit(opNEC, r2, 0); |
str8(r1, r2); |
drop; |
drop |
|IL.opSBOOLC: |
UnOp(r1); |
Emit(opSTR8C, r1, ORD(param2 # 0)); |
drop |
|IL.opINCC: |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr32(r2, r1); |
addrc(r2, param2); |
str32(r1, r2); |
drop; |
drop |
|IL.opINCCB, IL.opDECCB: |
IF opcode = IL.opDECCB THEN |
param2 := -param2 |
END; |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr8(r2, r1); |
addrc(r2, param2); |
str8(r1, r2); |
drop; |
drop |
|IL.opINCB, IL.opDECB: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
ldr8(r3, r1); |
IF opcode = IL.opINCB THEN |
add(r3, r2) |
ELSE |
sub(r3, r2) |
END; |
str8(r1, r3); |
drop; |
drop; |
drop |
|IL.opINC, IL.opDEC: |
BinOp(r2, r1); |
r3 := GetAnyReg(); |
ldr32(r3, r1); |
IF opcode = IL.opINC THEN |
add(r3, r2) |
ELSE |
sub(r3, r2) |
END; |
str32(r1, r3); |
drop; |
drop; |
drop |
|IL.opINCL, IL.opEXCL: |
BinOp(r2, r1); |
IF opcode = IL.opINCL THEN |
Emit(opINCL, r1, r2) |
ELSE |
Emit(opEXCL, r1, r2) |
END; |
drop; |
drop |
|IL.opINCLC, IL.opEXCLC: |
UnOp(r1); |
r2 := GetAnyReg(); |
ldr32(r2, r1); |
IF opcode = IL.opINCLC THEN |
Emit(opINCLC, r2, param2) |
ELSE |
Emit(opEXCLC, r2, param2) |
END; |
str32(r1, r2); |
drop; |
drop |
|IL.opEQB, IL.opNEB: |
BinOp(r1, r2); |
Emit(opNEC, r1, 0); |
Emit(opNEC, r2, 0); |
IF opcode = IL.opEQB THEN |
Emit(opEQ, r1, r2) |
ELSE |
Emit(opNE, r1, r2) |
END; |
drop |
|IL.opCHKBYTE: |
BinOp(r1, r2); |
r3 := GetAnyReg(); |
mov(r3, r1); |
Emit(opBTC, r3, 256); |
jnz(r3, param1); |
drop |
|IL.opCHKIDX: |
UnOp(r1); |
r2 := GetAnyReg(); |
mov(r2, r1); |
Emit(opBTC, r2, param2); |
jnz(r2, param1); |
drop |
|IL.opCHKIDX2: |
BinOp(r1, r2); |
IF param2 # -1 THEN |
r3 := GetAnyReg(); |
mov(r3, r2); |
Emit(opBT, r3, r1); |
jnz(r3, param1); |
drop |
END; |
INCL(R.regs, r1); |
DEC(R.top); |
R.stk[R.top] := r2 |
|IL.opEQP, IL.opNEP: |
ProcAdr(GetAnyReg(), param1); |
BinOp(r1, r2); |
IF opcode = IL.opEQP THEN |
Emit(opEQ, r1, r2) |
ELSE |
Emit(opNE, r1, r2) |
END; |
drop |
|IL.opSAVEP: |
UnOp(r1); |
r2 := GetAnyReg(); |
ProcAdr(r2, param2); |
str32(r1, r2); |
drop; |
drop |
|IL.opPUSHP: |
ProcAdr(GetAnyReg(), param2) |
|IL.opPUSHT: |
UnOp(r1); |
r2 := GetAnyReg(); |
mov(r2, r1); |
subrc(r2, 4); |
ldr32(r2, r2) |
|IL.opGET, IL.opGETC: |
IF opcode = IL.opGET THEN |
BinOp(r1, r2) |
ELSIF opcode = IL.opGETC THEN |
UnOp(r2); |
r1 := GetAnyReg(); |
movrc(r1, param1) |
END; |
drop; |
drop; |
CASE param2 OF |
|1: ldr8(r1, r1); str8(r2, r1) |
|2: ldr16(r1, r1); str16(r2, r1) |
|4: ldr32(r1, r1); str32(r2, r1) |
END |
|IL.opNOT: |
UnOp(r1); |
Emit(opEQC, r1, 0) |
|IL.opORD: |
UnOp(r1); |
Emit(opNEC, r1, 0) |
|IL.opMIN: |
BinOp(r1, r2); |
Emit(opMIN, r1, r2); |
drop |
|IL.opMAX: |
BinOp(r1, r2); |
Emit(opMAX, r1, r2); |
drop |
|IL.opMINC: |
UnOp(r1); |
Emit(opMINC, r1, param2) |
|IL.opMAXC: |
UnOp(r1); |
Emit(opMAXC, r1, param2) |
|IL.opIN: |
BinOp(r1, r2); |
Emit(opIN, r1, r2); |
drop |
|IL.opINL: |
r1 := GetAnyReg(); |
movrc(r1, param2); |
BinOp(r2, r1); |
Emit(opIN, r1, r2); |
mov(r2, r1); |
drop |
|IL.opINR: |
UnOp(r1); |
Emit(opINC, r1, param2) |
|IL.opERR: |
CallRTL(IL._error, 4) |
|IL.opEQS .. IL.opGES: |
PushAll(4); |
pushc(opcode - IL.opEQS); |
CallRTL(IL._strcmp, 5); |
GetAcc |
|IL.opEQSW .. IL.opGESW: |
PushAll(4); |
pushc(opcode - IL.opEQSW); |
CallRTL(IL._strcmpw, 5); |
GetAcc |
|IL.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(IL._move, 3) |
|IL.opMOVE: |
PushAll(3); |
CallRTL(IL._move, 3) |
|IL.opCOPYA: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._arrcpy, 5); |
GetAcc |
|IL.opCOPYS: |
PushAll(4); |
pushc(param2); |
CallRTL(IL._strcpy, 5) |
|IL.opROT: |
PushAll(0); |
mov(ACC, SP); |
push(ACC); |
pushc(param2); |
CallRTL(IL._rot, 2) |
|IL.opLENGTH: |
PushAll(2); |
CallRTL(IL._length, 2); |
GetAcc |
|IL.opLENGTHW: |
PushAll(2); |
CallRTL(IL._lengthw, 2); |
GetAcc |
|IL.opSAVES: |
UnOp(r2); |
REG.PushAll_1(R); |
r1 := GetAnyReg(); |
StrAdr(r1, param2); |
push(r1); |
drop; |
push(r2); |
drop; |
pushc(param1); |
CallRTL(IL._move, 3) |
|IL.opRSET: |
PushAll(2); |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSETR: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSETL: |
UnOp(r1); |
REG.PushAll_1(R); |
pushc(param2); |
push(r1); |
drop; |
CallRTL(IL._set, 2); |
GetAcc |
|IL.opRSET1: |
PushAll(1); |
CallRTL(IL._set1, 1); |
GetAcc |
|IL.opNEW: |
PushAll(1); |
INC(param2, 8); |
ASSERT(UTILS.Align(param2, 32)); |
pushc(param2); |
pushc(param1); |
CallRTL(IL._new, 3) |
|IL.opTYPEGP: |
UnOp(r1); |
PushAll(0); |
push(r1); |
pushc(param2); |
CallRTL(IL._guard, 2); |
GetAcc |
|IL.opIS: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._is, 2); |
GetAcc |
|IL.opISREC: |
PushAll(2); |
pushc(param2); |
CallRTL(IL._guardrec, 3); |
GetAcc |
|IL.opTYPEGR: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
GetAcc |
|IL.opTYPEGD: |
UnOp(r1); |
PushAll(0); |
subrc(r1, 4); |
ldr32(r1, r1); |
push(r1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
GetAcc |
|IL.opCASET: |
push(R1); |
push(R1); |
pushc(param2); |
CallRTL(IL._guardrec, 2); |
pop(R1); |
jnz(ACC, param1) |
|IL.opCONSTF: |
movrc(GetAnyReg(), UTILS.d2s(cmd.float)) |
|IL.opMULF: |
PushAll(2); |
CallRTL(IL._fmul, 2); |
GetAcc |
|IL.opDIVF: |
PushAll(2); |
CallRTL(IL._fdiv, 2); |
GetAcc |
|IL.opDIVFI: |
PushAll(2); |
CallRTL(IL._fdivi, 2); |
GetAcc |
|IL.opADDF: |
PushAll(2); |
CallRTL(IL._fadd, 2); |
GetAcc |
|IL.opSUBFI: |
PushAll(2); |
CallRTL(IL._fsubi, 2); |
GetAcc |
|IL.opSUBF: |
PushAll(2); |
CallRTL(IL._fsub, 2); |
GetAcc |
|IL.opEQF..IL.opGEF: |
PushAll(2); |
pushc(opcode - IL.opEQF); |
CallRTL(IL._fcmp, 3); |
GetAcc |
|IL.opFLOOR: |
PushAll(1); |
CallRTL(IL._floor, 1); |
GetAcc |
|IL.opFLT: |
PushAll(1); |
CallRTL(IL._flt, 1); |
GetAcc |
|IL.opUMINF: |
UnOp(r1); |
Emit(opXORC, r1, ORD({31})) |
|IL.opFABS: |
UnOp(r1); |
Emit(opANDC, r1, ORD({0..30})) |
|IL.opINF: |
movrc(GetAnyReg(), inf) |
|IL.opPUSHF: |
UnOp(r1); |
push(r1); |
drop |
|IL.opPACK: |
PushAll(2); |
CallRTL(IL._pack, 2) |
|IL.opPACKC: |
PushAll(1); |
pushc(param2); |
CallRTL(IL._pack, 2) |
|IL.opUNPK: |
PushAll(2); |
CallRTL(IL._unpk, 2) |
|IL.opCODE: |
OutInt(param2) |
END; |
cmd := cmd.next(IL.COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1) |
END translate; |
PROCEDURE prolog; |
BEGIN |
Emit(opLEA, SP + LStack * 256, 0); |
Emit(opLEA, ACC + LTypes * 256, 0); |
push(ACC); |
Emit(opLEA, ACC + LHeap * 256, 0); |
push(ACC); |
pushc(CHL.Length(IL.codes.types)); |
CallRTL(IL._init, 3) |
END prolog; |
PROCEDURE epilog (ram: INTEGER); |
VAR |
tcount, dcount, i, offTypes, offStrings, szData, szGlobal, szHeapStack: INTEGER; |
BEGIN |
Emit(opSTOP, 0, 0); |
offTypes := count; |
tcount := CHL.Length(IL.codes.types); |
FOR i := 0 TO tcount - 1 DO |
OutInt(CHL.GetInt(IL.codes.types, i)) |
END; |
offStrings := count; |
dcount := CHL.Length(IL.codes.data); |
FOR i := 0 TO dcount - 1 DO |
OutByte(CHL.GetByte(IL.codes.data, i)) |
END; |
IF dcount MOD 4 # 0 THEN |
i := 4 - dcount MOD 4; |
WHILE i > 0 DO |
OutByte(0); |
DEC(i) |
END |
END; |
szData := count - offTypes; |
szGlobal := (IL.codes.bss DIV 4 + 1) * 4; |
szHeapStack := ram - szData - szGlobal; |
OutInt(offTypes); |
OutInt(offStrings); |
OutInt(szGlobal DIV 4); |
OutInt(szHeapStack DIV 4); |
FOR i := 1 TO 8 DO |
OutInt(0) |
END |
END epilog; |
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS); |
CONST |
minRAM = 32*1024; |
maxRAM = 256*1024; |
VAR |
szData, szRAM: INTEGER; |
BEGIN |
szData := (CHL.Length(IL.codes.types) + CHL.Length(IL.codes.data) DIV 4 + IL.codes.bss DIV 4 + 2) * 4; |
szRAM := MIN(MAX(options.ram, minRAM), maxRAM) * 1024; |
IF szRAM - szData < 1024*1024 THEN |
ERRORS.Error(208) |
END; |
count := 0; |
WR.Create(outname); |
REG.Init(R, push, pop, mov, xchg, NIL, NIL, GPRs, {}); |
prolog; |
translate; |
epilog(szRAM); |
WR.Close |
END CodeGen; |
END RVM32I. |
/programs/develop/oberon07/source/TEXTDRV.ob07 |
---|
0,0 → 1,192 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
MODULE TEXTDRV; |
IMPORT FILES, C := COLLECTIONS; |
CONST |
CR = 0DX; LF = 0AX; |
CHUNK = 1024 * 256; |
TYPE |
TEXT* = POINTER TO RECORD (C.ITEM) |
chunk: ARRAY CHUNK OF CHAR; |
pos, size: INTEGER; |
file: FILES.FILE; |
utf8: BOOLEAN; |
CR: BOOLEAN; |
line*, col*: INTEGER; |
ifc*: INTEGER; |
elsec*: INTEGER; |
eof*: BOOLEAN; |
eol*: BOOLEAN; |
skip*: BOOLEAN; |
peak*: CHAR; |
_skip*, |
_elsif*, |
_else*: ARRAY 100 OF BOOLEAN; |
fname*: ARRAY 2048 OF CHAR |
END; |
VAR |
texts: C.COLLECTION; |
PROCEDURE load (text: TEXT); |
BEGIN |
IF ~text.eof THEN |
text.size := FILES.read(text.file, text.chunk, LEN(text.chunk)); |
text.pos := 0; |
IF text.size = 0 THEN |
text.eof := TRUE; |
text.chunk[0] := 0X |
END; |
text.peak := text.chunk[0] |
END |
END load; |
PROCEDURE next* (text: TEXT); |
VAR |
c: CHAR; |
BEGIN |
IF text.pos < text.size - 1 THEN |
INC(text.pos); |
text.peak := text.chunk[text.pos] |
ELSE |
load(text) |
END; |
IF ~text.eof THEN |
c := text.peak; |
IF c = CR THEN |
INC(text.line); |
text.col := 0; |
text.eol := TRUE; |
text.CR := TRUE |
ELSIF c = LF THEN |
IF ~text.CR THEN |
INC(text.line); |
text.col := 0; |
text.eol := TRUE |
ELSE |
text.eol := FALSE |
END; |
text.CR := FALSE |
ELSE |
text.eol := FALSE; |
IF text.utf8 THEN |
IF ORD(c) DIV 64 # 2 THEN |
INC(text.col) |
END |
ELSE |
INC(text.col) |
END; |
text.CR := FALSE |
END |
END |
END next; |
PROCEDURE init (text: TEXT); |
BEGIN |
IF (text.pos = 0) & (text.size >= 3) THEN |
IF (text.chunk[0] = 0EFX) & |
(text.chunk[1] = 0BBX) & |
(text.chunk[2] = 0BFX) THEN |
text.pos := 3; |
text.utf8 := TRUE |
END |
END; |
IF text.size = 0 THEN |
text.chunk[0] := 0X; |
text.size := 1; |
text.eof := FALSE |
END; |
text.line := 1; |
text.col := 1; |
text.peak := text.chunk[text.pos] |
END init; |
PROCEDURE close* (VAR text: TEXT); |
BEGIN |
IF text # NIL THEN |
IF text.file # NIL THEN |
FILES.close(text.file) |
END; |
C.push(texts, text); |
text := NIL |
END |
END close; |
PROCEDURE open* (name: ARRAY OF CHAR): TEXT; |
VAR |
text: TEXT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(texts); |
IF citem = NIL THEN |
NEW(text) |
ELSE |
text := citem(TEXT) |
END; |
IF text # NIL THEN |
text.chunk[0] := 0X; |
text.pos := 0; |
text.size := 0; |
text.utf8 := FALSE; |
text.CR := FALSE; |
text.line := 1; |
text.col := 1; |
text.eof := FALSE; |
text.eol := FALSE; |
text.skip := FALSE; |
text.ifc := 0; |
text.elsec := 0; |
text._skip[0] := FALSE; |
text.peak := 0X; |
text.file := FILES.open(name); |
COPY(name, text.fname); |
IF text.file # NIL THEN |
load(text); |
init(text) |
ELSE |
close(text) |
END |
END |
RETURN text |
END open; |
BEGIN |
texts := C.create() |
END TEXTDRV. |
/programs/develop/oberon07/source/AVLTREES.ob07 |
---|
0,0 → 1,197 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2019, Anton Krotov |
All rights reserved. |
*) |
MODULE AVLTREES; |
IMPORT C := COLLECTIONS; |
TYPE |
DATA* = POINTER TO RECORD (C.ITEM) END; |
NODE* = POINTER TO RECORD (C.ITEM) |
data*: DATA; |
height: INTEGER; |
left*, right*: NODE |
END; |
CMP* = PROCEDURE (a, b: DATA): INTEGER; |
DESTRUCTOR* = PROCEDURE (VAR data: DATA); |
VAR |
nodes: C.COLLECTION; |
PROCEDURE NewNode (data: DATA): NODE; |
VAR |
node: NODE; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(nodes); |
IF citem = NIL THEN |
NEW(node) |
ELSE |
node := citem(NODE) |
END; |
node.data := data; |
node.left := NIL; |
node.right := NIL; |
node.height := 1 |
RETURN node |
END NewNode; |
PROCEDURE height (p: NODE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF p = NIL THEN |
res := 0 |
ELSE |
res := p.height |
END |
RETURN res |
END height; |
PROCEDURE bfactor (p: NODE): INTEGER; |
RETURN height(p.right) - height(p.left) |
END bfactor; |
PROCEDURE fixheight (p: NODE); |
BEGIN |
p.height := MAX(height(p.left), height(p.right)) + 1 |
END fixheight; |
PROCEDURE rotateright (p: NODE): NODE; |
VAR |
q: NODE; |
BEGIN |
q := p.left; |
p.left := q.right; |
q.right := p; |
fixheight(p); |
fixheight(q) |
RETURN q |
END rotateright; |
PROCEDURE rotateleft (q: NODE): NODE; |
VAR |
p: NODE; |
BEGIN |
p := q.right; |
q.right := p.left; |
p.left := q; |
fixheight(q); |
fixheight(p) |
RETURN p |
END rotateleft; |
PROCEDURE balance (p: NODE): NODE; |
VAR |
res: NODE; |
BEGIN |
fixheight(p); |
IF bfactor(p) = 2 THEN |
IF bfactor(p.right) < 0 THEN |
p.right := rotateright(p.right) |
END; |
res := rotateleft(p) |
ELSIF bfactor(p) = -2 THEN |
IF bfactor(p.left) > 0 THEN |
p.left := rotateleft(p.left) |
END; |
res := rotateright(p) |
ELSE |
res := p |
END |
RETURN res |
END balance; |
PROCEDURE insert* (p: NODE; data: DATA; cmp: CMP; VAR newnode: BOOLEAN; VAR node: NODE): NODE; |
VAR |
res: NODE; |
rescmp: INTEGER; |
BEGIN |
IF p = NIL THEN |
res := NewNode(data); |
node := res; |
newnode := TRUE |
ELSE |
rescmp := cmp(data, p.data); |
IF rescmp < 0 THEN |
p.left := insert(p.left, data, cmp, newnode, node); |
res := balance(p) |
ELSIF rescmp > 0 THEN |
p.right := insert(p.right, data, cmp, newnode, node); |
res := balance(p) |
ELSE |
res := p; |
node := res; |
newnode := FALSE |
END |
END |
RETURN res |
END insert; |
PROCEDURE destroy* (VAR node: NODE; destructor: DESTRUCTOR); |
VAR |
left, right: NODE; |
BEGIN |
IF node # NIL THEN |
left := node.left; |
right := node.right; |
IF destructor # NIL THEN |
destructor(node.data) |
END; |
C.push(nodes, node); |
node := NIL; |
destroy(left, destructor); |
destroy(right, destructor) |
END |
END destroy; |
BEGIN |
nodes := C.create() |
END AVLTREES. |
/programs/develop/oberon07/source/COLLECTIONS.ob07 |
---|
0,0 → 1,59 |
(* |
BSD 2-Clause License |
Copyright (c) 2018-2019, Anton Krotov |
All rights reserved. |
*) |
MODULE COLLECTIONS; |
TYPE |
ITEM* = POINTER TO RECORD |
link: ITEM |
END; |
COLLECTION* = POINTER TO RECORD |
last: ITEM |
END; |
PROCEDURE push* (collection: COLLECTION; item: ITEM); |
BEGIN |
item.link := collection.last; |
collection.last := item |
END push; |
PROCEDURE pop* (collection: COLLECTION): ITEM; |
VAR |
item: ITEM; |
BEGIN |
item := collection.last; |
IF item # NIL THEN |
collection.last := item.link |
END |
RETURN item |
END pop; |
PROCEDURE create* (): COLLECTION; |
VAR |
collection: COLLECTION; |
BEGIN |
NEW(collection); |
collection.last := NIL |
RETURN collection |
END create; |
END COLLECTIONS. |
/programs/develop/oberon07/tools/RVMxI.ob07 |
---|
0,0 → 1,668 |
(* |
BSD 2-Clause License |
Copyright (c) 2020-2021, Anton Krotov |
All rights reserved. |
*) |
(* |
RVMxI executor and disassembler |
Usage: |
RVMxI.exe <program file> -run [program parameters] |
RVMxI.exe <program file> -dis <output file> |
*) |
MODULE RVMxI; |
IMPORT SYSTEM, File, Args, Out, API, HOST; |
CONST |
szWORD = HOST.bit_depth DIV 8; |
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opNOP = 5; |
opXCHG = 6; opLDB = 7; opLDH = 8; opLDW = 9; opPUSH = 10; opPUSHC = 11; |
opPOP = 12; opLABEL = 13; opLEA = 14; opLLA = 15; |
opLDD = 16; (* 17, 18 *) |
opJMP = 19; opCALL = 20; opCALLI = 21; |
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32; |
opSTB = 34; opSTH = 36; opSTW = 38; opSTD = 40; (* 42, 44 *) |
opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54; |
opLSL = 56; opROR = 58; (* 60, 62 *) opCMP = 64; |
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33; |
opSTBC = 35; opSTHC = 37; opSTWC = 39; opSTDC = 41; (* 43, 45 *) |
opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55; |
opLSLC = 57; opRORC = 59; (* 61, 63 *) opCMPC = 65; |
opBIT = 66; opSYSCALL = 67; opJBT = 68; opADDRC = 69; |
opJEQ = 70; opJNE = 71; opJLT = 72; opJGE = 73; opJGT = 74; opJLE = 75; |
opSEQ = 76; opSNE = 77; opSLT = 78; opSGE = 79; opSGT = 80; opSLE = 81; |
nREG = 16; |
ACC = 0; BP = 3; SP = 4; |
Types = 0; |
Strings = 1; |
Global = 2; |
Heap = 3; |
Stack = 4; |
TYPE |
COMMAND = POINTER TO RECORD |
op, param1, param2: INTEGER; |
next, prev: COMMAND |
END; |
LABELS = ARRAY 30000 OF COMMAND; |
SECTIONS = ARRAY 5 OF INTEGER; |
VAR |
Sections: SECTIONS; |
first, last: COMMAND; |
Labels: LABELS; |
F: INTEGER; buf: ARRAY 65536 OF BYTE; cnt: INTEGER; |
PROCEDURE syscall (ptr: INTEGER); |
VAR |
fn, r, n: INTEGER; |
proc2: PROCEDURE (a, b: INTEGER): INTEGER; |
proc3: PROCEDURE (a, b, c: INTEGER): INTEGER; |
proc4: PROCEDURE (a, b, c, d: INTEGER): INTEGER; |
r1, r2: REAL; |
PROCEDURE GetInt (ptr, n: INTEGER): INTEGER; |
BEGIN |
SYSTEM.GET(ptr + SYSTEM.SIZE(INTEGER) * n, n) |
RETURN n |
END GetInt; |
PROCEDURE GetReal (ptr, n: INTEGER): REAL; |
VAR |
r: REAL; |
BEGIN |
SYSTEM.GET(ptr + SYSTEM.SIZE(INTEGER) * n, r) |
RETURN r |
END GetReal; |
BEGIN |
fn := GetInt(ptr, 0); |
CASE fn OF |
| 0: |
HOST.ExitProcess(GetInt(ptr, 1)) |
| 1: |
SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.GetCurrentDirectory)); |
r := proc2(GetInt(ptr, 1), GetInt(ptr, 2)) |
| 2: |
n := GetInt(ptr, 1); |
SYSTEM.PUT(SYSTEM.ADR(proc3), SYSTEM.ADR(HOST.GetArg)); |
r := proc3(n - ORD(n = 0) + 2, GetInt(ptr, 2), GetInt(ptr, 3)) |
| 3: |
SYSTEM.PUT(SYSTEM.ADR(proc4), SYSTEM.ADR(HOST.FileRead)); |
SYSTEM.PUT(ptr, proc4(GetInt(ptr, 1), GetInt(ptr, 2), GetInt(ptr, 3), GetInt(ptr, 4))) |
| 4: |
SYSTEM.PUT(SYSTEM.ADR(proc4), SYSTEM.ADR(HOST.FileWrite)); |
SYSTEM.PUT(ptr, proc4(GetInt(ptr, 1), GetInt(ptr, 2), GetInt(ptr, 3), GetInt(ptr, 4))) |
| 5: |
SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.FileCreate)); |
SYSTEM.PUT(ptr, proc2(GetInt(ptr, 1), GetInt(ptr, 2))) |
| 6: |
HOST.FileClose(GetInt(ptr, 1)) |
| 7: |
SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.FileOpen)); |
SYSTEM.PUT(ptr, proc2(GetInt(ptr, 1), GetInt(ptr, 2))) |
| 8: |
HOST.OutChar(CHR(GetInt(ptr, 1))) |
| 9: |
SYSTEM.PUT(ptr, HOST.GetTickCount()) |
|10: |
SYSTEM.PUT(ptr, HOST.UnixTime()) |
|11: |
SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.isRelative)); |
SYSTEM.PUT(ptr, proc2(GetInt(ptr, 1), GetInt(ptr, 2))) |
|12: |
SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.chmod)); |
r := proc2(GetInt(ptr, 1), GetInt(ptr, 2)) |
|100..103: |
r1 := GetReal(ptr, 1); |
r2 := GetReal(ptr, 2); |
CASE fn OF |
|100: SYSTEM.PUT(ptr, r2 * r1) |
|101: SYSTEM.PUT(ptr, r2 / r1) |
|102: SYSTEM.PUT(ptr, r2 + r1) |
|103: SYSTEM.PUT(ptr, r2 - r1) |
END |
|104: |
r1 := GetReal(ptr, 2); |
r2 := GetReal(ptr, 3); |
CASE GetInt(ptr, 1) OF |
|0: SYSTEM.PUT(ptr, ORD(r2 = r1)) |
|1: SYSTEM.PUT(ptr, ORD(r2 # r1)) |
|2: SYSTEM.PUT(ptr, ORD(r2 < r1)) |
|3: SYSTEM.PUT(ptr, ORD(r2 <= r1)) |
|4: SYSTEM.PUT(ptr, ORD(r2 > r1)) |
|5: SYSTEM.PUT(ptr, ORD(r2 >= r1)) |
END |
|105: |
SYSTEM.PUT(ptr, FLOOR(GetReal(ptr, 1))) |
|106: |
SYSTEM.PUT(ptr, FLT(GetInt(ptr, 1))) |
END |
END syscall; |
PROCEDURE exec (VAR Labels: LABELS; first, last: COMMAND; Sections: SECTIONS); |
VAR |
cmd: COMMAND; |
param1, param2, i: INTEGER; |
R: ARRAY nREG OF INTEGER; |
fe, fl, fb: BOOLEAN; |
BEGIN |
FOR i := 0 TO LEN(Labels) - 1 DO |
cmd := Labels[i]; |
IF cmd # NIL THEN |
REPEAT |
cmd := cmd.next |
UNTIL cmd.op # opLABEL; |
Labels[i] := cmd |
END |
END; |
cmd := first; |
WHILE cmd # NIL DO |
IF cmd.op = opLABEL THEN |
cmd.prev.next := cmd.next; |
cmd.next.prev := cmd.prev |
END; |
cmd := cmd.next |
END; |
FOR i := 0 TO LEN(Labels) - 1 DO |
IF Labels[i] # NIL THEN |
Labels[i] := Labels[i].prev |
END |
END; |
cmd := first; |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
CASE cmd.op OF |
|opSTOP: cmd := last |
|opRET: SYSTEM.GET(R[SP], cmd); INC(R[SP], szWORD) |
|opENTER: DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], R[BP]); R[BP] := R[SP]; |
WHILE param1 > 0 DO DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], 0); DEC(param1) END |
|opPOP: SYSTEM.GET(R[SP], R[param1]); INC(R[SP], szWORD) |
|opPUSH: DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], R[param1]) |
|opPUSHC: DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], param1) |
|opCALL: DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], cmd); cmd := Labels[param1] |
|opCALLI: DEC(R[SP], szWORD); SYSTEM.PUT(R[SP], cmd); SYSTEM.GET(SYSTEM.ADR(R[param1]), cmd) |
|opNEG: R[param1] := -R[param1] |
|opNOT: R[param1] := ORD(-BITS(R[param1])) |
|opNOP: |
|opXCHG: i := R[param1]; R[param1] := R[param2]; R[param2] := i |
|opLDB: i := param1 MOD 256; SYSTEM.GET8(R[param1 DIV 256] + param2, R[i]); R[i] := R[i] MOD 256 |
|opLDH: i := param1 MOD 256; SYSTEM.GET16(R[param1 DIV 256] + param2, R[i]); R[i] := R[i] MOD 65536 |
|opLDW: SYSTEM.GET32(R[param1 DIV 256] + param2, R[param1 MOD 256]); |
$IF (CPU_X8664) |
R[param1 MOD 256] := R[param1 MOD 256] MOD 100000000H |
$END |
|opLDD: SYSTEM.GET(R[param1 DIV 256] + param2, R[param1 MOD 256]) |
|opLLA: SYSTEM.GET(SYSTEM.ADR(Labels[param2]), R[param1]) |
|opJMP: cmd := Labels[param1] |
|opMOV: R[param1] := R[param2] |
|opMOVC: R[param1] := param2 |
|opMUL: R[param1] := R[param1] * R[param2] |
|opMULC: R[param1] := R[param1] * param2 |
|opADD: INC(R[param1], R[param2]) |
|opADDC: INC(R[param1], param2) |
|opSUB: DEC(R[param1], R[param2]) |
|opSUBC: DEC(R[param1], param2) |
|opDIV: R[param1] := R[param1] DIV R[param2] |
|opDIVC: R[param1] := R[param1] DIV param2 |
|opMOD: R[param1] := R[param1] MOD R[param2] |
|opMODC: R[param1] := R[param1] MOD param2 |
|opSTB: SYSTEM.PUT8(R[param1 DIV 256] + param2, R[param1 MOD 256]) |
|opSTH: SYSTEM.PUT16(R[param1 DIV 256] + param2, R[param1 MOD 256]) |
|opSTW: SYSTEM.PUT32(R[param1 DIV 256] + param2, R[param1 MOD 256]) |
|opSTD: SYSTEM.PUT(R[param1 DIV 256] + param2, R[param1 MOD 256]) |
|opSTBC: SYSTEM.PUT8(R[param1], param2) |
|opSTHC: SYSTEM.PUT16(R[param1], param2) |
|opSTWC: SYSTEM.PUT32(R[param1], param2) |
|opSTDC: SYSTEM.PUT(R[param1], param2) |
|opAND: R[param1] := ORD(BITS(R[param1]) * BITS(R[param2])) |
|opANDC: R[param1] := ORD(BITS(R[param1]) * BITS(param2)) |
|opOR: R[param1] := ORD(BITS(R[param1]) + BITS(R[param2])) |
|opORC: R[param1] := ORD(BITS(R[param1]) + BITS(param2)) |
|opXOR: R[param1] := ORD(BITS(R[param1]) / BITS(R[param2])) |
|opXORC: R[param1] := ORD(BITS(R[param1]) / BITS(param2)) |
|opASR: R[param1] := ASR(R[param1], R[param2]) |
|opASRC: R[param1] := ASR(R[param1], param2) |
|opLSR: R[param1] := LSR(R[param1], R[param2]) |
|opLSRC: R[param1] := LSR(R[param1], param2) |
|opLSL: R[param1] := LSL(R[param1], R[param2]) |
|opLSLC: R[param1] := LSL(R[param1], param2) |
|opROR: R[param1] := ROR(R[param1], R[param2]) |
|opRORC: R[param1] := ROR(R[param1], param2) |
|opLEA: R[param1 MOD 256] := Sections[param1 DIV 256] + param2 |
(*|opLABEL:*) |
|opSYSCALL: syscall(R[param1]) |
|opADDRC: R[param1 MOD 256] := R[param1 DIV 256] + param2 |
|opCMP: fl := R[param1] < R[param2]; fe := R[param1] = R[param2]; fb := fl & (R[param1] >= 0) |
|opCMPC: fl := R[param1] < param2; fe := R[param1] = param2; fb := fl & (R[param1] >= 0) |
|opJEQ: IF fe THEN cmd := Labels[param1] END |
|opJNE: IF ~fe THEN cmd := Labels[param1] END |
|opJLT: IF fl THEN cmd := Labels[param1] END |
|opJLE: IF fl OR fe THEN cmd := Labels[param1] END |
|opJGT: IF ~fl & ~fe THEN cmd := Labels[param1] END |
|opJGE: IF ~fl THEN cmd := Labels[param1] END |
|opSEQ: R[param1] := ORD(fe) |
|opSNE: R[param1] := ORD(~fe) |
|opSLT: R[param1] := ORD(fl) |
|opSLE: R[param1] := ORD(fl OR fe) |
|opSGT: R[param1] := ORD(~fl & ~fe) |
|opSGE: R[param1] := ORD(~fl) |
|opJBT: IF fb THEN cmd := Labels[param1] END |
|opBIT: R[param1] := ORD({R[param2]}) |
END; |
cmd := cmd.next |
END |
END exec; |
PROCEDURE disasm (name: ARRAY OF CHAR; t_count, c_count, glob, heap: INTEGER); |
VAR |
cmd: COMMAND; |
param1, param2, i, t, ptr: INTEGER; |
b: BYTE; |
Names: ARRAY 5, 16 OF CHAR; |
PROCEDURE String (s: ARRAY OF CHAR); |
VAR |
n: INTEGER; |
BEGIN |
n := LENGTH(s); |
IF n > LEN(buf) - cnt THEN |
ASSERT(File.Write(F, SYSTEM.ADR(buf[0]), cnt) = cnt); |
cnt := 0 |
END; |
SYSTEM.MOVE(SYSTEM.ADR(s[0]), SYSTEM.ADR(buf[0]) + cnt, n); |
INC(cnt, n) |
END String; |
PROCEDURE Ln; |
BEGIN |
String(0DX + 0AX) |
END Ln; |
PROCEDURE hexdgt (n: INTEGER): CHAR; |
BEGIN |
IF n < 10 THEN |
INC(n, ORD("0")) |
ELSE |
INC(n, ORD("A") - 10) |
END |
RETURN CHR(n) |
END hexdgt; |
PROCEDURE Hex (x: INTEGER); |
VAR |
str: ARRAY 19 OF CHAR; |
n: INTEGER; |
BEGIN |
n := szWORD * 2 + 2; |
str[n] := 0X; |
WHILE n > 2 DO |
str[n - 1] := hexdgt(x MOD 16); |
x := x DIV 16; |
DEC(n) |
END; |
str[1] := "x"; |
str[0] := "0"; |
String(str) |
END Hex; |
PROCEDURE Byte (x: BYTE); |
VAR |
str: ARRAY 5 OF CHAR; |
BEGIN |
str[4] := 0X; |
str[3] := hexdgt(x MOD 16); |
str[2] := hexdgt(x DIV 16); |
str[1] := "x"; |
str[0] := "0"; |
String(str) |
END Byte; |
PROCEDURE Reg (n: INTEGER); |
VAR |
s: ARRAY 2 OF CHAR; |
BEGIN |
IF n = BP THEN |
String("BP") |
ELSIF n = SP THEN |
String("SP") |
ELSE |
String("R"); |
s[1] := 0X; |
IF n >= 10 THEN |
s[0] := CHR(n DIV 10 + ORD("0")); |
String(s) |
END; |
s[0] := CHR(n MOD 10 + ORD("0")); |
String(s) |
END |
END Reg; |
PROCEDURE Reg2 (r1, r2: INTEGER); |
BEGIN |
Reg(r1); String(", "); Reg(r2) |
END Reg2; |
PROCEDURE RegC (r, c: INTEGER); |
BEGIN |
Reg(r); String(", "); Hex(c) |
END RegC; |
PROCEDURE RegL (r, label: INTEGER); |
BEGIN |
Reg(r); String(", L"); Hex(label) |
END RegL; |
BEGIN |
Names[Types] := "TYPES"; |
Names[Strings] := "STRINGS"; |
Names[Global] := "GLOBAL"; |
Names[Heap] := "HEAP"; |
Names[Stack] := "STACK"; |
F := File.Create(name); |
ASSERT(F > 0); |
cnt := 0; |
String("CODE:"); Ln; |
cmd := first; |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
CASE cmd.op OF |
|opSTOP: String("STOP") |
|opRET: String("RET") |
|opENTER: String("ENTER "); Hex(param1) |
|opPOP: String("POP "); Reg(param1) |
|opNEG: String("NEG "); Reg(param1) |
|opNOT: String("NOT "); Reg(param1) |
|opNOP: String("NOP") |
|opXCHG: String("XCHG "); Reg2(param1, param2) |
|opLDB: String("LDB "); Reg(param1 MOD 256); String(", ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("]") |
|opLDH: String("LDH "); Reg(param1 MOD 256); String(", ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("]") |
|opLDW: String("LDW "); Reg(param1 MOD 256); String(", ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("]") |
|opLDD: String("LDD "); Reg(param1 MOD 256); String(", ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("]") |
|opPUSH: String("PUSH "); Reg(param1) |
|opPUSHC: String("PUSH "); Hex(param1) |
|opLLA: String("LLA "); RegL(param1, param2) |
|opJMP: String("JMP L"); Hex(param1) |
|opCALL: String("CALL L"); Hex(param1) |
|opCALLI: String("CALL "); Reg(param1) |
|opMOV: String("MOV "); Reg2(param1, param2) |
|opMOVC: String("MOV "); RegC(param1, param2) |
|opMUL: String("MUL "); Reg2(param1, param2) |
|opMULC: String("MUL "); RegC(param1, param2) |
|opADD: String("ADD "); Reg2(param1, param2) |
|opADDC: String("ADD "); RegC(param1, param2) |
|opSUB: String("SUB "); Reg2(param1, param2) |
|opSUBC: String("SUB "); RegC(param1, param2) |
|opDIV: String("DIV "); Reg2(param1, param2) |
|opDIVC: String("DIV "); RegC(param1, param2) |
|opMOD: String("MOD "); Reg2(param1, param2) |
|opMODC: String("MOD "); RegC(param1, param2) |
|opSTB: String("STB ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("], "); Reg(param1 MOD 256) |
|opSTH: String("STH ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("], "); Reg(param1 MOD 256) |
|opSTW: String("STW ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("], "); Reg(param1 MOD 256) |
|opSTD: String("STD ["); Reg(param1 DIV 256); String(" + "); Hex(param2); String("], "); Reg(param1 MOD 256) |
|opSTBC: String("STB ["); Reg(param1); String("], "); Hex(param2) |
|opSTHC: String("STH ["); Reg(param1); String("], "); Hex(param2) |
|opSTWC: String("STW ["); Reg(param1); String("], "); Hex(param2) |
|opSTDC: String("STD ["); Reg(param1); String("], "); Hex(param2) |
|opAND: String("AND "); Reg2(param1, param2) |
|opANDC: String("AND "); RegC(param1, param2) |
|opOR: String("OR "); Reg2(param1, param2) |
|opORC: String("OR "); RegC(param1, param2) |
|opXOR: String("XOR "); Reg2(param1, param2) |
|opXORC: String("XOR "); RegC(param1, param2) |
|opASR: String("ASR "); Reg2(param1, param2) |
|opASRC: String("ASR "); RegC(param1, param2) |
|opLSR: String("LSR "); Reg2(param1, param2) |
|opLSRC: String("LSR "); RegC(param1, param2) |
|opLSL: String("LSL "); Reg2(param1, param2) |
|opLSLC: String("LSL "); RegC(param1, param2) |
|opROR: String("ROR "); Reg2(param1, param2) |
|opRORC: String("ROR "); RegC(param1, param2) |
|opLEA: String("LEA "); Reg(param1 MOD 256); String(", "); String(Names[param1 DIV 256]); String(" + "); Hex(param2) |
|opADDRC: String("ADD "); Reg(param1 MOD 256); String(", "); Reg(param1 DIV 256); String(", "); Hex(param2) |
|opLABEL: String("L"); Hex(param1); String(":") |
|opSYSCALL: String("SYSCALL "); Reg(param1) |
|opCMP: String("CMP "); Reg2(param1, param2) |
|opCMPC: String("CMP "); RegC(param1, param2) |
|opJEQ: String("JEQ L"); Hex(param1) |
|opJNE: String("JNE L"); Hex(param1) |
|opJLT: String("JLT L"); Hex(param1) |
|opJLE: String("JLE L"); Hex(param1) |
|opJGT: String("JGT L"); Hex(param1) |
|opJGE: String("JGE L"); Hex(param1) |
|opSEQ: String("SEQ "); Reg(param1) |
|opSNE: String("SNE "); Reg(param1) |
|opSLT: String("SLT "); Reg(param1) |
|opSLE: String("SLE "); Reg(param1) |
|opSGT: String("SGT "); Reg(param1) |
|opSGE: String("SGE "); Reg(param1) |
|opJBT: String("JBT L"); Hex(param1) |
|opBIT: String("BIT "); Reg2(param1, param2) |
END; |
Ln; |
cmd := cmd.next |
END; |
String("TYPES:"); |
ptr := Sections[Types]; |
FOR i := 0 TO t_count - 1 DO |
IF i MOD 4 = 0 THEN |
Ln; String("WORD ") |
ELSE |
String(", ") |
END; |
SYSTEM.GET(ptr, t); INC(ptr, szWORD); |
Hex(t) |
END; |
Ln; |
String("STRINGS:"); |
ptr := Sections[Strings]; |
FOR i := 0 TO c_count - 1 DO |
IF i MOD 8 = 0 THEN |
Ln; String("BYTE ") |
ELSE |
String(", ") |
END; |
SYSTEM.GET8(ptr, b); INC(ptr); |
Byte(b) |
END; |
Ln; |
String("GLOBAL:"); Ln; |
String("WORDS "); Hex(glob); Ln; |
String("HEAP:"); Ln; |
String("WORDS "); Hex(heap); Ln; |
String("STACK:"); Ln; |
String("WORDS 8"); Ln; |
ASSERT(File.Write(F, SYSTEM.ADR(buf[0]), cnt) = cnt); |
File.Close(F) |
END disasm; |
PROCEDURE GetCommand (adr: INTEGER): COMMAND; |
VAR |
op, param1, param2: INTEGER; |
res: COMMAND; |
BEGIN |
op := 0; param1 := 0; param2 := 0; |
SYSTEM.GET(adr, op); |
SYSTEM.GET(adr + szWORD, param1); |
SYSTEM.GET(adr + szWORD * 2, param2); |
NEW(res); |
res.op := op; |
res.param1 := param1; |
res.param2 := param2; |
res.next := NIL |
RETURN res |
END GetCommand; |
PROCEDURE main; |
VAR |
name, param: ARRAY 1024 OF CHAR; |
cmd: COMMAND; |
file, fsize, n: INTEGER; |
descr: ARRAY 12 OF INTEGER; |
offTypes, offStrings, GlobalSize, HeapStackSize, DescrSize: INTEGER; |
BEGIN |
Out.Open; |
Args.GetArg(1, name); |
F := File.Open(name, File.OPEN_R); |
IF F > 0 THEN |
DescrSize := LEN(descr) * SYSTEM.SIZE(INTEGER); |
fsize := File.Seek(F, 0, File.SEEK_END); |
ASSERT(fsize > DescrSize); |
file := API._NEW(fsize); |
ASSERT(file # 0); |
n := File.Seek(F, 0, File.SEEK_BEG); |
ASSERT(fsize = File.Read(F, file, fsize)); |
File.Close(F); |
SYSTEM.MOVE(file + fsize - DescrSize, SYSTEM.ADR(descr[0]), DescrSize); |
offTypes := descr[0]; |
ASSERT(offTypes < fsize - DescrSize); |
ASSERT(offTypes > 0); |
ASSERT(offTypes MOD (3 * szWORD) = 0); |
offStrings := descr[1]; |
ASSERT(offStrings < fsize - DescrSize); |
ASSERT(offStrings > 0); |
ASSERT(offStrings MOD szWORD = 0); |
ASSERT(offStrings > offTypes); |
GlobalSize := descr[2]; |
ASSERT(GlobalSize > 0); |
HeapStackSize := descr[3]; |
ASSERT(HeapStackSize > 0); |
Sections[Types] := API._NEW(offStrings - offTypes); |
ASSERT(Sections[Types] # 0); |
SYSTEM.MOVE(file + offTypes, Sections[Types], offStrings - offTypes); |
Sections[Strings] := API._NEW(fsize - offStrings - DescrSize); |
ASSERT(Sections[Strings] # 0); |
SYSTEM.MOVE(file + offStrings, Sections[Strings], fsize - offStrings - DescrSize); |
Sections[Global] := API._NEW(GlobalSize * szWORD); |
ASSERT(Sections[Global] # 0); |
Sections[Heap] := API._NEW(HeapStackSize * szWORD); |
ASSERT(Sections[Heap] # 0); |
Sections[Stack] := Sections[Heap] + HeapStackSize * szWORD - szWORD*8; |
n := offTypes DIV (3 * szWORD); |
first := GetCommand(file + offTypes - n * (3 * szWORD)); |
first.prev := NIL; |
last := first; |
DEC(n); |
WHILE n > 0 DO |
cmd := GetCommand(file + offTypes - n * (3 * szWORD)); |
IF cmd.op = opLABEL THEN |
Labels[cmd.param1] := cmd |
END; |
last.next := cmd; |
cmd.prev := last; |
last := cmd; |
DEC(n) |
END; |
file := API._DISPOSE(file); |
Args.GetArg(2, param); |
IF param = "-dis" THEN |
Args.GetArg(3, name); |
IF name # "" THEN |
disasm(name, (offStrings - offTypes) DIV szWORD, fsize - offStrings - DescrSize, GlobalSize, HeapStackSize) |
END |
ELSIF param = "-run" THEN |
exec(Labels, first, last, Sections) |
END |
ELSE |
Out.String("file not found"); Out.Ln |
END |
END main; |
BEGIN |
main |
END RVMxI. |
/programs/develop/oberon07/tools/RVMxI.txt |
---|
0,0 → 1,270 |
|
Экспериментальная 32/64-битная виртуальная машина RVMxI |
--------------------------------------------------------------------------------------------------- |
Использование |
Скомпилировать исполнитель/дизассемблер в .\tools\RVMxI.ob07 |
для Windows32/64 Console или Linux32/64: |
Compiler.exe .\tools\RVMxI.ob07 win32con -nochk a -out RVMxI.exe |
Compiler.exe .\tools\RVMxI.ob07 win64con -nochk a -out RVMxI.exe |
Compiler ./tools/RVMxI.ob07 linux32exe -nochk a -out RVMxI |
Compiler ./tools/RVMxI.ob07 linux64exe -nochk a -out RVMxI |
Будет создан файл "RVMxI.exe" и/или "RVMxI". |
Компилировать программу в байт-код RVMxI: |
Compiler.exe program.ob07 rvm32i [-ram size] [-def host_linux] |
Compiler.exe program.ob07 rvm64i [-ram size] [-def host_linux] |
-ram size -- установить размер оперативной памяти для программы в килобайтах 32768..262144 |
(32..256 Мбайт), по умолчанию 32768 (32 Мбайт) |
-def host_linux -- если байт-код будет исполняться на Linux (по умолчанию -- Windows) |
Будет создан файл "program.bin". |
Выпонить программу: |
RVMxI.exe program.bin -run <параметры> |
Дизассемблировать программу: |
RVMxI.exe program.bin -dis program.txt |
Будет создан файл "program.txt". |
--------------------------------------------------------------------------------------------------- |
Архитектура |
Регистры |
Не меньше пяти 32/64-битных регистров: |
R0, R1, R2 регистры общего назначения |
BP(R3) указатель кадра стэка |
SP(R4) указатель стэка (растет вниз) |
R5, R6... регистры общего назначения (опционально) |
Регистра связи нет (адрес возврата передается через стэк), |
регистр-счетчик команд (PC) -- скрытый, регистр флагов -- скрытый. |
Нет вещественных регистров, операции с плавающей точкой (single (32-бит) или double (64-бит)) |
эмулируются. |
Формат кадра стэка |
Стэк: |
меньше <- |лок. переменные|старый BP|адрес возврата|парам1|парам2|...|парамN| -> больше |
(* 32 бита *) |
адрес(парам1) = BP + 8 |
адрес(парам2) = BP + 12 |
... |
(* 64 бита *) |
адрес(парам1) = BP + 16 |
адрес(парам2) = BP + 24 |
... |
Параметры передаются через стэк справа налево (как cdecl), результат передается через R0, |
вызывающая процедура очищает стэк (как cdecl). |
--------------------------------------------------------------------------------------------------- |
Формат "исполняемого" файла |
RECORD |
Text: ARRAY i OF RECORD opcode, param1, param2: INTEGER END; (* байт-код *) |
Types: ARRAY t OF INTEGER; (* таблица типов-записей *) |
Strings: ARRAY s OF BYTE; (* строковые литералы *) |
offTypes: INTEGER; (* смещение таблицы типов-записей от начала файла (в байтах) *) |
offStrings: INTEGER; (* смещение строковых литералов от начала файла (в байтах) *) |
GlobalSize: INTEGER; (* размер глобальных переменных (в словах; слово = 4 байта) *) |
HeapStackSize: INTEGER; (* размер области кучи/стэка (в словах; слово = 4 байта) *) |
Reserved: ARRAY 8 OF INTEGER (* зарезервировано *) |
END |
Где: |
INTEGER = INT32/INT64 |
i = offTypes DIV (3 * sizeof(INTEGER)); |
t = (offStrings - offTypes) DIV sizeof(INTEGER) |
s = FILE_SIZE - offStrings - 12 * sizeof(INTEGER) |
--------------------------------------------------------------------------------------------------- |
Система команд |
мнемоника опкод парам1 парам2 действие |
STOP 0 0 0 остановить программу |
RET 1 0 0 возврат из процедуры (pop PC) |
ENTER imm 2 imm 0 push BP; BP := SP; WHILE imm > 0 DO push 0; DEC(imm) END |
NEG Rn 3 n 0 Rn := -Rn |
NOT Rn 4 n 0 Rn := ORD(-BITS(Rn)) |
NOP 5 0 0 нет операции |
XCHG Rn, Rm 6 n m temp := Rn; Rn := Rm; Rm := temp |
LDB Rn, [Rm + imm] 7 m*256 + n imm Rn := UInt8Ptr(Rm + imm)^ |
LDH Rn, [Rm + imm] 8 m*256 + n imm Rn := UInt16Ptr(Rm + imm)^ |
LDW Rn, [Rm + imm] 9 m*256 + n imm Rn := UInt32Ptr(Rm + imm)^ |
* PUSH Rn 10 n 0 DEC(SP, 4); UInt32Ptr(SP)^ := Rn |
* PUSH imm 11 imm 0 DEC(SP, 4); UInt32Ptr(SP)^ := imm |
* POP Rn 12 n 0 Rn := UInt32Ptr(SP)^; INC(SP, 4) |
** PUSH Rn 10 n 0 DEC(SP, 8); UInt64Ptr(SP)^ := Rn |
** PUSH imm 11 imm 0 DEC(SP, 8); UInt64Ptr(SP)^ := imm |
** POP Rn 12 n 0 Rn := UInt64Ptr(SP)^; INC(SP, 8) |
L#hex: 13 hex 0 метка: |
LEA Rn, TYPES + imm 14 n + 000H imm Rn := imm + address(TYPES) |
LEA Rn, STRINGS + imm 14 n + 100H imm Rn := imm + address(STRINGS) |
LEA Rn, GLOBAL + imm 14 n + 200H imm Rn := imm + address(GLOBAL) |
LEA Rn, HEAP + imm 14 n + 300H imm Rn := imm + address(HEAP) |
LEA Rn, STACK + imm 14 n + 400H imm Rn := imm + address(STACK) |
LLA Rn, L#hex 15 n hex Rn := address(L#hex) |
** LDD Rn, [Rm + imm] 16 m*256 + n imm Rn := UInt64Ptr(Rm + imm)^ |
JMP L#hex 19 hex 0 goto L#hex |
CALL L#hex 20 hex 0 push PC; goto L#hex |
CALL Rn 21 n 0 push PC; goto Rn |
MOV Rn, Rm 22 n m Rn := Rm |
MOV Rn, imm 23 n imm Rn := imm |
MUL Rn, Rm 24 n m Rn := Rn * Rm |
MUL Rn, imm 25 n imm Rn := Rm * imm |
ADD Rn, Rm 26 n m Rn := Rn + Rm |
ADD Rn, imm 27 n imm Rn := Rn + imm |
SUB Rn, Rm 28 n m Rn := Rn - Rm |
SUB Rn, imm 29 n imm Rn := Rn - imm |
DIV Rn, Rm 30 n m Rn := Rn DIV Rm |
DIV Rn, imm 31 n imm Rn := Rn DIV imm |
MOD Rn, Rm 32 n m Rn := Rn MOD Rm |
MOD Rn, imm 33 n imm Rn := Rn MOD imm |
STB [Rn + imm], Rm 34 n*256 + m imm UInt8Ptr(Rn + imm)^ := Rm MOD 256 |
STB [Rn], imm 35 n imm UInt8Ptr(Rn)^ := imm MOD 256 |
STH [Rn + imm], Rm 36 n*256 + m imm UInt16Ptr(Rn + imm)^ := Rm MOD 65536 |
STH [Rn], imm 37 n imm UInt16Ptr(Rn)^ := imm MOD 65536 |
* STW [Rn + imm], Rm 38 n*256 + m imm UInt32Ptr(Rn + imm)^ := Rm |
* STW [Rn], imm 39 n imm UInt32Ptr(Rn)^ := imm |
** STW [Rn + imm], Rm 38 n*256 + m imm UInt32Ptr(Rn + imm)^ := Rm MOD 100000000H |
** STW [Rn], imm 39 n imm UInt32Ptr(Rn)^ := imm MOD 100000000H |
** STD [Rn + imm], Rm 40 n*256 + m imm UInt64Ptr(Rn + imm)^ := Rm |
** STD [Rn], imm 41 n imm UInt64Ptr(Rn)^ := imm |
AND Rn, Rm 46 n m Rn := ORD(BITS(Rn) * BITS(Rm)) |
AND Rn, imm 47 n imm Rn := ORD(BITS(Rn) * BITS(imm)) |
OR Rn, Rm 48 n m Rn := ORD(BITS(Rn) + BITS(Rm)) |
OR Rn, imm 49 n imm Rn := ORD(BITS(Rn) + BITS(imm)) |
XOR Rn, Rm 50 n m Rn := ORD(BITS(Rn) / BITS(Rm)) |
XOR Rn, imm 51 n imm Rn := ORD(BITS(Rn) / BITS(imm)) |
ASR Rn, Rm 52 n m Rn := ASR(Rn, Rm) |
ASR Rn, imm 53 n imm Rn := ASR(Rn, imm) |
LSR Rn, Rm 54 n m Rn := LSR(Rn, Rm) |
LSR Rn, imm 55 n imm Rn := LSR(Rn, imm) |
LSL Rn, Rm 56 n m Rn := LSL(Rn, Rm) |
LSL Rn, imm 57 n imm Rn := LSL(Rn, imm) |
ROR Rn, Rm 58 n m Rn := ROR(Rn, Rm) |
ROR Rn, imm 59 n imm Rn := ROR(Rn, imm) |
CMP Rn, Rm 64 n m сравнить Rn и Rm |
CMP Rn, imm 65 n imm сравнить Rn и imm |
BIT Rn, Rm 66 n m Rn := ORD({Rm}) |
SYSCALL Rn 67 n 0 системный вызов; Rn содержит адрес параметров |
JBT L#hex 68 hex 0 перейти на метку L#hex, если "ниже" |
ADD Rn, Rm, imm 69 m*256 + n imm Rn := Rm + imm |
JEQ L#hex 70 hex 0 перейти на метку L#hex, если "равно" |
JNE L#hex 71 hex 0 перейти на метку L#hex, если "не равно" |
JLT L#hex 72 hex 0 перейти на метку L#hex, если "меньше" |
JGE L#hex 73 hex 0 перейти на метку L#hex, если "не меньше" |
JGT L#hex 74 hex 0 перейти на метку L#hex, если "больше" |
JLE L#hex 75 hex 0 перейти на метку L#hex, если "не больше" |
SEQ Rn 76 n 0 если "равно": Rn := 1, иначе Rn := 0 |
SNE Rn 77 n 0 если "не равно": Rn := 1, иначе Rn := 0 |
SLT Rn 78 n 0 если "меньше": Rn := 1, иначе Rn := 0 |
SGE Rn 79 n 0 если "не меньше": Rn := 1, иначе Rn := 0 |
SGT Rn 80 n 0 если "больше": Rn := 1, иначе Rn := 0 |
SLE Rn 81 n 0 если "не больше": Rn := 1, иначе Rn := 0 |
Команда CMP сохраняет результат сравнения в скрытом регистре, этот результат используется |
в командах перехода по условию (JEQ, JNE, JLT, JGE, JGT, JLE, JBT) а также в командах |
установки регистра по условию (SEQ, SNE, SLT, SGE, SGT, SLE). |
* Команда для 32-битной виртуальной машины |
** Команда для 64-битной виртуальной машины |
--------------------------------------------------------------------------------------------------- |
Общая структура программы |
CODE: (* машинный код *) |
LEA SP, STACK + 0x00000000 (* точка входа; инициализация регистра SP *) |
... |
STOP (* конец программы *) |
TYPES: (* таблица типов-записей *) |
WORD 0x00000000, 0x00000000, 0x00000000, 0x00000000 |
WORD 0x00000002, 0x00000002, 0x00000002, 0x00000002 |
WORD 0x00000000, 0x00000006, 0x00000000, 0x00000000 |
WORD 0x00000002, 0x00000000, 0x0000000D, 0x0000000E |
WORD 0x0000000C, 0x0000000E, 0x0000000C, 0x00000000 |
WORD 0x00000000, 0x0000000C, 0x0000000C, 0x00000016 |
WORD 0x00000000, 0x0000000C, 0x0000000C, 0x0000000C |
WORD 0x00000000, 0x00000000, 0x0000000C, 0x0000000C |
WORD 0x0000000C, 0x0000000C, 0x0000000C, 0x0000000C |
WORD 0x0000000C, 0x0000000C, 0x00000000, 0x00000000 |
WORD 0x0000000C, 0x0000000C, 0x0000000C, 0x00000000 |
WORD 0x00000000, 0x0000000C, 0x0000002D, 0x0000002D |
WORD 0x0000002D, 0x00000030, 0x00000030, 0x00000030 |
WORD 0x00000030, 0x0000002D, 0x00000000, 0x00000000 |
WORD 0x0000000A, 0x00000000, 0x00000002, 0x00000000 |
WORD 0x00000000, 0x00000000, 0x00000000, 0x00000000 |
WORD 0x00000000, 0x00000000, 0x00000000, 0x00000000 |
WORD 0x00000000, 0x0000000C, 0x0000000C, 0x00000000 |
WORD 0x00000000, 0x0000000C, 0x00000049, 0x00000049 |
WORD 0x00000049, 0x0000004C, 0x0000004C, 0x0000004C |
WORD 0x00000049, 0x0000000C, 0x00000000, 0x0000000C |
WORD 0x00000053, 0x00000053, 0x00000053, 0x00000053 |
WORD 0x0000000C, 0x00000000, 0x00000000, 0x00000000 |
WORD 0x00000006, 0x0000000C |
STRINGS: (* строковые литералы *) |
BYTE 0x46, 0x50, 0x55, 0x00, 0x54, 0x72, 0x61, 0x70 |
BYTE 0x00, 0x0D, 0x0A, 0x00, 0x61, 0x73, 0x73, 0x65 |
BYTE 0x72, 0x74, 0x69, 0x6F, 0x6E, 0x20, 0x66, 0x61 |
BYTE 0x69, 0x6C, 0x75, 0x72, 0x65, 0x00, 0x4E, 0x49 |
BYTE 0x4C, 0x20, 0x64, 0x65, 0x72, 0x65, 0x66, 0x65 |
BYTE 0x72, 0x65, 0x6E, 0x63, 0x65, 0x00, 0x62, 0x61 |
BYTE 0x64, 0x20, 0x64, 0x69, 0x76, 0x69, 0x73, 0x6F |
BYTE 0x72, 0x00, 0x4E, 0x49, 0x4C, 0x20, 0x70, 0x72 |
BYTE 0x6F, 0x63, 0x65, 0x64, 0x75, 0x72, 0x65, 0x20 |
BYTE 0x63, 0x61, 0x6C, 0x6C, 0x00, 0x74, 0x79, 0x70 |
BYTE 0x65, 0x20, 0x67, 0x75, 0x61, 0x72, 0x64, 0x20 |
BYTE 0x65, 0x72, 0x72, 0x6F, 0x72, 0x00, 0x69, 0x6E |
BYTE 0x64, 0x65, 0x78, 0x20, 0x6F, 0x75, 0x74, 0x20 |
BYTE 0x6F, 0x66, 0x20, 0x72, 0x61, 0x6E, 0x67, 0x65 |
BYTE 0x00, 0x69, 0x6E, 0x76, 0x61, 0x6C, 0x69, 0x64 |
BYTE 0x20, 0x43, 0x41, 0x53, 0x45, 0x00, 0x61, 0x72 |
BYTE 0x72, 0x61, 0x79, 0x20, 0x61, 0x73, 0x73, 0x69 |
BYTE 0x67, 0x6E, 0x6D, 0x65, 0x6E, 0x74, 0x20, 0x65 |
BYTE 0x72, 0x72, 0x6F, 0x72, 0x00, 0x43, 0x48, 0x52 |
BYTE 0x20, 0x6F, 0x75, 0x74, 0x20, 0x6F, 0x66, 0x20 |
BYTE 0x72, 0x61, 0x6E, 0x67, 0x65, 0x00, 0x57, 0x43 |
BYTE 0x48, 0x52, 0x20, 0x6F, 0x75, 0x74, 0x20, 0x6F |
BYTE 0x66, 0x20, 0x72, 0x61, 0x6E, 0x67, 0x65, 0x00 |
BYTE 0x42, 0x59, 0x54, 0x45, 0x20, 0x6F, 0x75, 0x74 |
BYTE 0x20, 0x6F, 0x66, 0x20, 0x72, 0x61, 0x6E, 0x67 |
BYTE 0x65, 0x00, 0x65, 0x72, 0x72, 0x6F, 0x72, 0x20 |
BYTE 0x28, 0x00, 0x29, 0x3A, 0x20, 0x00, 0x6D, 0x6F |
BYTE 0x64, 0x75, 0x6C, 0x65, 0x3A, 0x20, 0x00, 0x6C |
BYTE 0x69, 0x6E, 0x65, 0x3A, 0x20, 0x00, 0x52, 0x54 |
BYTE 0x4C, 0x00, 0x54, 0x65, 0x73, 0x74, 0x00, 0x00 |
GLOBAL: |
WORDS 0x00000004 (* размер глобальных переменных в словах (слово = 4 или 8 байт) *) |
HEAP: |
WORDS 0x007FFFBF (* размер области кучи/стэка в словах (слово = 4 или 8 байт) *) |
STACK: |
WORDS 8 (* зарезервировано *) |
--------------------------------------------------------------------------------------------------- |