From 31a4eb52473ba61a1c8b970724edf95297be17fc Mon Sep 17 00:00:00 2001 From: "Kirill Lipatov (Leency)" Date: Sun, 23 Oct 2016 23:30:27 +0000 Subject: [PATCH] upload oberon07 by akron1, add to ISO git-svn-id: svn://kolibrios.org@6613 a494cfbc-eb01-0410-851d-a64ba20cac60 --- data/Tupfile.lua | 4 + programs/cmm/clipview/clipview | Bin 0 -> 9471 bytes programs/cmm/lib/clipboard.h | 2 +- programs/develop/oberon07/Compiler.kex | Bin 0 -> 34369 bytes programs/develop/oberon07/Docs/About1251.txt | 856 +++++++ programs/develop/oberon07/Docs/About866.txt | 856 +++++++ .../develop/oberon07/Docs/Oberon07.report.fb2 | 693 ++++++ .../develop/oberon07/Lib/KolibriOS/API.ob07 | 193 ++ .../develop/oberon07/Lib/KolibriOS/Args.ob07 | 100 + .../oberon07/Lib/KolibriOS/ColorDlg.ob07 | 105 + .../oberon07/Lib/KolibriOS/Console.ob07 | 66 + .../oberon07/Lib/KolibriOS/ConsoleLib.ob07 | 101 + .../oberon07/Lib/KolibriOS/DateTime.ob07 | 140 ++ .../develop/oberon07/Lib/KolibriOS/Debug.ob07 | 287 +++ .../develop/oberon07/Lib/KolibriOS/File.ob07 | 255 +++ .../develop/oberon07/Lib/KolibriOS/HOST.ob07 | 270 +++ .../develop/oberon07/Lib/KolibriOS/In.ob07 | 296 +++ .../oberon07/Lib/KolibriOS/KOSAPI.ob07 | 323 +++ .../develop/oberon07/Lib/KolibriOS/Math.ob07 | 254 +++ .../oberon07/Lib/KolibriOS/OpenDlg.ob07 | 153 ++ .../develop/oberon07/Lib/KolibriOS/Out.ob07 | 262 +++ .../develop/oberon07/Lib/KolibriOS/RTL.ob07 | 279 +++ .../oberon07/Lib/KolibriOS/RasterWorks.ob07 | 124 + .../develop/oberon07/Lib/KolibriOS/Read.ob07 | 50 + .../develop/oberon07/Lib/KolibriOS/Write.ob07 | 50 + .../oberon07/Lib/KolibriOS/kfonts.ob07 | 478 ++++ .../oberon07/Lib/KolibriOS/libimg.ob07 | 435 ++++ .../develop/oberon07/Lib/Linux32/API.ob07 | 143 ++ .../develop/oberon07/Lib/Linux32/HOST.ob07 | 121 + .../develop/oberon07/Lib/Linux32/RTL.ob07 | 279 +++ .../develop/oberon07/Lib/Windows32/API.ob07 | 75 + .../develop/oberon07/Lib/Windows32/HOST.ob07 | 141 ++ .../develop/oberon07/Lib/Windows32/RTL.ob07 | 279 +++ .../develop/oberon07/Samples/Dialogs.ob07 | 114 + programs/develop/oberon07/Samples/HW.ob07 | 54 + programs/develop/oberon07/Samples/HW_con.ob07 | 53 + .../develop/oberon07/Samples/RasterW.ob07 | 159 ++ programs/develop/oberon07/Samples/kfont.ob07 | 175 ++ .../develop/oberon07/Samples/lib_img.ob07 | 97 + .../develop/oberon07/Source/Compiler.ob07 | 1901 ++++++++++++++++ programs/develop/oberon07/Source/DECL.ob07 | 1618 ++++++++++++++ programs/develop/oberon07/Source/ELF.ob07 | 295 +++ programs/develop/oberon07/Source/ERRORS.ob07 | 285 +++ programs/develop/oberon07/Source/SCAN.ob07 | 699 ++++++ programs/develop/oberon07/Source/UTILS.ob07 | 426 ++++ programs/develop/oberon07/Source/X86.ob07 | 1986 +++++++++++++++++ 46 files changed, 15531 insertions(+), 1 deletion(-) create mode 100644 programs/cmm/clipview/clipview create mode 100644 programs/develop/oberon07/Compiler.kex create mode 100644 programs/develop/oberon07/Docs/About1251.txt create mode 100644 programs/develop/oberon07/Docs/About866.txt create mode 100644 programs/develop/oberon07/Docs/Oberon07.report.fb2 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/API.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Args.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Console.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/File.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/In.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Math.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Out.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Read.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/Write.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07 create mode 100644 programs/develop/oberon07/Lib/KolibriOS/libimg.ob07 create mode 100644 programs/develop/oberon07/Lib/Linux32/API.ob07 create mode 100644 programs/develop/oberon07/Lib/Linux32/HOST.ob07 create mode 100644 programs/develop/oberon07/Lib/Linux32/RTL.ob07 create mode 100644 programs/develop/oberon07/Lib/Windows32/API.ob07 create mode 100644 programs/develop/oberon07/Lib/Windows32/HOST.ob07 create mode 100644 programs/develop/oberon07/Lib/Windows32/RTL.ob07 create mode 100644 programs/develop/oberon07/Samples/Dialogs.ob07 create mode 100644 programs/develop/oberon07/Samples/HW.ob07 create mode 100644 programs/develop/oberon07/Samples/HW_con.ob07 create mode 100644 programs/develop/oberon07/Samples/RasterW.ob07 create mode 100644 programs/develop/oberon07/Samples/kfont.ob07 create mode 100644 programs/develop/oberon07/Samples/lib_img.ob07 create mode 100644 programs/develop/oberon07/Source/Compiler.ob07 create mode 100644 programs/develop/oberon07/Source/DECL.ob07 create mode 100644 programs/develop/oberon07/Source/ELF.ob07 create mode 100644 programs/develop/oberon07/Source/ERRORS.ob07 create mode 100644 programs/develop/oberon07/Source/SCAN.ob07 create mode 100644 programs/develop/oberon07/Source/UTILS.ob07 create mode 100644 programs/develop/oberon07/Source/X86.ob07 diff --git a/data/Tupfile.lua b/data/Tupfile.lua index 2717a53b03..92f51ee7bb 100644 --- a/data/Tupfile.lua +++ b/data/Tupfile.lua @@ -162,6 +162,10 @@ extra_files = { {"kolibrios/3D/TEST_GLU2", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/test_glu2"}, {"kolibrios/3D/TEXT_2.PNG", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/text_2.png"}, {"kolibrios/3D/TEXTURES1", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/textures1"}, + {"kolibrios/develop/oberon07/", PROGS .. "/develop/oberon07/*"}, + {"kolibrios/develop/oberon07/Docs/", PROGS .. "/develop/oberon07/Docs/*"}, + {"kolibrios/develop/oberon07/Lib/KolibriOS/", PROGS .. "/develop/oberon07/Lib/KolibriOS/*"}, + {"kolibrios/develop/oberon07/Samples/", PROGS .. "/develop/oberon07/Samples/*"}, {"kolibrios/emul/dosbox/", "common/emul/DosBox/*"}, {"kolibrios/emul/e80/readme.txt", PROGS .. "/emulator/e80/trunk/readme.txt"}, {"kolibrios/emul/fceu/fceu", PROGS .. "/emulator/fceu/fceu"}, diff --git a/programs/cmm/clipview/clipview b/programs/cmm/clipview/clipview new file mode 100644 index 0000000000000000000000000000000000000000..7c4a771639f741e95853c649d6d7cf1fcb20f1f1 GIT binary patch literal 9471 zcmb7K4|G)JmH(2Nghv>BqXr#mN~fAgln@d^gix@f@Lu51;0VSB5aWj9QfEX@U-w!$}3g6vu(o+=G zc4rNqbJ})iYGtm$vrbzX7|R`l@3|I~3nx9G3#RTm>DfKxV#H>z&~|5XdXSYl2G6=| zWkTV_lb-fr#!{fq?jh%w6Mp6973fAlH(I%C@I9xkJX1UxaSndqvPB#uBa?TLU7?W% zP+8E*GdZ1eriXcdwe=3PW}4<|WG(s-3jdhoR$2wt;%aXd9{2-edqt(y!CL0Gw>qfW zk`}uj&I~S0y27EAIZZv10)j%tww@fYtXE&K7%^ebV(i&0Aoc42^(`UjdV+2wXfZ*#1dV?Ukb|IO5TjpOfS()CIy~xN zOp7?X)4QY#F<_Y?ITQ7^)(b51Kbj;APN%9;9Dt(Rr|RRXG#y(6QcZGb#H^+(lGCn8 z4!cnnS6bsN@_y`EYL7U&)6w3Q4xxtRFv_Nt)@c^`5V(m)U_2dFcvF z@-izh#Y=a9VGai7;ipGx^Xh}>wx_&Je-pu?ytZZxGOHq?%6)5ju^&ZaU1hzG>Wz_x z@LJYV+g!V+&cBw`)P|Z-&uMn&RJ;G`FWFHTg_^3ItIBz*>{jJ0Rd!h((4;JCOV=cq zD%&+FQGC+dG#%_nT}oT_z-cYfc+% zTb(lMA(Eb}s7-b)BloytqyqJmBD+aEWl|b-9v38?l}JwU;A%@Ascw@6!u8z5<=9Ik zhj@^(fF|2*vV*EU0+%u)&A~>23Nj<&G$Ic2=T8j7=!}XTja)EdTUaLB$>%VHW|y2- zBE`iHQ?85P9*T6tJ_a|Ka!9(+c3>?NJ63R{b6GlgGcgr4Ik!ZbPB3N@Y%yY7b2+0X zU9ct_hF+PzTkL3n5M_F^*ipfOyTlG!CzR<@u_KQIo5YUmIN%jKw*nvwx=_X*u_`OD zK*d5<i&o%}+l_mPyB6cFNao!?Kt(a(4&J!=b zSz|>)O5l-fk|<|c0g;HoZo*;?o1^?Nr^#C;yAcvu;=ym2bsirH4$_%(`rQS17VYd;7`uIIf9aDgR(F=>p{$sSRt{`$roQwh$I#y2-pj`#1cfy z|0Q+Gtoxkkr&J{-DGuP=B(rpl4V3^#aqvOVoqci?#3Q01B}ua z(B!AbNCIFI$USZmics~6 zLe2{IkT0}9zi|)6?IaR>QtF<@eU)gon%G-d4g>i92HydEJ@}r+_s{tH@tweT7T+iM z?3h1`@GZsn1in6e|AB7^UkSd=_;%v^4Zg&mzq&SDi9T5ZsC>x3f2LC37-{yi7JsO@ zwy~koU(M?M4Ux({zEEX#$hUW<=BoqX~)L2(Xl3Gkz zvk@lq3??v_Bv5&|{3I!>3izuYB8xc7%2{>Ju`+2)RbVA+YzmWI3F_JP%jGvVF|RKi z*dA!yTiF!yH~B*T83cDlQ>gL5kiWS(>6_Vz1k7qezIwlD3}Y8C4xi&Q@YxW;_xSgP z+2(rRgMPN{j_SR#?1ovhG zEJ^zgh(QGjeFW;qp=azJlDz&G;6fX%14c1bOtruFnYpRLUX|&O6ZyY^TrYwQ@mLi3 zgS71At+xV)!%2o!y$#DMstc^@YP0IFs$0xzwfGn!6n)?>J2sr&i?*9JAToLh3}%i96byK(4>qR`Y8-f+xjD@rHVbh zr1|>4M`aX{sPO&Ve;VrB>N`ItjD8&E#JRjRAM(+?9Bnpw~hboagh zNQvs=v4u2xw~Tswf66gOy}?Y=#P&}OL*GF18QJ$WK!E_+x8MuIC`sE0a#1nuM+dQg z!HP6CyrHhPX-}gsRPDaE*1y*ua<>%b7ZlP7$0(-w4ANG*m^u$;YKtBtapc+{GrQN9 zc&*kYR%+?CU0+nRjxv*L~WMx@MZ5B69eux$TW&ONOCGHb~qez4|m|+xit$qP-8Id^e(w1h57kKmIyn`R%H*gvwtvk_63XZvdNxZ-)o<)3) zh|ghQuT1Q?jQ9c(A2o?h^DXPWy`;KlMt5$y2ZsLxncNGtO_QTZldtzavxjUmik}9_ zs~I@b>)-gua;xbIMcZR&ME&s}X>2$8>-=HAyUy1fb~o2GhM9%%)z$HOGu!5G z_J`f!0Eil^9&+!A)YSMx>?Zfa?v1{%&)r=6xBdhi-rq#{XO*MVj@EVPCjS@|*>7!A#5?da8Iy~x1Wr}~ongYUFLw z_N@e-=PYyd9MDQxPcez@^cMUc|8H`{>rj5`E%E3g(rW5G)524_Esb31F%#!0UC{+I zKCICW96o%Qy~+iA7K3tCaY_L9NEP?E-J7HeHk0OSo8A8Urtp4B@wmA&122xH!wd|g zm^>8l;5J160iuS^y%2hQ#OTNxD5vHfSY>eKggQSztq9jQ6=1hrg%za*$sr$g zwseE9!QIdpc2|Y`*sQv*M6@u&8}bu}yC%|rU2S878%h$Buf{!;gH$(qW? zXqj6A`-Wq51TzhI7Dy9X0;n?@(e+E0Kw{#aB9?Kg)4GP!7=yWdUqk{H;Cycy`~mhc zbWY(%gK%xb{w7~FUkbr;62qKixjo79)7dQ5{uX~-W7CR&AN%&A=qu>O_~gi@O}C5= zcfKnsAZ5y^F1H|J5e4ok&~{7lbva_kJpk7= zi5=Hcd575XuTW{7PweQWvR3TyQCTh0YRuL}#E!eEtP(p)sB9KHX>X-Tx+ z1VrPoMt9A+fg^fE=RHGB7!$k533Q730t zegbt(I-ep5u_Hth5soXkqoUpL^Jr2eA%i>Ud~79&EfcyWJzIoc>*kA(QlP$gN2(Oh z%iz89XnC;!2wokm*X>HH&LX4eK}8SW0ez38d-c-*lB(@Og;dL*qZ-Y6OEvSxT^LEv zf%!4oV8wFi2N`yjZ-iN+LcS3@i%3KSeDJ8SOqv)QF4$LK{ZZ5fo`tOxt#=_MCBxE# ziBVg_r>}X%DIS#subzXID-oW+>*VJb&3n5SQ+DIRe-w9QC!|UC#*e=>B3(#1Ax(dd zL8ccM>ozGeee+0qfkuU#!qmx_3K3XUXfIDxJv7^xhy5&SS==dvkGrlA0fVZEM%)}%>O29_D6b&^G%;o6XY z_>F=d0Sh|O593-VxNwL5cPNMHOvN7o^y&{Oe6X<-0-s{{8*t*C#jC%7RDr#o{v6y* z^8rLH(=sx~ z!f7WxcaDFCcMB_}pi}(2J4VJr>$clhnC~fSjp8tbcz&?QYGLgRSd6sF!QJpBrtV5dITUwY3l zYP@KfM$6>vmZzy@2OGt^7@GeymvMiB@$)S)l9zO zehTrE9y|&sz#Mv*8SbYb8KAWB3cN&K?5AW!l)`X7EgI&CE3KKVC0%KCvb|}sFer>j zmJx9okxY0Q?`rxO6bB9uO*YB7OmbislxR9KtBLTql_LrwBF;l-#ygcw%H$Xla0RMb zP+2cgqy_2XAYJa|x|oVMgDE8NcHW;0uU)1j3%%4tL$6?prF16mnlvVL!7VvFT&GKC zsW<+}e3|9 z<4GKkta=mIV-ki*6CN+W?tvmf7We?f`U#{YZt~_cWW}TrnXpLsuoeM}wZ%q{M=snK zRV1FYhexw9!=>}M{t)QdQ~drih{IGJoX+s-i*d|XrQi0no>xco-(k%F^z((^M1OCi z61$PBDd?YmK8x&_MRqljy+jr1JY`1rmOae9hu>FWlc>Lr7Gzd^1SK6_I_aE5TSC-P zTGze79P@uSsKW^P_Hz{LSl`ri^?v*MCL}WPAccE-J~gx-u$w5lp>J=n6At|Re?6$f z>L4-7S<0D|Q{&3Hl)+f4ayA8Tr|SJKb!(=UULp$!Y1v*PJH!rpp8-9Njq(~?oa40> zH|MyO=9m9;L%)Wa+YVGo=j-=>-_2zBR~r zz4QYK%jE2mGojTyc|KQ+o=HP+M z)DgLY#qK0UYF6P}htGo#T99HLl%lz^ofKx&O95An-(694BLt+-J-_TGm(9a}6q)1l z`}3^p_FzFp(6$Rh7|h+7yj?fn=lQm!4F7ebGaBBg4q?stcR)99(-wEW8!qy83u_ld zgpRRrhG)b0Cl$(&F#djpb|)Mg-#Py4HUwZ;FhX|yXV8&eaUHaUrNX;?W~oF<KE#i1uGvL>TlFH)M-S{r~jm$QqI~w{YUk!;ovnD z!A0;F2gq@>vOds%D~>V)Rrq;jBYs|WVVW7`f{(f(0_d(?x8QVGx>swlAMe8w@ceTb z=zGSIulyLulb!|9@X~Ewoo1z1W9@6`?!5v#gC@KFBh2*sl@Ve5`l-KMSz2D7;4f$HDqbU0Pk;r@~KOKXmG-j3ebE^LZ-EhtN#<-9dzd=xu3)SoAgNU>_#IQAG-t}W>%3wd1K?Ee2 z$9+2yU?hO_t9cHKe!Z`50rhf~ytj3Iu8*qM2_~C)p!JJuI>`2fRc22N+n&c_fO;w! z$*zaMwaotlv{X`doUt9%R_09GhOJ(DQxV1yI6F_A^MaWB(n%ZAwi*GNDA-5 zZoLJ@ahsUQeh%(byImEEv#<&qvvkOuYS@9S^V^5hE0dWx&6&JOF&adSkedTwH=&bl z@U8p1!|33-&iV@3DX{0EOw-jH_;>c#&deK~NT;Pw9RUMFE-(m(E3?a{MAPDx1@_?zn_e3 zSXU_Artu36$!s>c4A0^>16a*mUt|J5ML8z=o00*wV)S`7o!69cS!S}9gy=-lO8q&! zBf!;eQ~yncl$!nCdAG&896X#s7@cwTt--BjLi>lU*rXZ)JtXSm+_@c_g(N2#9f4KF zi71Yodr?QR&-@_OQ&L^?7b&{+{D4z>*z6@-YS>5>g4S;g^(pwUcel~UMP_wl8=)pP?CGA>|9~pJcA_G1G%iyjgs2t?G2n31o*UdVp0~c2{Q=_ftF)< zwP<0|{;kL6buogs`IWaj9VF;#%Kuq} zZFumcF7}$Rul@+r0mK?uJyZpOj!Mxp>fMyN@nQ?j{sV6#2;3nLsic|Nj9uzBD}yX8 zSk;@mGoNj6ajeWCRgiX3by6!905~yq=`>(_QA`AR`6{O6xOCLBqL(b}4oeJHsQn(z zWh08{l@fG=?X}d-{I|vWWQmvYmaQ-L34%oGMF@FO{{Dy*FH4Awlnp)=>3yAv_*s{} zq$GU1{ps%~KYY{5pj!MCa7!A{AV$F|ekw&{u7U9yuoUZYYwen_$fy0x$vvk^|v+!-C2SL1bEXz?t?;3&b0i|ib6_P zl1YH5x%7A<7Rq7FAu^bK2izxv=))jwQ1tLN}QROnLQW@Ea3%vYo*-QBO)N@#RT#n(T1u zl(O%UT#i)RM56}Hie2*rgY>@}2fZhLnhR@{!8FU+P*Zqo$5a4x+;|cGKQyH4VbQD% ztL`9#TCjlu#+R})l?34bbXIw;tZj7VHswMPB#+B+xubUfahTlfef32o4b?vMlLFNqai{>-q29;_2Ko})F0yPS3q2BH zxyNE$!3C;0s+ooVP8>-J#^Z0bWvKr6MZ5z$Ia^c91ak3k;-Ia9N;kuDz&60vU)x4e z3qT@6MEpH_6Jw&69V8yXM)_A>rU4t~b9&$;@g1}UcVq6Vrlh2D*(x;Iw1pwH11o{9 z=SFPw1W*ntdUwFZa=IS#BfbftwTLC9S?zpiKCNCT!t<)-rXT?Yb3&dwc5wwH#6b5j z3+VO`ReekND!Gf-s-0x zMW4O^J!0a(AGUd&U5mk&9v)<4Da5PW#?`Z^^ua(}uZL}YT>Hj6uDB^*>aNGlw^T8p zC_sd|=&R0Mdx$=56QedP^1bSxwOgC$1+b<}Mnmih#HZ?|n4!H^6}0TG1xg%HTfhw@ zi=}GQF7bFfJElceykwmhPkk8P5)($kA+#$_G)n(+{jjzChL4&g6W$P3frexAC;)*I ziOMMe@p@LfoK%X-Q>PU{f~1}$D6(Am3e*T{Ue-2E^Dv@4X5&IjLP*tPIrvp%gx=%;-avtMV7);eqoxoqf z577$u5Cs@tj(j?85o}XR4M*r=MHCg&xKg2M80&!$%cO zz}!^&Ku*!|{ye6f|`-wDbW~yu&`6Dbfxu?{ZixTzPBF>h^S#KvJBp?z%9i>Rzcoo zJMEb&siLWi01c(vh5vbt5B}iG)7QO^oD1iZA z0_WEBNI%ok%S$^tJfVua{t~yJ>!t2Wx0!*1(D)=5Wvu4 z>CY(Lvc#ECG<(CgkCaKIV;C2^F)1Z}1P70{5;(9$upx6h9j3$AAz86uV#pI$HY$*# zM}B*XL%&>UVH}5!7}-G(E%J;AIR@|PAeNz~EO`tRnSvDgd06A9$~&hz9lXvuPJ@%8 zptqOp<|}%QJmxL!!NZhW5^IlZzm zfTjM?SK7k*@uch~>-q9@g<3YXG{UT=v8W=b)o}r8s_Kn-1j)}^$ojBi?%1dy2g*fO zxH>)B`} zXL$^5#O&3={?_osnhW=uQjkyED%Uc?9nd5u#sGWs>MMPsseu#Gv!%gc&NMUuG&aSl zUqxS!UP8|*hdt!cx96tMBT!U|2cIRbwLj0D$~-To{ha{eEuj!r_i`HcIJo~kY2mHd zi@o$9m%hdF|7YDvWYP8H7f=&NgWiWnGAu~0 z$btHl6U5xS8vp9hq;$CfL+RIUlSQr56R^Cktu4AX#Q53vuPbr5a=?_5 zv1C5w%#3RYb<12*6c~J4@+3l_C{L~@dA%o{Kj=Rw_4Q6pyKLVE5XkN=Lkl zFdtEpD4w?GhUDpu=ctE)v)Z<;kj)0j!2lo3C4&6-eb+_mPsRvinX!j1x%%09{C_ zc!cyD?`l~iB*iOx4y7fE(q?(QIMzK$=N_cvgit0_=I0b}F0euXrS902 zlhXneX|RSk5G+rkD(7rUmsTBXQV`_YeJ~=T9_YDvA8>_4M@6$auY)&q35HS?xlDim ze$HeHjLFfc0#}Ox-CqtF7=0-;eOkNnj0Rds3Gro2YtJg_O+Dog@z2fWR7iGEuBGr4 zV-)>ddS<_)pr;fKn#BR4zYSv}6b!`ZT`4PaVPU{1@{$bh1t$y@WZvo$<4jm=SEhk9 zJz3^Q%2}#bD&(8mKh39WuH+iO=m&I2) zz_Q~k|H8_~1Znmqv;cyh-5%se$><{uvPXsBLe+gE30cn500wi64+=~KW2PMDoegOl z-xa47G&Uf-_KD=$iAw#&Q8XCOGUy8yq%3UdjWW z=4#xsy$8A-ThVRpyEmb2c$`3Mw&%{_!;&6uthlQ+R?$Z6yF~jtkr5%qKoe!Rc+I2w zn*w{}cK&7+?Q2p7ZU{$fRByAvNms9$P}VN zB$1gE&rkTd2YN%mmi*h4y!#1s@;~@&NVgc3JafL;CoCE-U+^eN^lu&eY%A^HgXvQboN2m?pTm7baRy|gwuejy3Tk!MtpqLJXb0gIIG^)mzmhJ(Y4V#zYxQfp zG4ALF6~WEQ3o7q^bm4M-oJFKaX-1bcSOZo*B%8HEa`GYt=}JdB(Zrd3@1YA{DVc}Q zkcHMLA&@UOoRP4}I{ItoVcY7EZ)vAUN?LT@>wSLAG-P+}_k`CW*SWE`(DjErk+cBz zy%*`xCL5HwN#K)PqG_$0+!^Bzfl~U98A<+R$-7|@Fpkkcn>H`Mu_RenbYx=uz-ljX znsX){vWN}fdU5-ze&SZSPrc=Bqp|W}H_axBcD}}ZN)flh~U+CLEG%24HvK6UO#S_B4%r zWI7Wzsm<-LPF%2v(17ZQm%Q-c^8ilo&ip%w%2y(>r%N&=QOZ$1s*U0Kxm`dj_m0-y zBF*4I0s_w-T)e4;c$Y(yb|7%>=b5~c_uaCbN}cs3g+%az0W{(AInN+pD5S1YY~Jb;y24pLEu40+Kn&e~*u;Ga#tWFHOorv_`6tOx1Y zc{;Bb;O*uki^R89mmNf%g@u~@iSI;TH3$G5Z@mLuYe%RQV>2%71ire-; zHhiIs&Vv$)a{lM;xWZgkCZ~1ozGZX+znU*5&d#Ol2N*5;Cd}5A)ACNV0r%Y>b|JPL z$Q})|BywuOB-&f!=aoMq15;B(G8a4uUX!wiz=~`0XV+3APQ?2`NN*y$jw}W>y0bT> z@Ax6)GO&0-X+}R0fV(AgO8A%l?t6HgyN!T3>&47%WnMX$6)jFx6MI5 z{tZ>{@Bn4RJVJbblCpM$zMqYNkYlgyoeCbip4m$U&(L9u+0}FtrDykv)R>t`TUOfp zHI}?ply5-Ne<}DT7RA55FKO?zgW{1Xgow5zx+ms)is&s4D~O4x%icii_V4@C7U=sA zv=2wT?UZe}v{h44ot|=0N4{svkH)<}s+(_totf;9WPJSw@lcqiNEc!b0Jz7qWNyD-d^+!L;@N6V`Q>rVjO zw9k14=!8F*8~mTv^I{GI+QyI|DFm~NEAk1Hop^j$)#$}huHY~KV9 zwp+wfL9raQnTI6Dx^H|{aRB_OR6`1kW57A85}}yir!Ke1@J<(MqdRpSV)K<&E6_^l zP0eOUEUK%3#}!pUd^y(+>dYtZm0Pk4R`b<&v@|Cik{YeWSgGOH-h=nuK0zyvd_ zRgxbH^-#uB!pMn)+^iDNlMbMtxcY)cET)Q&Ey_nTb&xIqap>9eslcB%GJ=a_Og*$c zL|`xcFVq_PtGs8i@pNQzXv~UwSiPUei=*~k8i=@B0y~(!IJ`~Jqau>CI79+Ysddg# zI$oa%h|&0xr|~a3K6<=H<=Yc#v*J56Hc8VdYqHJwd^ZlvU*IsuziP_D^BYE?e5}cU z@3?E7iCR$C=MZhj7#x2-VlJ-+NqE%G#(68V8BgdP{$M7!9;NgbjrWhy?e<|`EI#Vd z&vZruoylG!Qu+&=9<(<02*+uK@YSxoj`Nnu2!oQM-Z&I%5+r60(4U+|$L8?0;xen{ z23)gqS+dcYnZEx%_AfSfJYb6+v1@Nc?7{3Hg;PuQ{7tJJ%#V5G`I75He8@qu@^y}w zQFINNA7^eXLZg@rOXgj_^&R^hK0C9&slE(myY2Utrsq%2a&61myLrQ>HyF%8qv|G5 zzvBwH6hYch#d2v~xY~eBh2MJHSEMyUaQeIL08&<^zWoL8YiY}i&PP{(M*TU}gRps| z5VK|ZkV2i+`{t66e&*E%VV3x`vB(uhgHGCU@0P@6$KIOor{c7vaRqP}Ao(z+lS0fO zp$bQQ+5p>{lA8gH{nAN6X;+Ud5tt>W3O>oN^;YFk)J{u{FL%ncL9cO`w$|QSH%S@% z^o-sr0qRVXm-UUJf8$)`4WE%PgQDPLU6Lo7Oqt%p2jF;ig2hCh&Pum@371yyqM4_x zSibmp)OuZV|7r<9QLmv*qCPacl##N50UsW6F+u`=yg%^gfpRX^V=~2p;u}nXm$GVyJP>gNQd9-U2jtY#9e%X%Sx{`9IwOK?iFCR z&*$p$8O|_iX~ZR9?7;TDA_}(CWw_Ul|4Qmhb{7!i(Ucg#o=%N*(5WKpP2Q z53OovxYS~h0L0~t#A9ztsQy3CRlYRO}Do}MepI?~V zrI|Ja7R@sZV{4Yk-UjlH!`J#9@4|x35eOh%%)IT`#2QcGoUh`I8b=hD>~Vp+7$O%@ zt%14<5|Lb^fBsqh5J;V%+!Y;pS<#7NKTy-XuPrV#}ldG#@=9aH5<+@Yy97n&g*4|6g@V{(%Cs5 zXOHahvScY7q~8hEBZs;1ZHZkpjk=bYIgP`^8H@jOd18_wbI&Kiph;aY(&-!l-QYG% zrDaO-)<(>MJ=L##gS~jH*wA&pvIT7>FRI^@(C^tJ=q}N4VsvO=o-m4=HuN2QP!8#O zwzDJ_Z$izV2RRj{H!IH~l~MheGRy>|Cb&LcX)B3ipiO3)d6ESC%fn_UO2iByIo)2M z9{=`KRx;kI#BpaH9&#LibG@&@)s8+pRjag@+$zseL} zzRrN!fB$b{iNy%1b!(pSEL;xlV9ZWcyQS7E^|455x;e;7fWfB`v^kp-%1zi#(Yh5! zKu8aD%EdWmO3Evd4%(S|z$x0v6eKZfXUEqd#zmSd|#J=3eg8_GGZ)KeS&B+ezKQksQw@g z#CIZB_s*hCIr;~@bbNw#sfh+2=wjZiMJ*3PO_iKoj$2Q-kSrannKhMo?NKs=%;kbJ z2|13otb!Z~cxKi(>bfW_UcNV?=M4qU1TC$~5%)+jB=i<{sf8Fwx67SaYR6Ho;Wn-4 zH6?Q9&Gxv9xe%VW?OE?%E*iUe$oa{ElQfD4wJPVT`a)xw(!gd;j(Y~Q&4g}tmD}B^ zMyAA(@+yq&=0lO@V0JU)r&ao>7A+$*A zG!-*Nn;EnA?e3f`<}7zTA>A?k9vujVLWCyb@6~-CZ2@hoJExEp;~TNneD2BrN&6*D zH;)3uBqz|}q|7EuQ z4&c~y#X5tp;wI9hi~wN!jVEnthqovvmg$#n$A}0OeN2%wlzpZSsC0`|9;k%FCC%hk zZp|g_2#Dy5gX2Y@DGHz%3b*2zD=+kgjN&_K4-bMQ2yZ3m)-DqNzQd~uc9ljyG7zl? z<~By4hBkn$w@@Lj*49K_vP&#aG&82Fzp*kxa{|JFGD znpcKZ>qlplkY+3`?5P7}uRPXu8wY|2J3riBuTG=Aal3+&lqjr-q=F^BaXAg)BWSrG z%-LaOF4K$^40=4rp8F&kUt(f5r&*UWYl0+O>C*Xpum;_qMI5e`e^AB(Kzrx75t&go z*Y1faNA^|gf=#keMa}5gOB9O%`{>}m{a|G@bhjh_B|y2lNLLk8x$a{15Y|)@xAYt& zjE{`*uSHrDYCI)E&!4}cRb5nd)Kjsknt7fbGlD}}mjMXwQypBFu5qP(_nI;yp=G9N z0KA>WPGdXNJ^AaP2Lh8iTdjPi5SiGPzng@JJ?`mVQXG?FP^R)S^F$e1V@LgCo}Jjh zVgiXOS1LdRIpQyBOkUWj)p(E<1vKgqWgf_#asvF#vi0*uxNQo=8pnPc%iN2!q-Z9A zOi?PsP4H$mRN4eBTgljdU0n~$#e1Un$MnJ_*pvD8?p`e0Qlmzd_4{z*&J{%MhKx-V z3V*0ow*8Y6UwrD8t(_kVMmp}+a?1MA3KfHLrgMKvp zcwe=Q@nh*Xl>0cyb^_XgM6|{I|Caeipk1m{EJOz&96d6`W3U3d-4WFHMQ^z5n>Mt4 zTFHhximohEL%}2z%?1+E3zM}$ znP-)*{xuJtq#}eDPR5Ko`V_fcJA0tZ;l%I%GJSLHka9jbYAMF$FO0DtrR5L`Ygw}G zrJ_1z4TFh;mo>RHNI&vFzgOAlsj>Wbm~VJOKuv1`?^|w|RjtRcRm8nG>n4tM5-@M% zv63c?B+^I*5-zQib&gOE*slL`SVFK0>lpj`JooNy*A5j?x{dh*wfE*eo`T%tOUFA? zqJ^X9lbgq}5{`oKNeN4L)>pXL!a8cagr&ptopt{tZMaNFiT1iS&!@z%njh)qmj6@` z5u$;*ib@nBd(GTe&4TFfnaU{#Q=cyAq&6Jr@>WFo$b_bes306R{2_$^56n3nbg1du zd}jw3@2{_qVYwn^=u4@9=}wYwT`|Ws^4#os?9DJAd;9Z2s|~vc+pUFH)COQS2Eu2vv_C8Hh zMu5^!XNFIygJyNeyax9-FbKCQnk17y6&O%8CZNrU4uCsFka&v-E-SVlBV6weIBEoA zICs?`w?>IkqYQRli|=d`Uu7L1m1dp#z)1D>+US9?w6{s))ssN?U7!VJFZfbp{FvD3 zmX@Q7Jp1`KY@Kv*%^QCCG^wf)7;VNJVsSiAih<)#W|W-4PF{qpN?^eL2V6(O{h6p| zd8SiN3$rB?&9OXQ_3k=h#ENtR0zzKug^@ps+?LPjK2(#A`_&Fo$&n!54oB#1TGav! zJ)C#DmQu+Rn&S7%jblIDb`>-Upz$`omGVc9g z%vGq;Z+f79f+URSC?`$}!7vYWhXYanLTt6+NMEh*B7Q#@$UPg zyUI#9AQ(MeZV=s++5#LA9IH|97r9tPUDcy63|i+EZlSfGNCkU)f{qp8#6%M3>ugdaSH=hS|T-I;eP65Ll~p{RW}GAwVD{w6Kdi z_RQw6xWyjK(}XZ;tctC`g&67oX9!0FKmU9ED5|h)*MU+_I0{T>*K>cA0jvy^QP=kd zUw+a$oR;?rw+u^XQKnl78J6q$2Ho@_7=zQv{0NRr;>{NWQu!I`L2Ht*5;5UkI z8T}fsgz|yD$pf;^1+25|{EW^v0{J;sSk2YYwUMH#ydwQxn*@WieWy}JviM+Q-u9Bc zD|i1&YIVQyYy(u+sV|p{8l#R?ML;qtIhOqG^2xSzGDK1d9p@5RZJbvqi7n99LKodk z+yCHYEhw;+y1Z4!ZYU5{14=g;U#K)fvi$*8`hv%OeF@?`i3k316%H$2zT6tQG7LP% zwHz?wr~3%2=UhUwE3EcDcAtp`^6{E8ezU!<)qFwaCbOh&OOc4y{6Y!Iic?3& zC(#DubNVr`k`&h?)Ph<623iHlVlZ45%KOh-aF7s|i=I$LsU7vx6`v1US%t zxNCrQw*dPjSIUIj5jz(KptW&XNLGkY5o+vpVw$VFwvr&KUDa(_b*_!_ z5pI{S+t0B<09Y267nN|43u;p2!2PNF=9&ve1Djumgk^5t#B;p}$zpuAUuSiktZV4q zUks1;$fcVmfVtgu>2_N>SQzwnEXZL~R9tx(s&(h3A?hj|(1%SnRhRYNzf1lV0a23l z%3GX?#9nqA7<3oj2KryQ620|)^q$P}`W8UjV9E7w(q56fxefnf9;nP}UrlYoopyTX z#8J6Bu;|P=J$Kw++fFquQ|3`#rN4gK!dD#^nD*!)qT16_yyGR~B0?Ok=;W#`&6CIw zeA}~MMn9C+%!0+y;`4B-XrE6B9-bxnK1+c}b?13EF(77QN`Ovswv8WCL*|!24~7aC zkDrX*_klqo%_ln2mmrZaJP?=ABr8Duu^j9m6XK?`a8H za*I56?lBx^v6aXn%wY!cl{BBdd$!}i;=73spVfjT6ZjfxHzR0`?$z2*MnyYOOtP_$ ztf;PlVv&kzDl{0DB6|21W31t)nH2juI^2=qn5qm3iZY$E0d8&~XkBP!xJ{*8dHDpQ zF>Ntp-hamzbWoFP4O8MTi6Bu>#zff*TGTMZb+vpU`(u5oILQQ_`xPq`J}>BDu?Q%} zJF_3{14Wp*KBAWw0KIJnTk>M6hVVbPhhs zza}HeBhTAjX#Wn7wc*MMxI46qoZDpM9$X!fu zXa7q#=RO~ki2XS;YfQv)9eXm4MlIXX;cKVRHwZeMd%WR)Th|$s*i<_*&KSy)_4R}{ zHv=Wj(~$lV(4ZiXG;xFJITO)#E1D=Nc;?z0F5e3jYvf?s~F!a?prw0e{5Eub*db9K}RT<8P&#=LD?;7(m3(E=M zrW2M@%)XBS6g?|e%_KE8A4m7<&r7r0%yhkf9VQo)zDnI7vA-^j5KJF4r#*<19xFa~ zbxg+crD}4k5fNM5{*s_kTB_`muWPNq%?pD4)3o4EuUTysTSiHfrM*!(8$x?ud{}I?wE+GzPaynopY`$hnc2^U1HMT7WtLJ-3Lkgr#^T`!VeXI4 zR=u=n_jSL!+vD3e3ZMQD(bki_b*sE67FE06JD#FL$=)Ns12xhY*a$FU-Znd50zl=f%Rw>fyi2fetST z)_%<$vy5rK33)B5Zju71UNMLQ(gMI=$jB8~4r)k4Q<%3xA7;ZQbin=B?s2}iK`8$0 z?ZR@i1uyGiF*y%T;#80({~T43Q>|JcWdZ$FMwY@;#|G+kC};T`%*U#{$C+7pHjA1pD~J*c-AoAK`^e<5?%Mq(x3@Sf(9DO@@Wc6%D`um9Q&#L)CuHs(sib=&i^PK%n^pRaD*I^$6=vqC=q_yWHR80|PNyUtl=c1-HTuqYH%BgulxYLvtAX6DP z3|OCFP;CpHY~x+(;}#y=rNeC_8SrW7kL@V_yZ*|*F(o&+UUopnMYj@55Wy!;1EsB2PM zFcLVl)cA`*<M}N)h7&wS~%p796nCDt5A+Wx3cX zZY14ddq^!&qsuU;Y;~3957retDHUKmV4Y;ci`c1xA0w;dYs%TN{*GWP?y~ALB2mrB zCG>HMsK4P=K(Egzh3M_*_ZoQ#usCnl4NMye>%rKK68$?!njEb7##sXOCM{wL^$o-B z8r)def^UE5r*Ff|qXgTbz_N_H)@ti$-1*3;1ok~tlxH}g0_;Eiorm8TU<$IceHM7T zfGuafvk~#QW*Ej`h>C5?^gHEE1P&F4VHVEh_+jWw0v;M?tO57gc+z$MP!}gbI+*Mn zTXZE#kM!IvZ{fHYo=byZ;|Ou2(PdZj7)y#~TaO%wFfK!waFi5a;?09CuQa)O5>8E2 zu{?pRguk@D&E+S0D#{www96(A9%0jeKVq>yLc(|T(f^FAXw1;?0^PVdA;(RFyw2Ec z-8_fx8($j|H$DGruG2oEq_Q>MAJysmA^qNAl5}*wq2oRKPMMN3KXOK9}blVcfN8swB{beMBoErb=v`gl7cJI`HPpI((_trsS z+O2ZCI`9WF>lG3+WeKOm;fmjnf(pbj4Vo5`$h|H1VC)fAVCzFe4s2>d%^(3U+-5w_ z<@0BFRPDH>`mhyhK(4%s1mT4IWI}#La~IGU10Vz0O1qsrpD~x&NSMytyLyON6Z(p_ zV41!0iN1l}9cKi3lC{DqZ@G^$tVD-Y`{0^SmrwkSpO%t! zvhyO>SqX!S0m@~k6BPElz7T5LDmXhGfZ1uX9JXFI^21dvzpMXnzv-5vWItM1G1Sqx z_pj3Ai@Sk(?rdT(r$zRRk${|}t8zOTWTqweQT0hvTS5sq;Xf`%SFn5|dWGbxED42` ziMWl>qJbXidddfp(sMM7=U+KzTmx%G33E(by`{t-1=%P`H$~c*DFVqz8K*KM%_iyF zRgPS2oZE;JEglpDxz+>ciHm!|h4S`qpjudidlPz<<_E|q4Zw)PC7^e^$V7RTxYM7Y zN*vI-u4`S5O-~Ge5{`M&D8xrIQ|W1Nvv z&`ocH3Mlw^Rj!S=Hc3WY#-dx)c`vEc%C_&bCIKGeX;Y7i2hMTWTP_#|`hdMB#R%dp zDd`-Cio=dfZx7SU?A6`N#iTvBw5_e6P~q_fBSEg?2ahKHQYK+uop4BF5ju^fZxhcX z1*UmJP?*1dzLIh6f_09(cDFCtFKZ8Qr00Cn7;hr;)YBJUtOajCk_;o&Y zJIDdRz#l*h)hxrrmR_gLYA((1Pam+VwoWdx&B~sl3Ld8A1?*}oBs`JLXunC&w1sEc zNm1XvdU>(6zheita5%=Pke^b#4`EO)6u~5p8xlHNk5OJmq7fOZnRO-W;V%O#DnqM9 z9|N13ca=UzK+r`4z%@wP2% zVR75)x`;4T3?b~C!=3obj1JJ<33)?c7^>;zh)G*5XD{y-Y?j9jQfr@&xF<$=)HT0b zm*yhLWwXX14Lmrw=aDilQ|ZS$3MQ*})NhOrKMMJRgro>n^6GU6(xBT#g0MN$NDiz) z)^sMiKjn@NU9!c|bJe>|JL(K_B)alA>{JDVkLji6CxQp=%YiQc-h}yODJY+h*N9YR zFNW@>?hv^1H|jL#HrgvHPID6_W(|ejBcTOjC2L|VChYW+nSR6mU^w-Ru`P^1qgk(+ z=_C2hN4H=RT&!9+7FRhxgz9~Un%0OzwPzV%p;GV@Q{=-4P%f-JHeqVWj>foPO& z)W}P-sp4lWU8+A_VB=%C_?02!!&jC_Z8B!L;!9h-ZAW}QTYLn-j{0HItj1>90fL|$ zSj~oo!Z?5k!#oLNs)ynr(23ABuP(o|u1^Vy(f)0gHi7p3(v3@`h`d;Js3C1P1m@GKpv?s2P!P+p!DxWR4KF;|uHEuP7-WFN}l6@T)T>@V+INAwQ3j37R@c*D1l zHSYa;g5hCCx3;9H znG-B-$F#{-P0RI1jGhaS1hO-+r1JFnoAAUCKY?mFrJSZ9^4ppu|D<`>`GeYG~f%E)*cEWo>& z29G@^jcB?N#H#tX}56&_W%C5?OW7xknmnSx@UnT#2Hu9{XLj{od z$(4pddIxChL1MMW*>zq=wfw0vkE7ME*-_&HuBj|iM4Qr0q~=7JY<(Kn5fi^RKF%qYlaJ(#`3 zS_J-V;rBIkQaTD%_A^5tT*BEB4d4HtHKvQxK1)FVV6IviLi| z((jHF^Yb3(&OnF4epj>%Yk74W@xwQGjZHV7UYePQ##5XwprwkvGKB6zeWL{v*14%- z1}!u8Zx;O=WfIUnYEGDI-FH3)e~ob%7`GH56U9ad{^?K0EY5xZxcC*-vuU?MmS5`p zCn8%XAp6AmO_Kg;dTFyGO7kIBGR?|%dh6}jJ3U&nM=G@gS~j$8`co@Clvs+HXYbjchWQ1h=k+o{M2ZX zt#-iXv86Qjn#auU)}5JP`W4qoqdtKffq5Xutl~RnNJwCb1xBF{Zfkrq(0iNRuVU)J zuOIa}ylgnC#IC!!)SrLL6B6Xa;=IAXIxq_Gkw4n_^4v2M>Gs`ec}-3@5Ab6SdRD;^ z)L!vRdybYORM&@33AMGmc3*_vKz#s6K)1i>ht7)2N$g9g*+&oYCHE+Zyz0#*kz}kJ z`QcNitY6t+($LMo7W?O+nC}LDh}hhCh?r>YT%J^?gc*)nQDFKTYC>=SPh@!zeqA*Q z+#1_FOEk$JFLxR9v%C~Y1Bg)l_|7f+k^#ws%I;He+`*{MhKUT8+X&`NwdtX?udz2+ z)@e+L(T&3xl*u7w%UGEhTmu&PwAc3JOC3I3Qm1H&=rD&|n>u;ij;6Lqhs`&>+TFFT zd2hgZYjE+Kp#Zc>4jH316-`?Lj<`E2*ESNTf3u+x9oc#Pmb{)H!l~q<^7)cFK-d=C zf<5h)YP>AP){Z)6Ca_~8-*RH_-$8<_k5|ssl%=;O`zzXOanQoPL3F;qm&Z0HrC876 z(LHobAFApm*PpQ)N{x@)D^dG+?z8mvjKoT@AhqHY?b-WJn2XalRTpU(dO}emDsVPd zq$PS@Ylmvl#@ zzY?Z2_An3Vp|Hzc6YewLc@GlY3;0PEXj|1P_DiBF6#UP2HmY^VIm^DRPKxU*)6%J* z>%1|k*Crl{3CbIRzY5&L>kvHS{Qzi5#7GcUQgh|=>s)ghfC;mEB85^iAQ+lvZz#!1 zg{b^tWuaOx7n9J^KaGG?T@6U~q4Jdug3Uqv8EZcZyNR%Uw)2*SqmeQ&+18&2jZ0e~pCkxJZKiNniD zeu8h+QpH)nQmn(>s{smDJY_8vQGeLn`zFaw=H`T**)M&w@Hv=*B()D&PAdRvKECSH z?!lh9N+IWO!Y&t|d{-Uvf}SlG>DoCAYk2-ba))K+{1AE%A&@id3y;JW>sIuXI(^F5 zZuvyg;=3=9RW}MyO(XkM@&2(Js2c(DUklYoCtks%HUsR}Ugz04ga)>L@~;8xT+n?& z{F55^=g3U&_XhW|XYj7<6&@XQa<{aHlu?vI*~|xWP5pXT_Bq3s_gT2K#^gD$>6o01 zRv{Ojyz5Tdy9ef6{8yr0rf{X{rMM5=GaXb6Z=9&~Zb*=^r}@HHe2KcNtUJ_cu~{;+ zAu(+ftbDjC8@1z_%Zh{f-H30sdLy+M8^V^RAjf2)Me+NPT``PnmW?h!OUr~9BZ-Cm zo!?$QZrCs7>H{!}xl9mQ5}k}dskfz(szS}aKhGsRm#U)zHzAgeU&0~|M?V0 zW_W8e*9-uAAjr8*Vw@Z4NhEZ~-(~hJY+I)9q!#6S@9L)b;T00Z?0PR=Cf4F_HzUef zCck%U_&LukzAu>$vMXq@#yEp?fpk5-f8k3BZSVx{g_doh!AHdMHRg1eCAu9>yH=<# zlw#68v@zCcQWe))!Gf!v)^91?pRsVqj#U$QrI8@sZFFb5csFZ0y?5phTOtB4OtJcf zRN#&nTBiKpIwP}?ZQcy`3!;{Qyj_>z%9r6;p%~0cDtv4<7$;goO^CPS^lYzElD99q zn;D{Gs^D(b;Z}uD~|pY)6Lz0Y-F-zl}c$uBGYQR)!#77cH)p zn}6ou4adAzSZ$Y`>_MRSYFgiToq{;)_~iXC_*CoVCHR^r5lAsZQRq1xq&E^X;_-}& z#)o`MM{l{Hp1TJ?!cJxyY=^E+uH$EU8@1*${W4l~glTsTb*=1hmq^R`oi_q&HMt)p zL^!C6yvP4Gvv!1aHH$?3e04y!iuVV~Q;3$^VuX~$8}Edn+0_~6O;w-uToh=vDd@a% zt?3?g>1S%X0+!DG1@%e;__NA7-6Z@m!oMG`PBOll-k@D`eOY4_cFAxWecYe!Ghj|d zM;LAjU;%+dGBICw8?yf0kPT*_r3Pv<#@~6?Jqm@uX`bLLp19DJ%Ah`D`r#rr7FTgE zmr~g1v`WjQ zk?p>PUX&+z@0w{3x;_^QkT%z+&UcxCM2{|GdqTCH5zMyGK zozJcHC0cJH%O`kpN1QVE+B$XPpfxt6XE^O{D!QlXs6veHMyQr=x zK|L3Dz5Xh!_r-uZN2e6G_ZWoDSnTXT+aHXyL%|CRM;ttTIJ)e2iNC%%!>xt`VY9$J znZ;r*MX$JO_;c@8@x~mQkp7GGhb2i-dh7K2`5j9gO;qI1m(N$OvV6D4>v#X-ExjFP zQH>eTLDHWi$wXQ19P_F zPOP|iN%<1)XLJ>4(Y5-d`4k!G(dImg28gAoZt;AuiV2-6u-G&iXfYqoy4eLF(V*i9 zs&en#k@J4k@zMU+84Lv9PgiEMfVT#MqWz6?HhNlqzd!isXmRBXy>D4rC-|ZQ$r@N@ z?RT#B{PQ@xRi%-0$3sWEV1>NH)b+HfuoJ_5NqF?KS!$JDo#zxBqJ1Ac|GL3bF!`%# zXaoFBqFux<-_8W@wczhMwwDneXKr0v^kpi#k_IfjT zd#NGugs-|I`YMYVuW(|Zyow^ncT``jtHxkp%_gDvsMi>P^7p~sBQu$E>ECb1H{z=j zO|kXE+>{br`LJ7q*-sPzW@owk0_$cwt6;0Q_%EFBWPkt#12+TH*Vc$d^9)S9`0ze@ z)gPLIQ?eB?7w3fEqn{BQSR ziP=mjA=jdjtur@O)eGnw*1F@Adg&4wBunxnv=qkfUEhJMx zNr*S_j)2SKL0*0ukwwr=kD?cdjOl->hTe51p@CVws=mfEGgP4an)Jd3DfiLNRKQNa z+nPpsBjVD|MfVwRF)gXk(^XzQf=sMarE*mnbX@7F`3v>S=00Ya>E%YsHoEZ*s{thV zXxA5ldxsHu3BH;sTI6q7=)W2`eMr8UFn0uT&wm!}c0n!Qd|Da$R}*%%m1i`0n2DER z0{l=k(P7P@j!)-ycZ$#^CB@_#VfEw8pn>1#CW~E$aaV%oo;2RWtxGe4tABEc<*wJZ z57Re6kOx{`*Z?&z0NXsO%4Br8yfk*Covauk=_E=D|s%M?0 zEtO$XZe+uGwmab+xhH&3RBADwH9=`0klDM*3RA zCgJXO?iu8)fIOW2?G$Cwy=BS(QIUH)*D-pd9y=?6j+P-Qx-Gk=?s#ilG~1r>={P-o z(^4_*_)R9Twn=N5f>R@Rc<(CGYq0ERE`r|7%$>_|Ap(R9y_hb#XH~&9ru&t(bNqW4 zA+5Md#nP~UfV>6FzeMOoq8TB664ZPZ=|(AnNO>;#SAAwa){8it?*S=)(Qw99;pEyX z8A3xkEDY!GqQk^OrA3PusPj$&6T3=Wg};y78y|(LR}~$P2{8O0N|Rk}R+9NdH^`p! z>Nz~yvESyNrIH_tcJHLx*cRX+$QUi8b0j14{pM#szJJw$M^GG)?u+@O1eIDe2`FI85VE4bxi0NA!*@RuT0 zea%XHkd=AthOJ|yRb0gl7$XUnJj;Wv_~1a>=(*U|uhRmRjar%#W6;v-IT<83aNZP<`PhO`&GiLhLIXNz%c^|qdl?CI9VDbu!J zwib96#|-}{92foG%tq#=W9epC7rEpEgZL$>zuXDuXso$pA*-;1NDwhOiKl@C<89b>1?NLGBOpgOPVirBTEwga2SXHom?InEh*rvL5XAAlZchpJ~4z%T*stj3HLF^0(o*J&{{2Dk% z0w7P(&IUenZry;C?>cehO&cub0R##_$>VVnlm5`xy@nIs|B5A^Qp;oh zkuI2Zl1EK%NyXUbD8q*3sEfhOW6}`+o-M-A~eD8&D@r3bH;-BuihLhwPTm(X8 zRHVFp((FT%r%Z}Xi2Nikfz#%R$;LL;Dh)B}2<)iV(6c*y_rnm#w3FiAOy-WNyrP{O z^Wk-RMZk=v9h-~8`-Lzz{6_Yh6%*baF71erukT`jlK0nEqNvUWAj5xOx+MW|cpOz2 z{>?!VEhx)ehRk%L=uP!SG9A|F()ya)!8?eOfZ5Cm@VTiUbiEqSvfZ)fQ}4=sDb@$C zT@=mzGQiOkc*gal&2ojw_<$f@I?yZ15eJH}Lo(^M?s{@GnC^Cv6PLYNly~AjGeeXKEr(|V+O)m`$lSwF#BkC}%vJZ* z*@QzG%2bQ%T?z#)_7XAvUpk7VvF{IB8@f7I@F82LelOu6h@k;Z0xVf?KamW>Pn`y6 zR4SZa)Zzyuy>2opQp!&I##$K%n9sX!JP{k0=EXQm5>5F_Tk>dG^Plf$W>^C>uKrz^ zQTPDQp!n^Uv6GJ0XT6kkT*bM*Q6omN1PVY{{uUWb4xyyq9u*|hJFI{&UGH0WkuUlU z=C4?O7y{VT6l@3IOPgP5`H$=#L4}?ED37(n*;SEqAxO=y5B4OlnWJc#g?3j=wsGxQ z@R7tfJc3$gnTzJ^^7WxPS?(K2ztYYh3#%0dIZZjmw= zi+90mLC4zcz0XDS;qo37kl(*2(6Xr7Q$-H$49{Dv1aF@@o$P~Ln{tZDl3ue`S-wmd zd(0$BeEtc$I6r9M*L7!1(6isK^!+j{2$aL> z?cd>$P{Deq=H>eDd5hk^5_M~4aq-}}hK_rE|Jw-LAdtjba@y`LfR|u{|+qd06 zD)t3ZQeur>We#8!5RC(a?~-s8z;^n2YCl{|qam;N|H5U;OFj2=#8G>$&k-6vTyL9b zCfyAvo(VzaRnbqZ#_02`{R#4e7GxDtEJ?fo;e7}=T#DQPQ( zdEYK(&9Z2|YI#v55LG;Fp0}dB9I^{L?9DB~T>iN7l!(!6j49Ky`&syf$*ArlU1l#r zYK+X9Ve}M&mzPb~1cV)sj|;`~b1dSvRpyn8q$D!iXx%g52UfTs1aM67bl{QiS-2mW zl5MOgVs)9J;|42jMgE$%PvC{{Ty3XsV$WZS*iNd-Mg_&!b0H4Q=VNA>HM|%t357vi zMkdI*%5h`Ie0PAHFv}gB1Kn@2fj51y$xkV!qRahV zK8CLADjl2n`IsR|hX9NPltj+SzkrLrW?g_rJ)Kvez+--IF+8JeiQ#OPv1t*~`|8KJjU;BtF8x~%lyxfnr){&3r zrrO6g*ff}y0M(o+=e|;9QHEU$Lnq-&O>Vn%6$d@qIUdzEKC43Wde={ekVS-K33!k% zd4lAr1#~O4s_BIqhli3g&D>kT-sN<{_=3#OYYkMBRk1c5K?hV8K*XF9fYJ1{#7JIs zfCi;HD|3vkyTN6!M80Yy*TI;tn6B|KhZ&#}xM-%WrD}T{PX(lD8tF$%f>0eYD<09-v%9l*bc_%lzNiP*7^3e+db zZK!o%-khC{`t!}>pw08 zvRk$zhXdH6F=l21zejgUiL)kzFM+_-td2V@&|1EM6|Q7KvW0`%>Xn1^E@I|KKy6zl z5YD!DPWLB9`L4In6syFge8zOM0W z2<~%QuQ#%LO@}$8qhvixd!(kq?DddwIqlrTK`MQsXqg)kuab`5osU#YJ;*uur^iOp z6ttJxm(YK$?8Eedv7BH@Y4>gteK;@Lc8$AO5*X^;7bw=Cq`DV2)>BzSc}MF(3OS@o6r(2RQij993#>rDfCM? z5IU>4PJ`j3m}Nn)6|b-^e&pemi8UR{V5AD_5F3+J@)Ow9i+>H;!pG+Qj=WD4L)>cF}wT@t)1U`Ryq`H z+#bfH2X6%bY3SCq>jt$#0EI9K5P*V}vUvLc?BHg~HVg^D(e9i8pw$Y*{DC{-JA=e6 zGDQt9OZ?pqd>fb9K0wn2xN?yvksNpw&vKG?K*U=Ddd%$3dhEj6fiKntQEah%&1M=r zcRC!Ref9trWXpR?rzE-&y+Dz>ZgE8L29lw3=@fM$^%9`3;wFpt?wuul@rcN*r_a88 zNg?AlqZ2kFyG)`wPBCz-26=>Ki<>tc0HQSjI^05n=et?|vtJ{wrf>ksn_XafZ6Liv zB(UtF$F(2Y6Rkl$WV&7Peclbu`QWXW5+ZCsXTnGVd@DZ5@@t1^&HrnWJH(~;a)AG& zek{<`a`%y2l-Djz5ya6>J*%*F_rQSH-ZFh)HR!8*+(6-s;2(ee5Oey;D*X{umJf~vQ;^jg0ruGYnl=A+Q`g9bZf~n|3coiGIWK6xt`fXl?RZ_il`eB$ZTEoZcdA!(;lkg9z<8 z`unKq5$j&%P`$OhBI7ARk#j)}x0pS&jjXafQ<*Xw?Qy;Y zz+(OWH4S^)21hg3%lAx+Z$SX)W>UOViZ-<};IY5n8CvTiK%J@~LX zzY`IP*{g-k8qm0_1395@^GH;=*m0Cj;QvrtWfF?_3x7Y9OFKM~*xLbXC*kaQlGgH_ z6$ugv*W}6^$(f&W&@vov5oby0FgR=~AL`OFWzrB0F)~unt@4#O_qVEu_EWqTm6)Hk7PXKDp9|{ZxLFj=~L~#9ageYVQ^j7w{N>1Om!wE zxV3aem}&@%Ah=sl2;adsPt%<1GZy&Ol={0cu~-|hg3?^rp(l<0hrI5hL#G5YwDjwQ z)6E;3P1MrN2?u*^s#_h*Gi9f8GpbwwNANvdZrQ#C*7pP!i41cQs_x4~USteOF`p^M zg8iF7+akp5dZ|Nip_DOfiSbLi_?oWgsLqYA)l*FVvt)sbUZ`=C@upg|*Mvu15Yi|5mPF0LA4Wfu4E9o-!B1R4*Mqx~^HBrsf#P|F85`HLZM!g>C zEuf*>!Zl>X-qa!PR4EM55uE1tUHM7m2~czTjMji9M`5SA93`Zg#dg=i!@f@gwNYvl zXxnAZK{StqtC(ue=Yvnx?<4sMo{TnUJTcMH`xavzcAMgd@)c;e zUY)=RrshF21Ikfm(_K#J3Tn_(;!HkM3dY_mt)U2`I2etUlRmt&RIRy^qY=f2=9@~K z)il=8k<5kxWFz68bVQd_vdt?#-11P9^z5)Qf>h-z-C{w9r-^dM%vZBG4x z;1cvHcQ3Ggqqn_gX+=Ib+u zY^5zq(f~GSeJEJ++SAHlC%uJG=3&xL<(6>U67t!<=w%(D#C*F3PER5f_9P1G8A%9uo-Dz=6a}p;nlaGuNXmp>l?`0_y^N=_`Q|rPaH5DrwM`v)B-BG&tgaAL>KabI8;Stb%JR>64DmzM3XFMbg+s~#r#A(@+ z7;x8HqXdnC2_o-#@ug&rE{}O$4vB+-#Qkzu~2#nQy-c+!{Ap9N6%E!Ch$XHsupel5Nr?XSBnjqB*$G&0atYv6?85n41 zD$=QUL~KsE>|t($0m8$}XE+T#Kda3jC82>g2bt;BN)5Y}*EY?Imv3z65a55eBKBJ1 zjnj)&MvaQmnE=S@JEkdo?x_SSyvoC=2OiD+*D$M4^iNiU%kPT4DR518&$Zj--H>h# z1V;Ttk~&AUHCHO`a=d?8=Mp*;O_E_ma@HMURO66UH{j)M&+I>d^(qpp>sG>h_wyMM z+%c_(R4K#j?L6c;b;&dMUryGaYenQ4m(elqL-t(~9ZLg$@&_o*-=jXOI^#YSWjSRc zzhAX;m4CHI!ZVtmr#!nLk$!cBZy0}NYSc6uEU~u7j4TALY8EN$bBVA>?>F$B)h^gH zokoq_o4z@@-efEoe!!yDrw3juKbkz4mrIsjxi*{S;d4b;#0~gwEB)Ik9jE7C87j7! z+l@~^5nho|(p6mP@-9|ivCLHxpGGLgB&r8A(06%~r{G#ei;9O4-fBAu68WLoriuj+ z8F!XAAPm>-CW7@J=>gm()9L+SZ|;R3&|`Uq3?P%ICc3jEn}ia3*@OK&@B{jTm`S_L zm>cRAA69V{6*~|4-K+1Cp_e90eHlK=sascNlfBwb6XX3rKj*dE;}Xti5c4^Y$R^h8 zMq2%;FfM%Ga<5szLq)+^SERTR)IHm)ACCYZ9eixL7xH6J8lyN9@$h6O(K)i9T+-0|!IWI&###mqhYo>361<)pU5_b=E+i}2+9$uQo3&Z0C$94fu}AP0;W1N za8Nxbp#%B%#^qA&$M7)3@qIC^efK)~?=c`3-vQ?;yen#2a5`+7cev^#0i}&ONfYqL}P&ZC%CJ5X}yEPzqBzc(tz%<(~$pz$g#C1 z6!Jq)`*WrHu6RuTpKS#9#t*C3W!IL9m*ofpz+?IzWNw} zx4s6FPSDj>ptmjB8v~umxgXNwzHJWn5AN}X&ejpoh8z$uKKwDw|9o6uWe? zpaMKR=n_|_5ToO0K|1*qfejKQU`Mx#KYCK)QaV-hXD@43Y(ydL;6fpZS9z8xt=N!V znx2B-zazzlS5YhA=EOL2aIMkR2px9hinot{i8W&QRdK#rWw=xUA1$0qQ=`|+CeFA* z6#1Rxecce<0%dR4on$q^GzrxEV8rwn-1mU1w+PEtwGGUHHPP@Pm}q_h7uv}&W=R&m{2H}QN_^z z9ftk1?S`Vf?_{D|Yg1jGl>^r5`UfvT^chaygsn45;Zs|euYl~iEU&p|8I?f>1r&xCdr@;ji+=l)1)3Qe%{E+ z+9G}V20Y)mLWA38A>uM{w)vDeCgr-AHQ>6GV^|+bGAVc#A|z<6LJLC*GnhH_W3O&63TerwxGXt) zqPs#Bc2k7M)tV(b#hlG{7YV~?%gm31#9{#&QLUM}%R215mG12B`e0H~kq!+Py@VHc zQ`rHCl!oj`A?1_2j_#3Z5d|3E4Hs3KwgepNInQZ0JZV2G{VViYSy(oOyBDaR6z4e$ zZ_+$;rXIy?IgSj5}smgOSg#utq<=Ig2; zQvEq8-;EcsFK%K21ExMO3c5j_X!VZYl-Q&qAE-BNL5RjQ)Yy?-Ks7|%uiN?lSYm*l zenU>ByPQhiigOD@`L@}!MewH0dL~2kk%DzGg%;`?upbc>Q9;pHdd3mw%@`6_&^O*} zpbj9gkSr|kK&u+se%B^tGw92t@Uy7qC9LE+Qy*J8b<)r6K;zTl6M0_9L|`8*vU0&j zr3QRK?knEWPhb%N)@mLaRi8~^Ppt!L; zejlnt+_FDDV94s*3#Nc`>CABDSv2YrX~cgd=G#-v3}3{2kBdqUl_K_s11|+{m?p$1 znF`%6{gonAKQ;S&f(`>T>ws=e&dY^@O8EOd>WYM2;g4zLA-o>{x>VBcc~WN7(i>mV z;O(Z75J7f18fR}SHM#W-y;+@n-%sik^`kqAHvr!a@EeGj`zA)SS`cNX_c!*B=d@57 zGs7_iqmL2VZo9pMupdUQVEW3hm{x$H<N=8P)*TKo#R<-^X{!t^0u|HE&l6g+<2IQkV2Q-7Dv@ zC4E_;tPe3B=U{Ov>l2t&F{-@V9K}C%H^?x5mr@fA>~Cny z80~0O)aMZ#rzXf!fGR1GOl0I*kdNpN?jXX8<7#3b3M>R4Fn_i{OY(%~GXGBo1Zx;s z3p+e>qh1@R&#*E#x-phdJsJoL2SyG!Y2%)h6pyyOV*jbnQ?;H;co>c7^@V{-wx^bN z`ybjt-rv0Rfoji38Yqd_VcF6tfc$U4cttTH9*mnB;!F+o@D@&lwfx-6m$~3zx4QCi zmIaP4YGU0naiw1c8 z7Ds|n-RPf~$c`i5*kip|WU%Iu!AFKB&0>{;C9Zwh2e@lF{lpYLFg+FwI3Qg+S#364 zWlcHIX^r>Aa%U)!MZFlbbIwCQlnFVoiVB#-J6C##bLpTE4WNd}{G=e$^fG^vnz%Nd zmj)Y=#9&H1sIiyKj=XYr?vZEv&_5rRr#EGPklRY_lo2pf4hI)*v=oTS#y$!4thaE4 zq*49BD=-t>;$@0)enE!)tn2dp8N>Q!lU47vpCzgn`eaWt}pS?9-PQy*FiHdm1)CJDua zNRp+i9{aTWcs%z@2-Dv5i?OQ_Lxe!;dT$dxxo&3G!!wCsf-F(7g$R#j)<|Jtf0@X8 zzuG((aMgn$HY4k)yBG9nB=WCa(hc~>HiWb%?xwsb6NFpN z`Yz2UTW0Tjf1VX4>CAhdB~J+f(!-)CqpX3d9hgz4kq2o=V+Wit{Er$_^|cYu>KEy$ z|5Zr!Uv?wALyU<*msicXGGF3{`tpPW1EZI@4nwT?*gia zvL)lT5_`ut6dL{Y_PZ_U?eIwn=7>rHMrsT5pDiJCwCoznzqs{2un95e%&nqePOrCf zJikPW0;wA}e1sZrc5(!8n7IbA3ujlGx;dul(b1k{!2ax(_%0?9g&z{zdj_)IYcDz8 zlxUzoyF(M5r16`z@;UFnBhlzQW<9M9+Uf>QrHD9ykPsnaDl| zW`d&EOYyQx4^VPF9!93^eN%3D@k5yYKY{k@dG9;a+9>y}ph>Op+l~2z6maPH- zAvtW0)cqi@VxbNTeE03I#>+S$Zh;E%PEq?dJ+A|xMZe`Pq+f6eYht5^ef42r8!bD{ zYikj61~Y;tLg=9JRZ!cL@2gXPemWfZu?&4Q;%nWp%IqJmbK7fCZMNuvXNF6aRu$V?UDl!opZ z-C6Vi=D6^9C^t77^RJ-)k*6R#E%FsN8k^8%s=&o_Seh>Wl?OySTeC@@#q*sNy-(8a z<=*Hj0XHf%Ttp8Kj{PTSYpekM6~!f37VSHfCr<1FS8ZSZRh!mt0(EP^DwdAGU!{GQ zB&{<iBpW@62&(Kq|k?7V9eywatf7H-=@lF|#xc z+rWCF%t`5pEooKoZzg&m36lypHH8C#$V0-GhEwYhb;d(o zDDS`%E}x@ma$)S{E>@7J)HSJf=-QAN26qAs_k|45`V5OT=lp&h*eu>w=ik)*+ov{) zm~ujgWpH6BW7mJ*JFTAIC>Kf%ZxmOnS-LttIGC!s zscu1#OSqHJq7_o=Cj2hi+=6h#)i!}&5*R&bsg1Ob4~~}45~e%p_Kw*}Y>uRd=_HxQ zZvIkhzHRh>96mzFuny zW@IjP8FINaiZvy-GE2hH!+zvLp+o*z)D^hCH1bVIPh;biEoacJ3adM3V$Z_J^-CA^ z2`+*>C(74Mhcpl36B(~qu@BNh;6-S4C()Gh<=J(u- zuP%lOdYQ=WQ*u*1ITZ3`9mic4lZ^>B&N$TNNi4mm!e#}@M0!8TtJraAB{>)zJ`s9; zL#_O+sD35&kQ%CYnz~5jpZ{06xz4hjGRSiH96t9F;5=3S7T7isIw%WkVsIxp{MH(c z%q~kxyr$^eT>VgT0W$S0{5Lr`W2WowCG{wB-33*>i?Bk`^3kn0v5l;i?;V9VBpGY+ z?0FIS5`?W(U4s?|xwO!*uH@7(cKX=GEuSfW{bhOoo~_@Mn|0JaqdI*@|F%POSxF@8 zub+rg~XH}(QU*)`B_WRGWySt@ePif++Gkx z6DoJ1$b-4U9~0Vux6heuF*==i+>WzMq$Df@{iKt!nlZWj&Ii3(uDOE#1#lk1VH;rm zEqhMNFxhiTK7!$z;*Qt@`EP^vEZwz@UhWHo;=Y^Ys`r)ksvo zo272~;0s%#s<%cnTvLJ|#MFCAesa*X_Y-drcn5bA{bucNUTY> z0X&pSU-7UtWf3|B+%SMh?&UKiw1&|t8@I_TGJ;iH-UR~R03TornuQ7>iUtkCKsxOOvW-RS zm-ODz5-43o)rU-!yi@qor-MsK_w(WsJ&Q7S{LW1b*3FR4V@mo^4Xy2HHx~aAx+HLt zAzT0Asdf-gky=JHKKgTv>`W|de05E92JKf`9-Nm~wVjwD;i{`E^Ycpt%vAu7{tmed zwxw7Ch{qf0MRzPIISq~gYVVDP(8>%JU-ItC#saS@WrZio8kgLnQ!qmtEFewR=GyEu z4J-#_4tK)O6`Fm!XWfA`o^|8J|)re5?+WN@)q){e&Ty7{&Mlr$6f^D*W7kQp_TCNc+F?n50EV zW*NJO!#v+5Klmj*c_j~)DcIeeINrgs;^&_1>=W#$5yv)hkkp>iYuCMG;azEOP4zbW zk_o09K9l@Z%knPee!C?24hhIiX7ky|gQoR5MFi->P@PUb3!3hzpsx&66?jHuMr>E8 zTs8~|6Y+xl00bu^W;gUr6hcL|$>O4I{a_9>En`6-N>QL}-+Ra-PwrNsRCIMcmbA`e zi_Z}-9?k71o=2N1EpW2+U!;gkD98NU7b9)p1SDj+EpY?3kHFvBC| z!3-N?h0?V`5&0?^!mAK(hlIRLAjK76%>!&tdmNO)_4eF#(g+*afA3HV|rmXJnb%_td4!;K!Q zzCTF|BBeKNL|Z)FEt-yycN#P#pZNQrs#YV0Sw~Xi{tk%?u%b;YKOAux9}V>cx;w?q zT?w)nhxCwQ{P=RM0}~fdn@0bLHN_S~#7yz=Dz0OkkA;GC8l8Xaq#MMj2Lbdqkq<1q zhmOeT3pujdgT!#Yg!NfsfbuKl_tv9$&l}<>xRz|NY7Q=D%t9`+n0PUgSX9>+7d8q+{bm>NR3b0*Mksw2n+!Z6T9y{%1ZOMgz$G=2lXqrVsF zq1GRCN$sR2^whjCl%-qe{VksjoONDuzX=^N>tbbx{__sBp4mfH>30dqDm_;TIS#t0 zP)RJ23k9I>!&Mv~J!+yQUrp`vp&t?CMEnh%f%zb2HwdHbzc{UZF53d|;Lw^85I7}( z+s--Z_FZQ2IR0HBRW#Qyqc5=`I-Z3&=Tu@uUF}+a@2MeA!Lh;w_LWA;{prn{RTFqu z`su-ujd^n>YtV$z&(^}bv?6)g2l$k+q~E1V@d+Fqh`FN*9eZZ}UhC)_1gFt4%c>zE z;>mhLCua(-#6z|+3?k`OkPQ>5B~v#=q;dZEEJ6&#P9+_8(6ZM^8f)$=w=55isELs< z0OPXZt4`vd=RnAB@&VotC{RLBh2? zuu~PIt}IMOLuuJM6J9Ssr$o!qr!}6BiI!S({pUC)sUQnn~Cn>iqwGjG=0Drz;74Qdf3c9?c1pLBs3Zmnq6dV!ri88@1F>QWjroOOxg3z@G*~} zQ2addb(pQKX}wyA>ILL8T9UY>6FqFwycmyvr?UW|@!)SqqZMhiUpvzXa99)Nj6|Qv zi^!AbK5_r1ce4;EHbKXa5RgTCF2f5R4HNS|ToC|-LMj@1Pi`QCN&f-ERG##WT=Df$ z**yzLu>GFV^)<$M7G6Lvt-`@!&CG|thGmPa~ErGpR%7#bmJfZ?sqcYSK~@ZnM;6S_`0|2eE@clKrtuf=Su=%<~FKDxSFmA6Bv zRHI5%`1u;v4kT_x+InNrEALB8`PM2F&(x9xA1|X!elseuS8dimXrH%;UG(uo@H3`( zoD==d3`%tLMUWh7$iw`)!>V2~q$wout6_ZZ7BQuA%e4ESiskk3J&7UTYNrfvhi30Q zt@bur7SnkT(psAfRiFUxi{?5{8!J1=}gn1wb2!1kS@|G>rNowz1+d)EfT)W>mUtZ zVKFPJ$p`%9mU0{_Y}?djV*Qh1+Od2b3dYjyGf`|F8qB%Wq2=e9X}Rh7J}x39YS#+^ z?gbJ0!9x^#s3X%wXiuQaU&oDeaxb(YR$7#7!O0N6BXi9*D_!VB0HC-)*-97Nj?R9M zWg>5Oe678Xlco&do>sq+b{+Mh-0kLLE*Jt>?y~uE_RwS3p5A0>m^OAnFuukBzQJI%{FjU_n?DxAi z6%wJ$OZgrfRYa^gcLf?M`4S+}vs55FTl#28v25^oWBTjM+ABCYwH)|I=~bGov?lfL zzgL4~1__@N!Y?j1c6X-vvlXTssR>Xg1PZ4>|ji zERZ=$TH0A=+K1)9QEok6R6GhcdJ!`86}$D)w=L3}h;Oko(1PF8?3hQ!xBzS1V@NaN zjfAn$V=C+kd3u29rBapYw|z~r$RI&a7oypXaifAYMw=X~YnCHWI*SP_AUg!B6njqB zVw&K1!Lc{(qD`4?Q(KwvqzCN#K8oj z=HSdL=S!$mdot=5_ihQdSVHNXKckt>iurqu9v%Iab?E&4raipz*afT z@CJ$&DQgBM+h~nd{kMO2NazEZ(`gz-9`hrlFNhZvj129d%$WN`}wgB|) zMbYz{Vp2z^^-5dHCs?w^b$czmT$5g*ih+k2*3d#ipm$~{eeBF;c{*6#n9g_BiqD@c zUPhe=K6~xkQt8-jpe3f7WT8NKE{^L&9m%Sgj%lJ5p9dHfC5K_~LV%Y5yq*vWo|%Xu zzxiwTE0jkj&o3oxx(;n=*QkfQxzQHah31+V&I{i-ewnC;@%p9y*x77_9GP*&*g9#a zaM}icr#m)!+LR%M>3Ewr21pqAlWiynbmu-Uw8f~m-XC}M(5=U$-W^6Mjl?@*v7#4kCErmIk|L^P)?z3{eL8K-aSau{b?{t` zV*4Cib5+t$$ioS_WTRo#+N$8zb^w_9_jC_l0{N#Hw(6-@K{wT(Fa6}X$Yk$^(}Pvf zxwglny8vhoDB*yc6EkK?X(TIaEV`Zs_M5)AzbOGr-O<*TDzt(i19yc*$m=N<7{U(H8Qy53u^re&o z08RZ4=Lsn%^K0H;gv;^GQp0VeWiJ9nx z=~Kc+qr`)F8LMyJQ)ETsTre!pOlXNl|MieO0Dw@}kfOynh)UQW04#|IBeDx*>)^=7 z*tX4tfG(nc5uKh976r=QA6@p)bi{Qluv|Fv-#Vm4ZDrBAE&uGewik7cf;tcVw;=p5 zbC^UEnHg!*mEOzmww94V*z-#~18pqEoq?jqT{lRX&GP$&0=fH8f(^bHlkNg5e5)kQ RVT44>W|y%PpQ;f600Nci1dsp# literal 0 HcmV?d00001 diff --git a/programs/develop/oberon07/Docs/About1251.txt b/programs/develop/oberon07/Docs/About1251.txt new file mode 100644 index 0000000000..4d530cfc06 --- /dev/null +++ b/programs/develop/oberon07/Docs/About1251.txt @@ -0,0 +1,856 @@ + Компилятор языка программирования Oberon-07/11 для i386 + Windows/Linux/KolibriOS. +------------------------------------------------------------------------------ + + Состав программы + +1. Compiler.kex (KolibriOS) - исполняемый файл компилятора. + Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI + или UTF-8 с BOM-сигнатурой. + Выход - исполняемый файл формата PE, ELF или MENUET01/MS COFF. + Параметры: + 1) имя главного модуля + 2) тип приложения и платформа + "con" - Windows console + "gui" - Windows GUI + "dll" - Windows DLL + "elf" - Linux + "kos" - KolibriOS + "obj" - KolibriOS DLL + 3) размер стэка в мегабайтах, необязательный параметр, по умолчанию - + 1 Мб, для ELF игнорируется. Если 2-й параметр = "obj" (KolibriOS DLL), + то 3-й параметр задается шестнадцатиричным числом + (0x00000001 .. 0xffffffff) и определяет версию программы, + по умолчанию - 0x00010000 (v1.0). + Например: + "C:\oberon-07\example.ob07" con 1 + "C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *) + В случае успешной компиляции, компилятор передает код завершения 0, + иначе 1. При работе компилятора в KolibriOS, код завершения не + передается. Сообщения компилятора выводятся на консоль (Windows, + KolibriOS), в терминал (Linux). +2. Папка Lib - библиотека модулей +3. Папка Source - исходный код компилятора + +------------------------------------------------------------------------------ + Отличия от оригинала + +1. Расширен псевдомодуль SYSTEM +2. Разрешен символ "_" в идентификаторах +3. Добавлены системные флаги +4. Оператор CASE реализован в соответствии с синтаксисом и семантикой + данного оператора в языке Oberon (Revision 1.10.90) +5. Расширен набор стандартных процедур +6. Семантика охраны/проверки типа уточнена для нулевого указателя +7. Семантика DIV и MOD уточнена для отрицательных чисел +8. Добавлены однострочные комментарии (начинаются с пары символов "//") +9. Разрешен экспорт переменных типов ARRAY и RECORD (только для чтения) + +------------------------------------------------------------------------------ + Особенности реализации + +1. Основные типы + + Тип Диапазон значений Размер, байт + + INTEGER -2147483648 .. 2147483647 4 + REAL 1.40E-45 .. 3.34E+38 4 + LONGREAL 4.94E-324 .. 1.70E+308 8 + CHAR символ ASCII (0X .. 0FFX) 1 + BOOLEAN FALSE, TRUE 1 + SET множество из целых чисел {0 .. 31} 4 + +2. Максимальная длина идентификаторов - 255 символов +3. Максимальная длина строковых констант - 255 символов +4. Максимальная длина строк исходного кода - 511 символов +5. Максимальная размерность открытых массивов - 5 +6. Максимальное количество объявленных типов-записей - 2047 +7. Процедура NEW заполняет нулями выделенный блок памяти +8. Глобальные и локальные переменные инициализируются нулями +9. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая + модульность отсутствуют + +------------------------------------------------------------------------------ + Псевдомодуль SYSTEM + + Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры, +ошибки при использовании процедур псевдомодуля SYSTEM могут привести к +повреждению данных времени выполнения и аварийному завершению программы. + + PROCEDURE ADR(v: любой тип): INTEGER + v - переменная, процедура или строковая константа; + возвращает адрес v + + PROCEDURE SIZE(T): INTEGER + возвращает размер типа T + + PROCEDURE TYPEID(T): INTEGER + T - тип-запись или тип-указатель, + возвращает номер типа в таблице типов-записей + + PROCEDURE INF(T): T + T - REAL или LONGREAL, + возвращает специальное вещественное значение "бесконечность" + + PROCEDURE GET(a: INTEGER; + VAR v: любой основной тип, PROCEDURE, POINTER) + v := Память[a] + + PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER) + Память[a] := x + + PROCEDURE MOVE(Source, Dest, n: INTEGER) + Копирует n байт памяти из Source в Dest, + области Source и Dest не должны перекрываться + + PROCEDURE CODE(s: ARRAY OF CHAR) + Вставка машинного кода + s - строковая константа шестнадцатиричных цифр + количество цифр должно быть четным + например: SYSTEM.CODE("B801000000") (* mov eax, 1 *) + + Также в модуле SYSTEM определен тип CARD16 (2 байта). Для типа CARD16 не +допускаются никакие явные операции, за исключением присваивания. +Преобразования CARD16 -> INTEGER и INTEGER -> CARD16 могут быть реализованы +так: + + PROCEDURE Card16ToInt(w: SYSTEM.CARD16): INTEGER; + VAR i: INTEGER; + BEGIN + SYSTEM.PUT(SYSTEM.ADR(i), w) + RETURN i + END Card16ToInt; + + PROCEDURE IntToCard16(i: INTEGER): SYSTEM.CARD16; + VAR w: SYSTEM.CARD16; + BEGIN + SYSTEM.GET(SYSTEM.ADR(i), w) + RETURN w + END IntToCard16; + + Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях. + +------------------------------------------------------------------------------ + Системные флаги + + При объявлении процедурных типов и глобальных процедур, после ключевого +слова PROCEDURE может быть указан флаг соглашения вызова: [stdcall], [cdecl] +или [winapi]. Например: + + PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER; + + Если указан флаг [winapi], то принимается соглашение stdcall и +процедуру-функцию можно вызвать как собственно процедуру, вне выражения. +Флаг [winapi] доступен только для платформы Windows. + При объявлении типов-записей, после ключевого слова RECORD может быть +указан флаг [noalign] или [union]. Флаг [noalign] означает отсутствие +выравнивания полей записи, а флаг [union] означает, что смещения всех полей +записи равны нулю, при этом размер записи равен размеру наибольшего поля. +Записи RECORD [union] ... END соответствуют объединениям (union) в языке C. +Записи с системными флагами не могут иметь базового типа и не могут быть +базовыми типами для других записей. + Для использования системных флагов, требуется импортировать SYSTEM. + +------------------------------------------------------------------------------ + Оператор CASE + + Синтаксис оператора CASE: + + CaseStatement = + CASE Expression OF Сase {"|" Сase} + [ELSE StatementSequence] END. + Case = [CaseLabelList ":" StatementSequence]. + CaseLabelList = CaseLabels {"," CaseLabels}. + CaseLabels = ConstExpression [".." ConstExpression]. + + Например: + + CASE x OF + |-1: DoSomething1 + | 1: DoSomething2 + | 0: DoSomething3 + ELSE + DoSomething4 + END + + В метках вариантов можно использовать константные выражения, ветка ELSE +необязательна. Если не выполнен ни один вариант и ELSE отсутствует, то +программа прерывается с ошибкой времени выполнения. + +------------------------------------------------------------------------------ + Проверка и охрана типа нулевого указателя + + Оригинальное сообщение о языке не определяет поведение программы при +выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих +Oberon-реализациях выполнение такой операции приводит к ошибке времени +выполнения. В данной реализации охрана типа нулевого указателя не приводит к +ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет +значительно сократить частоту применения охраны типа. + +------------------------------------------------------------------------------ + Дополнительные стандартные процедуры + + DISPOSE(VAR v: любой_указатель) + Освобождает память, выделенную процедурой NEW для + динамической переменной v^, и присваивает переменной v + значение NIL. + + LSR(x, n: INTEGER): INTEGER + Логический сдвиг x на n бит вправо. + + BITS(x: INTEGER): SET + Интерпретирует x как значение типа SET. + Выполняется на этапе компиляции. + + LENGTH(s: ARRAY OF CHAR): INTEGER + Длина 0X-завершенной строки s, без учета символа 0X. + Если символ 0X отсутствует, функция возвращает длину + массива s. + +------------------------------------------------------------------------------ + DIV и MOD + + x y x DIV y x MOD y + + 5 3 1 2 + -5 3 -2 1 + 5 -3 -2 -1 + -5 -3 1 -2 + +------------------------------------------------------------------------------ + Скрытые параметры процедур + + Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке +формальных параметров, но учитываются компилятором при трансляции вызовов. +Это возможно в следующих случаях: + +1. Процедура имеет формальный параметр открытый массив: + PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL); + Вызов транслируется так: + Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0]) +2. Процедура имеет формальный параметр-переменную типа RECORD: + PROCEDURE Proc(VAR x: Rec); + Вызов транслируется так: + Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x)) +3. Процедура является вложенной, глубина вложения k, + для глобальных процедур k = 0: + PROCEDURE Proc(p1, ..., pn); + Вызов транслируется так: + Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn), + где base(m) - адрес базы кадра стэка охватывающей процедуры глубины + вложения m (используется для доступа к локальным переменным + охватывающей процедуры) + +------------------------------------------------------------------------------ + Модуль RTL + + Все программы неявно используют модуль RTL. Компилятор транслирует +некоторые операции (проверка и охрана типа, сравнение строк, сообщения об +ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не +следует явно вызывать эти процедуры, за исключением процедуры SetClose: + + PROCEDURE SetClose(proc: PROC), где TYPE PROC = PROCEDURE + +SetClose назначает процедуру proc (без параметров) вызываемой при выгрузке +dll-библиотеки (Windows), если приложение компилируется как Windows DLL. Для +прочих типов приложений и платформ вызов процедуры SetClose не влияет на +поведение программы. + Сообщения об ошибках времени выполнения выводятся в диалоговых окнах +(Windows), в терминал (Linux), на доску отладки (KolibriOS). + +------------------------------------------------------------------------------ + Модуль API + + Существуют три реализации модуля API: для Windows, Linux и KolibriOS. Как и +модуль RTL, модуль API не предназначен для прямого использования. Он +обеспечивает кроссплатформенность компилятора. + +------------------------------------------------------------------------------ + Генерация исполняемых файлов DLL + + Разрешается экспортировать только процедуры. Для этого, процедура должна +находиться в главном модуле программы, и ее имя должно быть отмечено символом +экспорта ("*"). KolibriOS DLL всегда экспортируют идентификаторы "version" +(версия программы) и "lib_init" - адрес процедуры инициализации DLL: + + PROCEDURE [stdcall] lib_init(): INTEGER + +Эта процедура должна быть вызвана перед использованием DLL. +Процедура всегда возвращает 1. + В настоящее время генерация DLL для Linux не реализована. + +============================================================================== +============================================================================== + + Библиотека (KolibriOS) + +------------------------------------------------------------------------------ +MODULE Out - консольный вывод + + PROCEDURE Open + формально открывает консольный вывод + + PROCEDURE Int(x, width: INTEGER) + вывод целого числа x; + width - количество знакомест, используемых для вывода + + PROCEDURE Real(x: LONGREAL; width: INTEGER) + вывод вещественного числа x в плавающем формате; + width - количество знакомест, используемых для вывода + + PROCEDURE Char(x: CHAR) + вывод символа x + + PROCEDURE FixReal(x: LONGREAL; 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 LongReal(VAR x: LONGREAL) + ввод числа типа LONGREAL + + 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.141592653589793D+00 + e = 2.718281828459045D+00 + + VAR + + Inf, nInf: LONGREAL + положительная и отрицательная бесконечность + + PROCEDURE IsNan(x: LONGREAL): BOOLEAN + возвращает TRUE, если x - не число + + PROCEDURE IsInf(x: LONGREAL): BOOLEAN + возвращает TRUE, если x - бесконечность + + PROCEDURE sqrt(x: LONGREAL): LONGREAL + квадратный корень x + + PROCEDURE exp(x: LONGREAL): LONGREAL + экспонента x + + PROCEDURE ln(x: LONGREAL): LONGREAL + натуральный логарифм x + + PROCEDURE sin(x: LONGREAL): LONGREAL + синус x + + PROCEDURE cos(x: LONGREAL): LONGREAL + косинус x + + PROCEDURE tan(x: LONGREAL): LONGREAL + тангенс x + + PROCEDURE arcsin(x: LONGREAL): LONGREAL + арксинус x + + PROCEDURE arccos(x: LONGREAL): LONGREAL + арккосинус x + + PROCEDURE arctan(x: LONGREAL): LONGREAL + арктангенс x + + PROCEDURE arctan2(y, x: LONGREAL): LONGREAL + арктангенс y/x + + PROCEDURE power(base, exponent: LONGREAL): LONGREAL + возведение числа base в степень exponent + + PROCEDURE log(base, x: LONGREAL): LONGREAL + логарифм x по основанию base + + PROCEDURE sinh(x: LONGREAL): LONGREAL + гиперболический синус x + + PROCEDURE cosh(x: LONGREAL): LONGREAL + гиперболический косинус x + + PROCEDURE tanh(x: LONGREAL): LONGREAL + гиперболический тангенс x + + PROCEDURE arcsinh(x: LONGREAL): LONGREAL + обратный гиперболический синус x + + PROCEDURE arccosh(x: LONGREAL): LONGREAL + обратный гиперболический косинус x + + PROCEDURE arctanh(x: LONGREAL): LONGREAL + обратный гиперболический тангенс x + + PROCEDURE round(x: LONGREAL): LONGREAL + округление x до ближайшего целого + + PROCEDURE frac(x: LONGREAL): LONGREAL; + дробная часть числа x + + PROCEDURE floor(x: LONGREAL): LONGREAL + наибольшее целое число (представление как LONGREAL), + не больше x: floor(1.2) = 1.0 + + PROCEDURE ceil(x: LONGREAL): LONGREAL + наименьшее целое число (представление как LONGREAL), + не меньше x: ceil(1.2) = 2.0 + + PROCEDURE sgn(x: LONGREAL): INTEGER + если x > 0 возвращает 1 + если x < 0 возвращает -1 + если x = 0 возвращает 0 + +------------------------------------------------------------------------------ +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 LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN + + PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN + + PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN + + PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): 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 LongReal(F: File.FS; x: LONGREAL): BOOLEAN + + PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN + + PROCEDURE Set(F: File.FS; x: SET): BOOLEAN + + PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN + +------------------------------------------------------------------------------ +MODULE DateTime - дата, время + + CONST ERR = -7.0D5 + + PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER) + записывает в параметры компоненты текущей системной даты и + времени + + PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL + возвращает дату, полученную из компонентов + Year, Month, Day, Hour, Min, Sec; + при ошибке возвращает константу ERR = -7.0D5 + + PROCEDURE Decode(Date: LONGREAL; 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 +------------------------------------------------------------------------------ \ No newline at end of file diff --git a/programs/develop/oberon07/Docs/About866.txt b/programs/develop/oberon07/Docs/About866.txt new file mode 100644 index 0000000000..b2b16829d8 --- /dev/null +++ b/programs/develop/oberon07/Docs/About866.txt @@ -0,0 +1,856 @@ + Љ®¬ЇЁ«пв®а п§лЄ  Їа®Ја ¬¬Ёа®ў ­Ёп Oberon-07/11 ¤«п i386 + Windows/Linux/KolibriOS. +------------------------------------------------------------------------------ + + ‘®бв ў Їа®Ја ¬¬л + +1. Compiler.kex (KolibriOS) - ЁбЇ®«­пҐ¬л© д ©« Є®¬ЇЁ«пв®а . + ‚室 - ⥪бв®ўлҐ д ©«л ¬®¤г«Ґ© б а биЁаҐ­ЁҐ¬ ".ob07", Є®¤Ёа®ўЄ  ANSI + Ё«Ё UTF-8 б BOM-бЁЈ­ вга®©. + ‚л室 - ЁбЇ®«­пҐ¬л© д ©« д®а¬ в  PE, ELF Ё«Ё MENUET01/MS COFF. + Џ а ¬Ґвал: + 1) Ё¬п Ј« ў­®Ј® ¬®¤г«п + 2) вЁЇ ЇаЁ«®¦Ґ­Ёп Ё Ї« вд®а¬  + "con" - Windows console + "gui" - Windows GUI + "dll" - Windows DLL + "elf" - Linux + "kos" - KolibriOS + "obj" - KolibriOS DLL + 3) а §¬Ґа бвнЄ  ў ¬ҐЈ Ў ©в е, ­Ґ®Ўп§ вҐ«м­л© Ї а ¬Ґва, Ї® 㬮«з ­Ёо - + 1 ЊЎ, ¤«п ELF ЁЈ­®аЁагҐвбп. …б«Ё 2-© Ї а ¬Ґва = "obj" (KolibriOS DLL), + в® 3-© Ї а ¬Ґва § ¤ Ґвбп иҐбв­ ¤ж вЁаЁз­л¬ зЁб«®¬ + (0x00000001 .. 0xffffffff) Ё ®ЇаҐ¤Ґ«пҐв ўҐабЁо Їа®Ја ¬¬л, + Ї® 㬮«з ­Ёо - 0x00010000 (v1.0). + Ќ ЇаЁ¬Ґа: + "C:\oberon-07\example.ob07" con 1 + "C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *) + ‚ б«гз Ґ гбЇҐи­®© Є®¬ЇЁ«пжЁЁ, Є®¬ЇЁ«пв®а ЇҐаҐ¤ Ґв Є®¤ § ўҐа襭Ёп 0, + Ё­ зҐ 1. ЏаЁ а Ў®вҐ Є®¬ЇЁ«пв®а  ў KolibriOS, Є®¤ § ўҐа襭Ёп ­Ґ + ЇҐаҐ¤ Ґвбп. ‘®®ЎйҐ­Ёп Є®¬ЇЁ«пв®а  ўлў®¤пвбп ­  Є®­б®«м (Windows, + KolibriOS), ў вҐа¬Ё­ « (Linux). +2. Џ ЇЄ  Lib - ЎЁЎ«Ё®вҐЄ  ¬®¤г«Ґ© +3. Џ ЇЄ  Source - Ёб室­л© Є®¤ Є®¬ЇЁ«пв®а  + +------------------------------------------------------------------------------ + Ћв«ЁзЁп ®в ®аЁЈЁ­ «  + +1. ђ биЁаҐ­ ЇбҐў¤®¬®¤г«м SYSTEM +2. ђ §аҐиҐ­ бЁ¬ў®« "_" ў Ё¤Ґ­вЁдЁЄ в®а е +3. „®Ў ў«Ґ­л бЁб⥬­лҐ д« ЈЁ +4. ЋЇҐа в®а CASE ॠ«Ё§®ў ­ ў ᮮ⢥вбвўЁЁ б бЁ­в ЄбЁб®¬ Ё ᥬ ­вЁЄ®© + ¤ ­­®Ј® ®ЇҐа в®а  ў п§лЄҐ Oberon (Revision 1.10.90) +5. ђ биЁаҐ­ ­ Ў®а бв ­¤ ав­ле Їа®жҐ¤га +6. ‘Ґ¬ ­вЁЄ  ®еа ­л/Їа®ўҐаЄЁ вЁЇ  гв®з­Ґ­  ¤«п ­г«Ґў®Ј® гЄ § вҐ«п +7. ‘Ґ¬ ­вЁЄ  DIV Ё MOD гв®з­Ґ­  ¤«п ®ваЁж вҐ«м­ле зЁбҐ« +8. „®Ў ў«Ґ­л ®¤­®бва®з­лҐ Є®¬¬Ґ­в аЁЁ (­ зЁ­ овбп б Ї ал бЁ¬ў®«®ў "//") +9. ђ §аҐиҐ­ нЄбЇ®ав ЇҐаҐ¬Ґ­­ле вЁЇ®ў ARRAY Ё RECORD (в®«мЄ® ¤«п з⥭Ёп) + +------------------------------------------------------------------------------ + Ћб®ЎҐ­­®б⨠ॠ«Ё§ жЁЁ + +1. Ћб­®ў­лҐ вЁЇл + + ’ЁЇ „Ё Ї §®­ §­ зҐ­Ё© ђ §¬Ґа, Ў ©в + + INTEGER -2147483648 .. 2147483647 4 + REAL 1.40E-45 .. 3.34E+38 4 + LONGREAL 4.94E-324 .. 1.70E+308 8 + CHAR бЁ¬ў®« ASCII (0X .. 0FFX) 1 + BOOLEAN FALSE, TRUE 1 + SET ¬­®¦Ґбвў® Ё§ 楫ле зЁбҐ« {0 .. 31} 4 + +2. Њ ЄбЁ¬ «м­ п ¤«Ё­  Ё¤Ґ­вЁдЁЄ в®а®ў - 255 бЁ¬ў®«®ў +3. Њ ЄбЁ¬ «м­ п ¤«Ё­  бва®Є®ўле Є®­бв ­в - 255 бЁ¬ў®«®ў +4. Њ ЄбЁ¬ «м­ п ¤«Ё­  бва®Є Ёб室­®Ј® Є®¤  - 511 бЁ¬ў®«®ў +5. Њ ЄбЁ¬ «м­ п а §¬Ґа­®бвм ®вЄалвле ¬ ббЁў®ў - 5 +6. Њ ЄбЁ¬ «м­®Ґ Є®«ЁзҐбвў® ®Ўкпў«Ґ­­ле вЁЇ®ў-§ ЇЁбҐ© - 2047 +7. Џа®жҐ¤га  NEW § Ї®«­пҐв ­г«п¬Ё ўл¤Ґ«Ґ­­л© Ў«®Є Ї ¬пвЁ +8. ѓ«®Ў «м­лҐ Ё «®Є «м­лҐ ЇҐаҐ¬Ґ­­лҐ Ё­ЁжЁ «Ё§Ёаговбп ­г«п¬Ё +9. ‚ ®в«ЁзЁҐ ®в ¬­®ЈЁе Oberon-ॠ«Ё§ жЁ©, бЎ®айЁЄ ¬гб®а  Ё ¤Ё­ ¬ЁзҐбЄ п + ¬®¤г«м­®бвм ®вбгвбвўгов + +------------------------------------------------------------------------------ + ЏбҐў¤®¬®¤г«м SYSTEM + + ЏбҐў¤®¬®¤г«м SYSTEM ᮤҐа¦Ёв ­Ё§Є®га®ў­ҐўлҐ Ё ­ҐЎҐ§®Ї б­лҐ Їа®жҐ¤гал, +®иЁЎЄЁ ЇаЁ ЁбЇ®«м§®ў ­ЁЁ Їа®жҐ¤га ЇбҐў¤®¬®¤г«п SYSTEM ¬®Јгв ЇаЁўҐбвЁ Є +Ї®ўаҐ¦¤Ґ­Ёо ¤ ­­ле ўаҐ¬Ґ­Ё ўлЇ®«­Ґ­Ёп Ё  ў аЁ©­®¬г § ўҐа襭Ёо Їа®Ја ¬¬л. + + PROCEDURE ADR(v: «оЎ®© вЁЇ): INTEGER + v - ЇҐаҐ¬Ґ­­ п, Їа®жҐ¤га  Ё«Ё бва®Є®ў п Є®­бв ­в ; + ў®§ўа й Ґв  ¤аҐб v + + PROCEDURE SIZE(T): INTEGER + ў®§ўа й Ґв а §¬Ґа вЁЇ  T + + PROCEDURE TYPEID(T): INTEGER + T - вЁЇ-§ ЇЁбм Ё«Ё вЁЇ-гЄ § вҐ«м, + ў®§ўа й Ґв ­®¬Ґа вЁЇ  ў в Ў«ЁжҐ вЁЇ®ў-§ ЇЁбҐ© + + PROCEDURE INF(T): T + T - REAL Ё«Ё LONGREAL, + ў®§ўа й Ґв бЇҐжЁ «м­®Ґ ўҐйҐб⢥­­®Ґ §­ зҐ­ЁҐ "ЎҐбЄ®­Ґз­®бвм" + + PROCEDURE GET(a: INTEGER; + VAR v: «оЎ®© ®б­®ў­®© вЁЇ, PROCEDURE, POINTER) + v := Џ ¬пвм[a] + + PROCEDURE PUT(a: INTEGER; x: «оЎ®© ®б­®ў­®© вЁЇ, PROCEDURE, POINTER) + Џ ¬пвм[a] := x + + PROCEDURE MOVE(Source, Dest, n: INTEGER) + Љ®ЇЁагҐв n Ў ©в Ї ¬пвЁ Ё§ Source ў Dest, + ®Ў« бвЁ Source Ё Dest ­Ґ ¤®«¦­л ЇҐаҐЄалў вмбп + + PROCEDURE CODE(s: ARRAY OF CHAR) + ‚бв ўЄ  ¬ иЁ­­®Ј® Є®¤  + s - бва®Є®ў п Є®­бв ­в  иҐбв­ ¤ж вЁаЁз­ле жЁда + Є®«ЁзҐбвў® жЁда ¤®«¦­® Ўлвм зҐв­л¬ + ­ ЇаЁ¬Ґа: SYSTEM.CODE("B801000000") (* mov eax, 1 *) + + ’ Є¦Ґ ў ¬®¤г«Ґ SYSTEM ®ЇаҐ¤Ґ«Ґ­ вЁЇ CARD16 (2 Ў ©в ). „«п вЁЇ  CARD16 ­Ґ +¤®ЇгбЄ овбп ­ЁЄ ЄЁҐ пў­лҐ ®ЇҐа жЁЁ, §  ЁбЄ«о祭ЁҐ¬ ЇаЁбў Ёў ­Ёп. +ЏаҐ®Ўа §®ў ­Ёп CARD16 -> INTEGER Ё INTEGER -> CARD16 ¬®Јгв Ўлвм ॠ«Ё§®ў ­л +в Є: + + PROCEDURE Card16ToInt(w: SYSTEM.CARD16): INTEGER; + VAR i: INTEGER; + BEGIN + SYSTEM.PUT(SYSTEM.ADR(i), w) + RETURN i + END Card16ToInt; + + PROCEDURE IntToCard16(i: INTEGER): SYSTEM.CARD16; + VAR w: SYSTEM.CARD16; + BEGIN + SYSTEM.GET(SYSTEM.ADR(i), w) + RETURN w + END IntToCard16; + + ”г­ЄжЁЁ ЇбҐў¤®¬®¤г«п SYSTEM ­Ґ«м§п ЁбЇ®«м§®ў вм ў Є®­бв ­в­ле ўла ¦Ґ­Ёпе. + +------------------------------------------------------------------------------ + ‘Ёб⥬­лҐ д« ЈЁ + + ЏаЁ ®Ўкпў«Ґ­ЁЁ Їа®жҐ¤га­ле вЁЇ®ў Ё Ј«®Ў «м­ле Їа®жҐ¤га, Ї®б«Ґ Є«о祢®Ј® +б«®ў  PROCEDURE ¬®¦Ґв Ўлвм гЄ § ­ д« Ј б®Ј« иҐ­Ёп ўл§®ў : [stdcall], [cdecl] +Ё«Ё [winapi]. Ќ ЇаЁ¬Ґа: + + PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER; + + …б«Ё гЄ § ­ д« Ј [winapi], в® ЇаЁ­Ё¬ Ґвбп б®Ј« иҐ­ЁҐ stdcall Ё +Їа®жҐ¤гаг-дг­ЄжЁо ¬®¦­® ўл§ў вм Є Є б®Ўб⢥­­® Їа®жҐ¤гаг, ў­Ґ ўла ¦Ґ­Ёп. +”« Ј [winapi] ¤®бвгЇҐ­ в®«мЄ® ¤«п Ї« вд®а¬л Windows. + ЏаЁ ®Ўкпў«Ґ­ЁЁ вЁЇ®ў-§ ЇЁбҐ©, Ї®б«Ґ Є«о祢®Ј® б«®ў  RECORD ¬®¦Ґв Ўлвм +гЄ § ­ д« Ј [noalign] Ё«Ё [union]. ”« Ј [noalign] ®§­ з Ґв ®вбгвбвўЁҐ +ўла ў­Ёў ­Ёп Ї®«Ґ© § ЇЁбЁ,   д« Ј [union] ®§­ з Ґв, з⮠ᬥ饭Ёп ўбҐе Ї®«Ґ© +§ ЇЁбЁ а ў­л ­г«о, ЇаЁ н⮬ а §¬Ґа § ЇЁбЁ а ўҐ­ а §¬Ґаг ­ ЁЎ®«м襣® Ї®«п. +‡ ЇЁбЁ RECORD [union] ... END ᮮ⢥вбвўгов ®ЎкҐ¤Ё­Ґ­Ёп¬ (union) ў п§лЄҐ C. +‡ ЇЁбЁ б бЁб⥬­л¬Ё д« Ј ¬Ё ­Ґ ¬®Јгв Ё¬Ґвм Ў §®ў®Ј® вЁЇ  Ё ­Ґ ¬®Јгв Ўлвм +Ў §®ўл¬Ё вЁЇ ¬Ё ¤«п ¤агЈЁе § ЇЁбҐ©. + „«п ЁбЇ®«м§®ў ­Ёп бЁб⥬­ле д« Ј®ў, вॡгҐвбп Ё¬Ї®авЁа®ў вм SYSTEM. + +------------------------------------------------------------------------------ + ЋЇҐа в®а CASE + + ‘Ё­в ЄбЁб ®ЇҐа в®а  CASE: + + CaseStatement = + CASE Expression OF ‘ase {"|" ‘ase} + [ELSE StatementSequence] END. + Case = [CaseLabelList ":" StatementSequence]. + CaseLabelList = CaseLabels {"," CaseLabels}. + CaseLabels = ConstExpression [".." ConstExpression]. + + Ќ ЇаЁ¬Ґа: + + CASE x OF + |-1: DoSomething1 + | 1: DoSomething2 + | 0: DoSomething3 + ELSE + DoSomething4 + END + + ‚ ¬ҐвЄ е ў аЁ ­в®ў ¬®¦­® ЁбЇ®«м§®ў вм Є®­бв ­в­лҐ ўла ¦Ґ­Ёп, ўҐвЄ  ELSE +­Ґ®Ўп§ вҐ«м­ . …б«Ё ­Ґ ўлЇ®«­Ґ­ ­Ё ®¤Ё­ ў аЁ ­в Ё ELSE ®вбгвбвўгҐв, в® +Їа®Ја ¬¬  ЇаҐалў Ґвбп б ®иЁЎЄ®© ўаҐ¬Ґ­Ё ўлЇ®«­Ґ­Ёп. + +------------------------------------------------------------------------------ + Џа®ўҐаЄ  Ё ®еа ­  вЁЇ  ­г«Ґў®Ј® гЄ § вҐ«п + + ЋаЁЈЁ­ «м­®Ґ б®®ЎйҐ­ЁҐ ® п§лЄҐ ­Ґ ®ЇаҐ¤Ґ«пҐв Ї®ўҐ¤Ґ­ЁҐ Їа®Ја ¬¬л ЇаЁ +ўлЇ®«­Ґ­ЁЁ ®еа ­л p(T) Ё Їа®ўҐаЄЁ вЁЇ  p IS T ЇаЁ p = NIL. ‚® ¬­®ЈЁе +Oberon-ॠ«Ё§ жЁпе ўлЇ®«­Ґ­ЁҐ в Є®© ®ЇҐа жЁЁ ЇаЁў®¤Ёв Є ®иЁЎЄҐ ўаҐ¬Ґ­Ё +ўлЇ®«­Ґ­Ёп. ‚ ¤ ­­®© ॠ«Ё§ жЁЁ ®еа ­  вЁЇ  ­г«Ґў®Ј® гЄ § вҐ«п ­Ґ ЇаЁў®¤Ёв Є +®иЁЎЄҐ,   Їа®ўҐаЄ  вЁЇ  ¤ Ґв १г«мв в FALSE. ‚ а拉 б«гз Ґў нв® Ї®§ў®«пҐв +§­ зЁвҐ«м­® б®Єа вЁвм з бв®вг ЇаЁ¬Ґ­Ґ­Ёп ®еа ­л вЁЇ . + +------------------------------------------------------------------------------ + „®Ї®«­ЁвҐ«м­лҐ бв ­¤ ав­лҐ Їа®жҐ¤гал + + DISPOSE(VAR v: «оЎ®©_гЄ § вҐ«м) + Ћбў®Ў®¦¤ Ґв Ї ¬пвм, ўл¤Ґ«Ґ­­го Їа®жҐ¤га®© NEW ¤«п + ¤Ё­ ¬ЁзҐбЄ®© ЇҐаҐ¬Ґ­­®© v^, Ё ЇаЁбў Ёў Ґв ЇҐаҐ¬Ґ­­®© v + §­ зҐ­ЁҐ NIL. + + LSR(x, n: INTEGER): INTEGER + ‹®ЈЁзҐбЄЁ© б¤ўЁЈ x ­  n ЎЁв ўЇа ў®. + + BITS(x: INTEGER): SET + €­вҐаЇаҐвЁагҐв x Є Є §­ зҐ­ЁҐ вЁЇ  SET. + ‚лЇ®«­пҐвбп ­  нв ЇҐ Є®¬ЇЁ«пжЁЁ. + + LENGTH(s: ARRAY OF CHAR): INTEGER + „«Ё­  0X-§ ўҐа襭­®© бва®ЄЁ s, ЎҐ§ гзҐв  бЁ¬ў®«  0X. + …б«Ё бЁ¬ў®« 0X ®вбгвбвўгҐв, дг­ЄжЁп ў®§ўа й Ґв ¤«Ё­г + ¬ ббЁў  s. + +------------------------------------------------------------------------------ + DIV Ё MOD + + x y x DIV y x MOD y + + 5 3 1 2 + -5 3 -2 1 + 5 -3 -2 -1 + -5 -3 1 -2 + +------------------------------------------------------------------------------ + ‘ЄалвлҐ Ї а ¬Ґвал Їа®жҐ¤га + + ЌҐЄ®в®алҐ Їа®жҐ¤гал ¬®Јгв Ё¬Ґвм бЄалвлҐ Ї а ¬Ґвал, ®­Ё ®вбгвбвўгов ў бЇЁбЄҐ +д®а¬ «м­ле Ї а ¬Ґва®ў, ­® гзЁвлў овбп Є®¬ЇЁ«пв®а®¬ ЇаЁ ва ­б«пжЁЁ ўл§®ў®ў. +ќв® ў®§¬®¦­® ў б«Ґ¤гойЁе б«гз пе: + +1. Џа®жҐ¤га  Ё¬ҐҐв д®а¬ «м­л© Ї а ¬Ґва ®вЄалвл© ¬ ббЁў: + PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL); + ‚맮ў ва ­б«ЁагҐвбп в Є: + Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0]) +2. Џа®жҐ¤га  Ё¬ҐҐв д®а¬ «м­л© Ї а ¬Ґва-ЇҐаҐ¬Ґ­­го вЁЇ  RECORD: + PROCEDURE Proc(VAR x: Rec); + ‚맮ў ва ­б«ЁагҐвбп в Є: + Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x)) +3. Џа®жҐ¤га  пў«пҐвбп ў«®¦Ґ­­®©, Ј«гЎЁ­  ў«®¦Ґ­Ёп k, + ¤«п Ј«®Ў «м­ле Їа®жҐ¤га k = 0: + PROCEDURE Proc(p1, ..., pn); + ‚맮ў ва ­б«ЁагҐвбп в Є: + Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn), + Ј¤Ґ base(m) -  ¤аҐб Ў §л Є ¤а  бвнЄ  ®еў влў о饩 Їа®жҐ¤гал Ј«гЎЁ­л + ў«®¦Ґ­Ёп m (ЁбЇ®«м§гҐвбп ¤«п ¤®бвгЇ  Є «®Є «м­л¬ ЇҐаҐ¬Ґ­­л¬ + ®еў влў о饩 Їа®жҐ¤гал) + +------------------------------------------------------------------------------ + Њ®¤г«м RTL + + ‚ᥠЇа®Ја ¬¬л ­Ґпў­® ЁбЇ®«м§гов ¬®¤г«м RTL. Љ®¬ЇЁ«пв®а ва ­б«ЁагҐв +­ҐЄ®в®алҐ ®ЇҐа жЁЁ (Їа®ўҐаЄ  Ё ®еа ­  вЁЇ , ба ў­Ґ­ЁҐ бва®Є, б®®ЎйҐ­Ёп ®Ў +®иЁЎЄ е ўаҐ¬Ґ­Ё ўлЇ®«­Ґ­Ёп Ё ¤а.) Є Є ўл§®ўл Їа®жҐ¤га нв®Ј® ¬®¤г«п. ЌҐ +б«Ґ¤гҐв пў­® ўл§лў вм нвЁ Їа®жҐ¤гал, §  ЁбЄ«о祭ЁҐ¬ Їа®жҐ¤гал SetClose: + + PROCEDURE SetClose(proc: PROC), Ј¤Ґ TYPE PROC = PROCEDURE + +SetClose ­ §­ з Ґв Їа®жҐ¤гаг proc (ЎҐ§ Ї а ¬Ґва®ў) ўл§лў Ґ¬®© ЇаЁ ўлЈаг§ЄҐ +dll-ЎЁЎ«Ё®вҐЄЁ (Windows), Ґб«Ё ЇаЁ«®¦Ґ­ЁҐ Є®¬ЇЁ«ЁагҐвбп Є Є Windows DLL. „«п +Їа®зЁе вЁЇ®ў ЇаЁ«®¦Ґ­Ё© Ё Ї« вд®а¬ ўл§®ў Їа®жҐ¤гал SetClose ­Ґ ў«ЁпҐв ­  +Ї®ўҐ¤Ґ­ЁҐ Їа®Ја ¬¬л. + ‘®®ЎйҐ­Ёп ®Ў ®иЁЎЄ е ўаҐ¬Ґ­Ё ўлЇ®«­Ґ­Ёп ўлў®¤пвбп ў ¤Ё «®Ј®ўле ®Є­ е +(Windows), ў вҐа¬Ё­ « (Linux), ­  ¤®бЄг ®в« ¤ЄЁ (KolibriOS). + +------------------------------------------------------------------------------ + Њ®¤г«м API + + ‘гйҐбвўгов вਠॠ«Ё§ жЁЁ ¬®¤г«п API: ¤«п Windows, Linux Ё KolibriOS. Љ Є Ё +¬®¤г«м RTL, ¬®¤г«м API ­Ґ ЇаҐ¤­ §­ зҐ­ ¤«п ЇаאַЈ® ЁбЇ®«м§®ў ­Ёп. Ћ­ +®ЎҐбЇҐзЁў Ґв Єа®ббЇ« вд®а¬Ґ­­®бвм Є®¬ЇЁ«пв®а . + +------------------------------------------------------------------------------ + ѓҐ­Ґа жЁп ЁбЇ®«­пҐ¬ле д ©«®ў DLL + + ђ §аҐи Ґвбп нЄбЇ®авЁа®ў вм в®«мЄ® Їа®жҐ¤гал. „«п нв®Ј®, Їа®жҐ¤га  ¤®«¦­  +­ е®¤Ёвмбп ў Ј« ў­®¬ ¬®¤г«Ґ Їа®Ја ¬¬л, Ё ҐҐ Ё¬п ¤®«¦­® Ўлвм ®в¬ҐзҐ­® бЁ¬ў®«®¬ +нЄбЇ®ав  ("*"). KolibriOS DLL ўбҐЈ¤  нЄбЇ®авЁагов Ё¤Ґ­вЁдЁЄ в®ал "version" +(ўҐабЁп Їа®Ја ¬¬л) Ё "lib_init" -  ¤аҐб Їа®жҐ¤гал Ё­ЁжЁ «Ё§ жЁЁ DLL: + + PROCEDURE [stdcall] lib_init(): INTEGER + +ќв  Їа®жҐ¤га  ¤®«¦­  Ўлвм ўл§ў ­  ЇҐаҐ¤ ЁбЇ®«м§®ў ­ЁҐ¬ DLL. +Џа®жҐ¤га  ўбҐЈ¤  ў®§ўа й Ґв 1. + ‚ ­ бв®п饥 ўаҐ¬п ЈҐ­Ґа жЁп DLL ¤«п Linux ­Ґ ॠ«Ё§®ў ­ . + +============================================================================== +============================================================================== + + ЃЁЎ«Ё®вҐЄ  (KolibriOS) + +------------------------------------------------------------------------------ +MODULE Out - Є®­б®«м­л© ўлў®¤ + + PROCEDURE Open + д®а¬ «м­® ®вЄалў Ґв Є®­б®«м­л© ўлў®¤ + + PROCEDURE Int(x, width: INTEGER) + ўлў®¤ 楫®Ј® зЁб«  x; + width - Є®«ЁзҐбвў® §­ Є®¬Ґбв, ЁбЇ®«м§гҐ¬ле ¤«п ўлў®¤  + + PROCEDURE Real(x: LONGREAL; width: INTEGER) + ўлў®¤ ўҐйҐб⢥­­®Ј® зЁб«  x ў Ї« ў о饬 д®а¬ вҐ; + width - Є®«ЁзҐбвў® §­ Є®¬Ґбв, ЁбЇ®«м§гҐ¬ле ¤«п ўлў®¤  + + PROCEDURE Char(x: CHAR) + ўлў®¤ бЁ¬ў®«  x + + PROCEDURE FixReal(x: LONGREAL; 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 LongReal(VAR x: LONGREAL) + ўў®¤ зЁб«  вЁЇ  LONGREAL + + 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.141592653589793D+00 + e = 2.718281828459045D+00 + + VAR + + Inf, nInf: LONGREAL + Ї®«®¦ЁвҐ«м­ п Ё ®ваЁж вҐ«м­ п ЎҐбЄ®­Ґз­®бвм + + PROCEDURE IsNan(x: LONGREAL): BOOLEAN + ў®§ўа й Ґв TRUE, Ґб«Ё x - ­Ґ зЁб«® + + PROCEDURE IsInf(x: LONGREAL): BOOLEAN + ў®§ўа й Ґв TRUE, Ґб«Ё x - ЎҐбЄ®­Ґз­®бвм + + PROCEDURE sqrt(x: LONGREAL): LONGREAL + Єў ¤а в­л© Є®аҐ­м x + + PROCEDURE exp(x: LONGREAL): LONGREAL + нЄбЇ®­Ґ­в  x + + PROCEDURE ln(x: LONGREAL): LONGREAL + ­ вга «м­л© «®Ј аЁд¬ x + + PROCEDURE sin(x: LONGREAL): LONGREAL + бЁ­гб x + + PROCEDURE cos(x: LONGREAL): LONGREAL + Є®бЁ­гб x + + PROCEDURE tan(x: LONGREAL): LONGREAL + в ­ЈҐ­б x + + PROCEDURE arcsin(x: LONGREAL): LONGREAL +  аЄбЁ­гб x + + PROCEDURE arccos(x: LONGREAL): LONGREAL +  аЄЄ®бЁ­гб x + + PROCEDURE arctan(x: LONGREAL): LONGREAL +  аЄв ­ЈҐ­б x + + PROCEDURE arctan2(y, x: LONGREAL): LONGREAL +  аЄв ­ЈҐ­б y/x + + PROCEDURE power(base, exponent: LONGREAL): LONGREAL + ў®§ўҐ¤Ґ­ЁҐ зЁб«  base ў б⥯Ґ­м exponent + + PROCEDURE log(base, x: LONGREAL): LONGREAL + «®Ј аЁд¬ x Ї® ®б­®ў ­Ёо base + + PROCEDURE sinh(x: LONGREAL): LONGREAL + ЈЁЇҐаЎ®«ЁзҐбЄЁ© бЁ­гб x + + PROCEDURE cosh(x: LONGREAL): LONGREAL + ЈЁЇҐаЎ®«ЁзҐбЄЁ© Є®бЁ­гб x + + PROCEDURE tanh(x: LONGREAL): LONGREAL + ЈЁЇҐаЎ®«ЁзҐбЄЁ© в ­ЈҐ­б x + + PROCEDURE arcsinh(x: LONGREAL): LONGREAL + ®Ўа в­л© ЈЁЇҐаЎ®«ЁзҐбЄЁ© бЁ­гб x + + PROCEDURE arccosh(x: LONGREAL): LONGREAL + ®Ўа в­л© ЈЁЇҐаЎ®«ЁзҐбЄЁ© Є®бЁ­гб x + + PROCEDURE arctanh(x: LONGREAL): LONGREAL + ®Ўа в­л© ЈЁЇҐаЎ®«ЁзҐбЄЁ© в ­ЈҐ­б x + + PROCEDURE round(x: LONGREAL): LONGREAL + ®ЄагЈ«Ґ­ЁҐ x ¤® Ў«Ё¦ ©иҐЈ® 楫®Ј® + + PROCEDURE frac(x: LONGREAL): LONGREAL; + ¤а®Ў­ п з бвм зЁб«  x + + PROCEDURE floor(x: LONGREAL): LONGREAL + ­ ЁЎ®«м襥 楫®Ґ зЁб«® (ЇаҐ¤бв ў«Ґ­ЁҐ Є Є LONGREAL), + ­Ґ Ў®«миҐ x: floor(1.2) = 1.0 + + PROCEDURE ceil(x: LONGREAL): LONGREAL + ­ Ё¬Ґ­м襥 楫®Ґ зЁб«® (ЇаҐ¤бв ў«Ґ­ЁҐ Є Є LONGREAL), + ­Ґ ¬Ґ­миҐ x: ceil(1.2) = 2.0 + + PROCEDURE sgn(x: LONGREAL): INTEGER + Ґб«Ё x > 0 ў®§ўа й Ґв 1 + Ґб«Ё x < 0 ў®§ўа й Ґв -1 + Ґб«Ё x = 0 ў®§ўа й Ґв 0 + +------------------------------------------------------------------------------ +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 LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN + + PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN + + PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN + + PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): 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 LongReal(F: File.FS; x: LONGREAL): BOOLEAN + + PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN + + PROCEDURE Set(F: File.FS; x: SET): BOOLEAN + + PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN + +------------------------------------------------------------------------------ +MODULE DateTime - ¤ в , ўаҐ¬п + + CONST ERR = -7.0D5 + + PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER) + § ЇЁблў Ґв ў Ї а ¬Ґвал Є®¬Ї®­Ґ­вл ⥪г饩 бЁб⥬­®© ¤ вл Ё + ўаҐ¬Ґ­Ё + + PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL + ў®§ўа й Ґв ¤ вг, Ї®«г祭­го Ё§ Є®¬Ї®­Ґ­в®ў + Year, Month, Day, Hour, Min, Sec; + ЇаЁ ®иЁЎЄҐ ў®§ўа й Ґв Є®­бв ­вг ERR = -7.0D5 + + PROCEDURE Decode(Date: LONGREAL; 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 +------------------------------------------------------------------------------ \ No newline at end of file diff --git a/programs/develop/oberon07/Docs/Oberon07.report.fb2 b/programs/develop/oberon07/Docs/Oberon07.report.fb2 new file mode 100644 index 0000000000..6f5f8b32ff --- /dev/null +++ b/programs/develop/oberon07/Docs/Oberon07.report.fb2 @@ -0,0 +1,693 @@ + + + + +
<p>The Programming Language Oberon</p><p>Revision 22.9.2011</p><p>Niklaus Wirth</p> +

Make it as simple as possible, but not simpler.

(A. Einstein) +

Table of Contents

+ +

1. Introduction

+

2. Syntax

+

3. Vocabulary

+

4. Declarations and scope rules

+

5. Constant declarations

+

6. Type declarations

+

7. Variable declarations

+

8. Expressions

+

9. Statements

+

10. Procedure declarations

+

11. Modules

+

Appendix: The Syntax of Oberon

+
<p>1. Introduction</p> +

Oberon is a general-purpose programming language that evolved from Modula-2. Its principal new feature is the concept of type extension. It permits the construction of new data types on the basis of existing ones and to relate them.

+

This report is not intended as a programmer's tutorial. It is intentionally kept concise. Its function is to serve as a reference for programmers, implementors, and manual writers. What remains unsaid is mostly left so intentionally, either because it is derivable from stated rules of the language, or because it would unnecessarily restrict the freedom of implementors.

+

This document describes the language defined in 1988/90 as revised in 2007/11.

+
+
<p>2. Syntax</p> +

A language is an infinite set of sentences, namely the sentences well formed according to its syntax. In Oberon, these sentences are called compilation units. Each unit is a finite sequence of symbols from a finite vocabulary. The vocabulary of Oberon consists of identifiers, numbers, strings, operators, delimiters, and comments. They are called lexical symbols and are composed of sequences of characters. (Note the distinction between symbols and characters.)

+

To describe the syntax, an extended Backus-Naur Formalism called EBNF is used. Brackets [ and ] denote optionality of the enclosed sentential form, and braces { and } denote its repetition (possibly 0 times). Syntactic entities (non-terminal symbols) are denoted by English words expressing their intuitive meaning. Symbols of the language vocabulary (terminal symbols) are denoted by strings enclosed in quote marks or by words in capital letters.

+
+
<p>3. Vocabulary</p> +

The following lexical rules must be observed when composing symbols. Blanks and line breaks must not occur within symbols (except in comments, and blanks in strings). They are ignored unless they are essential to separate two consecutive symbols. Capital and lower-case letters are considered as being distinct.

+

Identifiers are sequences of letters and digits. The first character must be a letter.

+ +

ident = letter {letter | digit}.

+ +

Examples:

+ +

x scan Oberon GetSymbol firstLetter

+ +

Numbers are (unsigned) integers or real numbers. Integers are sequences of digits and may be followed by a suffix letter. If no suffix is specified, the representation is decimal. The suffix H indicates hexadecimal representation.

+

A real number always contains a decimal point. Optionally it may also contain a decimal scale factor. The letter E is pronounced as "times ten to the power of". A real number is of type REAL, unless it contains a scale factor with the letter D, in which case it is of type LONGREAL.

+ +

number = integer | real.

+

integer = digit {digit} | digit {hexDigit} "H".

+

real = digit {digit} "." {digit} [ScaleFactor].

+

ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.

+

hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".

+

digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".

+ +

Examples:

+ +

1987

+

100H = 256

+

12.3

+

4.567E8 = 456700000

+ +

Strings are sequences of characters enclosed in quote marks ("). A string cannot contain the delimiting quote mark. Alternatively, a single-character string may be specified by the ordinal number of the character in hexadecimal notation followed by an "X". The number of characters in a string is called the length of the string.

+ +

string = """ {character} """ | digit {hexdigit} "X" .

+ +

Examples:

+ +

"OBERON" "Don't worry!" 22X

+ +

Operators and delimiters are the special characters, character pairs, or reserved words listed below. These reserved words consist exclusively of capital letters and cannot be used in the role of identifiers.

+ +

+ := ARRAY IMPORT THEN

+

- ^ BEGIN IN TO

+

* = BY IS TRUE

+

/ # CASE MOD TYPE

+

~ < CONST MODULE UNTIL

+

& > DIV NIL VAR

+

. <= DO OF WHILE

+

, >= ELSE OR

+

; .. ELSIF POINTER

+

| : END PROCEDURE

+

( ) FALSE RECORD

+

[ ] FOR REPEAT

+

{ } IF RETURN

+ +

Comments may be inserted between any two symbols in a program. They are arbitrary character sequences opened by the bracket (* and closed by *). Comments do not affect the meaning of a program. They may be nested.

+
+
<p>4. Declarations and scope rules</p> +

Every identifier occurring in a program must be introduced by a declaration, unless it is a predefined identifier. Declarations also serve to specify certain permanent properties of an object, such as whether it is a constant, a type, a variable, or a procedure.

+

The identifier is then used to refer to the associated object. This is possible in those parts of a program only which are within the scope of the declaration. No identifier may denote more than one object within a given scope. The scope extends textually from the point of the declaration to the end of the block (procedure or module) to which the declaration belongs and hence to which the object is local. The scope rule has the following amendments:

+

1. If a type T is defined as POINTER TO T1 (see 6.4), the identifier T1 can be declared textually following the declaration of T, but it must lie within the same scope.

+

2. Field identifiers of a record declaration (see 6.3) are valid in field designators only.

+

In its declaration, an identifier in the global scope may be followed by an export mark (*) to indicate that it be exported from its declaring module. In this case, the identifier may be used in other modules, if they import the declaring module. The identifier is then prefixed by the identifier designating its module (see Ch. 11). The prefix and the identifier are separated by a period and together are called a qualified identifier.

+ +

qualident = [ident "."] ident.

+

identdef = ident ["*"].

+ +

The following identifiers are predefined; their meaning is defined in section 6.1 (types) or 10.2 (procedures):

+ +

ABS ASR ASSERT BOOLEAN CHAR

+

CHR COPY DEC EXCL FLOOR

+

FLT INC INCL INTEGER LEN

+

LSL LONG LONGREAL NEW ODD

+

ORD PACK REAL ROR SET

+

SHORT UNPK

+
+
<p>5. Constant declarations</p> +

A constant declaration associates an identifier with a constant value.

+ +

ConstantDeclaration = identdef "=" ConstExpression.

+

ConstExpression = expression.

+ +

A constant expression can be evaluated by a mere textual scan without actually executing the program. Its operands are constants (see Ch. 8). Examples of constant declarations are:

+ +

N = 100

+

limit = 2*N - 1

+

all = {0 .. WordSize-1}

+

name = "Oberon"

+
+
<p>6. Type declarations</p> +

A data type determines the set of values which variables of that type may assume, and the operators that are applicable. A type declaration is used to associate an identifier with a type. The types define the structure of variables of this type and, by implication, the operators that are applicable to components. There are two different structures, namely arrays and records, with different component selectors.

+ +

TypeDeclaration = identdef "=" StrucType.

+

StrucType = ArrayType | RecordType | PointerType | ProcedureType.

+

type = qualident | StrucType.

+ +

Examples:

+ +

Table = ARRAY N OF REAL

+

Tree = POINTER TO Node

+

Node = RECORD

+

key: INTEGER;

+

left, right: Tree

+

END

+

CenterNode = RECORD (Node)

+

name: ARRAY 32 OF CHAR;

+

subnode: Tree

+

END

+

Function = PROCEDURE (x: INTEGER): INTEGER

+
<p>6.1. Basic types</p> +

The following basic types are denoted by predeclared identifiers. The associated operators are defined in 8.2, and the predeclared function procedures in 10.2. The values of a given basic type are the following:

+ +

BOOLEAN the truth values TRUE and FALSE

+

CHAR the characters of a standard character set

+

INTEGER the integers

+

REAL real numbers

+

LONGREAL real numbers

+

SET the sets of integers between 0 and 31

+ +

The type LONGREAL is intended to represent real numbers with a higher number of digits than REAL. However, the two types may be identical.

+
+
<p>6.2. Array types</p> +

An array is a structure consisting of a fixed number of elements which are all of the same type, called the element type. The number of elements of an array is called its length. The elements of the array are designated by indices, which are integers between 0 and the length minus 1.

+ +

ArrayType = ARRAY length {"," length} OF type.

+

length = ConstExpression.

+ +

A declaration of the form

+ +

ARRAY N0, N1, ... , Nk OF T

+

is understood as an abbreviation of the declaration +

ARRAY N0 OF

+

ARRAY N1 OF

+

...

+

ARRAY Nk OF T

+ +

Examples of array types:

+ +

ARRAY N OF INTEGER

+

ARRAY 10, 20 OF REAL

+
+
<p>6.3. Record types</p> +

A record type is a structure consisting of a fixed number of elements of possibly different types. The record type declaration specifies for each element, called field, its type and an identifier which denotes the field. The scope of these field identifiers is the record definition itself, but they are also visible within field designators (see 8.1) referring to elements of record variables.

+ +

RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.

+

BaseType = qualident.

+

FieldListSequence = FieldList {";" FieldList}.

+

FieldList = IdentList ":" type.

+

IdentList = identdef {"," identdef}.

+ +

If a record type is exported, field identifiers that are to be visible outside the declaring module must be marked. They are called public fields; unmarked fields are called private fields.

+

Record types are extensible, i.e. a record type can be defined as an extension of another record type. In the examples above, CenterNode (directly) extends Node, which is the (direct) base type of CenterNode. More specifically, CenterNode extends Node with the fields name and subnode.

+

Definition: A type T extends a type T0, if it equals T0, or if it directly extends an extension of T0. Conversely, a type T0 is a base type of T, if it equals T, or if it is the direct base type of a base type of T.

+

Examples of record types:

+ +

RECORD day, month, year: INTEGER

+

END

+

RECORD

+

name, firstname: ARRAY 32 OF CHAR;

+

age: INTEGER;

+

salary: REAL

+

END

+
+
<p>6.4. Pointer types</p> +

Variables of a pointer type P assume as values pointers to variables of some type T. It must be a record type. The pointer type P is said to be bound to T, and T is the pointer base type of P. Pointer types inherit the extension relation of their base types, if there is any. If a type T is an extension of T0 and P is a pointer type bound to T, then P is also an extension of P0, the pointer type bound to T0.

+ +

PointerType = POINTER TO type.

+ +

If p is a variable of type P = POINTER TO T, then a call of the predefined procedure NEW(p) has the following effect (see 10.2): A variable of type T is allocated in free storage, and a pointer to it is assigned to p. This pointer p is of type P and the referenced variable p^ is of type T. Failure of allocation results in p obtaining the value NIL. Any pointer variable may be assigned the value NIL, which points to no variable at all.

+
+
<p>6.5. Procedure types</p> +

Variables of a procedure type T have a procedure (or NIL) as value. If a procedure P is assigned to a procedure variable of type T, the (types of the) formal parameters of P must be the same as those indicated in the formal parameters of T. The same holds for the result type in the case of a function procedure (see 10.1). P must not be declared local to another procedure, and neither can it be a standard procedure.

+ +

ProcedureType = PROCEDURE [FormalParameters].

+
+
+
<p>7. Variable declarations</p> +

Variable declarations serve to introduce variables and associate them with identifiers that must be unique within the given scope. They also serve to associate fixed data types with the variables.

+ +

VariableDeclaration = IdentList ":" type.

+ +

Variables whose identifiers appear in the same list are all of the same type. Examples of variable declarations (refer to examples in Ch. 6):

+ +

i, j, k: INTEGER

+

x, y: REAL

+

p, q: BOOLEAN

+

s: SET

+

f: Function

+

a: ARRAY 100 OF REAL

+

w: ARRAY 16 OF

+

RECORD

+

ch: CHAR;

+

count: INTEGER

+

END

+

t: Tree

+
+
<p>8. Expressions</p> +

Expressions are constructs denoting rules of computation whereby constants and current values of variables are combined to derive other values by the application of operators and function procedures. Expressions consist of operands and operators. Parentheses may be used to express specific associations of operators and operands.

+
<p>8.1. Operands</p> +

With the exception of sets and literal constants, i.e. numbers and strings, operands are denoted by designators. A designator consists of an identifier referring to the constant, variable, or procedure to be designated. This identifier may possibly be qualified by module identifiers (see Ch. 4 and 11), and it may be followed by selectors, if the designated object is an element of a structure.

+

If A designates an array, then A[E] denotes that element of A whose index is the current value of the expression E. The type of E must be of type INTEGER. A designator of the form A[E1, E2, ..., En] stands for A[E1][E2] ... [En]. If p designates a pointer variable, p^ denotes the variable which is referenced by p. If r designates a record, then r.f denotes the field f of r. If p designates a pointer, p.f denotes the field f of the record p^, i.e. the dot implies dereferencing and p.f stands for p^.f.

+

The typeguard v(T0) asserts that v is of type T0, i.e. it aborts program execution, if it is not of type T0. The guard is applicable, if

+

1. T0 is an extension of the declared type T of v, and if

+

2. v is a variable parameter of record type, or v is a pointer.

+ +

designator = qualident {selector}.

+

selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".

+

ExpList = expression {"," expression}.

+ +

If the designated object is a variable, then the designator refers to the variable's current value. If the object is a procedure, a designator without parameter list refers to that procedure. If it is followed by a (possibly empty) parameter list, the designator implies an activation of the procedure and stands for the value resulting from its execution. The (types of the) actual parameters must correspond to the formal parameters as specified in the procedure's declaration (see Ch. 10).

+

Examples of designators (see examples in Ch. 7):

+ +

i (INTEGER)

+

a[i] (REAL)

+

w[3].ch (CHAR)

+

t.key (INTEGER)

+

t.left.right (Tree)

+

t(CenterNode).subnode (Tree)

+
+
<p>8.2. Operators</p> +

The syntax of expressions distinguishes between four classes of operators with different precedences (binding strengths). The operator ~ has the highest precedence, followed by multiplication operators, addition operators, and relations. Operators of the same precedence associate from left to right. For example, x-y-z stands for (x-y)-z.

+ +

expression = SimpleExpression [relation SimpleExpression].

+

relation = "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.

+

SimpleExpression = ["+"|"-"] term {AddOperator term}.

+

AddOperator = "+" | "-" | OR.

+

term = factor {MulOperator factor}.

+

MulOperator = "*" | "/" | DIV | MOD | "&" .

+

factor = number | string | NIL | TRUE | FALSE |

+

set | designator [ActualParameters] | "(" expression ")" | "~" factor.

+

set = "{" [element {"," element}] "}".

+

element = expression [".." expression].

+

ActualParameters = "(" [ExpList] ")" .

+ +

The available operators are listed in the following tables. In some instances, several different operations are designated by the same operator symbol. In these cases, the actual operation is identified by the type of the operands.

+
<p><emphasis>8.2.1. Logical operators</emphasis></p> +

symbol result

+ +

OR logical disjunction

+

& logical conjunction

+

~ negation

+ +

These operators apply to BOOLEAN operands and yield a BOOLEAN result.

+ +

p OR q stands for "if p then TRUE, else q"

+

p & q stands for "if p then q, else FALSE"

+

~ p stands for "not p"

+
+
<p><emphasis>8.2.2. Arithmetic operators</emphasis></p> +

symbol result

+ +

+ sum

+

- difference

+

* product

+

/ quotient

+

DIV integer quotient

+

MOD modulus

+ +

The operators +, -, *, and / apply to operands of numeric types. Both operands must be of the same type, which is also the type of the result. When used as unary operators, - denotes sign inversion and + denotes the identity operation.

+

The operators DIV and MOD apply to integer operands only. Let q = x DIV y, and r = x MOD y. Then quotient q and remainder r are defined by the equation

+ +

x = q*y + r 0 <= r < y

+
+
<p><emphasis>8.2.3. Set operators</emphasis></p> +

symbol result

+ +

+ union

+

- difference

+

* intersection

+

/ symmetric set difference

+ +

When used with a single operand of type SET, the minus sign denotes the set complement.

+
+
<p><emphasis>8.2.4. Relations</emphasis></p> +

symbol relation

+ +

= equal

+

# unequal

+

< less

+

<= less or equal

+

> greater

+

>= greater or equal

+

IN set membership

+

IS type test

+ +

Relations are Boolean. The ordering relations <, <=, >, >= apply to the numeric types, CHAR, and character arrays. The relations = and # also apply to the types BOOLEAN and SET, and to pointer and procedure types. The relations <= and >= denote inclusion when applied to sets.

+

x IN s stands for "x is an element of s". x must be of type INTEGER, and s of type SET.

+

v IS T stands for "v is of type T" and is called a type test. It is applicable, if

+

1. T is an extension of the declared type T0 of v, and if

+

2. v is a variable parameter of record type or v is a pointer.

+

Assuming, for instance, that T is an extension of T0 and that v is a designator declared of type T0, then the test v IS T determines whether the actually designated variable is (not only a T0, but also) a T. The value of NIL IS T is undefined.

+

Examples of expressions (refer to examples in Ch. 7):

+ +

1987 (INTEGER)

+

i DIV 3 (INTEGER)

+

~p OR q (BOOLEAN)

+

(i+j) * (i-j) (INTEGER)

+

s - {8, 9, 13} (SET)

+

a[i+j] * a[i-j] (REAL)

+

(0<=i) & (i<100) (BOOLEAN)

+

t.key = 0 (BOOLEAN)

+

k IN {i .. j-1} (BOOLEAN)

+

t IS CenterNode (BOOLEAN)

+
+
+
+
<p>9. Statements</p> +

Statements denote actions. There are elementary and structured statements. Elementary statements are not composed of any parts that are themselves statements. They are the assignment and the procedure call. Structured statements are composed of parts that are themselves statements. They are used to express sequencing and conditional, selective, and repetitive execution. A statement may also be empty, in which case it denotes no action. The empty statement is included in order to relax punctuation rules in statement sequences.

+ +

statement = [assignment | ProcedureCall | IfStatement | CaseStatement |

+

WhileStatement | RepeatStatement | ForStatement].

+
<p>9.1. Assignments</p> +

The assignment serves to replace the current value of a variable by a new value specified by an expression. The assignment operator is written as ":=" and pronounced as becomes.

+ +

assignment = designator ":=" expression.

+ +

If a value parameter is structured (of array or record type), no assignment to it or to its elements are permitted. Neither may assignments be made to imported variables.

+

The type of the expression must be the same as that of the designator. The following exceptions hold:

+

1. The constant NIL can be assigned to variables of any pointer or procedure type.

+

2. Strings can be assigned to any array of characters, provided the number of characters in the string is not greater than that of the array. If it is less, a null character (0X) is appended. Singlecharacter strings can also be assigned to variables of type CHAR.

+

3. In the case of records, the type of the source must be an extension of the type of the destination. Examples of assignments (see examples in Ch. 7):

+ +

i := 0

+

p := i = j

+

x := FLT(i + 1)

+

k := (i + j) DIV 2

+

f := log2

+

s := {2, 3, 5, 7, 11, 13}

+

a[i] := (x+y) * (x-y)

+

t.key := i

+

w[i+1].ch := "A"

+
+
<p>9.2. Procedure calls</p> +

A procedure call serves to activate a procedure. The procedure call may contain a list of actual parameters which are substituted in place of their corresponding formal parameters defined in the procedure declaration (see Ch. 10). The correspondence is established by the positions of the parameters in the lists of actual and formal parameters respectively. There exist two kinds of parameters: variable and value parameters.

+

In the case of variable parameters, the actual parameter must be a designator denoting a variable. If it designates an element of a structured variable, the selector is evaluated when the formal/actual parameter substitution takes place, i.e. before the execution of the procedure. If the parameter is a value parameter, the corresponding actual parameter must be an expression. This expression is evaluated prior to the procedure activation, and the resulting value is assigned to the formal parameter which now constitutes a local variable (see also 10.1.).

+ +

ProcedureCall = designator [ActualParameters].

+ +

Examples of procedure calls:

+ +

ReadInt(i) (see Ch. 10)

+

WriteInt(2*j + 1, 6)

+

INC(w[k].count)

+
+
<p>9.3. Statement sequences</p> +

Statement sequences denote the sequence of actions specified by the component statements which are separated by semicolons.

+ +

StatementSequence = statement {";" statement}.

+
+
<p>9.4. If statements</p> +

IfStatement = IF expression THEN StatementSequence

+

{ELSIF expression THEN StatementSequence}

+

[ELSE StatementSequence]

+

END.

+ +

If statements specify the conditional execution of guarded statements. The Boolean expression preceding a statement is called its guard. The guards are evaluated in sequence of occurrence, until one evaluates to TRUE, whereafter its associated statement sequence is executed. If no guard is satisfied, the statement sequence following the symbol ELSE is executed, if there is one.

+

Example:

+ +

IF (ch >= "A") & (ch <= "Z") THEN ReadIdentifier

+

ELSIF (ch >= "0") & (ch <= "9") THEN ReadNumber

+

ELSIF ch = 22X THEN ReadString

+

END

+
+
<p>9.5. Case statements</p> +

Case statements specify the selection and execution of a statement sequence according to the value of an expression. First the case expression is evaluated, then the statement sequence is executed whose case label list contains the obtained value. The case expression must be of type INTEGER or CHAR, and all labels must be integers or single-character strings, respectively.

+ +

CaseStatement = CASE expression OF case {"|" case} END.

+

case = [CaseLabelList ":" StatementSequence].

+

CaseLabelList = LabelRange {"," LabelRange}.

+

LabelRange = label [".." label].

+

label = integer | string | ident.

+ +

Example:

+ +

CASE k OF

+

0: x := x + y

+

| 1: x := x - y

+

| 2: x := x * y

+

| 3: x := x / y

+

END

+
+
<p>9.6. While statements</p> +

While statements specify repetition. If any of the Boolean expressions (guards) yields TRUE, the corresponding statement sequence is executed. The expression evaluation and the statement execution are repeated until none of the Boolean expressions yields TRUE.

+ +

WhileStatement = WHILE expression DO StatementSequence

+

{ELSIF expression DO StatementSequence} END.

+ +

Examples:

+ +

WHILE j > 0 DO

+

j := j DIV 2; i := i+1

+

END

+

WHILE (t # NIL) & (t.key # i) DO

+

t := t.left

+

END

+

WHILE m > n DO m := m - n

+

ELSIF n > m DO n := n - m

+

END

+
+
<p>9.7. Repeat Statements</p> +

A repeat statement specifies the repeated execution of a statement sequence until a condition is satisfied. The statement sequence is executed at least once.

+ +

RepeatStatement = REPEAT StatementSequence UNTIL expression.

+
+
<p>9.8. For statements</p> +

A for statement specifies the repeated execution of a statement sequence for a given number of times, while a progression of values is assigned to an integer variable called the control variable of the for statement.

+ +

ForStatement =

+

FOR ident ":=" expression TO expression [BY ConstExpression] DO

+

StatementSequence END .

+ +

The for statement

+ +

FOR v := beg TO end BY inc DO S END

+ +is, if inc > 0, equivalent to + +

v := beg; lim := end;

+

WHILE v <= lim DO S; v := v + inc END

+ +and if inc < 0 it is equivalent to + +

v := beg; lim := end;

+

WHILE v >= lim DO S; v := v + inc END

+ +

The types of v, beg and end must be INTEGER, and inc must be an integer (constant expression). If the step is not specified, it is assumed to be 1.

+
+
+
<p>10. Procedure declarations</p> +

Procedure declarations consist of a procedure heading and a procedure body. The heading specifies the procedure identifier, the formal parameters, and the result type (if any). The body contains declarations and statements. The procedure identifier is repeated at the end of the procedure declaration.

+

There are two kinds of procedures, namely proper procedures and function procedures. The latter are activated by a function designator as a constituent of an expression, and yield a result that is an operand in the expression. Proper procedures are activated by a procedure call. A function procedure is distinguished in the declaration by indication of the type of its result following the parameter list. Its body must end with a RETURN clause which defines the result of the function procedure.

+

All constants, variables, types, and procedures declared within a procedure body are local to the procedure. The values of local variables are undefined upon entry to the procedure. Since procedures may be declared as local objects too, procedure declarations may be nested.

+

In addition to its formal parameters and locally declared objects, the objects declared in the environment of the procedure are also visible in the procedure (with the exception of variables and of those objects that have the same name as an object declared locally).

+

The use of the procedure identifier in a call within its declaration implies recursive activation of the procedure.

+ +

ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.

+

ProcedureHeading = PROCEDURE identdef [FormalParameters].

+

ProcedureBody = DeclarationSequence [BEGIN StatementSequence]

+

[RETURN expression] END.

+

DeclarationSequence = [CONST {ConstantDeclaration ";"}]

+

[TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"}]

+

{ProcedureDeclaration ";"}.

+
<p>10.1. Formal parameters</p> +

Formal parameters are identifiers which denote actual parameters specified in the procedure call. The correspondence between formal and actual parameters is established when the procedure is called. There are two kinds of parameters, namely value and variable parameters. A variable parameter corresponds to an actual parameter that is a variable, and it stands for that variable. A value parameter corresponds to an actual parameter that is an expression, and it stands for its value, which cannot be changed by assignment. However, if a value parameter is of a scalar type, it represents a local variable to which the value of the actual expression is initially assigned.

+

The kind of a parameter is indicated in the formal parameter list: Variable parameters are denoted by the symbol VAR and value parameters by the absence of a prefix.

+

A function procedure without parameters must have an empty parameter list. It must be called by a function designator whose actual parameter list is empty too.

+

Formal parameters are local to the procedure, i.e. their scope is the program text which constitutes the procedure declaration.

+ +

FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].

+

FPSection = [VAR] ident {"," ident} ":" FormalType.

+

FormalType = {ARRAY OF} qualident.

+ +

The type of each formal parameter is specified in the parameter list. For variable parameters, it must be identical to the corresponding actual parameter's type, except in the case of a record, where it must be a base type of the corresponding actual parameter's type.

+

If the formal parameter's type is specified as

+ +

ARRAY OF T

+ +the parameter is said to be an open array, and the corresponding actual parameter may be of arbitrary length. +

If a formal parameter specifies a procedure type, then the corresponding actual parameter must be either a procedure declared globally, or a variable (or parameter) of that procedure type. It cannot be a predefined procedure. The result type of a procedure can be neither a record nor an array.

+

Examples of procedure declarations:

+ +

PROCEDURE ReadInt(VAR x: INTEGER);

+

VAR i : INTEGER; ch: CHAR;

+

BEGIN i := 0; Read(ch);

+

WHILE ("0" <= ch) & (ch <= "9") DO

+

i := 10*i + (ORD(ch)-ORD("0")); Read(ch)

+

END ;

+

x := i

+

END ReadInt

+ +

PROCEDURE WriteInt(x: INTEGER); (* 0 <= x < 10^5 *)

+

VAR i: INTEGER;

+

buf: ARRAY 5 OF INTEGER;

+

BEGIN i := 0;

+

REPEAT buf[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;

+

REPEAT DEC(i); Write(CHR(buf[i] + ORD("0"))) UNTIL i = 0

+

END WriteInt

+ +

PROCEDURE log2(x: INTEGER): INTEGER;

+

VAR y: INTEGER; (*assume x>0*)

+

BEGIN y := 0;

+

WHILE x > 1 DO x := x DIV 2; INC(y) END ;

+

RETURN y

+

END log2

+
+
<p>10.2. Predefined procedures</p> +

The following table lists the predefined procedures. Some are generic procedures, i.e. they apply to several types of operands. v stands for a variable, x and n for expressions, and T for a type.

+ +

Function procedures:

+ +

Name Argument type Result type Function

+ +

ABS(x) numeric type type of x absolute value

+

ODD(x) INTEGER BOOLEAN x MOD 2 = 1

+

LEN(v) v: array INTEGER the length of v

+

LSL(x, n) x, n: INTEGER type of x logical shift left, x * 2n

+

ASR(x, n) x, n: INTEGER type of x signed shift right, x DIV 2n

+

ROR(x, n) x. n: INTEGER type of x x rotated right by n bits

+ +

Type conversion functions:

+ +

Name Argument type Result type Function

+ +

FLOOR(x) REAL, LONGREAL INTEGER largest integer <= x

+

FLT(x) INTEGER REAL identity

+

ORD(x) CHAR, BOOLEAN, SET INTEGER ordinal number of x

+

CHR(x) INTEGER CHAR character with ordinal number x

+

LONG(x) REAL LONGREAL x

+

SHORT(x) LONGREAL REAL x

+ +

Proper procedures:

+ +

Name Argument types Function

+ +

INC(v) INTEGER v := v + 1

+

INC(v, n) INTEGER v := v + n

+

DEC(v) INTEGER v := v - 1

+

DEC(v, n) INTEGER v := v - n

+

INCL(v, x) v: SET; x: INTEGER v := v + {x}

+

EXCL(v, x) v: SET; x: INTEGER v := v - {x}

+

COPY(x, v) x: character array, string v := x

+

v: character array

+

NEW(v) pointer type allocate v^

+

ASSERT(b) BOOLEAN abort, if ~b

+

ASSERT(b, n) BOOLEAN, INTEGER

+

PACK(x, y) REAL; INTEGER pack x and y into x

+

UNPK(x, y) REAL; INTEGER unpack x into x and y

+ +

Procedures INC and DEC may have an explicit increment or decrement. It must be a constant. Also for INCL and EXCL, x must be a constant. The second parameter n of ASSERT is a value transmitted to the system as an abort parameter.

+

The parameter y of PACK represents the exponent of x. PACK(x, y) is equivalent to x := x * 2y. UNPK is the reverse operation of PACK. The resulting x is normalized, i.e. 1.0 <= x < 2.0.

+
+
+
<p>11. Modules</p> +

A module is a collection of declarations of constants, types, variables, and procedures, and a sequence of statements for the purpose of assigning initial values to the variables. A module typically constitutes a text that is compilable as a unit.

+ +

module = MODULE ident ";" [ImportList ";"] DeclarationSequence

+

[BEGIN StatementSequence] END ident "." .

+

ImportList = IMPORT import {"," import} ";" .

+

Import = ident [":=" ident].

+ +

The import list specifies the modules of which the module is a client. If an identifier x is exported from a module M, and if M is listed in a module's import list, then x is referred to as M.x. If the form "M := M1" is used in the import list, an exported object x declared within M1 is referenced in the importing module as M.x .

+

Identifiers that are to be visible in client modules, i.e. which are to be exported, must be marked by an asterisk (export mark) in their declaration. Variables cannot be exported, with the exception of those of scalar types in read-only mode.

+

The statement sequence following the symbol BEGIN is executed when the module is added to a system (loaded). Individual (parameterless) procedures can thereafter be activated from the system, and these procedures serve as commands.

+

Example:

+ +

MODULE Out; (*exported procedures: Write, WriteInt, WriteLn*)

+

IMPORT Texts, Oberon;

+

VAR W: Texts.Writer;

+ +

PROCEDURE Write*(ch: CHAR);

+

BEGIN Texts.Write(W, ch)

+

END ;

+ +

PROCEDURE WriteInt*(x, n: INTEGER);

+

VAR i: INTEGER; a: ARRAY 16 OF CHAR;

+

BEGIN i := 0;

+

IF x < 0 THEN Texts.Write(W, "-"); x := -x END ;

+

REPEAT a[i] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(i) UNTIL x = 0;

+

REPEAT Texts.Write(W, " "); DEC(n) UNTIL n <= i;

+

REPEAT DEC(i); Texts.Write(W, a[i]) UNTIL i = 0

+

END WriteInt;

+ +

PROCEDURE WriteLn*;

+

BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)

+

END WriteLn;

+ +

BEGIN Texts.OpenWriter(W)

+

END Out.

+
<p>11.1 The Module SYSTEM</p> +

The optional module SYSTEM contains definitions that are necessary to program low-level operations referring directly to resources particular to a given computer and/or implementation. These include for example facilities for accessing devices that are controlled by the computer, and perhaps facilities to break the data type compatibility rules otherwise imposed by the language definition. It is strongly recommended to restrict their use to specific low-level modules, as such modules are inherently non-portable and not "type-safe". However, they are easily recognized due to the identifier SYSTEM appearing in their import lists. The subsequent definitions are generally applicable. However, individual implementations may include in their module SYSTEM additional definitions that are particular to the specific, underlying computer. In the following, v stands for a variable, x, a, and n for expressions.

+ +

Function procedures:

+ +

Name Argument types Result type Function

+ +

ADR(v) any INTEGER address of variable v

+

SIZE(T) any type INTEGER size in bytes

+

BIT(a, n) a, n: INTEGER BOOLEAN bit n of mem[a]

+ +

Proper procedures:

+ +

Name Argument types Function

+ +

GET(a, v) a: INTEGER; v: any basic type v := mem[a]

+

PUT(a, x) a: INTEGER; x: any basic type mem[a] := x

+
+
+
<p>Appendix</p><p>The Syntax of Oberon</p> +

letter = "A" | "B" | … | "Z" | "a" | "b" | … | "z".

+

digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".

+

hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".

+

ident = letter {letter | digit}.

+

qualident = [ident "."] ident.

+

identdef = ident ["*"].

+

integer = digit {digit} | digit {hexDigit} "H".

+

real = digit {digit} "." {digit} [ScaleFactor].

+

ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.

+

number = integer | real.

+

string = """ {character} """ | digit {hexDigit} "X".

+

ConstantDeclaration = identdef "=" ConstExpression.

+

ConstExpression = expression.

+

TypeDeclaration = identdef "=" StrucType.

+

StrucType = ArrayType | RecordType | PointerType | ProcedureType.

+

type = qualident | StrucType.

+

ArrayType = ARRAY length {"," length} OF type.

+

length = ConstExpression.

+

RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.

+

BaseType = qualident.

+

FieldListSequence = FieldList {";" FieldList}.

+

FieldList = IdentList ":" type.

+

IdentList = identdef {"," identdef}.

+

PointerType = POINTER TO type.

+

ProcedureType = PROCEDURE [FormalParameters].

+

VariableDeclaration = IdentList ":" type.

+

expression = SimpleExpression [relation SimpleExpression].

+

relation = "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.

+

SimpleExpression = ["+" | "-"] term {AddOperator term}.

+

AddOperator = "+" | "-" | OR.

+

term = factor {MulOperator factor}.

+

MulOperator = "*" | "/" | DIV | MOD | "&".

+

factor = number | string | NIL | TRUE | FALSE |

+

set | designator [ActualParameters] | "(" expression ")" | "~" factor.

+

designator = qualident {selector}.

+

selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".

+

set = "{" [element {"," element}] "}".

+

element = expression [".." expression].

+

ExpList = expression {"," expression}.

+

ActualParameters = "(" [ExpList] ")" .

+

statement = [assignment | ProcedureCall | IfStatement | CaseStatement |

+

WhileStatement | RepeatStatement | ForStatement].

+

assignment = designator ":=" expression.

+

ProcedureCall = designator [ActualParameters].

+

StatementSequence = statement {";" statement}.

+

IfStatement = IF expression THEN StatementSequence

+

{ELSIF expression THEN StatementSequence}

+

[ELSE StatementSequence] END.

+

CaseStatement = CASE expression OF case {"|" case} END.

+

case = [CaseLabelList ":" StatementSequence].

+

CaseLabelList = LabelRange {"," LabelRange}.

+

LabelRange = label [".." label].

+

label = integer | string | ident.

+

WhileStatement = WHILE expression DO StatementSequence

+

{ELSIF expression DO StatementSequence} END.

+

RepeatStatement = REPEAT StatementSequence UNTIL expression.

+

ForStatement = FOR ident ":=" expression TO expression [BY ConstExpression]

+

DO StatementSequence END.

+

ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.

+

ProcedureHeading = PROCEDURE identdef [FormalParameters].

+

ProcedureBody = DeclarationSequence [BEGIN StatementSequence]

+

[RETURN expression] END.

+

DeclarationSequence = [CONST {ConstDeclaration ";"}]

+

[TYPE {TypeDeclaration ";"}]

+

[VAR {VariableDeclaration ";"}]

+

{ProcedureDeclaration ";"}.

+

FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].

+

FPSection = [VAR] ident {"," ident} ":" FormalType.

+

FormalType = {ARRAY OF} qualident.

+

module = MODULE ident ";" [ImportList] DeclarationSequence

+

[BEGIN StatementSequence] END ident "." .

+

ImportList = IMPORT import {"," import} ";".

+

import = ident [":=" ident].

+
+
+ + + + + diff --git a/programs/develop/oberon07/Lib/KolibriOS/API.ob07 b/programs/develop/oberon07/Lib/KolibriOS/API.ob07 new file mode 100644 index 0000000000..1d27b1c24e --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/API.ob07 @@ -0,0 +1,193 @@ +(* + 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 . +*) + +MODULE API; + +IMPORT sys := SYSTEM; + +CONST + + MAX_SIZE = 16 * 400H; + HEAP_SIZE = 1 * 100000H; + +VAR + + heap, endheap: INTEGER; + pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER; + +PROCEDURE [stdcall] zeromem*(size, adr: INTEGER); +BEGIN + sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") +END zeromem; + +PROCEDURE strncmp*(a, b, n: INTEGER): INTEGER; +VAR A, B: CHAR; Res: INTEGER; +BEGIN + Res := 0; + WHILE n > 0 DO + sys.GET(a, A); INC(a); + sys.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 [stdcall] sysfunc1(arg1: INTEGER): INTEGER; +BEGIN + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20400"); (* ret 04h *) + RETURN 0 +END sysfunc1; + +PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20800"); (* ret 08h *) + RETURN 0 +END sysfunc2; + +PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc3; + +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 + sys.GET(res, pockets[idx]); + sys.PUT(res, size); + INC(res, 4) + ELSE + IF heap + size >= endheap THEN + IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN + heap := sysfunc3(68, 12, HEAP_SIZE); + endheap := heap + HEAP_SIZE + ELSE + heap := 0 + END + END; + IF heap # 0 THEN + sys.PUT(heap, size); + res := heap + 4; + heap := heap + size + ELSE + endheap := 0; + res := 0 + END + END + ELSE + IF sysfunc2(18, 16) > ASR(size, 10) THEN + res := sysfunc3(68, 12, size); + sys.PUT(res, size); + INC(res, 4) + ELSE + res := 0 + END + END; + IF res # 0 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); + sys.GET(ptr, size); + IF size <= MAX_SIZE THEN + idx := ASR(size, 5); + sys.PUT(ptr, pockets[idx]); + pockets[idx] := ptr + ELSE + size := sysfunc3(68, 13, ptr) + END + RETURN 0 +END _DISPOSE; + +PROCEDURE ExitProcess*(p1: INTEGER); +BEGIN + p1 := sysfunc1(-1) +END ExitProcess; + +PROCEDURE OutChar(c: CHAR); +VAR res: INTEGER; +BEGIN + res := sysfunc3(63, 1, ORD(c)) +END OutChar; + +PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER); +VAR c: CHAR; +BEGIN + IF lpCaption # 0 THEN + OutChar(0DX); + OutChar(0AX); + REPEAT + sys.GET(lpCaption, c); + IF c # 0X THEN + OutChar(c) + END; + INC(lpCaption) + UNTIL c = 0X; + OutChar(":"); + OutChar(0DX); + OutChar(0AX) + END; + REPEAT + sys.GET(lpText, c); + IF c # 0X THEN + OutChar(c) + END; + INC(lpText) + UNTIL c = 0X; + IF lpCaption # 0 THEN + OutChar(0DX); + OutChar(0AX) + END +END DebugMsg; + +PROCEDURE init* (p1: INTEGER); +BEGIN + p1 := sysfunc2(68, 11) +END init; + +END API. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Args.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Args.ob07 new file mode 100644 index 0000000000..d3bfcb1312 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Args.ob07 @@ -0,0 +1,100 @@ +(* + 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 . +*) + +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); + 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); IF cond = 1 THEN Params[count, 0] := p END + |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END + |3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END + |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END + |5: ChangeCond(5, 1, 5); 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 + 1 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. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 b/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 new file mode 100644 index 0000000000..763ef55cd4 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 @@ -0,0 +1,105 @@ +(* + 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 . +*) + +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.ADR("/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(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(sys.ADR(Dialog_init), "ColorDialog_init"); + GetProc(sys.ADR(Dialog_start), "ColorDialog_start"); +END Load; + +BEGIN + Load +END ColorDlg. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Console.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Console.ob07 new file mode 100644 index 0000000000..140800c739 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Console.ob07 @@ -0,0 +1,66 @@ +(* + 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 . +*) + +MODULE Console; + +IMPORT ConsoleLib; + +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; + +END Console. diff --git a/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07 b/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07 new file mode 100644 index 0000000000..a9a76fffb7 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07 @@ -0,0 +1,101 @@ +(* + 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 . +*) + +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); + +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(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(sys.ADR(version), "version"); + GetProc(sys.ADR(init), "con_init"); + GetProc(sys.ADR(exit), "con_exit"); + GetProc(sys.ADR(write_asciiz), "con_write_asciiz"); + GetProc(sys.ADR(write_string), "con_write_string"); + GetProc(sys.ADR(get_flags), "con_get_flags"); + GetProc(sys.ADR(set_flags), "con_set_flags"); + GetProc(sys.ADR(get_font_height), "con_get_font_height"); + GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height"); + GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height"); + GetProc(sys.ADR(getch), "con_getch"); + GetProc(sys.ADR(getch2), "con_getch2"); + GetProc(sys.ADR(kbhit), "con_kbhit"); + GetProc(sys.ADR(gets), "con_gets"); + GetProc(sys.ADR(gets2), "con_gets2"); + GetProc(sys.ADR(cls), "con_cls"); + GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos"); + GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos"); +END main; + +BEGIN + main +END ConsoleLib. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 b/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 new file mode 100644 index 0000000000..e87e132ed3 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 @@ -0,0 +1,140 @@ +(* + 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 . +*) + +MODULE DateTime; + +IMPORT KOSAPI; + +CONST ERR* = -7.0D5; + +PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL; +VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL; +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 := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0 + END + END + RETURN Res +END Encode; + +PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN; +VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR; + + PROCEDURE MonthDay(n: INTEGER): 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.0D0) & (Date < 2958466.0D0) THEN + d := FLOOR(Date); + t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0); + 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); + 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: 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 +END Now; + +END DateTime. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 new file mode 100644 index 0000000000..a376a11c54 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 @@ -0,0 +1,287 @@ +(* + 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 . +*) + +MODULE Debug; + +IMPORT KOSAPI, sys := SYSTEM; + +CONST + + d = 1.0D0 - 5.0D-12; + +VAR + + Realp: PROCEDURE (x: LONGREAL; 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: LONGREAL): 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: LONGREAL): BOOLEAN; + RETURN ABS(x) = sys.INF(LONGREAL) +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: LONGREAL; width: INTEGER); +VAR s: ARRAY 4 OF CHAR; i: INTEGER; +BEGIN + IF IsNan(x) THEN + s := "Nan"; + INC(width) + ELSIF IsInf(x) & (x > 0.0D0) THEN + s := "+Inf" + ELSIF IsInf(x) & (x < 0.0D0) 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: LONGREAL; width, p: INTEGER); +VAR e, len, i: INTEGER; y: LONGREAL; 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.0D0 THEN + minus := TRUE; + INC(len); + x := ABS(x) + END; + e := 0; + WHILE x >= 10.0D0 DO + x := x / 10.0D0; + INC(e) + END; + IF e >= 0 THEN + len := len + e + p + 1; + IF x > 9.0D0 + 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.0D0) & (y # 0.0D0) DO + y := y * 10.0D0; + DEC(e) + END; + IF e < 0 THEN + IF x - LONG(FLT(FLOOR(x))) > d THEN + Char("1"); + x := 0.0D0 + ELSE + Char("0"); + x := x * 10.0D0 + END + ELSE + WHILE e >= 0 DO + IF x - LONG(FLT(FLOOR(x))) > d THEN + IF x > 9.0D0 THEN + String("10") + ELSE + Char(CHR(FLOOR(x) + ORD("0") + 1)) + END; + x := 0.0D0 + ELSE + Char(CHR(FLOOR(x) + ORD("0"))); + x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 + END; + DEC(e) + END + END; + IF p > 0 THEN + Char(".") + END; + WHILE p > 0 DO + IF x - LONG(FLT(FLOOR(x))) > d THEN + Char(CHR(FLOOR(x) + ORD("0") + 1)); + x := 0.0D0 + ELSE + Char(CHR(FLOOR(x) + ORD("0"))); + x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 + END; + DEC(p) + END + END +END FixReal; + +PROCEDURE Real*(x: LONGREAL; 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.0D0 THEN + x := -x; + minus := TRUE + ELSE + minus := FALSE + END; + WHILE x >= 10.0D0 DO + x := x / 10.0D0; + INC(e) + END; + WHILE (x < 1.0D0) & (x # 0.0D0) DO + x := x * 10.0D0; + DEC(e) + END; + IF x > 9.0D0 + d THEN + x := 1.0D0; + INC(e) + END; + FOR i := 1 TO n DO + Char(" ") + END; + IF minus THEN + x := -x + END; + FixReal(x, width, width - 3); + Char("E"); + IF e >= 0 THEN + Char("+") + ELSE + Char("-"); + e := ABS(e) + END; + IF e < 100 THEN + Char("0") + END; + IF e < 10 THEN + Char("0") + END; + Int(e, 0) + END +END Real; + +PROCEDURE 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.ADR(" "); + info.rsrvd1 := 0; + info.rsrvd2 := 0; + info.fname := "/rd/1/develop/board"; + res := KOSAPI.sysfunc2(70, sys.ADR(info)) +END Open; + +BEGIN + Realp := Real +END Debug. diff --git a/programs/develop/oberon07/Lib/KolibriOS/File.ob07 b/programs/develop/oberon07/Lib/KolibriOS/File.ob07 new file mode 100644 index 0000000000..684853b6db --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/File.ob07 @@ -0,0 +1,255 @@ +(* + 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 . +*) + +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("53"); (* push ebx *) + sys.CODE("6A44"); (* push 68 *) + sys.CODE("58"); (* pop eax *) + sys.CODE("6A1B"); (* push 27 *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *) + sys.CODE("8911"); (* mov [ecx], edx *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20800"); (* ret 08h *) + 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 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. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 b/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 new file mode 100644 index 0000000000..8e7d1d763d --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 @@ -0,0 +1,270 @@ +(* + 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 . +*) + +MODULE HOST; + +IMPORT sys := SYSTEM, API; + +CONST + + OS* = "KOS"; + Slash* = "/"; + +TYPE + + FILENAME = ARRAY 2048 OF CHAR; + + OFSTRUCT = RECORD + subfunc, pos, hpos, bytes, buf: INTEGER; + name: FILENAME + END; + +VAR + + con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER); + con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN); + con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER); + + fsize, sec*, dsec*: INTEGER; + +PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER; +BEGIN + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20400"); (* ret 04h *) + RETURN 0 +END sysfunc1; + +PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20800"); (* ret 08h *) + RETURN 0 +END sysfunc2; + +PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc3; + +PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8919"); (* mov [ecx], ebx *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc22; + +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 + sys.GET(str1, c1); + sys.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 + sys.GET(cur, procname); + INC(cur, 8) + UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0])); + IF procname # 0 THEN + sys.GET(cur - 4, adr) + END + END + RETURN adr +END GetProcAdr; + +PROCEDURE Time*(VAR sec, dsec: INTEGER); +VAR t: INTEGER; +BEGIN + t := sysfunc2(26, 9); + sec := t DIV 100; + dsec := t MOD 100 +END Time; + +PROCEDURE init*; +VAR Lib: INTEGER; + + PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR); + VAR a: INTEGER; + BEGIN + a := GetProcAdr(name, Lib); + sys.PUT(v, a) + END GetProc; + +BEGIN + Time(sec, dsec); + Lib := sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj")); + IF Lib # 0 THEN + GetProc(sys.ADR(con_init), "con_init"); + GetProc(sys.ADR(con_exit), "con_exit"); + GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz"); + IF con_init # NIL THEN + con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS")) + END + END +END init; + +PROCEDURE ExitProcess* (n: INTEGER); +BEGIN + IF con_exit # NIL THEN + con_exit(FALSE) + END; + n := sysfunc1(-1) +END ExitProcess; + +PROCEDURE GetCommandLine*(): INTEGER; +VAR param: INTEGER; +BEGIN + sys.GET(28, param) + RETURN param +END GetCommandLine; + +PROCEDURE GetName*(): INTEGER; +VAR name: INTEGER; +BEGIN + sys.GET(32, name) + RETURN name +END GetName; + +PROCEDURE malloc*(size: INTEGER): INTEGER; + RETURN sysfunc3(68, 12, size) +END malloc; + +PROCEDURE CloseFile*(hObject: INTEGER); +VAR pFS: POINTER TO OFSTRUCT; +BEGIN + sys.PUT(sys.ADR(pFS), hObject); + DISPOSE(pFS) +END CloseFile; + +PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER; +VAR buf: ARRAY 40 OF CHAR; res: INTEGER; +BEGIN + FS.subfunc := mode; + FS.pos := 0; + FS.hpos := 0; + FS.bytes := 0; + FS.buf := sys.ADR(buf); + COPY(FileName, FS.name); + IF sysfunc22(70, sys.ADR(FS), res) = 0 THEN + res := sys.ADR(FS); + sys.GET(sys.ADR(buf) + 32, fsize) + ELSE + res := 0 + END + RETURN res +END _OCFile; + +PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER; +VAR res1, res: INTEGER; +BEGIN + FS.subfunc := io; + FS.bytes := bytes; + FS.buf := Buffer; + res1 := sysfunc22(70, sys.ADR(FS), res); + IF res = -1 THEN + res := 0 + END; + FS.pos := FS.pos + res + RETURN res +END IOFile; + +PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER; +VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER; +BEGIN + IF _OCFile(FName, FS, mode, fsize) # 0 THEN + NEW(pFS); + IF pFS = NIL THEN + res := 0 + ELSE + sys.GET(sys.ADR(pFS), res); + pFS^ := FS + END + ELSE + res := 0 + END + RETURN res +END OCFile; + +PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; + RETURN OCFile(FName, 2) +END CreateFile; + +PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; + RETURN OCFile(FName, 5) +END OpenFile; + +PROCEDURE FileSize* (F: INTEGER): INTEGER; + RETURN fsize +END FileSize; + +PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; +VAR pFS: POINTER TO OFSTRUCT; res: INTEGER; +BEGIN + IF hFile # 0 THEN + sys.PUT(sys.ADR(pFS), hFile); + res := IOFile(pFS^, Buffer, nNumberOfBytes, 3 * ORD(write)) + ELSE + res := 0 + END + RETURN res +END FileRW; + +PROCEDURE OutString* (str: ARRAY OF CHAR); +VAR n: INTEGER; +BEGIN + n := ORD(str[0] = 3X); + IF con_write_asciiz # NIL THEN + con_write_asciiz(sys.ADR(str[n])) + ELSE + API.DebugMsg(sys.ADR(str[n]), 0) + END +END OutString; + +END HOST. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/In.ob07 b/programs/develop/oberon07/Lib/KolibriOS/In.ob07 new file mode 100644 index 0000000000..e2c740decc --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/In.ob07 @@ -0,0 +1,296 @@ +(* + 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 . +*) + +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): LONGREAL; +CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH; +VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN; + + PROCEDURE part1(): BOOLEAN; + BEGIN + res := 0.0D0; + d := 1.0D0; + WHILE digit(str[i]) DO + res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0"))); + INC(i) + END; + IF str[i] = "." THEN + INC(i); + WHILE digit(str[i]) DO + d := d / 10.0D0; + res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d; + INC(i) + END + END + RETURN str[i] # 0X + END part1; + + PROCEDURE part2(): BOOLEAN; + BEGIN + INC(i); + m := 10.0D0; + minus := FALSE; + IF str[i] = "+" THEN + INC(i) + ELSIF str[i] = "-" THEN + minus := TRUE; + INC(i); + m := 0.1D0 + END; + scale := 0; + err := FALSE; + WHILE ~err & digit(str[i]) DO + IF scale > maxINT DIV 10 THEN + err := TRUE; + res := 0.0D0 + ELSE + scale := scale * 10; + IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN + err := TRUE; + res := 0.0D0 + ELSE + scale := scale + (ORD(str[i]) - ORD("0")); + INC(i) + END + END + END + RETURN ~err + END part2; + + PROCEDURE part3; + VAR i: INTEGER; + BEGIN + err := FALSE; + IF scale = maxINT THEN + err := TRUE; + res := 0.0D0 + END; + i := 1; + WHILE ~err & (i <= scale) DO + IF ~minus & (res > maxDBL / m) THEN + err := TRUE; + res := 0.0D0 + ELSE + res := res * m; + INC(i) + END + END + END part3; + +BEGIN + IF CheckReal(str, i, neg) THEN + IF part1() & part2() THEN + part3 + END; + IF neg THEN + res := -res + END + ELSE + res := 0.0D0; + 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 LongReal*(VAR x: LONGREAL); +VAR str: STRING; err: BOOLEAN; +BEGIN + err := FALSE; + REPEAT + String(str) + UNTIL ~Space(str); + x := StrToFloat(str, err); + Done := ~err +END LongReal; + +PROCEDURE Real*(VAR x: REAL); +CONST maxREAL = 3.39E38; +VAR y: LONGREAL; +BEGIN + LongReal(y); + IF Done THEN + IF ABS(y) > LONG(maxREAL) THEN + x := 0.0; + Done := FALSE + ELSE + x := SHORT(y) + END + END +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. diff --git a/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07 b/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07 new file mode 100644 index 0000000000..06f2fcf802 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07 @@ -0,0 +1,323 @@ +(* + 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 . +*) + +MODULE KOSAPI; + +IMPORT sys := SYSTEM; + +TYPE STRING = ARRAY 1024 OF CHAR; + +VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER); + +PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER; +BEGIN + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20400"); (* ret 04h *) + RETURN 0 +END sysfunc1; + +PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20800"); (* ret 08h *) + RETURN 0 +END sysfunc2; + +PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc3; + +PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C21000"); (* ret 10h *) + RETURN 0 +END sysfunc4; + +PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("56"); (* push esi *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) + sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5E"); (* pop esi *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C21400"); (* ret 14h *) + RETURN 0 +END sysfunc5; + +PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("56"); (* push esi *) + sys.CODE("57"); (* push edi *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) + sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) + sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5F"); (* pop edi *) + sys.CODE("5E"); (* pop esi *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C21800"); (* ret 18h *) + RETURN 0 +END sysfunc6; + +PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("56"); (* push esi *) + sys.CODE("57"); (* push edi *) + sys.CODE("55"); (* push ebp *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) + sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) + sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *) + sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5D"); (* pop ebp *) + sys.CODE("5F"); (* pop edi *) + sys.CODE("5E"); (* pop esi *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C21C00"); (* ret 1Ch *) + RETURN 0 +END sysfunc7; + +PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8919"); (* mov [ecx], ebx *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc22; + +PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER; +BEGIN + sys.CODE("60"); (* pusha *) + size := sysfunc3(68, 12, size); + sys.CODE("61") (* popa *) + RETURN size +END malloc; + +PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER; +BEGIN + sys.CODE("60"); (* pusha *) + IF ptr # 0 THEN + ptr := sysfunc3(68, 13, ptr) + END; + sys.CODE("61") (* popa *) + RETURN 0 +END free; + +PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER; +BEGIN + sys.CODE("60"); (* pusha *) + ptr := sysfunc4(68, 20, size, ptr); + sys.CODE("61") (* popa *) + RETURN ptr +END realloc; + +PROCEDURE GetCommandLine*(): INTEGER; +VAR param: INTEGER; +BEGIN + sys.GET(28, param) + RETURN param +END GetCommandLine; + +PROCEDURE GetName*(): INTEGER; +VAR name: INTEGER; +BEGIN + sys.GET(32, name) + RETURN name +END GetName; + +PROCEDURE [stdcall] dll_init2(arg1, arg2, arg3, arg4, arg5: INTEGER); +BEGIN + sys.CODE("60"); (* pusha *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *) + sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *) + sys.CODE("FFD6"); (* call esi *) + sys.CODE("61"); (* popa *) + sys.CODE("C9"); (* leave *) + sys.CODE("C21400"); (* ret 14h *) +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 + sys.GET(str1, c1); + sys.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 + sys.GET(cur, procname); + INC(cur, 8) + UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0])); + IF procname # 0 THEN + sys.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 [stdcall] dll_Load(import_table: INTEGER): INTEGER; +VAR imp, lib, exp, proc, res: INTEGER; + fail, done: BOOLEAN; + procname, libname: STRING; + + PROCEDURE GetStr(adr, i: INTEGER; VAR str: STRING); + VAR c: CHAR; + BEGIN + REPEAT + sys.GET(adr, c); INC(adr); + str[i] := c; INC(i) + UNTIL c = 0X + END GetStr; + +BEGIN + sys.CODE("60"); (* pusha *) + fail := FALSE; + done := FALSE; + res := 0; + libname := "/rd/1/lib/"; + REPEAT + sys.GET(import_table, imp); + IF imp # 0 THEN + sys.GET(import_table + 4, lib); + GetStr(lib, 10, libname); + exp := sysfunc3(68, 19, sys.ADR(libname[0])); + fail := exp = 0; + ELSE + done := TRUE + END; + IF fail THEN + done := TRUE + END; + IF (imp # 0) & ~fail THEN + REPEAT + sys.GET(imp, proc); + IF proc # 0 THEN + GetStr(proc, 0, procname); + proc := GetProcAdr(procname, exp); + IF proc # 0 THEN + sys.PUT(imp, proc); + INC(imp, 4); + END + END + UNTIL proc = 0; + init(exp); + INC(import_table, 8) + END + UNTIL done; + IF fail THEN + res := 1 + END; + import_table := res; + sys.CODE("61") (* popa *) + RETURN import_table +END dll_Load; + +PROCEDURE [stdcall] dll_Init(entry: INTEGER); +BEGIN + sys.CODE("60"); (* pusha *) + IF entry # 0 THEN + dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry) + END; + sys.CODE("61"); (* popa *) +END dll_Init; + +PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER; +VAR Lib: INTEGER; +BEGIN + Lib := sysfunc3(68, 19, sys.ADR(name[0])); + IF Lib # 0 THEN + init(Lib) + END + RETURN Lib +END LoadLib; + +BEGIN + DLL_INIT := dll_Init +END KOSAPI. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Math.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Math.ob07 new file mode 100644 index 0000000000..6c41800886 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Math.ob07 @@ -0,0 +1,254 @@ +(* + 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 . +*) + +MODULE Math; + +IMPORT sys := SYSTEM; + +CONST pi* = 3.141592653589793D+00; + e* = 2.718281828459045D+00; + +VAR Inf*, nInf*: LONGREAL; + +PROCEDURE IsNan*(x: LONGREAL): BOOLEAN; +VAR h, l: SET; +BEGIN + sys.GET(sys.ADR(x), l); + sys.GET(sys.ADR(x) + 4, h); + RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) +END IsNan; + +PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; + RETURN ABS(x) = sys.INF(LONGREAL) +END IsInf; + +PROCEDURE Max(A, B: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF A > B THEN + Res := A + ELSE + Res := B + END + RETURN Res +END Max; + +PROCEDURE Min(A, B: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF A < B THEN + Res := A + ELSE + Res := B + END + RETURN Res +END Min; + +PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN; +VAR Epsilon: LONGREAL; Res: BOOLEAN; +BEGIN + Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12); + IF A > B THEN + Res := (A - B) <= Epsilon + ELSE + Res := (B - A) <= Epsilon + END + RETURN Res +END SameValue; + +PROCEDURE IsZero(x: LONGREAL): BOOLEAN; + RETURN ABS(x) <= 1.0D-12 +END IsZero; + +PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D9FAC9C20800") + RETURN 0.0D0 +END sqrt; + +PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D9FEC9C20800") + RETURN 0.0D0 +END sin; + +PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D9FFC9C20800") + RETURN 0.0D0 +END cos; + +PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D9F2DEC9C9C20800") + RETURN 0.0D0 +END tan; + +PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508DD4510D9F3C9C21000") + RETURN 0.0D0 +END arctan2; + +PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("D9EDDD4508D9F1C9C20800") + RETURN 0.0D0 +END ln; + +PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000") + RETURN 0.0D0 +END log; + +PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800") + RETURN 0.0D0 +END exp; + +PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800") + RETURN 0.0D0 +END round; + +PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL; +BEGIN + sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800") + RETURN 0.0D0 +END frac; + +PROCEDURE arcsin*(x: LONGREAL): LONGREAL; + RETURN arctan2(x, sqrt(1.0D0 - x * x)) +END arcsin; + +PROCEDURE arccos*(x: LONGREAL): LONGREAL; + RETURN arctan2(sqrt(1.0D0 - x * x), x) +END arccos; + +PROCEDURE arctan*(x: LONGREAL): LONGREAL; + RETURN arctan2(x, 1.0D0) +END arctan; + +PROCEDURE sinh*(x: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF IsZero(x) THEN + Res := 0.0D0 + ELSE + Res := (exp(x) - exp(-x)) / 2.0D0 + END + RETURN Res +END sinh; + +PROCEDURE cosh*(x: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF IsZero(x) THEN + Res := 1.0D0 + ELSE + Res := (exp(x) + exp(-x)) / 2.0D0 + END + RETURN Res +END cosh; + +PROCEDURE tanh*(x: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF IsZero(x) THEN + Res := 0.0D0 + ELSE + Res := sinh(x) / cosh(x) + END + RETURN Res +END tanh; + +PROCEDURE arcsinh*(x: LONGREAL): LONGREAL; + RETURN ln(x + sqrt((x * x) + 1.0D0)) +END arcsinh; + +PROCEDURE arccosh*(x: LONGREAL): LONGREAL; + RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0)) +END arccosh; + +PROCEDURE arctanh*(x: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF SameValue(x, 1.0D0) THEN + Res := Inf + ELSIF SameValue(x, -1.0D0) THEN + Res := nInf + ELSE + Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x)) + END + RETURN Res +END arctanh; + +PROCEDURE floor*(x: LONGREAL): LONGREAL; +VAR f: LONGREAL; +BEGIN + f := frac(x); + x := x - f; + IF f < 0.0D0 THEN + x := x - 1.0D0 + END + RETURN x +END floor; + +PROCEDURE ceil*(x: LONGREAL): LONGREAL; +VAR f: LONGREAL; +BEGIN + f := frac(x); + x := x - f; + IF f > 0.0D0 THEN + x := x + 1.0D0 + END + RETURN x +END ceil; + +PROCEDURE power*(base, exponent: LONGREAL): LONGREAL; +VAR Res: LONGREAL; +BEGIN + IF exponent = 0.0D0 THEN + Res := 1.0D0 + ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN + Res := 0.0D0 + ELSE + Res := exp(exponent * ln(base)) + END + RETURN Res +END power; + +PROCEDURE sgn*(x: LONGREAL): INTEGER; +VAR Res: INTEGER; +BEGIN + IF x > 0.0D0 THEN + Res := 1 + ELSIF x < 0.0D0 THEN + Res := -1 + ELSE + Res := 0 + END + RETURN Res +END sgn; + +BEGIN + Inf := sys.INF(LONGREAL); + nInf := -sys.INF(LONGREAL) +END Math. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07 b/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07 new file mode 100644 index 0000000000..78ca879fcf --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07 @@ -0,0 +1,153 @@ +(* + 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 . +*) + +MODULE OpenDlg; + +IMPORT sys := SYSTEM, KOSAPI; + +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.ADR("/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(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(sys.ADR(Dialog_init), "OpenDialog_init"); + GetProc(sys.ADR(Dialog_start), "OpenDialog_start"); +END Load; + +BEGIN + Load +END OpenDlg. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Out.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Out.ob07 new file mode 100644 index 0000000000..5549c5a6e1 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Out.ob07 @@ -0,0 +1,262 @@ +(* + 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 . +*) + +MODULE Out; + +IMPORT ConsoleLib, sys := SYSTEM; + +CONST + + d = 1.0D0 - 5.0D-12; + +VAR + + Realp: PROCEDURE (x: LONGREAL; 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: LONGREAL): 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: LONGREAL): BOOLEAN; + RETURN ABS(x) = sys.INF(LONGREAL) +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: LONGREAL; width: INTEGER); +VAR s: ARRAY 4 OF CHAR; i: INTEGER; +BEGIN + IF IsNan(x) THEN + s := "Nan"; + INC(width) + ELSIF IsInf(x) & (x > 0.0D0) THEN + s := "+Inf" + ELSIF IsInf(x) & (x < 0.0D0) 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: LONGREAL; width, p: INTEGER); +VAR e, len, i: INTEGER; y: LONGREAL; 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.0D0 THEN + minus := TRUE; + INC(len); + x := ABS(x) + END; + e := 0; + WHILE x >= 10.0D0 DO + x := x / 10.0D0; + INC(e) + END; + IF e >= 0 THEN + len := len + e + p + 1; + IF x > 9.0D0 + 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.0D0) & (y # 0.0D0) DO + y := y * 10.0D0; + DEC(e) + END; + IF e < 0 THEN + IF x - LONG(FLT(FLOOR(x))) > d THEN + Char("1"); + x := 0.0D0 + ELSE + Char("0"); + x := x * 10.0D0 + END + ELSE + WHILE e >= 0 DO + IF x - LONG(FLT(FLOOR(x))) > d THEN + IF x > 9.0D0 THEN + String("10") + ELSE + Char(CHR(FLOOR(x) + ORD("0") + 1)) + END; + x := 0.0D0 + ELSE + Char(CHR(FLOOR(x) + ORD("0"))); + x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 + END; + DEC(e) + END + END; + IF p > 0 THEN + Char(".") + END; + WHILE p > 0 DO + IF x - LONG(FLT(FLOOR(x))) > d THEN + Char(CHR(FLOOR(x) + ORD("0") + 1)); + x := 0.0D0 + ELSE + Char(CHR(FLOOR(x) + ORD("0"))); + x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 + END; + DEC(p) + END + END +END FixReal; + +PROCEDURE Real*(x: LONGREAL; 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.0D0 THEN + x := -x; + minus := TRUE + ELSE + minus := FALSE + END; + WHILE x >= 10.0D0 DO + x := x / 10.0D0; + INC(e) + END; + WHILE (x < 1.0D0) & (x # 0.0D0) DO + x := x * 10.0D0; + DEC(e) + END; + IF x > 9.0D0 + d THEN + x := 1.0D0; + INC(e) + END; + FOR i := 1 TO n DO + Char(" ") + END; + IF minus THEN + x := -x + END; + FixReal(x, width, width - 3); + Char("E"); + IF e >= 0 THEN + Char("+") + ELSE + Char("-"); + e := ABS(e) + END; + IF e < 100 THEN + Char("0") + END; + IF e < 10 THEN + Char("0") + END; + Int(e, 0) + END +END Real; + +PROCEDURE Open*; +END Open; + +BEGIN + Realp := Real +END Out. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 b/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 new file mode 100644 index 0000000000..8ce9249a8a --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 @@ -0,0 +1,279 @@ +(* + 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 . +*) + +MODULE RTL; + +IMPORT sys := SYSTEM, API; + +TYPE + + IntArray = ARRAY 2048 OF INTEGER; + STRING = ARRAY 2048 OF CHAR; + PROC = PROCEDURE; + +VAR + + SelfName, rtab: INTEGER; CloseProc: PROC; + +PROCEDURE [stdcall] _halt*(n: INTEGER); +BEGIN + API.ExitProcess(n) +END _halt; + +PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); +BEGIN + ptr := API._NEW(size); + IF ptr # 0 THEN + sys.PUT(ptr, t); + INC(ptr, 4) + END +END _newrec; + +PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); +BEGIN + IF ptr # 0 THEN + ptr := API._DISPOSE(ptr - 4) + END +END _disprec; + +PROCEDURE [stdcall] _rset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") +END _rset; + +PROCEDURE [stdcall] _inset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") +END _inset; + +PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); +BEGIN + table := rtab; + sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") +END _checktype; + +PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); +BEGIN + sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") +END _savearr; + +PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; +VAR res: BOOLEAN; +BEGIN + res := dyn = stat; + IF res THEN + _savearr(size, source, dest) + END + RETURN res +END _saverec; + +PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); +VAR i, m: INTEGER; +BEGIN + m := bsize * idx; + FOR i := 4 TO Dim + 2 DO + m := m * Arr[i] + END; + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := c + m + ELSE + Arr[3] := 0 + END +END _arrayidx; + +PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); +BEGIN + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := bsize * idx + c + ELSE + Arr[3] := 0 + END +END _arrayidx1; + +PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); +VAR i, j, t: INTEGER; +BEGIN + FOR i := 1 TO n DO + t := Arr[0]; + FOR j := 0 TO m + n - 1 DO + Arr[j] := Arr[j + 1] + END; + Arr[m + n] := t + END +END _arrayrot; + +PROCEDURE Min(a, b: INTEGER): INTEGER; +BEGIN + IF a > b THEN + a := b + END + RETURN a +END Min; + +PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; +BEGIN + sys.CODE("8B4508"); // mov eax, [ebp + 08h] + sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] + sys.CODE("48"); // dec eax + // L1: + sys.CODE("40"); // inc eax + sys.CODE("803800"); // cmp byte ptr [eax], 0 + sys.CODE("7403"); // jz L2 + sys.CODE("E2F8"); // loop L1 + sys.CODE("40"); // inc eax + // L2: + sys.CODE("2B4508"); // sub eax, [ebp + 08h] + sys.CODE("C9"); // leave + sys.CODE("C20800"); // ret 08h + RETURN 0 +END _length; + +PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); +BEGIN + _savearr(Min(alen, blen), a, b); + IF blen > alen THEN + sys.PUT(b + alen, 0X) + END +END _strcopy; + +PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; +VAR i: INTEGER; Res: BOOLEAN; +BEGIN + i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); + IF i = 0 THEN + i := _length(a) - _length(b) + END; + CASE op OF + |0: Res := i = 0 + |1: Res := i # 0 + |2: Res := i < 0 + |3: Res := i > 0 + |4: Res := i <= 0 + |5: Res := i >= 0 + ELSE + END + RETURN Res +END _strcmp; + +PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := b; + s[1] := 0X; + RETURN _strcmp(op, s, a) +END _lstrcmp; + +PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := a; + s[1] := 0X; + RETURN _strcmp(op, b, s) +END _rstrcmp; + +PROCEDURE Int(x: INTEGER; VAR str: STRING); +VAR i, a, b: INTEGER; c: CHAR; +BEGIN + i := 0; + a := 0; + REPEAT + str[i] := CHR(x MOD 10 + ORD("0")); + x := x DIV 10; + INC(i) + UNTIL x = 0; + b := i - 1; + WHILE a < b DO + c := str[a]; + str[a] := str[b]; + str[b] := c; + INC(a); + DEC(b) + END; + str[i] := 0X +END Int; + +PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); +VAR msg, int: STRING; pos, n: INTEGER; + + PROCEDURE StrAppend(s: STRING); + VAR i, n: INTEGER; + BEGIN + n := LEN(s); + i := 0; + WHILE (i < n) & (s[i] # 0X) DO + msg[pos] := s[i]; + INC(pos); + INC(i) + END + END StrAppend; + +BEGIN + pos := 0; + n := line MOD 16; + line := line DIV 16; + CASE n OF + |1: StrAppend("assertion failure") + |2: StrAppend("variable of a procedure type has NIL as value") + |3: StrAppend("typeguard error") + |4: StrAppend("inadmissible dynamic type") + |5: StrAppend("index check error") + |6: StrAppend("NIL pointer dereference") + |7: StrAppend("invalid value in case statement") + |8: StrAppend("division by zero") + ELSE + END; + StrAppend(0DX); + StrAppend(0AX); + StrAppend("module "); + StrAppend(modname); + StrAppend(0DX); + StrAppend(0AX); + StrAppend("line "); + Int(line, int); + StrAppend(int); + IF m = 2 THEN + StrAppend(0DX); + StrAppend(0AX); + StrAppend("code "); + Int(code, int); + StrAppend(int) + END; + API.DebugMsg(sys.ADR(msg), SelfName) +END _assrt; + +PROCEDURE [stdcall] _close*; +BEGIN + IF CloseProc # NIL THEN + CloseProc + END +END _close; + +PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); +BEGIN + API.zeromem(gsize, gadr); + API.init(esp); + SelfName := self; + rtab := rec; + CloseProc := NIL +END _init; + +PROCEDURE SetClose*(proc: PROC); +BEGIN + CloseProc := proc +END SetClose; + +END RTL. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07 b/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07 new file mode 100644 index 0000000000..421a01185f --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07 @@ -0,0 +1,124 @@ +(* + Copyright 2016 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 . +*) + +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(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(sys.ADR(drawText), "drawText"); + GetProc(sys.ADR(cntUTF_8), "cntUTF-8"); + GetProc(sys.ADR(charsFit), "charsFit"); + GetProc(sys.ADR(strWidth), "strWidth"); +END main; + + +BEGIN + main +END RasterWorks. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Read.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Read.ob07 new file mode 100644 index 0000000000..edcda5d186 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Read.ob07 @@ -0,0 +1,50 @@ +(* + 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 . +*) + +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 LongReal*(F: File.FS; VAR x: LONGREAL): BOOLEAN; + RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) +END LongReal; + +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 Card16*(F: File.FS; VAR x: sys.CARD16): BOOLEAN; + RETURN File.Read(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) +END Card16; + +END Read. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/Write.ob07 b/programs/develop/oberon07/Lib/KolibriOS/Write.ob07 new file mode 100644 index 0000000000..ece6fac831 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/Write.ob07 @@ -0,0 +1,50 @@ +(* + 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 . +*) + +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 LongReal*(F: File.FS; x: LONGREAL): BOOLEAN; + RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL) +END LongReal; + +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 Card16*(F: File.FS; x: sys.CARD16): BOOLEAN; + RETURN File.Write(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16) +END Card16; + +END Write. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07 b/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07 new file mode 100644 index 0000000000..165c093a4d --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07 @@ -0,0 +1,478 @@ +(* + 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 . +*) + +MODULE kfonts; + +IMPORT sys := SYSTEM; + +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] LoadFile(file_name: INTEGER; VAR size: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("6A44"); (* push 68 *) + sys.CODE("58"); (* pop eax *) + sys.CODE("6A1B"); (* push 27 *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *) + sys.CODE("8911"); (* mov [ecx], edx *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20800"); (* ret 08h *) + RETURN 0 +END LoadFile; + +PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER; +BEGIN + sys.CODE("53"); (* push ebx *) + sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) + sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) + sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) + sys.CODE("CD40"); (* int 40h *) + sys.CODE("5B"); (* pop ebx *) + sys.CODE("C9"); (* leave *) + sys.CODE("C20C00"); (* ret 0Ch *) + RETURN 0 +END sysfunc3; + +PROCEDURE [stdcall] zeromem(size, adr: INTEGER); +BEGIN + sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") +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); +VAR res: 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; + 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); + getrgb(color, r0, g0, b0); + 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 TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER); +VAR width: INTEGER; c: CHAR; bpp32, smoothing: BOOLEAN; +BEGIN + IF Font # NIL THEN + smoothing := 4 IN BITS(params); + bpp32 := 5 IN BITS(params); + sys.GET(str, c); + WHILE (length > 0) OR (length = -1) & (c # 0X) DO + INC(str); + width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params); + IF 3 IN BITS(params) THEN + hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width, color, bpp32) + END; + IF 2 IN BITS(params) THEN + hline(canvas, x, y + Font.height - 1, width, color, bpp32) + END; + x := x + width; + IF length > 0 THEN + DEC(length) + END; + sys.GET(str, c) + END + END +END TextOut; + +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; + sys.GET(str, c) + 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 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 := sysfunc3(68, 12, memsize); + IF Font.mem # 0 THEN + IF mem # 0 THEN + mem := 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 := sysfunc3(68, 13, Font.mem) + END; + IF Font.data # 0 THEN + Font.data := 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 := LoadFile(sys.ADR(file_name[0]), 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 := sysfunc3(68, 13, data) + END; + Font := NIL + END + RETURN Font +END LoadFont; + +END kfonts. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07 b/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07 new file mode 100644 index 0000000000..d927d8aea2 --- /dev/null +++ b/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07 @@ -0,0 +1,435 @@ +(* + Copyright 2016 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 . +*) + +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 .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(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(sys.ADR(img_is_img) , "img_is_img"); + GetProc(sys.ADR(img_to_rgb) , "img_to_rgb"); + GetProc(sys.ADR(img_to_rgb2) , "img_to_rgb2"); + GetProc(sys.ADR(img_decode) , "img_decode"); + GetProc(sys.ADR(img_encode) , "img_encode"); + GetProc(sys.ADR(img_create) , "img_create"); + GetProc(sys.ADR(img_destroy) , "img_destroy"); + GetProc(sys.ADR(img_destroy_layer) , "img_destroy_layer"); + GetProc(sys.ADR(img_count) , "img_count"); + GetProc(sys.ADR(img_flip) , "img_flip"); + GetProc(sys.ADR(img_flip_layer) , "img_flip_layer"); + GetProc(sys.ADR(img_rotate) , "img_rotate"); + GetProc(sys.ADR(img_rotate_layer) , "img_rotate_layer"); + GetProc(sys.ADR(img_draw) , "img_draw"); + GetProc(sys.ADR(img_scale) , "img_scale"); + GetProc(sys.ADR(img_convert) , "img_convert"); + GetProc(sys.ADR(formats_table_ptr) , "img_formats_table"); + GetFormatsTable(formats_table_ptr) +END main; + + +BEGIN + main +END libimg. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Linux32/API.ob07 b/programs/develop/oberon07/Lib/Linux32/API.ob07 new file mode 100644 index 0000000000..6ef5bd5f5a --- /dev/null +++ b/programs/develop/oberon07/Lib/Linux32/API.ob07 @@ -0,0 +1,143 @@ +(* + 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 . +*) + +MODULE API; + +IMPORT sys := SYSTEM; + +TYPE + + TP* = ARRAY 2 OF INTEGER; + +VAR + + Param*: INTEGER; + + sec* : INTEGER; + dsec* : INTEGER; + stdin* : INTEGER; + stdout* : INTEGER; + stderr* : INTEGER; + dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER; + dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER; + _malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER; + free* : PROCEDURE [cdecl] (ptr: INTEGER); + fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER; + fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER; + fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER; + fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER; + exit* : PROCEDURE [cdecl] (code: INTEGER); + strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER; + strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER; + clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER; + +PROCEDURE [stdcall] zeromem* (size, adr: INTEGER); +BEGIN + sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") +END zeromem; + +PROCEDURE Align(n, m: INTEGER): INTEGER; + RETURN n + (m - n MOD m) MOD m +END Align; + +PROCEDURE malloc* (Bytes: INTEGER): INTEGER; +VAR res: INTEGER; +BEGIN + Bytes := Align(Bytes, 4); + res := _malloc(Bytes); + IF res # 0 THEN + zeromem(ASR(Bytes, 2), res) + END + RETURN res +END malloc; + +PROCEDURE Free* (hMem: INTEGER): INTEGER; +BEGIN + free(hMem) + RETURN 0 +END Free; + +PROCEDURE _NEW*(size: INTEGER): INTEGER; + RETURN malloc(size) +END _NEW; + +PROCEDURE _DISPOSE*(p: INTEGER): INTEGER; + RETURN Free(p) +END _DISPOSE; + +PROCEDURE ConOut(str, length: INTEGER); +BEGIN + length := fwrite(str, length, 1, stdout) +END ConOut; + +PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); +VAR eol: ARRAY 3 OF CHAR; +BEGIN + eol[0] := 0DX; + eol[1] := 0AX; + eol[2] := 00X; + ConOut(sys.ADR(eol), 2); + ConOut(lpCaption, strlen(lpCaption)); + ConOut(sys.ADR(":"), 1); + ConOut(sys.ADR(eol), 2); + ConOut(lpText, strlen(lpText)); + ConOut(sys.ADR(eol), 2); +END DebugMsg; + +PROCEDURE ExitProcess* (code: INTEGER); +BEGIN + exit(code) +END ExitProcess; + +PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); +VAR H: INTEGER; +BEGIN + H := dlsym(hMOD, sys.ADR(name[0])); + ASSERT(H # 0); + sys.PUT(adr, H); +END GetProc; + +PROCEDURE init* (esp: INTEGER); +VAR lib, proc: INTEGER; +BEGIN + Param := esp; + sys.MOVE(Param + 12, sys.ADR(dlopen), 4); + sys.MOVE(Param + 16, sys.ADR(dlsym), 4); + sys.MOVE(Param + 20, sys.ADR(exit), 4); + sys.MOVE(Param + 24, sys.ADR(stdin), 4); + sys.MOVE(Param + 28, sys.ADR(stdout), 4); + sys.MOVE(Param + 32, sys.ADR(stderr), 4); + sys.MOVE(Param + 36, sys.ADR(_malloc), 4); + sys.MOVE(Param + 40, sys.ADR(free), 4); + sys.MOVE(Param + 44, sys.ADR(fopen), 4); + sys.MOVE(Param + 48, sys.ADR(fclose), 4); + sys.MOVE(Param + 52, sys.ADR(fwrite), 4); + sys.MOVE(Param + 56, sys.ADR(fread), 4); + sys.MOVE(Param + 60, sys.ADR(fseek), 4); + sys.MOVE(Param + 64, sys.ADR(ftell), 4); + + lib := dlopen(sys.ADR("libc.so.6"), 1); + ASSERT(lib # 0); + GetProc("strncmp", lib, sys.ADR(strncmp)); + GetProc("strlen", lib, sys.ADR(strlen)); + + lib := dlopen(sys.ADR("librt.so.1"), 1); + ASSERT(lib # 0); + GetProc("clock_gettime", lib, sys.ADR(clock_gettime)); +END init; + +END API. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Linux32/HOST.ob07 b/programs/develop/oberon07/Lib/Linux32/HOST.ob07 new file mode 100644 index 0000000000..76913bcd41 --- /dev/null +++ b/programs/develop/oberon07/Lib/Linux32/HOST.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 . +*) + +MODULE HOST; + +IMPORT sys := SYSTEM, API; + +CONST + + OS* = "LNX"; + Slash* = "/"; + +VAR + + fsize : INTEGER; + + sec* : INTEGER; + dsec* : INTEGER; + +PROCEDURE GetCommandLine* (): INTEGER; + RETURN API.Param +END GetCommandLine; + +PROCEDURE CloseFile* (File: INTEGER); +BEGIN + File := API.fclose(File) +END CloseFile; + +PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; +VAR res: INTEGER; +BEGIN + IF write THEN + res := API.fwrite(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes + ELSE + res := API.fread(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes + END + RETURN res +END FileRW; + +PROCEDURE OutString* (str: ARRAY OF CHAR); +VAR res: INTEGER; +BEGIN + res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE) +END OutString; + +PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; + RETURN API.fopen(sys.ADR(FName), sys.ADR("wb")) +END CreateFile; + +PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; +VAR F, res: INTEGER; +BEGIN + F := API.fopen(sys.ADR(FName), sys.ADR("rb")); + IF F # 0 THEN + res := API.fseek(F, 0, 2); + fsize := API.ftell(F); + res := API.fseek(F, 0, 0) + END + RETURN F +END OpenFile; + +PROCEDURE FileSize* (F: INTEGER): INTEGER; + RETURN fsize +END FileSize; + +PROCEDURE Align(n, m: INTEGER): INTEGER; + RETURN n + (m - n MOD m) MOD m +END Align; + +PROCEDURE malloc* (Bytes: INTEGER): INTEGER; +VAR res: INTEGER; +BEGIN + Bytes := Align(Bytes, 4); + res := API.malloc(Bytes); + IF res # 0 THEN + API.zeromem(ASR(Bytes, 2), res) + END + RETURN res +END malloc; + +PROCEDURE ExitProcess* (code: INTEGER); +BEGIN + API.exit(code) +END ExitProcess; + +PROCEDURE Time* (VAR sec, dsec: INTEGER); +VAR tp: API.TP; +BEGIN + IF API.clock_gettime(0, tp) = 0 THEN + sec := tp[0]; + dsec := tp[1] DIV 10000000 + ELSE + sec := 0; + dsec := 0 + END +END Time; + +PROCEDURE init*; +BEGIN + Time(sec, dsec) +END init; + +PROCEDURE GetName*(): INTEGER; + RETURN 0 +END GetName; + +END HOST. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Linux32/RTL.ob07 b/programs/develop/oberon07/Lib/Linux32/RTL.ob07 new file mode 100644 index 0000000000..a6a051ec73 --- /dev/null +++ b/programs/develop/oberon07/Lib/Linux32/RTL.ob07 @@ -0,0 +1,279 @@ +(* + 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 . +*) + +MODULE RTL; + +IMPORT sys := SYSTEM, API; + +TYPE + + IntArray = ARRAY 2048 OF INTEGER; + STRING = ARRAY 2048 OF CHAR; + PROC = PROCEDURE; + +VAR + + SelfName, rtab: INTEGER; CloseProc: PROC; + +PROCEDURE [stdcall] _halt*(n: INTEGER); +BEGIN + API.ExitProcess(n) +END _halt; + +PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); +BEGIN + ptr := API._NEW(size); + IF ptr # 0 THEN + sys.PUT(ptr, t); + INC(ptr, 4) + END +END _newrec; + +PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); +BEGIN + IF ptr # 0 THEN + ptr := API._DISPOSE(ptr - 4) + END +END _disprec; + +PROCEDURE [stdcall] _rset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") +END _rset; + +PROCEDURE [stdcall] _inset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") +END _inset; + +PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); +BEGIN + table := rtab; + sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") +END _checktype; + +PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); +BEGIN + sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") +END _savearr; + +PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; +VAR res: BOOLEAN; +BEGIN + res := dyn = stat; + IF res THEN + _savearr(size, source, dest) + END + RETURN res +END _saverec; + +PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); +VAR i, m: INTEGER; +BEGIN + m := bsize * idx; + FOR i := 4 TO Dim + 2 DO + m := m * Arr[i] + END; + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := c + m + ELSE + Arr[3] := 0 + END +END _arrayidx; + +PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); +BEGIN + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := bsize * idx + c + ELSE + Arr[3] := 0 + END +END _arrayidx1; + +PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); +VAR i, j, t: INTEGER; +BEGIN + FOR i := 1 TO n DO + t := Arr[0]; + FOR j := 0 TO m + n - 1 DO + Arr[j] := Arr[j + 1] + END; + Arr[m + n] := t + END +END _arrayrot; + +PROCEDURE Min(a, b: INTEGER): INTEGER; +BEGIN + IF a > b THEN + a := b + END + RETURN a +END Min; + +PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; +BEGIN + sys.CODE("8B4508"); // mov eax, [ebp + 08h] + sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] + sys.CODE("48"); // dec eax + // L1: + sys.CODE("40"); // inc eax + sys.CODE("803800"); // cmp byte ptr [eax], 0 + sys.CODE("7403"); // jz L2 + sys.CODE("E2F8"); // loop L1 + sys.CODE("40"); // inc eax + // L2: + sys.CODE("2B4508"); // sub eax, [ebp + 08h] + sys.CODE("C9"); // leave + sys.CODE("C20800"); // ret 08h + RETURN 0 +END _length; + +PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); +BEGIN + _savearr(Min(alen, blen), a, b); + IF blen > alen THEN + sys.PUT(b + alen, 0X) + END +END _strcopy; + +PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; +VAR i: INTEGER; Res: BOOLEAN; +BEGIN + i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); + IF i = 0 THEN + i := _length(a) - _length(b) + END; + CASE op OF + |0: Res := i = 0 + |1: Res := i # 0 + |2: Res := i < 0 + |3: Res := i > 0 + |4: Res := i <= 0 + |5: Res := i >= 0 + ELSE + END + RETURN Res +END _strcmp; + +PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := b; + s[1] := 0X; + RETURN _strcmp(op, s, a) +END _lstrcmp; + +PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := a; + s[1] := 0X; + RETURN _strcmp(op, b, s) +END _rstrcmp; + +PROCEDURE Int(x: INTEGER; VAR str: STRING); +VAR i, a, b: INTEGER; c: CHAR; +BEGIN + i := 0; + a := 0; + REPEAT + str[i] := CHR(x MOD 10 + ORD("0")); + x := x DIV 10; + INC(i) + UNTIL x = 0; + b := i - 1; + WHILE a < b DO + c := str[a]; + str[a] := str[b]; + str[b] := c; + INC(a); + DEC(b) + END; + str[i] := 0X +END Int; + +PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); +VAR msg, int: STRING; pos, n: INTEGER; + + PROCEDURE StrAppend(s: STRING); + VAR i, n: INTEGER; + BEGIN + n := LEN(s); + i := 0; + WHILE (i < n) & (s[i] # 0X) DO + msg[pos] := s[i]; + INC(pos); + INC(i) + END + END StrAppend; + +BEGIN + pos := 0; + n := line MOD 16; + line := line DIV 16; + CASE n OF + |1: StrAppend("assertion failure") + |2: StrAppend("variable of a procedure type has NIL as value") + |3: StrAppend("typeguard error") + |4: StrAppend("inadmissible dynamic type") + |5: StrAppend("index check error") + |6: StrAppend("NIL pointer dereference") + |7: StrAppend("invalid value in case statement") + |8: StrAppend("division by zero") + ELSE + END; + StrAppend(0DX); + StrAppend(0AX); + StrAppend("module "); + StrAppend(modname); + StrAppend(0DX); + StrAppend(0AX); + StrAppend("line "); + Int(line, int); + StrAppend(int); + IF m = 2 THEN + StrAppend(0DX); + StrAppend(0AX); + StrAppend("code "); + Int(code, int); + StrAppend(int) + END; + API.DebugMsg(sys.ADR(msg), SelfName) +END _assrt; + +PROCEDURE [stdcall] _close*; +BEGIN + IF CloseProc # NIL THEN + CloseProc + END +END _close; + +PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); +BEGIN + API.zeromem(gsize, gadr); + API.init(esp); + SelfName := self; + rtab := rec; + CloseProc := NIL; +END _init; + +PROCEDURE SetClose*(proc: PROC); +BEGIN + CloseProc := proc +END SetClose; + +END RTL. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Windows32/API.ob07 b/programs/develop/oberon07/Lib/Windows32/API.ob07 new file mode 100644 index 0000000000..a6aadc73b0 --- /dev/null +++ b/programs/develop/oberon07/Lib/Windows32/API.ob07 @@ -0,0 +1,75 @@ +(* + 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 . +*) + +MODULE API; + +IMPORT sys := SYSTEM; + +VAR + + Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER; + Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER; + MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER; + ExitProcess*: PROCEDURE [winapi] (code: INTEGER); + strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER; + + GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER; + LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER; + +PROCEDURE zeromem*(size, adr: INTEGER); +END zeromem; + +PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER); +BEGIN + MessageBoxA(0, lpText, lpCaption, 16) +END DebugMsg; + +PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); +VAR H: INTEGER; +BEGIN + H := GetProcAddress(hMOD, sys.ADR(name[0])); + ASSERT(H # 0); + sys.PUT(adr, H); +END GetProc; + +PROCEDURE _NEW*(size: INTEGER): INTEGER; + RETURN Alloc(64, size) +END _NEW; + +PROCEDURE _DISPOSE*(p: INTEGER): INTEGER; + RETURN Free(p) +END _DISPOSE; + +PROCEDURE init* (esp: INTEGER); +VAR lib: INTEGER; +BEGIN + sys.GET(esp, GetProcAddress); + sys.GET(esp + 4, LoadLibraryA); + + lib := LoadLibraryA(sys.ADR("kernel32.dll")); + GetProc("ExitProcess", lib, sys.ADR(ExitProcess)); + GetProc("GlobalAlloc", lib, sys.ADR(Alloc)); + GetProc("GlobalFree", lib, sys.ADR(Free)); + + lib := LoadLibraryA(sys.ADR("msvcrt.dll")); + GetProc("strncmp", lib, sys.ADR(strncmp)); + + lib := LoadLibraryA(sys.ADR("user32.dll")); + GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA)); +END init; + +END API. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Windows32/HOST.ob07 b/programs/develop/oberon07/Lib/Windows32/HOST.ob07 new file mode 100644 index 0000000000..bc0788f4a0 --- /dev/null +++ b/programs/develop/oberon07/Lib/Windows32/HOST.ob07 @@ -0,0 +1,141 @@ +(* + 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 . +*) + +MODULE HOST; + +IMPORT sys := SYSTEM, API; + +CONST + + OS* = "WIN"; + Slash* = "\"; + + OFS_MAXPATHNAME = 128; + +TYPE + + OFSTRUCT = RECORD + cBytes: CHAR; + fFixedDisk: CHAR; + nErrCode: sys.CARD16; + Reserved1: sys.CARD16; + Reserved2: sys.CARD16; + szPathName: ARRAY OFS_MAXPATHNAME OF CHAR + END; + +VAR + + sec*, dsec*, hConsoleOutput: INTEGER; + + GetStdHandle: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER; + CloseFile*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER; + _CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes, + dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER; + _OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER; + ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER; + GetCommandLine*: PROCEDURE [winapi] (): INTEGER; + GetTickCount: PROCEDURE [winapi] (): INTEGER; + Alloc: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER; + ExitProcess*: PROCEDURE [winapi] (code: INTEGER); + SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER; + +PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; +VAR res: INTEGER; +BEGIN + IF write THEN + WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0) + ELSE + ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0) + END + RETURN res +END FileRW; + +PROCEDURE OutString* (str: ARRAY OF CHAR); +VAR res: INTEGER; +BEGIN + res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE) +END OutString; + +PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; +VAR res: INTEGER; +BEGIN + res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0); + IF res = -1 THEN + res := 0 + END + RETURN res +END CreateFile; + +PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; +VAR res: INTEGER; ofstr: OFSTRUCT; +BEGIN + res := _OpenFile(sys.ADR(FName[0]), ofstr, 0); + IF res = -1 THEN + res := 0 + END + RETURN res +END OpenFile; + +PROCEDURE FileSize*(F: INTEGER): INTEGER; +VAR res: INTEGER; +BEGIN + res := SetFilePointer(F, 0, 0, 2); + SetFilePointer(F, 0, 0, 0) + RETURN res +END FileSize; + +PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); +BEGIN + sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0]))) +END GetProc; + +PROCEDURE Time*(VAR sec, dsec: INTEGER); +VAR t: INTEGER; +BEGIN + t := GetTickCount() DIV 10; + sec := t DIV 100; + dsec := t MOD 100 +END Time; + +PROCEDURE malloc*(size: INTEGER): INTEGER; + RETURN Alloc(64, size) +END malloc; + +PROCEDURE init*; +VAR lib: INTEGER; +BEGIN + lib := API.LoadLibraryA(sys.ADR("kernel32.dll")); + GetProc("GetTickCount", lib, sys.ADR(GetTickCount)); + Time(sec, dsec); + GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle)); + GetProc("CreateFileA", lib, sys.ADR(_CreateFile)); + GetProc("CloseHandle", lib, sys.ADR(CloseFile)); + GetProc("OpenFile", lib, sys.ADR(_OpenFile)); + GetProc("ReadFile", lib, sys.ADR(ReadFile)); + GetProc("WriteFile", lib, sys.ADR(WriteFile)); + GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine)); + GetProc("ExitProcess", lib, sys.ADR(ExitProcess)); + GetProc("GlobalAlloc", lib, sys.ADR(Alloc)); + GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer)); + hConsoleOutput := GetStdHandle(-11) +END init; + +PROCEDURE GetName*(): INTEGER; + RETURN 0 +END GetName; + +END HOST. \ No newline at end of file diff --git a/programs/develop/oberon07/Lib/Windows32/RTL.ob07 b/programs/develop/oberon07/Lib/Windows32/RTL.ob07 new file mode 100644 index 0000000000..a6a051ec73 --- /dev/null +++ b/programs/develop/oberon07/Lib/Windows32/RTL.ob07 @@ -0,0 +1,279 @@ +(* + 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 . +*) + +MODULE RTL; + +IMPORT sys := SYSTEM, API; + +TYPE + + IntArray = ARRAY 2048 OF INTEGER; + STRING = ARRAY 2048 OF CHAR; + PROC = PROCEDURE; + +VAR + + SelfName, rtab: INTEGER; CloseProc: PROC; + +PROCEDURE [stdcall] _halt*(n: INTEGER); +BEGIN + API.ExitProcess(n) +END _halt; + +PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); +BEGIN + ptr := API._NEW(size); + IF ptr # 0 THEN + sys.PUT(ptr, t); + INC(ptr, 4) + END +END _newrec; + +PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); +BEGIN + IF ptr # 0 THEN + ptr := API._DISPOSE(ptr - 4) + END +END _disprec; + +PROCEDURE [stdcall] _rset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") +END _rset; + +PROCEDURE [stdcall] _inset*(y, x: INTEGER); +BEGIN + sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") +END _inset; + +PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); +BEGIN + table := rtab; + sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") +END _checktype; + +PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); +BEGIN + sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") +END _savearr; + +PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; +VAR res: BOOLEAN; +BEGIN + res := dyn = stat; + IF res THEN + _savearr(size, source, dest) + END + RETURN res +END _saverec; + +PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); +VAR i, m: INTEGER; +BEGIN + m := bsize * idx; + FOR i := 4 TO Dim + 2 DO + m := m * Arr[i] + END; + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := c + m + ELSE + Arr[3] := 0 + END +END _arrayidx; + +PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); +BEGIN + IF (Arr[3] > idx) & (idx >= 0) THEN + Arr[3] := bsize * idx + c + ELSE + Arr[3] := 0 + END +END _arrayidx1; + +PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); +VAR i, j, t: INTEGER; +BEGIN + FOR i := 1 TO n DO + t := Arr[0]; + FOR j := 0 TO m + n - 1 DO + Arr[j] := Arr[j + 1] + END; + Arr[m + n] := t + END +END _arrayrot; + +PROCEDURE Min(a, b: INTEGER): INTEGER; +BEGIN + IF a > b THEN + a := b + END + RETURN a +END Min; + +PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; +BEGIN + sys.CODE("8B4508"); // mov eax, [ebp + 08h] + sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] + sys.CODE("48"); // dec eax + // L1: + sys.CODE("40"); // inc eax + sys.CODE("803800"); // cmp byte ptr [eax], 0 + sys.CODE("7403"); // jz L2 + sys.CODE("E2F8"); // loop L1 + sys.CODE("40"); // inc eax + // L2: + sys.CODE("2B4508"); // sub eax, [ebp + 08h] + sys.CODE("C9"); // leave + sys.CODE("C20800"); // ret 08h + RETURN 0 +END _length; + +PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); +BEGIN + _savearr(Min(alen, blen), a, b); + IF blen > alen THEN + sys.PUT(b + alen, 0X) + END +END _strcopy; + +PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; +VAR i: INTEGER; Res: BOOLEAN; +BEGIN + i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); + IF i = 0 THEN + i := _length(a) - _length(b) + END; + CASE op OF + |0: Res := i = 0 + |1: Res := i # 0 + |2: Res := i < 0 + |3: Res := i > 0 + |4: Res := i <= 0 + |5: Res := i >= 0 + ELSE + END + RETURN Res +END _strcmp; + +PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := b; + s[1] := 0X; + RETURN _strcmp(op, s, a) +END _lstrcmp; + +PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; +VAR s: ARRAY 2 OF CHAR; +BEGIN + s[0] := a; + s[1] := 0X; + RETURN _strcmp(op, b, s) +END _rstrcmp; + +PROCEDURE Int(x: INTEGER; VAR str: STRING); +VAR i, a, b: INTEGER; c: CHAR; +BEGIN + i := 0; + a := 0; + REPEAT + str[i] := CHR(x MOD 10 + ORD("0")); + x := x DIV 10; + INC(i) + UNTIL x = 0; + b := i - 1; + WHILE a < b DO + c := str[a]; + str[a] := str[b]; + str[b] := c; + INC(a); + DEC(b) + END; + str[i] := 0X +END Int; + +PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); +VAR msg, int: STRING; pos, n: INTEGER; + + PROCEDURE StrAppend(s: STRING); + VAR i, n: INTEGER; + BEGIN + n := LEN(s); + i := 0; + WHILE (i < n) & (s[i] # 0X) DO + msg[pos] := s[i]; + INC(pos); + INC(i) + END + END StrAppend; + +BEGIN + pos := 0; + n := line MOD 16; + line := line DIV 16; + CASE n OF + |1: StrAppend("assertion failure") + |2: StrAppend("variable of a procedure type has NIL as value") + |3: StrAppend("typeguard error") + |4: StrAppend("inadmissible dynamic type") + |5: StrAppend("index check error") + |6: StrAppend("NIL pointer dereference") + |7: StrAppend("invalid value in case statement") + |8: StrAppend("division by zero") + ELSE + END; + StrAppend(0DX); + StrAppend(0AX); + StrAppend("module "); + StrAppend(modname); + StrAppend(0DX); + StrAppend(0AX); + StrAppend("line "); + Int(line, int); + StrAppend(int); + IF m = 2 THEN + StrAppend(0DX); + StrAppend(0AX); + StrAppend("code "); + Int(code, int); + StrAppend(int) + END; + API.DebugMsg(sys.ADR(msg), SelfName) +END _assrt; + +PROCEDURE [stdcall] _close*; +BEGIN + IF CloseProc # NIL THEN + CloseProc + END +END _close; + +PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); +BEGIN + API.zeromem(gsize, gadr); + API.init(esp); + SelfName := self; + rtab := rec; + CloseProc := NIL; +END _init; + +PROCEDURE SetClose*(proc: PROC); +BEGIN + CloseProc := proc +END SetClose; + +END RTL. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/Dialogs.ob07 b/programs/develop/oberon07/Samples/Dialogs.ob07 new file mode 100644 index 0000000000..bb06cf5e83 --- /dev/null +++ b/programs/develop/oberon07/Samples/Dialogs.ob07 @@ -0,0 +1,114 @@ +MODULE Dialogs; + +IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg; + +VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER; + +PROCEDURE WindowRedrawStatus(p: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc2(12, p) +END WindowRedrawStatus; + +PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := 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; +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc1(-1) +END ExitApp; + +PROCEDURE pause(t: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := 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. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/HW.ob07 b/programs/develop/oberon07/Samples/HW.ob07 new file mode 100644 index 0000000000..93617db970 --- /dev/null +++ b/programs/develop/oberon07/Samples/HW.ob07 @@ -0,0 +1,54 @@ +MODULE HW; + +IMPORT sys := SYSTEM, KOSAPI; + +PROCEDURE WindowRedrawStatus(p: INTEGER); +VAR res: INTEGER; +BEGIN + res := KOSAPI.sysfunc2(12, p) +END WindowRedrawStatus; + +PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); +VAR res: INTEGER; +BEGIN + res := 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); +VAR res: INTEGER; +BEGIN + res := 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; +VAR res: INTEGER; +BEGIN + res := 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. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/HW_con.ob07 b/programs/develop/oberon07/Samples/HW_con.ob07 new file mode 100644 index 0000000000..3186eb3c31 --- /dev/null +++ b/programs/develop/oberon07/Samples/HW_con.ob07 @@ -0,0 +1,53 @@ +MODULE HW_con; + +IMPORT Out, In, Console, DateTime, ConsoleLib; + +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: INTEGER; +BEGIN + ConsoleLib.open(-1, -1, -1, -1, "Hello!"); + Out.String("Hello, world!"); Out.Ln; + Console.SetColor(Console.Yellow, Console.Blue); + DateTime.Now(Year, Month, Day, Hour, Min, Sec); + Out.Int(Year, 0); Out.Char("-"); + OutMonth(Month); Out.Char("-"); + OutInt2(Day); Out.Char(" "); + OutInt2(Hour); Out.Char(":"); + OutInt2(Min); Out.Char(":"); + OutInt2(Sec); + In.Ln; + ConsoleLib.exit(TRUE) +END main; + +BEGIN + main +END HW_con. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/RasterW.ob07 b/programs/develop/oberon07/Samples/RasterW.ob07 new file mode 100644 index 0000000000..f53a856bd0 --- /dev/null +++ b/programs/develop/oberon07/Samples/RasterW.ob07 @@ -0,0 +1,159 @@ +MODULE RasterW; + +IMPORT sys := SYSTEM, RW := RasterWorks, KOSAPI; + + +TYPE + + TWindow = RECORD + + Left, Top, Width, Height: INTEGER; + Color: INTEGER; + Header: ARRAY 256 OF CHAR + + END; + + +VAR + + canvas : INTEGER; + bpp32 : BOOLEAN; + + +PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER; +VAR canvas: INTEGER; +BEGIN + canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8); + sys.PUT(canvas, width); + sys.PUT(canvas + 4, height) + RETURN canvas +END CreateCanvas; + + +PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN); +VAR data, width, height, i: INTEGER; +BEGIN + sys.GET(canvas, width); + sys.GET(canvas + 4, height); + data := canvas + 8; + IF bpp32 THEN + FOR i := 1 TO width * height DO + sys.PUT(data, color); INC(data, 4) + END + ELSE + FOR i := 1 TO width * height - 1 DO + sys.PUT(data, color); INC(data, 3) + END; + sys.MOVE(sys.ADR(color), data, 3) + END +END ClearCanvas; + + +PROCEDURE WindowRedrawStatus(p: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc2(12, p) +END WindowRedrawStatus; + + +PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0])) +END DefineAndDrawWindow; + + +PROCEDURE WaitForEvent(): INTEGER; + RETURN KOSAPI.sysfunc1(10) +END WaitForEvent; + + +PROCEDURE ExitApp; +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc1(-1) +END ExitApp; + + +PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN); +VAR xsize, ysize, aux: INTEGER; +BEGIN + sys.GET(canvas, xsize); + sys.GET(canvas + 4, ysize); + aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0) +END DrawCanvas; + + +PROCEDURE TextOut(canvas, x, y: INTEGER; string: ARRAY OF CHAR; color, params: INTEGER); +VAR width: INTEGER; +BEGIN + width := RW.drawText(canvas, x, y, sys.ADR(string[0]), LENGTH(string), color + 0FF000000H, params) +END TextOut; + + +PROCEDURE DrawText; +VAR x, y: INTEGER; +BEGIN + ClearCanvas(canvas, 00FFFFFFH, bpp32); + + x := 0; y := 0; + + TextOut(canvas, x, y, "font size 16", 000000FFH, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) ); + y := y + 16; + x := x + 20; + TextOut(canvas, x, y, "font size 12", 00FF0000H, RW.params( 12, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) ); + y := y + 12; + x := x + 20; + TextOut(canvas, x, y, "italic", 00808080H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.italic ) ); + y := y + 16; + x := x + 20; + TextOut(canvas, x, y, "bold", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.bold ) ); + y := y + 16; + x := x + 20; + TextOut(canvas, x, y, "underline", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.underline ) ); + y := y + 16; + x := x + 20; + TextOut(canvas, x, y, "strike-through", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.strike_through ) ); + y := y + 16; + x := x + 20; + + DrawCanvas(canvas, 10, 10, bpp32); +END DrawText; + + +PROCEDURE draw_window(Window: TWindow); +BEGIN + WindowRedrawStatus(1); + DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header); + DrawText; + WindowRedrawStatus(2); +END draw_window; + + +PROCEDURE main; +VAR Window: TWindow; +BEGIN + + Window.Left := 200; + Window.Top := 200; + Window.Width := 400; + Window.Height := 300; + Window.Color := 00C0C0C0H; + Window.Header := "RasterWorks"; + + bpp32 := FALSE; + canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32); + + WHILE TRUE DO + CASE WaitForEvent() OF + |1: draw_window(Window) + |3: ExitApp + ELSE + END + END + +END main; + +BEGIN + main +END RasterW. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/kfont.ob07 b/programs/develop/oberon07/Samples/kfont.ob07 new file mode 100644 index 0000000000..61bb5698dd --- /dev/null +++ b/programs/develop/oberon07/Samples/kfont.ob07 @@ -0,0 +1,175 @@ +MODULE kfont; + +IMPORT sys := SYSTEM, kfonts, KOSAPI; + + +CONST + + FileName = "/rd/1/fonts/tahoma.kf"; + + +TYPE + + TWindow = RECORD + + Left, Top, Width, Height: INTEGER; + Color: INTEGER; + Header: ARRAY 256 OF CHAR + + END; + + +VAR + + canvas : INTEGER; + bpp32 : BOOLEAN; + + Font12, Font16: kfonts.TFont; + + +PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER; +VAR canvas: INTEGER; +BEGIN + canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8); + sys.PUT(canvas, width); + sys.PUT(canvas + 4, height) + RETURN canvas +END CreateCanvas; + + +PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN); +VAR data, width, height, i: INTEGER; +BEGIN + sys.GET(canvas, width); + sys.GET(canvas + 4, height); + data := canvas + 8; + IF bpp32 THEN + FOR i := 1 TO width * height DO + sys.PUT(data, color); INC(data, 4) + END + ELSE + FOR i := 1 TO width * height - 1 DO + sys.PUT(data, color); INC(data, 3) + END; + sys.MOVE(sys.ADR(color), data, 3) + END +END ClearCanvas; + + +PROCEDURE WindowRedrawStatus(p: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc2(12, p) +END WindowRedrawStatus; + + +PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0])) +END DefineAndDrawWindow; + + +PROCEDURE WaitForEvent(): INTEGER; + RETURN KOSAPI.sysfunc1(10) +END WaitForEvent; + + +PROCEDURE ExitApp; +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc1(-1) +END ExitApp; + + +PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN); +VAR xsize, ysize, aux: INTEGER; +BEGIN + sys.GET(canvas, xsize); + sys.GET(canvas + 4, ysize); + aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0) +END DrawCanvas; + + +PROCEDURE DrawText; +VAR x, y: INTEGER; +BEGIN + ClearCanvas(canvas, 00FFFFFFH, bpp32); + + x := 0; y := 0; + + kfonts.TextOut(Font16, canvas, x, y, sys.ADR("font size 16"), -1, 000000FFH, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing ); + y := y + kfonts.TextHeight( Font16 ); + x := x + 20; + + kfonts.TextOut(Font12, canvas, x, y, sys.ADR("font size 12"), -1, 00FF0000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing ); + y := y + kfonts.TextHeight( Font12 ); + x := x + 20; + + kfonts.TextOut(Font16, canvas, x, y, sys.ADR("italic"), -1, 00808080H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.italic ); + y := y + kfonts.TextHeight( Font16 ); + x := x + 20; + + kfonts.TextOut(Font16, canvas, x, y, sys.ADR("bold"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.bold ); + y := y + kfonts.TextHeight( Font16 ); + x := x + 20; + + kfonts.TextOut(Font16, canvas, x, y, sys.ADR("underline"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.underline ); + y := y + kfonts.TextHeight( Font16 ); + x := x + 20; + + kfonts.TextOut(Font16, canvas, x, y, sys.ADR("strike-through"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.strike_through ); + y := y + kfonts.TextHeight( Font16 ); + x := x + 20; + + DrawCanvas(canvas, 10, 10, bpp32); +END DrawText; + + +PROCEDURE draw_window(Window: TWindow); +BEGIN + WindowRedrawStatus(1); + DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header); + DrawText; + WindowRedrawStatus(2); +END draw_window; + + +PROCEDURE main; +VAR Window: TWindow; + bool: BOOLEAN; +BEGIN + + Window.Left := 200; + Window.Top := 200; + Window.Width := 400; + Window.Height := 300; + Window.Color := 00C0C0C0H; + Window.Header := "kfonts"; + + bpp32 := TRUE; + canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32); + + Font12 := kfonts.LoadFont(FileName); + IF kfonts.Enabled(Font12, 12) THEN + bool := kfonts.SetSize(Font12, 12) + END; + + Font16 := kfonts.LoadFont(FileName); + IF kfonts.Enabled(Font16, 16) THEN + bool := kfonts.SetSize(Font16, 16) + END; + + WHILE TRUE DO + CASE WaitForEvent() OF + |1: draw_window(Window) + |3: ExitApp + ELSE + END + END + +END main; + +BEGIN + main +END kfont. \ No newline at end of file diff --git a/programs/develop/oberon07/Samples/lib_img.ob07 b/programs/develop/oberon07/Samples/lib_img.ob07 new file mode 100644 index 0000000000..104c83fb6e --- /dev/null +++ b/programs/develop/oberon07/Samples/lib_img.ob07 @@ -0,0 +1,97 @@ +MODULE lib_img; + +IMPORT sys := SYSTEM, KOSAPI, libimg, File; + + +TYPE + + TWindow = RECORD + + Left, Top, Width, Height: INTEGER; + Color: INTEGER; + Header: ARRAY 256 OF CHAR + + END; + +VAR + + img, rgb, width, height: INTEGER; + + +PROCEDURE WindowRedrawStatus(p: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc2(12, p) +END WindowRedrawStatus; + + +PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0])) +END DefineAndDrawWindow; + + +PROCEDURE WaitForEvent(): INTEGER; + RETURN KOSAPI.sysfunc1(10) +END WaitForEvent; + + +PROCEDURE PutImage(x, y, rgb, width, height: INTEGER); +VAR aux: INTEGER; +BEGIN + aux := KOSAPI.sysfunc7(65, rgb + 8, width * 65536 + height, x * 65536 + y, 24, 0, 0) +END PutImage; + + +PROCEDURE draw_window(Window: TWindow); +BEGIN + WindowRedrawStatus(1); + DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header); + PutImage(10, 10, rgb, width, height); + WindowRedrawStatus(2) +END draw_window; + + +PROCEDURE LoadImage(FName: ARRAY OF CHAR); +VAR data, size: INTEGER; +BEGIN + data := File.Load(FName, size); + IF data # 0 THEN + img := libimg.img_decode(data, size, 0); + data := KOSAPI.free(data); + IF img # 0 THEN + rgb := libimg.img_to_rgb(img); + IF rgb # 0 THEN + sys.GET(img + 4, width); + sys.GET(img + 8, height) + END + END + END +END LoadImage; + + +PROCEDURE main; +VAR Window: TWindow; + exit: BOOLEAN; +BEGIN + Window.Left := 200; + Window.Top := 200; + Window.Width := 400; + Window.Height := 300; + Window.Color := 00C0C0C0H; + Window.Header := "libimg"; + LoadImage("/rd/1/toolbar.png"); + exit := FALSE; + REPEAT + CASE WaitForEvent() OF + |1: draw_window(Window) + |3: exit := TRUE + ELSE + END + UNTIL exit +END main; + +BEGIN + main +END lib_img. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/Compiler.ob07 b/programs/develop/oberon07/Source/Compiler.ob07 new file mode 100644 index 0000000000..452ba36a2e --- /dev/null +++ b/programs/develop/oberon07/Source/Compiler.ob07 @@ -0,0 +1,1901 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE Compiler; + +IMPORT DECL, SCAN, UTILS, X86, SYSTEM; + +CONST + + Slash = UTILS.Slash; + + lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7; + lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8; + lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16; + lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23; + lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30; + lxUNTIL = 31; lxVAR = 32; lxWHILE = 33; + + lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58; + lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65; + lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70; + lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76; + + TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; + TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14; + + TNUM = {TINTEGER, TREAL, TLONGREAL}; + TFLOAT = {TREAL, TLONGREAL}; + TOBJECT = {TRECORD, TPOINTER}; + TSTRUCT = {TARRAY, TRECORD}; + + eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6; + + IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9; + + stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8; + stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15; + stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22; + stBITS = 23; stLSR = 24; stLENGTH = 25; + + sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105; + sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; + +TYPE + + LABEL = POINTER TO RECORD (UTILS.rITEM) + a, b: INTEGER + END; + +VAR + + pExpr, pFactor: PROCEDURE (VAR e: DECL.EXPRESSION); + pOpSeq: PROCEDURE; + sttypes: DECL.stTYPES; + voidtype, inttype, booltype, strtype, settype, realtype, longrealtype, chartype, niltype: DECL.pTYPE; + +PROCEDURE Load(e: DECL.EXPRESSION); +BEGIN + IF e.eType = eVAR THEN + X86.Load(e.T.tType) + END +END Load; + +PROCEDURE LenString(adr: LONGREAL): INTEGER; +VAR s: UTILS.STRCONST; +BEGIN + s := DECL.GetString(adr) + RETURN s.Len +END LenString; + +PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER); +BEGIN + IF ~cond THEN + DECL.Assert(FALSE, coord, code) + END +END Assert; + +PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER); +BEGIN + IF ~cond THEN + DECL.Assert(FALSE, SCAN.coord, code) + END +END Assert2; + +PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord); +BEGIN + Assert(T.tType = TINTEGER, coord, 52) +END IntType; + +PROCEDURE Next; +BEGIN + DECL.Next +END Next; + +PROCEDURE Coord(VAR coord: SCAN.TCoord); +BEGIN + coord := SCAN.coord +END Coord; + +PROCEDURE NextCoord(VAR coord: SCAN.TCoord); +BEGIN + DECL.Next; + coord := SCAN.coord +END NextCoord; + +PROCEDURE Check(key: INTEGER); +BEGIN + DECL.Check(key) +END Check; + +PROCEDURE NextCheck(key: INTEGER); +BEGIN + DECL.Next; + DECL.Check(key) +END NextCheck; + +PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN; +BEGIN + IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN + IF T0.tType = TPOINTER THEN + T0 := T0.Base; + T1 := T1.Base + END; + WHILE (T1 # NIL) & (T1 # T0) DO + T1 := T1.Base + END + END + RETURN T0 = T1 +END BaseOf; + +PROCEDURE Designator(VAR e: DECL.EXPRESSION); +VAR id, id2: DECL.IDENT; name: SCAN.NODE; e1: DECL.EXPRESSION; + coord: SCAN.TCoord; i, n, bases, glob, loc, idx: INTEGER; + imp, break, guard: BOOLEAN; f: DECL.FIELD; + T, BaseT: DECL.pTYPE; s: UTILS.STRCONST; + + PROCEDURE LoadVar; + BEGIN + IF glob # -1 THEN + X86.GlobalAdr(glob); + glob := -1 + ELSIF loc # -1 THEN + X86.LocalAdr(loc, bases); + loc := -1 + END + END LoadVar; + +BEGIN + glob := -1; + loc := -1; + Coord(coord); + Check(lxIDENT); + name := SCAN.id; + id := DECL.GetIdent(name); + IF (id # NIL) & (id.iType = IDMOD) THEN + NextCheck(lxDot); + NextCheck(lxIDENT); + Coord(coord); + name := SCAN.id; + imp := id.Unit # DECL.unit; + id := DECL.GetQIdent(id.Unit, name) + END; + Assert(id # NIL, coord, 42); + e.vparam := FALSE; + e.deref := FALSE; + e.id := id; + Next; + CASE id.iType OF + |IDVAR: + e.eType := eVAR; + e.T := id.T; + IF id.VarKind = 0 THEN + e.Read := imp + ELSE + e.Read := (id.VarKind = DECL.param) & (id.T.tType IN TSTRUCT); + e.vparam := id.VarKind = DECL.paramvar + END; + bases := DECL.unit.Level - id.Level; + IF id.Level = 3 THEN + glob := id.Offset + ELSIF (id.VarKind = 0) OR (id.VarKind = DECL.param) & ~(id.T.tType IN TSTRUCT) THEN + loc := id.Offset + ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN + IF DECL.Dim(e.T) > 0 THEN + n := DECL.Dim(e.T); + FOR i := n TO 1 BY -1 DO + X86.LocalAdr(id.Offset + i * 4, bases); + X86.Load(TINTEGER) + END + END; + X86.LocalAdr(id.Offset, bases); + X86.Load(TINTEGER) + END + |IDCONST: + Assert(id.T # NIL, coord, 75); + e.eType := eCONST; + e.T := id.T; + e.Value := id.Value; + IF id.T.tType IN {TINTEGER, TSET, TBOOLEAN} THEN + X86.PushConst(FLOOR(e.Value)) + ELSIF id.T.tType IN TFLOAT THEN + X86.PushFlt(e.Value) + ELSIF id.T.tType = TSTRING THEN + s := DECL.GetString(e.Value); + IF s.Len = 1 THEN + X86.PushConst(ORD(s.Str[0])) + ELSE + X86.PushInt(s.Number) + END + END + |IDPROC: + e.eType := ePROC; + NEW(id2); + UTILS.MemErr(id2 = NIL); + id2^ := id^; + UTILS.Push(DECL.curproc.Procs, id2); + e.T := voidtype + |IDTYPE: + Assert(FALSE, coord, 101) + |IDSTPROC: + e.eType := eSTPROC; + e.T := voidtype + |IDSYSPROC: + e.eType := eSYSPROC; + e.T := voidtype + ELSE + END; + break := FALSE; + guard := FALSE; + REPEAT + CASE SCAN.tLex OF + |lxDot: + e.deref := FALSE; + Assert2(e.T.tType IN TOBJECT, 105); + IF e.T.tType = TPOINTER THEN + e.Read := FALSE; + LoadVar; + e.T := e.T.Base; + X86.Load(TINTEGER); + IF ~guard THEN + X86.CheckNIL + END + END; + NextCheck(lxIDENT); + Coord(coord); + name := SCAN.id; + T := e.T; + REPEAT + f := DECL.GetField(T, name); + T := T.Base + UNTIL (f # NIL) OR (T = NIL); + Assert(f # NIL, coord, 99); + IF f.Unit # DECL.unit THEN + Assert(f.Export, coord, 99) + END; + IF glob # -1 THEN + glob := glob + f.Offset + ELSIF loc # -1 THEN + loc := loc + f.Offset + ELSE + X86.Field(f.Offset) + END; + e.T := f.T; + e.vparam := FALSE; + guard := FALSE; + Next + |lxLSquare: + LoadVar; + REPEAT + Assert2(e.T.tType = TARRAY, 102); + NextCoord(coord); + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + IF e.T.Len = 0 THEN + BaseT := DECL.OpenBase(e.T); + X86.PushConst(BaseT.Size); + X86.OpenIdx(DECL.Dim(e.T)) + ELSE + IF e1.eType = eCONST THEN + idx := FLOOR(e1.Value); + Assert((idx >= 0) & (idx < e.T.Len), coord, 159); + IF e.T.Base.Size # 1 THEN + X86.Drop; + X86.PushConst(e.T.Base.Size * idx) + END; + X86.Idx + ELSE + X86.FixIdx(e.T.Len, e.T.Base.Size) + END + END; + e.T := e.T.Base + UNTIL SCAN.tLex # lxComma; + Check(lxRSquare); + e.vparam := FALSE; + guard := FALSE; + Next + |lxCaret: + LoadVar; + Assert2(e.T.tType = TPOINTER, 104); + e.Read := FALSE; + X86.Load(TINTEGER); + IF ~guard THEN + X86.CheckNIL + END; + e.T := e.T.Base; + e.vparam := FALSE; + e.deref := TRUE; + guard := FALSE; + Next + |lxLRound: + LoadVar; + IF e.T.tType IN TOBJECT THEN + IF e.T.tType = TRECORD THEN + Assert2(e.vparam, 108) + END; + NextCheck(lxIDENT); + Coord(coord); + T := DECL.IdType(coord); + Assert(T # NIL, coord, 42); + IF e.T.tType = TRECORD THEN + Assert(T.tType = TRECORD, coord, 106) + ELSE + Assert(T.tType = TPOINTER, coord, 107) + END; + Assert(BaseOf(e.T, T), coord, 108); + e.T := T; + Check(lxRRound); + Next; + IF e.T.tType = TPOINTER THEN + IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN + X86.DupLoadCheck + ELSE + X86.DupLoad + END; + guard := TRUE; + T := T.Base + ELSE + X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level) + END; + X86.Guard(T.Number, FALSE) + ELSE + break := TRUE + END + ELSE + break := TRUE + END + UNTIL break; + LoadVar +END Designator; + +PROCEDURE Set(VAR e: DECL.EXPRESSION); +VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN; + beg: X86.ASMLINE; +BEGIN + Next; + e.eType := eEXP; + e.T := settype; + e.Value := 0.0D0; + e.vparam := FALSE; + s := {}; + flag := TRUE; + fpu := X86.fpu; + beg := X86.current; + X86.PushConst(0); + WHILE SCAN.tLex # lxRCurly DO + Coord(coord); + pExpr(a); + IntType(a.T, coord); + IF a.eType = eCONST THEN + Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53) + END; + Load(a); + b := a; + IF SCAN.tLex = lxDbl THEN + NextCoord(coord); + pExpr(b); + IntType(b.T, coord); + IF b.eType = eCONST THEN + Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53); + Assert(a.Value <= b.Value, coord, 54) + END; + Load(b) + ELSE + X86.Dup + END; + X86.rset; + X86.Set(lxPlus); + flag := (a.eType = eCONST) & (b.eType = eCONST) & flag; + IF flag THEN + s := s + {FLOOR(a.Value) .. FLOOR(b.Value)} + END; + IF SCAN.tLex = lxComma THEN + Next; + Assert2(SCAN.tLex # lxRCurly, 36) + ELSE + Check(lxRCurly) + END + END; + IF flag THEN + e.Value := LONG(FLT(ORD(s))); + e.eType := eCONST; + X86.Del(beg); + X86.Setfpu(fpu); + IF ~DECL.Const THEN + X86.PushConst(ORD(s)) + END + END; + Next +END Set; + +PROCEDURE IsString(a: DECL.EXPRESSION): BOOLEAN; + RETURN (a.T.tType = TSTRING) OR (a.T.tType = TARRAY) & (a.T.Base.tType = TCHAR) +END IsString; + +PROCEDURE Str(e: DECL.EXPRESSION); +VAR A: X86.TIDX; +BEGIN + IF (e.T.tType = TARRAY) & (e.T.Base.tType = TCHAR) & (e.T.Len # 0) THEN + A[0] := e.T.Len; + X86.OpenArray(A, 1) + ELSIF e.T.tType = TSTRING THEN + A[0] := LenString(e.Value) + 1; + IF A[0] # 2 THEN + X86.OpenArray(A, 1) + END + END +END Str; + +PROCEDURE StFunc(VAR e: DECL.EXPRESSION; func: INTEGER); +VAR coord, coord2: SCAN.TCoord; a, b, p: INTEGER; e1, e2: DECL.EXPRESSION; + T: DECL.pTYPE; str, str2: UTILS.STRCONST; +BEGIN + e.vparam := FALSE; + e.eType := eEXP; + Coord(coord2); + Check(lxLRound); + NextCoord(coord); + CASE func OF + |stABS: + pExpr(e1); + Assert(e1.T.tType IN TNUM, coord, 57); + Load(e1); + IF e1.eType = eCONST THEN + e.Value := ABS(e1.Value); + e.eType := eCONST; + Assert(~((e1.T.tType = TINTEGER) & (e1.Value = LONG(FLT(SCAN.minINT)))), coord, DECL.IOVER) + END; + IF e1.T.tType = TINTEGER THEN + X86.StFunc(X86.stABS) + ELSE + X86.StFunc(X86.stFABS) + END; + e.T := e1.T + |stODD: + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + IF e1.eType = eCONST THEN + e.Value := LONG(FLT(ORD(ODD(FLOOR(e1.Value))))); + e.eType := eCONST + END; + X86.StFunc(X86.stODD); + e.T := booltype + |stLEN: + Designator(e1); + Assert((e1.eType = eVAR) & (e1.T.tType = TARRAY), coord, 102); + IF e1.T.Len > 0 THEN + X86.Len(-e1.T.Len) + ELSE + X86.Len(DECL.Dim(e1.T)) + END; + e.T := inttype + |stLSL, stASR, stROR, stLSR: + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + Check(lxComma); + NextCoord(coord); + pExpr(e2); + IntType(e2.T, coord); + Load(e2); + IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN + a := FLOOR(e1.Value); + b := FLOOR(e2.Value); + CASE func OF + |stLSL: a := LSL(a, b) + |stASR: a := ASR(a, b) + |stROR: a := ROR(a, b) + |stLSR: a := LSR(a, b) + ELSE + END; + e.Value := LONG(FLT(a)); + e.eType := eCONST + END; + CASE func OF + |stLSL: X86.StFunc(X86.stLSL) + |stASR: X86.StFunc(X86.stASR) + |stROR: X86.StFunc(X86.stROR) + |stLSR: X86.StFunc(X86.stLSR) + ELSE + END; + e.T := inttype + |stFLOOR: + pExpr(e1); + Assert(e1.T.tType IN TFLOAT, coord, 66); + Load(e1); + IF e1.eType = eCONST THEN + Assert((e1.Value - 1.0D0 < LONG(FLT(SCAN.maxINT))) & (e1.Value >= LONG(FLT(SCAN.minINT))), coord, 74); + e.Value := LONG(FLT(FLOOR(e1.Value))); + e.eType := eCONST + END; + X86.StFunc(X86.stFLOOR); + e.T := inttype + |stFLT: + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + IF e1.eType = eCONST THEN + e.Value := e1.Value; + e.eType := eCONST + END; + X86.StFunc(X86.stFLT); + e.T := realtype + |stORD: + pExpr(e1); + Assert(e1.T.tType IN {TCHAR, TBOOLEAN, TSET, TSTRING}, coord, 68); + IF e1.T.tType = TSTRING THEN + Assert(LenString(e1.Value) = 1, coord, 94) + END; + Load(e1); + IF e1.eType = eCONST THEN + IF e1.T.tType = TSTRING THEN + str := DECL.GetString(e1.Value); + e.Value := LONG(FLT(ORD(str.Str[0]))) + ELSE + e.Value := e1.Value + END; + e.eType := eCONST + END; + IF e1.T.tType = TBOOLEAN THEN + X86.StFunc(X86.stORD) + END; + e.T := inttype + |stBITS: + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + IF e1.eType = eCONST THEN + e.Value := e1.Value; + e.eType := eCONST + END; + e.T := settype + |stCHR: + pExpr(e1); + IntType(e1.T, coord); + Load(e1); + e.T := chartype; + IF e1.eType = eCONST THEN + Assert(ASR(FLOOR(e1.Value), 8) = 0, coord, 76); + str2 := DECL.AddMono(CHR(FLOOR(e1.Value))); + SYSTEM.GET(SYSTEM.ADR(str2), p); + e.Value := LONG(FLT(p)); + e.T := strtype; + e.eType := eCONST + END + |stLONG: + pExpr(e1); + Assert(e1.T.tType = TREAL, coord, 71); + IF e1.eType = eCONST THEN + e.Value := e1.Value; + e.eType := eCONST + END; + Load(e1); + e.T := longrealtype + |stSHORT: + pExpr(e1); + Assert(e1.T.tType = TLONGREAL, coord, 70); + IF e1.eType = eCONST THEN + Assert(ABS(e1.Value) <= LONG(SCAN.maxREAL), coord, DECL.FOVER); + Assert(ABS(e1.Value) >= LONG(SCAN.minREAL), coord, DECL.UNDER); + e.Value := e1.Value; + e.eType := eCONST + END; + Load(e1); + e.T := realtype + |stLENGTH: + pExpr(e1); + Assert(IsString(e1), coord, 141); + IF e1.T.tType = TSTRING THEN + str := DECL.GetString(e1.Value); + IF str.Len = 1 THEN + X86.Mono(str.Number); + X86.StrMono + END; + e.Value := LONG(FLT(LENGTH(str.Str))); + e.eType := eCONST + END; + Str(e1); + e.T := inttype; + X86.StFunc(X86.stLENGTH) + |sysADR: + Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43); + IF SCAN.tLex = lxIDENT THEN + Designator(e1); + Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43); + IF e1.eType = ePROC THEN + X86.PushInt(e1.id.Number) + END + ELSE + pFactor(e1) + END; + IF e1.T = strtype THEN + str := DECL.GetString(e1.Value); + IF str.Len = 1 THEN + X86.Drop; + X86.PushInt(str.Number) + END + END; + e.T := inttype; + X86.ADR(DECL.Dim(e1.T)) + |sysSIZE, sysTYPEID, sysINF: + DECL.SetSizeFunc; + Check(lxIDENT); + T := DECL.IdType(coord); + Assert(T # NIL, coord, 42); + e.eType := eCONST; + IF func = sysTYPEID THEN + e.T := inttype; + Assert(T.tType IN TOBJECT, coord, 47); + IF T.tType = TPOINTER THEN + T := T.Base + END; + e.Value := LONG(FLT(T.Number)); + X86.PushConst(T.Number) + ELSIF func = sysSIZE THEN + e.T := inttype; + e.Value := LONG(FLT(T.Size)); + X86.PushConst(T.Size) + ELSIF func = sysINF THEN + Assert(T.tType IN TFLOAT, coord, 91); + e.T := T; + e.Value := SYSTEM.INF(LONGREAL); + X86.PushFlt(e.Value) + END + ELSE + Assert(FALSE, coord2, 73) + END; + Check(lxRRound); + Next +END StFunc; + +PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN; +VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE; + + PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN; + VAR fp, ft: DECL.FIELD; Res: BOOLEAN; + + PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN; + VAR Res: BOOLEAN; + BEGIN + IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN + Res := TypeComp(T1.Base, T2.Base) + ELSE + Res := ProcTypeComp1(T1, T2) + END + RETURN Res + END TypeComp; + + PROCEDURE Check(): BOOLEAN; + VAR i: INTEGER; res: BOOLEAN; + BEGIN + i := 0; + res := FALSE; + WHILE (i < sp) & ~res DO + res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1)); + INC(i) + END + RETURN res + END Check; + + BEGIN + INC(sp); + stk[sp][0] := T1; + stk[sp][1] := T2; + IF Check() THEN + Res := TRUE + ELSE + IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN + Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base); + fp := T1.Fields.First(DECL.FIELD); + ft := T2.Fields.First(DECL.FIELD); + WHILE Res & (fp # NIL) DO + Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T); + fp := fp.Next(DECL.FIELD); + ft := ft.Next(DECL.FIELD) + END + ELSE + Res := T1 = T2 + END + END; + DEC(sp) + RETURN Res + END ProcTypeComp1; + +BEGIN + sp := -1 + RETURN ProcTypeComp1(T1, T2) +END ProcTypeComp; + +PROCEDURE ArrComp(Ta, Tf: DECL.pTYPE): BOOLEAN; +VAR Res: BOOLEAN; +BEGIN + IF (Tf.tType = TARRAY) & (Tf.Len = 0) & (Ta.tType = TARRAY) THEN + Res := ArrComp(Ta.Base, Tf.Base) + ELSE + Res := ProcTypeComp(Ta, Tf) + END + RETURN Res +END ArrComp; + +PROCEDURE AssComp(e: DECL.EXPRESSION; T: DECL.pTYPE; param: BOOLEAN): BOOLEAN; +VAR Res: BOOLEAN; +BEGIN + CASE T.tType OF + |TINTEGER, TREAL, TLONGREAL, TSET, TBOOLEAN, TCARD16: + Res := e.T = T + |TCHAR: + IF e.T.tType = TSTRING THEN + Res := LenString(e.Value) = 1 + ELSE + Res := e.T.tType = TCHAR + END + |TARRAY: + IF param THEN + IF T.Len = 0 THEN + IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN + Res := TRUE + ELSE + Res := ArrComp(e.T, T) + END + ELSE + IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN + Res := LenString(e.Value) <= T.Len + ELSE + Res := e.T = T + END + END + ELSE + IF T.Len = 0 THEN + Res := FALSE + ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN + Res := LenString(e.Value) <= T.Len + ELSE + Res := e.T = T + END + END + |TRECORD: Res := BaseOf(T, e.T) + |TPOINTER: Res := BaseOf(T, e.T) OR (e.T.tType = TNIL) + |TPROC: Res := (e.T.tType = TNIL) OR (e.eType = ePROC) & ProcTypeComp(e.id.T, T) OR + (e.eType # ePROC) & ProcTypeComp(e.T, T) + ELSE + Res := FALSE + END + RETURN Res +END AssComp; + +PROCEDURE ParamComp(e: DECL.EXPRESSION; T: DECL.pTYPE; ByRef: BOOLEAN): BOOLEAN; +VAR Res: BOOLEAN; +BEGIN + IF ByRef THEN + IF e.eType = eVAR THEN + CASE T.tType OF + |TINTEGER, TREAL, TLONGREAL, TCHAR, + TSET, TBOOLEAN, TPOINTER, TCARD16: + Res := e.T = T + |TARRAY: + IF T.Len > 0 THEN + Res := e.T = T + ELSE + Res := ArrComp(e.T, T) + END + |TRECORD: + Res := BaseOf(T, e.T) + |TPROC: + Res := ProcTypeComp(e.T, T) + ELSE + END + ELSE + Res := FALSE + END + ELSE + Res := AssComp(e, T, TRUE) + END + RETURN Res +END ParamComp; + +PROCEDURE Call(param: DECL.FIELD); +VAR coord: SCAN.TCoord; i, n: INTEGER; e1: DECL.EXPRESSION; s: UTILS.STRCONST; A: X86.TIDX; TA: DECL.pTYPE; +BEGIN + WHILE param # NIL DO + Coord(coord); + X86.Param; + pExpr(e1); + Assert(ParamComp(e1, param.T, param.ByRef), coord, 114); + Assert(~(param.ByRef & e1.Read), coord, 115); + Assert(~((e1.eType = ePROC) & (e1.id.Level > 3)), coord, 116); + IF (e1.eType = eVAR) & ~param.ByRef THEN + X86.Load(e1.T.tType) + END; + IF param.ByRef & (e1.T.tType = TRECORD) THEN + IF e1.vparam THEN + X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level); + X86.Load(TINTEGER) + ELSIF e1.deref THEN + X86.DerefType(0) + ELSE + X86.PushConst(e1.T.Number) + END + END; + IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN + X86.DropFpu(param.T.tType = TLONGREAL) + END; + IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN + s := DECL.GetString(e1.Value); + IF s.Len = 1 THEN + X86.Mono(s.Number) + END; + IF param.T.Len = 0 THEN + A[0] := s.Len + 1; + X86.OpenArray(A, 1) + END + END; + IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN + n := DECL.Dim(param.T) - DECL.Dim(e1.T); + TA := DECL.OpenBase(e1.T); + FOR i := 0 TO n - 1 DO + A[i] := TA.Len; + TA := TA.Base + END; + IF DECL.Dim(e1.T) = 0 THEN + X86.OpenArray(A, n) + ELSE + X86.ExtArray(A, n, DECL.Dim(e1.T)) + END + END; + param := param.Next(DECL.FIELD); + IF param # NIL THEN + Check(lxComma); + Next + END + END; + Check(lxRRound); + Next +END Call; + +PROCEDURE Factor(VAR e: DECL.EXPRESSION); +VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST; +BEGIN + e.eType := eCONST; + e.vparam := FALSE; + CASE SCAN.tLex OF + |lxIDENT: + begcall := X86.current; + Designator(e); + IF e.eType = ePROC THEN + IF SCAN.tLex = lxLRound THEN + Assert2(e.id.T.Base.tType # TVOID, 73); + Next; + X86.PushCall(begcall); + Call(e.id.T.Fields.First(DECL.FIELD)); + X86.EndCall; + e.eType := eEXP; + e.T := e.id.T.Base; + IF e.id.Level = 3 THEN + ccall := 0 + ELSIF e.id.Level > DECL.curBlock.Level THEN + ccall := 1 + ELSE + ccall := 2 + END; + X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3, + DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize) + ELSE + X86.PushInt(e.id.Number) + END + ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN + Assert2(e.T.Base.tType # TVOID, 73); + Next; + X86.PushCall(begcall); + Call(e.T.Fields.First(DECL.FIELD)); + X86.EndCall; + e.eType := eEXP; + X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize); + e.T := e.T.Base; + ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN + StFunc(e, e.id.StProc) + END + |lxNIL: + e.T := niltype; + e.Value := 0.0D0; + X86.PushConst(0); + Next + |lxTRUE: + e.T := booltype; + e.Value := 1.0D0; + X86.PushConst(1); + Next + |lxFALSE: + e.T := booltype; + e.Value := 0.0D0; + X86.PushConst(0); + Next + |lxCHX, lxSTRING: + IF SCAN.tLex = lxSTRING THEN + str2 := DECL.AddString(SCAN.Lex); + SYSTEM.GET(SYSTEM.ADR(str2), p); + e.Value := LONG(FLT(p)); + s := DECL.GetString(e.Value); + IF s.Len = 1 THEN + X86.PushConst(ORD(s.Str[0])) + ELSE + X86.PushInt(s.Number) + END + ELSE + str2 := DECL.AddMono(SCAN.vCHX); + SYSTEM.GET(SYSTEM.ADR(str2), p); + e.Value := LONG(FLT(p)); + X86.PushConst(ORD(SCAN.vCHX)) + END; + e.T := strtype; + Next + |lxREAL: + e.T := realtype; + e.Value := SCAN.vFLT; + X86.PushFlt(SCAN.vFLT); + Next + |lxLONGREAL: + e.T := longrealtype; + e.Value := SCAN.vFLT; + X86.PushFlt(SCAN.vFLT); + Next + |lxINT, lxHEX: + e.T := inttype; + e.Value := LONG(FLT(SCAN.vINT)); + X86.PushConst(SCAN.vINT); + Next + |lxLRound: + Next; + pExpr(e); + Check(lxRRound); + Next + |lxNot: + NextCoord(coord); + Factor(e); + Assert(e.T.tType = TBOOLEAN, coord, 37); + Load(e); + IF e.eType = eCONST THEN + e.Value := LONG(FLT(ORD(e.Value = 0.0D0))) + ELSE + e.eType := eEXP + END; + X86.Not; + e.vparam := FALSE + |lxLCurly: + Set(e) + ELSE + Assert2(FALSE, 36) + END +END Factor; + +PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN; + RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR) +END IsChr; + +PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER); +BEGIN + IF ~(IsChr(a) OR IsChr(b)) THEN + X86.strcmp(Op, 0) + ELSIF IsChr(a) & IsChr(b) THEN + X86.CmpInt(Op) + ELSIF IsChr(a) THEN + X86.strcmp(Op, 1) + ELSE + X86.strcmp(Op, -1) + END +END StrRel; + +PROCEDURE log2(n: INTEGER): INTEGER; +VAR x, i: INTEGER; +BEGIN + x := 1; + i := 0; + WHILE (x # n) & (i < 31) DO + x := LSL(x, 1); + INC(i) + END; + IF x # n THEN + i := -1 + END + RETURN i +END log2; + +PROCEDURE Operation(VAR a, b: DECL.EXPRESSION; Op: INTEGER; coord: SCAN.TCoord); +VAR n, m: INTEGER; +BEGIN + CASE Op OF + |lxPlus, lxMinus, lxMult, lxSlash: + Assert((a.T.tType IN (TNUM + {TSET})) & (a.T.tType = b.T.tType), coord, 37); + Assert(~((Op = lxSlash) & (a.T.tType = TINTEGER)), coord, 37); + CASE a.T.tType OF + |TINTEGER: X86.Int(Op) + |TSET: X86.Set(Op) + |TREAL, TLONGREAL: X86.farith(Op) + ELSE + END + |lxDIV, lxMOD: + Assert((a.T.tType = TINTEGER) & (b.T.tType = TINTEGER), coord, 37); + IF b.eType = eCONST THEN + m := FLOOR(b.Value); + Assert(m # 0, coord, 48); + n := log2(m); + IF n = -1 THEN + X86.idivmod(Op = lxMOD) + ELSE + X86.Drop; + IF Op = lxMOD THEN + n := ORD(-BITS(LSL(-1, n))); + X86.PushConst(n); + X86.Set(lxMult) + ELSE + X86.PushConst(n); + X86.StFunc(X86.stASR) + END + END + ELSE + X86.idivmod(Op = lxMOD) + END + |lxAnd, lxOR: + Assert((a.T.tType = TBOOLEAN) & (b.T.tType = TBOOLEAN), coord, 37) + |lxIN: + Assert((a.T.tType = TINTEGER) & (b.T.tType = TSET), coord, 37); + X86.inset + |lxLT, lxLE, lxGT, lxGE: + Assert(((a.T.tType IN TNUM) & (a.T.tType = b.T.tType)) OR + (IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR + (a.T.tType = TSET) & (b.T.tType = TSET) & ((Op = lxLE) OR (Op = lxGE)), coord, 37); + IF a.T.tType IN TFLOAT THEN + X86.fcmp(Op) + ELSIF a.T.tType = TSET THEN + X86.Inclusion(Op) + ELSIF IsString(a) OR IsString(b) THEN + StrRel(a, b, Op) + ELSE + X86.CmpInt(Op) + END + |lxEQ, lxNE: + Assert(((a.T.tType IN (TNUM + {TSET, TBOOLEAN})) & (a.T.tType = b.T.tType)) OR + (IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR + (a.T.tType IN {TPOINTER, TPROC, TNIL}) & (b.T.tType = TNIL) OR + (b.T.tType IN {TPOINTER, TPROC, TNIL}) & (a.T.tType = TNIL) OR + (a.T.tType = TPOINTER) & (b.T.tType = TPOINTER) & (BaseOf(a.T, b.T) OR BaseOf(b.T, a.T)) OR + (a.T.tType = TPROC) & ProcTypeComp(b.T, a.T) OR (a.eType = ePROC) & ProcTypeComp(b.T, a.id.T) OR + (b.eType = ePROC) & ProcTypeComp(a.T, b.id.T), coord, 37); + IF a.T.tType IN TFLOAT THEN + X86.fcmp(Op) + ELSIF IsString(a) OR IsString(b) THEN + StrRel(a, b, Op) + ELSE + X86.CmpInt(Op) + END + ELSE + END; + IF (a.eType # eCONST) OR (b.eType # eCONST) THEN + a.eType := eEXP; + IF DECL.Relation(Op) THEN + a.T := booltype + END + ELSE + DECL.Calc(a.Value, b.Value, a.T, b.T, Op, coord, a.Value, a.T) + END; + a.vparam := FALSE +END Operation; + +PROCEDURE Term(VAR e: DECL.EXPRESSION); +VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord; +BEGIN + Factor(e); + WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR + (SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR + (SCAN.tLex = lxAnd) DO + Load(e); + Coord(coord); + Op := SCAN.tLex; + Next; + IF Op = lxAnd THEN + L := X86.NewLabel(); + X86.IfWhile(L, FALSE) + END; + Factor(a); + Load(a); + IF Op = lxAnd THEN + X86.Label(L) + END; + Operation(e, a, Op, coord) + END +END Term; + +PROCEDURE Simple(VAR e: DECL.EXPRESSION); +VAR a: DECL.EXPRESSION; Op, uOp, L: INTEGER; coord, ucoord: SCAN.TCoord; +BEGIN + uOp := 0; + IF (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) THEN + Coord(ucoord); + uOp := SCAN.tLex; + Next + END; + Term(e); + IF uOp # 0 THEN + Assert(e.T.tType IN (TNUM + {TSET}), ucoord, 37); + Load(e); + IF uOp = lxMinus THEN + CASE e.T.tType OF + |TINTEGER: X86.NegInt + |TSET: X86.NegSet + |TREAL, TLONGREAL: X86.fneg + ELSE + END + END; + IF (uOp = lxMinus) & (e.eType = eCONST) THEN + CASE e.T.tType OF + |TINTEGER: + Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER) + |TSET: + e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value))))) + ELSE + END; + e.Value := -e.Value + END; + IF e.eType # eCONST THEN + e.eType := eEXP + END; + e.vparam := FALSE + END; + WHILE (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) OR (SCAN.tLex = lxOR) DO + Load(e); + Coord(coord); + Op := SCAN.tLex; + Next; + IF Op = lxOR THEN + L := X86.NewLabel(); + X86.IfWhile(L, TRUE) + END; + Term(a); + Load(a); + IF Op = lxOR THEN + X86.Label(L) + END; + Operation(e, a, Op, coord) + END +END Simple; + +PROCEDURE Expr(VAR e: DECL.EXPRESSION); +VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST; +BEGIN + fpu := X86.fpu; + beg := X86.current; + Simple(e); + IF DECL.Relation(SCAN.tLex) THEN + Coord(coord); + Op := SCAN.tLex; + Next; + IF Op = lxIS THEN + Assert(e.T.tType IN TOBJECT, coord, 37); + IF e.T.tType = TRECORD THEN + Assert(e.vparam, coord, 37) + END; + Check(lxIDENT); + Coord(coord2); + T := DECL.IdType(coord2); + Assert(T # NIL, coord2, 42); + IF e.T.tType = TRECORD THEN + Assert(T.tType = TRECORD, coord2, 106) + ELSE + Assert(T.tType = TPOINTER, coord2, 107) + END; + Assert(BaseOf(e.T, T), coord, 37); + IF e.T.tType = TRECORD THEN + X86.Drop; + X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level) + END; + Load(e); + IF e.T.tType = TPOINTER THEN + T := T.Base + END; + X86.Guard(T.Number, TRUE); + e.T := booltype; + e.eType := eEXP; + e.vparam := FALSE + ELSE + Load(e); + Str(e); + Simple(a); + Load(a); + Str(a); + Operation(e, a, Op, coord) + END + END; + IF e.eType = eCONST THEN + X86.Del(beg); + X86.Setfpu(fpu); + IF ~DECL.Const THEN + CASE e.T.tType OF + |TREAL, TLONGREAL: + X86.PushFlt(e.Value) + |TINTEGER, TSET, TBOOLEAN, TNIL: + X86.PushConst(FLOOR(e.Value)) + |TSTRING: + s := DECL.GetString(e.Value); + IF s.Len = 1 THEN + X86.PushConst(ORD(s.Str[0])) + ELSE + X86.PushInt(s.Number) + END + ELSE + END + END + END +END Expr; + +PROCEDURE IfWhileOper(wh: BOOLEAN); +VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER; +BEGIN + L := X86.NewLabel(); + IF wh THEN + X86.Label(L) + END; + REPEAT + NextCoord(coord); + Expr(e); + Assert(e.T.tType = TBOOLEAN, coord, 117); + Load(e); + IF wh THEN + Check(lxDO) + ELSE + Check(lxTHEN) + END; + L3 := X86.NewLabel(); + X86.ifwh(L3); + Next; + pOpSeq; + X86.jmp(X86.JMP, L); + X86.Label(L3) + UNTIL SCAN.tLex # lxELSIF; + IF ~wh & (SCAN.tLex = lxELSE) THEN + Next; + pOpSeq + END; + Check(lxEND); + IF ~wh THEN + X86.Label(L) + END; + Next +END IfWhileOper; + +PROCEDURE RepeatOper; +VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER; +BEGIN + Next; + L := X86.NewLabel(); + X86.Label(L); + pOpSeq; + Check(lxUNTIL); + NextCoord(coord); + Expr(e); + Assert(e.T.tType = TBOOLEAN, coord, 117); + Load(e); + X86.ifwh(L) +END RepeatOper; + +PROCEDURE ForOper; +VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL; + T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT; +BEGIN + NextCheck(lxIDENT); + name := SCAN.id; + id := DECL.GetIdent(name); + Assert2(id # NIL, 42); + Assert2(id.iType = IDVAR, 126); + Assert2(id.VarKind = 0, 127); + Assert2(id.T.tType = TINTEGER, 128); + Assert2(id.Level = DECL.unit.Level, 129); + NextCheck(lxAssign); + NextCoord(coord); + IF id.Level = 3 THEN + X86.GlobalAdr(id.Offset) + ELSE + X86.LocalAdr(id.Offset, 0) + END; + X86.Dup; + Expr(e); + IntType(e.T, coord); + Load(e); + X86.Save(TINTEGER); + Check(lxTO); + NextCoord(coord); + Expr(e); + IntType(e.T, coord); + Load(e); + iValue := 1; + IF SCAN.tLex = lxBY THEN + NextCoord(coord); + DECL.ConstExpr(Value, T); + IntType(T, coord); + iValue := FLOOR(Value); + Assert(iValue # 0, coord, 122) + END; + Check(lxDO); + Next; + X86.For(iValue > 0, LBeg, LEnd); + pOpSeq; + X86.NextFor(iValue, LBeg, LEnd); + Check(lxEND); + Next +END ForOper; + +PROCEDURE CheckLabel(a, b: INTEGER; Labels: UTILS.LIST): BOOLEAN; +VAR cur: LABEL; +BEGIN + cur := Labels.First(LABEL); + WHILE (cur # NIL) & ((b < cur.a) OR (a > cur.b)) DO + cur := cur.Next(LABEL) + END + RETURN cur = NIL +END CheckLabel; + +PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN); +VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord; +BEGIN + Coord(coord); + DECL.ConstExpr(Value, T); + IF int THEN + Assert(T.tType = TINTEGER, coord, 161); + a := FLOOR(Value) + ELSE + Assert(T.tType = TSTRING, coord, 55); + s := DECL.GetString(Value); + Assert(s.Len = 1, coord, 94); + a := ORD(s.Str[0]) + END +END LabelVal; + +PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER); +VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord; +BEGIN + Coord(coord); + LabelVal(a, int); + b := a; + IF SCAN.tLex = lxDbl THEN + Next; + LabelVal(b, int) + END; + Assert(a <= b, coord, 54); + Assert(CheckLabel(a, b, Labels), coord, 100); + NEW(label); + DECL.MemErr(label = NIL); + label.a := a; + label.b := b; + UTILS.Push(Labels, label); + X86.CaseLabel(a, b, LBeg) +END Label; + +PROCEDURE Variant(int: BOOLEAN; Labels: UTILS.LIST; EndCase: INTEGER); +VAR LBeg, LEnd: INTEGER; +BEGIN + LBeg := X86.NewLabel(); + LEnd := X86.NewLabel(); + IF ~((SCAN.tLex = lxStick) OR (SCAN.tLex = lxEND)) THEN + Label(int, Labels, LBeg); + WHILE SCAN.tLex = lxComma DO + Next; + Label(int, Labels, LBeg) + END; + Check(lxColon); + Next; + X86.jmp(X86.JMP, LEnd); + X86.Label(LBeg); + pOpSeq; + X86.jmp(X86.JMP, EndCase); + X86.Label(LEnd) + END +END Variant; + +PROCEDURE CaseOper; +VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST; +BEGIN + NextCoord(coord); + Expr(e); + Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156); + Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94); + int := e.T.tType = TINTEGER; + Check(lxOF); + Load(e); + X86.Drop; + Labels := UTILS.CreateList(); + Next; + EndCase := X86.NewLabel(); + Variant(int, Labels, EndCase); + WHILE SCAN.tLex = lxStick DO + Next; + Variant(int, Labels, EndCase) + END; + IF SCAN.tLex = lxELSE THEN + Next; + pOpSeq + ELSE + UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line); + X86.OnError(7) + END; + Check(lxEND); + X86.Label(EndCase); + Next; + UTILS.Clear(Labels) +END CaseOper; + +PROCEDURE CheckCode(Code: UTILS.STRING; Len: INTEGER; coord: SCAN.TCoord); +VAR i: INTEGER; +BEGIN + Assert(~ODD(Len), coord, 34); + FOR i := 0 TO Len - 1 DO + Assert(SCAN.HexDigit(Code[i]), coord, 34) + END +END CheckCode; + +PROCEDURE StProc(proc: INTEGER); +VAR coord, coord2: SCAN.TCoord; iValue: INTEGER; e1, e2: DECL.EXPRESSION; Value: LONGREAL; + T: DECL.pTYPE; str: UTILS.STRCONST; begcall: X86.ASMLINE; +BEGIN + Coord(coord2); + Check(lxLRound); + NextCoord(coord); + CASE proc OF + |stINC, stDEC: + Designator(e1); + Assert(e1.eType = eVAR, coord, 63); + Assert(~e1.Read, coord, 115); + Assert(e1.T.tType = TINTEGER, coord, 128); + IF SCAN.tLex = lxComma THEN + NextCoord(coord); + DECL.ConstExpr(Value, T); + IntType(T, coord); + iValue := FLOOR(Value); + Assert(iValue # 0, coord, 122); + IF iValue < 0 THEN + IF proc = stINC THEN + proc := stDEC + ELSE + proc := stINC + END; + iValue := -iValue + END; + IF iValue # 1 THEN + X86.PushConst(iValue); + IF proc = stDEC THEN + X86.StProc(X86.stDEC) + ELSE + X86.StProc(X86.stINC) + END + ELSE + IF proc = stDEC THEN + X86.StProc(X86.stDEC1) + ELSE + X86.StProc(X86.stINC1) + END + END + ELSE + IF proc = stDEC THEN + X86.StProc(X86.stDEC1) + ELSE + X86.StProc(X86.stINC1) + END + END + |stINCL, stEXCL: + Designator(e1); + Assert(e1.eType = eVAR, coord, 63); + Assert(~e1.Read, coord, 115); + Assert(e1.T.tType = TSET, coord, 138); + Check(lxComma); + NextCoord(coord); + DECL.ConstExpr(Value, T); + IntType(T, coord); + iValue := FLOOR(Value); + Assert(ASR(iValue, 5) = 0, coord, 53); + IF proc = stINCL THEN + X86.PushConst(ORD({iValue})); + X86.StProc(X86.stINCL) + ELSE + X86.PushConst(ORD(-{iValue})); + X86.StProc(X86.stEXCL) + END + |stCOPY: + Expr(e1); + Assert(IsString(e1), coord, 141); + Check(lxComma); + IF e1.T.tType = TSTRING THEN + str := DECL.GetString(e1.Value); + IF str.Len = 1 THEN + X86.Mono(str.Number); + X86.StrMono + END + END; + Str(e1); + NextCoord(coord); + Designator(e2); + Assert(e2.eType = eVAR, coord, 63); + Assert(IsString(e2), coord, 143); + Assert(~e2.Read, coord, 115); + Str(e2); + X86.StProc(X86.stCOPY) + |stNEW, stDISPOSE: + Designator(e1); + Assert(e1.eType = eVAR, coord, 63); + Assert(~e1.Read, coord, 115); + Assert(e1.T.tType = TPOINTER, coord, 145); + IF proc = stNEW THEN + X86.PushConst(e1.T.Base.Number); + X86.PushConst(X86.Align(e1.T.Base.Size + 8, 32)); + X86.newrec + ELSE + X86.disprec + END + |stASSERT: + Expr(e1); + Assert(e1.T.tType = TBOOLEAN, coord, 117); + Load(e1); + IF SCAN.tLex = lxComma THEN + NextCoord(coord); + DECL.ConstExpr(Value, T); + IntType(T, coord); + Assert((Value >= 0.0D0) & (Value <= 127.0D0), coord, 95); + X86.Assert(X86.stASSERT, FLOOR(Value)) + ELSE + X86.Assert(X86.stASSERT1, 0) + END + |stPACK, stUNPK: + Designator(e1); + Assert(e1.eType = eVAR, coord, 63); + Assert(e1.T.tType IN TFLOAT, coord, 149); + Assert(~e1.Read, coord, 115); + Check(lxComma); + NextCoord(coord); + IF proc = stUNPK THEN + Designator(e2); + Assert(e2.eType = eVAR, coord, 63); + Assert(e2.T.tType = TINTEGER, coord, 128); + Assert(~e2.Read, coord, 115); + IF e1.T.tType = TLONGREAL THEN + X86.StProc(X86.stUNPK) + ELSE + X86.StProc(X86.stUNPK1) + END + ELSE + Expr(e2); + IntType(e2.T, coord); + Load(e2); + IF e1.T.tType = TLONGREAL THEN + X86.StProc(X86.stPACK) + ELSE + X86.StProc(X86.stPACK1) + END + END + |sysPUT, sysGET: + begcall := X86.current; + Expr(e1); + IntType(e1.T, coord); + Load(e1); + Check(lxComma); + NextCoord(coord); + IF proc = sysGET THEN + X86.PushCall(begcall); + X86.Param; + Designator(e2); + Assert(e2.eType = eVAR, coord, 63); + Assert(~(e2.T.tType IN TSTRUCT), coord, 90); + Assert(~e2.Read, coord, 115); + X86.EndCall; + X86.Load(e2.T.tType); + X86.Save(e2.T.tType) + ELSE + Expr(e2); + Assert(~(e2.T.tType IN TSTRUCT), coord, 90); + IF e2.T.tType = TSTRING THEN + Assert(LenString(e2.Value) = 1, coord, 94) + ELSIF e2.T.tType = TVOID THEN + e2.T := inttype + END; + Load(e2); + X86.Save(e2.T.tType) + END + |sysCODE: + Assert(SCAN.tLex = lxSTRING, coord, 150); + CheckCode(SCAN.Lex, SCAN.count - 1, coord); + X86.Asm(SCAN.Lex); + Next + |sysMOVE: + begcall := X86.current; + Expr(e1); + IntType(e1.T, coord); + Load(e1); + Check(lxComma); + X86.PushCall(begcall); + X86.Param; + NextCoord(coord); + Expr(e1); + IntType(e1.T, coord); + Load(e1); + Check(lxComma); + X86.EndCall; + NextCoord(coord); + Expr(e1); + IntType(e1.T, coord); + Load(e1); + ELSE + Assert(FALSE, coord2, 132) + END; + Check(lxRRound); + Next; + IF proc = sysMOVE THEN + X86.StProc(X86.sysMOVE) + END +END StProc; + +PROCEDURE IdentOper; +VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST; +BEGIN + Coord(coord); + begcall := X86.current; + Designator(e1); + Assert(e1.eType # eCONST, coord, 130); + IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN + Check(lxAssign); + Assert(~e1.Read, coord, 115); + NextCoord(coord); + Expr(e2); + Assert(AssComp(e2, e1.T, FALSE), coord, 131); + Load(e2); + IF e1.T.tType = TRECORD THEN + X86.PushConst(e1.T.Size); + X86.PushConst(e1.T.Number); + IF e1.vparam THEN + X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level); + X86.Load(TINTEGER) + ELSIF e1.deref THEN + X86.DerefType(12) + ELSE + X86.PushConst(e1.T.Number) + END + ELSIF e2.T.tType = TARRAY THEN + X86.PushConst(e2.T.Size) + ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN + s := DECL.GetString(e2.Value); + IF s.Len = 1 THEN + X86.Mono(s.Number) + END; + X86.PushConst(UTILS.min(s.Len + 1, e1.T.Len)) + END; + X86.Save(e1.T.tType) + ELSIF e1.eType = ePROC THEN + Assert((e1.id.T.Base.tType = TVOID) OR (e1.id.T.Call = DECL.winapi), coord, 132); + IF e1.id.ParamCount > 0 THEN + Check(lxLRound); + Next; + X86.PushCall(begcall); + Call(e1.id.T.Fields.First(DECL.FIELD)); + X86.EndCall + ELSIF SCAN.tLex = lxLRound THEN + NextCheck(lxRRound); + Next + END; + IF e1.id.Level = 3 THEN + ccall := 0 + ELSIF e1.id.Level > DECL.curBlock.Level THEN + ccall := 1 + ELSE + ccall := 2 + END; + X86.Call(e1.id.Number, FALSE, FALSE, e1.id.T.Call, ccall, e1.id.Level - 3, DECL.curBlock.Level - 3, e1.id.ParamSize, DECL.curBlock.LocalSize) + ELSIF e1.eType IN {eSTPROC, eSYSPROC} THEN + StProc(e1.id.StProc) + ELSIF (e1.eType = eVAR) & (e1.T.tType = TPROC) THEN + IF SCAN.tLex = lxLRound THEN + Next; + Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132); + X86.PushCall(begcall); + Call(e1.T.Fields.First(DECL.FIELD)); + X86.EndCall; + X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize) + ELSIF SCAN.tLex = lxAssign THEN + Assert(~e1.Read, coord, 115); + NextCoord(coord); + Expr(e2); + Assert(AssComp(e2, e1.T, FALSE), coord, 131); + Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116); + IF e2.eType = eVAR THEN + X86.Load(TPROC) + END; + X86.Save(TPROC) + ELSE + Assert2(e1.T.Fields.Count = 0, 155); + Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132); + X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize) + END + END +END IdentOper; + +PROCEDURE Operator; +BEGIN + UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line); + CASE SCAN.tLex OF + |lxIDENT: IdentOper + |lxIF, lxWHILE: IfWhileOper(SCAN.tLex = lxWHILE) + |lxREPEAT: RepeatOper + |lxFOR: ForOper + |lxCASE: CaseOper + ELSE + END +END Operator; + +PROCEDURE OpSeq; +BEGIN + Operator; + WHILE SCAN.tLex = lxSemi DO + Next; + Operator + END +END OpSeq; + +PROCEDURE Start; +VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath, + Name, Ext, temp, system, stk: UTILS.STRING; + platform, stksize: INTEGER; + + PROCEDURE getstksize(): INTEGER; + VAR res, i: INTEGER; + BEGIN + res := 0; + i := 0; + WHILE SCAN.Digit(stk[i]) DO + INC(i) + END; + IF stk[i] <= 20X THEN + stk[i] := 0X; + res := SCAN.StrToInt(stk) + END; + IF res = 0 THEN + res := 1 + END + RETURN res + END getstksize; + + PROCEDURE getver(): INTEGER; + VAR res, i: INTEGER; err: BOOLEAN; + + PROCEDURE hexdgt(c: CHAR): BOOLEAN; + RETURN ("0" <= c) & (c <= "9") OR + ("A" <= c) & (c <= "F") OR + ("a" <= c) & (c <= "f") + END hexdgt; + + PROCEDURE hex(c: CHAR): INTEGER; + VAR res: INTEGER; + BEGIN + IF ("0" <= c) & (c <= "9") THEN + res := ORD(c) - ORD("0") + ELSIF ("A" <= c) & (c <= "F") THEN + res := ORD(c) - ORD("A") + 10 + ELSIF ("a" <= c) & (c <= "f") THEN + res := ORD(c) - ORD("a") + 10 + END + RETURN res + END hex; + + BEGIN + res := 0; + i := 0; + err := stk[i] # "0"; INC(i); + err := err OR (stk[i] # "x"); INC(i); + WHILE ~err & hexdgt(stk[i]) DO + INC(i) + END; + err := err OR (i = 2); + IF stk[i] <= 20X THEN + stk[i] := 0X + ELSE + err := TRUE + END; + i := 2; + WHILE ~err & (stk[i] # 0X) DO + res := LSL(res, 4) + hex(stk[i]); + INC(i) + END; + IF res = 0 THEN + res := 65536 + END + RETURN res + END getver; + +BEGIN + IF UTILS.ParamCount < 2 THEN + UTILS.ErrMsg(59); + UTILS.HALT(1) + END; + UTILS.ParamStr(SelfName, 0); + UTILS.ParamStr(FName, 1); + UTILS.ParamStr(system, 2); + UTILS.ParamStr(stk, 3); + pExpr := Expr; + pFactor := Factor; + pOpSeq := OpSeq; + UTILS.Split(FName, Path, Name, Ext); + IF Ext # UTILS.Ext THEN + UTILS.ErrMsg(121); + UTILS.HALT(1) + END; + UTILS.Split(SelfName, SelfPath, CName, CExt); + temp := Name; + IF UTILS.streq(system, "obj") THEN + platform := 6; + UTILS.concat(temp, ".obj") + ELSIF UTILS.streq(system, "elf") THEN + platform := 5 + ELSIF UTILS.streq(system, "kos") THEN + platform := 4; + UTILS.concat(temp, ".kex") + ELSIF UTILS.streq(system, "con") THEN + platform := 3; + UTILS.concat(temp, ".exe") + ELSIF UTILS.streq(system, "gui") THEN + platform := 2; + UTILS.concat(temp, ".exe") + ELSIF UTILS.streq(system, "dll") THEN + platform := 1; + UTILS.concat(temp, ".dll") + ELSE + UTILS.ErrMsg(60); + UTILS.HALT(1) + END; + IF platform IN {1, 2, 3, 4} THEN + stksize := getstksize() + ELSE + stksize := 1 + END; + IF platform = 6 THEN + stksize := getver() + END; + UTILS.concat(SelfPath, "Lib"); + UTILS.concat(SelfPath, UTILS.Slash); + IF platform = 5 THEN + UTILS.concat(SelfPath, "Linux32") + ELSIF platform IN {4, 6} THEN + UTILS.concat(SelfPath, "KolibriOS") + ELSIF platform IN {1, 2, 3} THEN + UTILS.concat(SelfPath, "Windows32") + END; + UTILS.concat(SelfPath, UTILS.Slash); + X86.Init(platform); + X86.Prolog(temp); + DECL.Program(SelfPath, Path, Name, Ext, platform IN {1, 2, 3}, OpSeq, Expr, AssComp, sttypes); + voidtype := sttypes[TVOID]; + inttype := sttypes[TINTEGER]; + booltype := sttypes[TBOOLEAN]; + strtype := sttypes[TSTRING]; + settype := sttypes[TSET]; + realtype := sttypes[TREAL]; + longrealtype := sttypes[TLONGREAL]; + chartype := sttypes[TCHAR]; + niltype := sttypes[TNIL]; + DECL.Compile(platform, stksize); + UTILS.OutString("success"); UTILS.Ln; + UTILS.HALT(0) +END Start; + +BEGIN + Start +END Compiler. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/DECL.ob07 b/programs/develop/oberon07/Source/DECL.ob07 new file mode 100644 index 0000000000..07c7cdac8e --- /dev/null +++ b/programs/develop/oberon07/Source/DECL.ob07 @@ -0,0 +1,1618 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE DECL; + +IMPORT SCAN, UTILS, X86, SYSTEM; + +CONST + + lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7; + lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8; + lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16; + lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23; + lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30; + lxUNTIL = 31; lxVAR = 32; lxWHILE = 33; + + lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58; + lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65; + lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70; + lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76; + + lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106; + lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120; + + IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9; + + stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8; + stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15; + stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22; + stBITS = 23; stLSR = 24; stLENGTH = 25; + + sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105; + sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; + + TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; TNIL = 8; + TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14; + + TNUM = {TINTEGER, TREAL, TLONGREAL}; + TFLOAT = {TREAL, TLONGREAL}; + TSTRUCT = {TARRAY, TRECORD}; + + paramvar* = 1; param* = 2; + + defcall = 0; stdcall = 1; cdecl = 2; winapi* = 3; + + record = 0; union = 1; noalign = 2; + + eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6; + + IOVER* = lxERR5 - lxERR0; + FOVER* = lxERR7 - lxERR0; + UNDER* = lxERR9 - lxERR0; + +TYPE + + pTYPE* = POINTER TO RECORD (UTILS.rITEM) + tType*, Size*, Len*, Number*, Align, Call*, Rec: INTEGER; + Base*: pTYPE; + Fields*: UTILS.LIST + END; + + IDENT* = POINTER TO rIDENT; + + UNIT* = POINTER TO RECORD (UTILS.rITEM) + Name: SCAN.NODE; + File: UTILS.STRING; + Idents: UTILS.LIST; + Import: UTILS.LIST; + IdentBegin: IDENT; + scanner: SCAN.SCANNER; + Level*: INTEGER; + Closed, typedecl, Std, sys: BOOLEAN + END; + + rIDENT* = RECORD (UTILS.rITEM) + Name*: SCAN.NODE; + T*: pTYPE; + Unit*: UNIT; + Parent*: IDENT; + Proc*: UTILS.ITEM; + Value*: LONGREAL; + coord*: SCAN.TCoord; + Number*, iType*, StProc*, VarSize, ParamSize*, + LocalSize*, Offset*, VarKind*, Level*, ParamCount*: INTEGER; + Export: BOOLEAN + END; + + PTRBASE = POINTER TO RECORD (UTILS.rITEM) + Name: SCAN.NODE; + coord: SCAN.TCoord; + Ptr: pTYPE + END; + + STRITEM = POINTER TO RECORD (UTILS.rITEM) + Str: UTILS.STRING + END; + + FIELD* = POINTER TO RECORD (UTILS.rITEM) + Name: SCAN.NODE; + T*: pTYPE; + Offset*: INTEGER; + ByRef*, Export*: BOOLEAN; + Unit*: UNIT + END; + + EXPRESSION* = RECORD + id*: IDENT; + T*: pTYPE; + eType*: INTEGER; + Value*: LONGREAL; + Read*, vparam*, deref*: BOOLEAN + END; + + opPROC = PROCEDURE; + expPROC = PROCEDURE (VAR e: EXPRESSION); + assPROC = PROCEDURE (e: EXPRESSION; T: pTYPE; param: BOOLEAN): BOOLEAN; + + stTYPES* = ARRAY 11 OF pTYPE; + + Proc* = POINTER TO RECORD (UTILS.rITEM) + used: BOOLEAN; + beg, end: X86.ASMLINE; + Procs*: UTILS.LIST + END; + +VAR + + sttypes: stTYPES; unit*, sys: UNIT; curBlock*: IDENT; + Path, Main, Std, ExtMain: UTILS.STRING; + NamePtrBase: SCAN.NODE; ProgSize*, RecCount, UnitNumber*: INTEGER; + PtrBases, Strings, types, prog, procs: UTILS.LIST; OpSeq: opPROC; Expr: expPROC; + AssComp: assPROC; main, sizefunc, winplatf, Const*: BOOLEAN; + pParseType: PROCEDURE (VAR coord: SCAN.TCoord): pTYPE; + pReadModule: PROCEDURE (Path, Name, Ext: UTILS.STRING): BOOLEAN; + Platform: INTEGER; voidtype: pTYPE; zcoord: SCAN.TCoord; + curproc*: Proc; + +PROCEDURE SetSizeFunc*; +BEGIN + sizefunc := TRUE +END SetSizeFunc; + +PROCEDURE MemErr*(err: BOOLEAN); +BEGIN + IF err THEN + UTILS.MemErr(TRUE) + END +END MemErr; + +PROCEDURE GetString*(adr: LONGREAL): UTILS.STRCONST; +VAR str: UTILS.STRCONST; +BEGIN + SYSTEM.PUT(SYSTEM.ADR(str), FLOOR(adr)) + RETURN str +END GetString; + +PROCEDURE AddString*(str: UTILS.STRING): UTILS.STRCONST; +VAR nov: UTILS.STRCONST; +BEGIN + nov := UTILS.GetStr(Strings, str); + IF nov = NIL THEN + NEW(nov); + MemErr(nov = NIL); + nov.Str := str; + nov.Len := SCAN.count - 1; + nov.Number := X86.NewLabel(); + UTILS.Push(Strings, nov); + X86.String(nov.Number, nov.Len, nov.Str) + END + RETURN nov +END AddString; + +PROCEDURE AddMono*(c: CHAR): UTILS.STRCONST; +VAR nov: UTILS.STRCONST; s: UTILS.STRING; +BEGIN + s[0] := c; + s[1] := 0X; + nov := UTILS.GetStr(Strings, s); + IF nov = NIL THEN + NEW(nov); + MemErr(nov = NIL); + nov.Str := s; + nov.Len := 1; + nov.Number := X86.NewLabel(); + UTILS.Push(Strings, nov); + X86.String(nov.Number, nov.Len, nov.Str) + END + RETURN nov +END AddMono; + +PROCEDURE Coord(VAR coord: SCAN.TCoord); +BEGIN + coord := SCAN.coord +END Coord; + +PROCEDURE GetModule(Name: SCAN.NODE): UNIT; +VAR cur, res: UNIT; +BEGIN + res := NIL; + cur := prog.First(UNIT); + WHILE (cur # NIL) & UTILS.streq(cur.Name.Name, Name.Name) DO + res := cur; + cur := NIL + ELSIF cur # NIL DO + cur := cur.Next(UNIT) + END + RETURN res +END GetModule; + +PROCEDURE Assert*(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER); +BEGIN + IF ~cond THEN + UTILS.ErrMsgPos(coord.line, coord.col, code); + UTILS.HALT(1) + END +END Assert; + +PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER); +BEGIN + IF ~cond THEN + Assert(FALSE, SCAN.coord, code) + END +END Assert2; + +PROCEDURE Next*; +VAR coord: SCAN.TCoord; +BEGIN + SCAN.GetLex; + IF (SCAN.tLex > lxERR0) & (SCAN.tLex < lxERR20) THEN + coord.line := SCAN.coord.line; + coord.col := SCAN.coord.col + SCAN.count; + Assert(FALSE, coord, SCAN.tLex - lxERR0) + END; + Assert2(SCAN.tLex # lxEOF, 27) +END Next; + +PROCEDURE NextCoord(VAR coord: SCAN.TCoord); +BEGIN + Next; + coord := SCAN.coord +END NextCoord; + +PROCEDURE Check*(key: INTEGER); +VAR code: INTEGER; +BEGIN + IF SCAN.tLex # key THEN + CASE key OF + |lxMODULE: code := 21 + |lxIDENT: code := 22 + |lxSemi: code := 23 + |lxEND: code := 24 + |lxDot: code := 25 + |lxEQ: code := 35 + |lxRRound: code := 38 + |lxTO: code := 40 + |lxOF: code := 41 + |lxRCurly: code := 51 + |lxLRound: code := 56 + |lxComma: code := 61 + |lxTHEN: code := 98 + |lxRSquare: code := 109 + |lxDO: code := 118 + |lxUNTIL: code := 119 + |lxAssign: code := 120 + |lxRETURN: code := 124 + |lxColon: code := 157 + ELSE + END; + Assert2(FALSE, code) + END +END Check; + +PROCEDURE NextCheck(key: INTEGER); +BEGIN + Next; + Check(key) +END NextCheck; + +PROCEDURE CheckIdent(Name: SCAN.NODE): BOOLEAN; +VAR cur: IDENT; +BEGIN + cur := unit.Idents.Last(IDENT); + WHILE (cur.iType # IDGUARD) & (cur.Name # Name) DO + cur := cur.Prev(IDENT) + END + RETURN cur.iType = IDGUARD +END CheckIdent; + +PROCEDURE Guard; +VAR ident: IDENT; +BEGIN + NEW(ident); + MemErr(ident = NIL); + ident.Name := NIL; + ident.iType := IDGUARD; + ident.T := voidtype; + UTILS.Push(unit.Idents, ident); + INC(unit.Level) +END Guard; + +PROCEDURE PushIdent(Name: SCAN.NODE; coord: SCAN.TCoord; iType: INTEGER; T: pTYPE; u: UNIT; Export: BOOLEAN; StProc: INTEGER); +VAR ident: IDENT; i: INTEGER; +BEGIN + Assert(CheckIdent(Name), coord, 30); + NEW(ident); + MemErr(ident = NIL); + ident.Name := Name; + ident.coord := coord; + IF iType IN {IDPROC, IDMOD} THEN + ident.Number := X86.NewLabel(); + i := X86.NewLabel(); + i := X86.NewLabel(); + i := X86.NewLabel() + END; + ident.iType := iType; + ident.T := T; + ident.Unit := u; + ident.Export := Export; + ident.StProc := StProc; + ident.Level := unit.Level; + UTILS.Push(unit.Idents, ident) +END PushIdent; + +PROCEDURE StTypes; +VAR type: pTYPE; i: INTEGER; +BEGIN + sttypes[0] := NIL; + FOR i := TINTEGER TO TSTRING DO + NEW(type); + MemErr(type = NIL); + type.tType := i; + UTILS.Push(types, type); + sttypes[i] := type + END; + sttypes[TINTEGER].Size := 4; + sttypes[TREAL].Size := 4; + sttypes[TLONGREAL].Size := 8; + sttypes[TBOOLEAN].Size := 1; + sttypes[TCHAR].Size := 1; + sttypes[TSET].Size := 4; + sttypes[TVOID].Size := 0; + sttypes[TSTRING].Size := 0; + sttypes[TNIL].Size := 4; + sttypes[TCARD16].Size := 2; + FOR i := TINTEGER TO TSTRING DO + sttypes[i].Align := sttypes[i].Size + END +END StTypes; + +PROCEDURE PushStProc(Name: UTILS.STRING; StProc: INTEGER); +BEGIN + PushIdent(SCAN.AddNode(Name), zcoord, IDSTPROC, voidtype, NIL, FALSE, StProc) +END PushStProc; + +PROCEDURE PushStType(Name: UTILS.STRING; T: INTEGER); +BEGIN + PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, FALSE, 0) +END PushStType; + +PROCEDURE PushSysProc(Name: UTILS.STRING; StProc: INTEGER); +BEGIN + PushIdent(SCAN.AddNode(Name), zcoord, IDSYSPROC, voidtype, NIL, TRUE, StProc) +END PushSysProc; + +PROCEDURE PushSysType(Name: UTILS.STRING; T: INTEGER); +BEGIN + PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, TRUE, 0) +END PushSysType; + +PROCEDURE StIdent; +BEGIN + Guard; + PushStProc("ABS", stABS); + PushStProc("ASR", stASR); + PushStProc("ASSERT", stASSERT); + PushStType("BOOLEAN", TBOOLEAN); + PushStType("CHAR", TCHAR); + PushStProc("CHR", stCHR); + PushStProc("COPY", stCOPY); + PushStProc("DEC", stDEC); + PushStProc("DISPOSE", stDISPOSE); + PushStProc("EXCL", stEXCL); + PushStProc("FLOOR", stFLOOR); + PushStProc("FLT", stFLT); + PushStProc("INC", stINC); + PushStProc("INCL", stINCL); + PushStType("INTEGER", TINTEGER); + PushStProc("LEN", stLEN); + PushStProc("LSL", stLSL); + PushStProc("LONG", stLONG); + PushStType("LONGREAL", TLONGREAL); + PushStProc("NEW", stNEW); + PushStProc("ODD", stODD); + PushStProc("ORD", stORD); + PushStProc("PACK", stPACK); + PushStType("REAL", TREAL); + PushStProc("ROR", stROR); + PushStType("SET", TSET); + PushStProc("SHORT", stSHORT); + PushStProc("UNPK", stUNPK); + PushStProc("BITS", stBITS); + PushStProc("LSR", stLSR); + PushStProc("LENGTH", stLENGTH); + Guard +END StIdent; + +PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT; +VAR cur, res: IDENT; +BEGIN + res := NIL; + cur := Unit.IdentBegin.Next(IDENT); + WHILE (cur # NIL) & (cur.iType # IDGUARD) DO + IF cur.Name = Name THEN + IF (Unit # unit) & ~cur.Export THEN + res := NIL + ELSE + res := cur + END; + cur := NIL + ELSE + cur := cur.Next(IDENT) + END + END + RETURN res +END GetQIdent; + +PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT; +VAR cur, res: IDENT; +BEGIN + res := NIL; + cur := unit.Idents.Last(IDENT); + WHILE (cur # NIL) & (cur.Name = Name) DO + res := cur; + cur := NIL + ELSIF cur # NIL DO + cur := cur.Prev(IDENT) + END + RETURN res +END GetIdent; + +PROCEDURE Relation*(Op: INTEGER): BOOLEAN; +VAR Res: BOOLEAN; +BEGIN + CASE Op OF + |lxEQ, lxNE, lxLT, lxGT, + lxLE, lxGE, lxIN, lxIS: + Res := TRUE + ELSE + Res := FALSE + END + RETURN Res +END Relation; + +PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL; +CONST max = SCAN.maxDBL; +VAR res: LONGREAL; +BEGIN + CASE Op OF + |lxPlus: res := a + b + |lxMinus: res := a - b + |lxMult: res := a * b + |lxSlash: + Assert(b # 0.0D0, coord, 46); + res := a / b + |lxDIV: + Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER); + res := LONG(FLT(FLOOR(a) DIV FLOOR(b))) + |lxMOD: + res := LONG(FLT(FLOOR(a) MOD FLOOR(b))) + ELSE + END; + Assert(~UTILS.IsInf(res), coord, FOVER); + CASE T.tType OF + |TINTEGER: Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER) + |TREAL: Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER) + |TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER) + ELSE + END; + IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN + CASE Op OF + |lxPlus: Assert(a = -b, coord, UNDER) + |lxMinus: Assert(a = b, coord, UNDER) + |lxMult: Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER) + |lxSlash: Assert((a = 0.0D0), coord, UNDER) + ELSE + END + END + RETURN res +END Arith; + +PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL; +VAR sa, sb: UTILS.STRCONST; Res: LONGREAL; +BEGIN + sa := GetString(a); + sb := GetString(b); + CASE Op OF + |lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str))) + |lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str))) + |lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str))) + ELSE + END + RETURN Res +END strcmp; + +PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE); +VAR c: LONGREAL; ai, bi: INTEGER; +BEGIN + ai := FLOOR(a); + bi := FLOOR(b); + IF Op # lxIN THEN + Assert(Ta = Tb, coord, 37) + END; + CASE Op OF + |lxPlus, lxMinus, lxMult, lxSlash: + Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37); + IF Ta.tType IN TNUM THEN + Res := Arith(a, b, Ta, Op, coord) + ELSIF Ta.tType = TSET THEN + CASE Op OF + |lxPlus: Res := LONG(FLT(ORD(BITS(ai) + BITS(bi)))) + |lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi)))) + |lxMult: Res := LONG(FLT(ORD(BITS(ai) * BITS(bi)))) + |lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi)))) + ELSE + END + ELSE + Assert(FALSE, coord, 37) + END; + TRes := Ta + |lxDIV, lxMOD: + Assert(Ta.tType = TINTEGER, coord, 37); + Assert(bi # 0, coord, 48); + TRes := Ta; + Res := Arith(a, b, Ta, Op, coord) + |lxAnd: + Assert(Ta.tType = TBOOLEAN, coord, 37); + Res := LONG(FLT(ORD((ai # 0) & (bi # 0)))) + |lxOR: + Assert(Ta.tType = TBOOLEAN, coord, 37); + Res := LONG(FLT(ORD((ai # 0) OR (bi # 0)))) + |lxEQ, lxNE: + IF Ta.tType = TSTRING THEN + Res := strcmp(a, b, Op) + ELSE + Res := LONG(FLT(ORD(a = b))) + END; + IF Op = lxNE THEN + Res := LONG(FLT(ORD(Res = 0.0D0))) + END + |lxLT, lxGT: + IF Op = lxGT THEN + c := a; + a := b; + b := c + END; + Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37); + IF Ta.tType = TSTRING THEN + Res := strcmp(a, b, Op) + ELSE + Res := LONG(FLT(ORD(a < b))) + END + |lxLE, lxGE: + IF Op = lxGE THEN + c := a; + a := b; + b := c + END; + Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37); + IF Ta.tType = TSTRING THEN + Res := strcmp(a, b, Op) + ELSIF Ta.tType = TSET THEN + Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b))))) + ELSE + Res := LONG(FLT(ORD(a <= b))) + END + |lxIN: + Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37); + Assert(ASR(ai, 5) = 0, coord, 49); + Res := LONG(FLT(ORD(ai IN BITS(bi)))) + ELSE + END; + IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN + TRes := sttypes[TBOOLEAN] + END +END Calc; + +PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE); +VAR e: EXPRESSION; coord: SCAN.TCoord; +BEGIN + Const := TRUE; + Coord(coord); + sizefunc := FALSE; + Expr(e); + Assert(~sizefunc & (e.eType = eCONST), coord, 62); + Value := e.Value; + T := e.T; + Const := FALSE +END ConstExpr; + +PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE; +VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE; +BEGIN + Res := NIL; + Name := SCAN.id; + id := GetIdent(Name); + IF id = NIL THEN + Coord(coord); + NamePtrBase := Name; + Next + ELSE + IF id.iType = IDTYPE THEN + Coord(coord); + Next; + Res := id.T + ELSIF id.iType = IDMOD THEN + Unit := id.Unit; + NextCheck(lxDot); + NextCheck(lxIDENT); + Name := SCAN.id; + NamePtrBase := Name; + id := GetQIdent(Unit, Name); + IF Unit # unit THEN + Assert2(id # NIL, 42); + Assert2(id.iType = IDTYPE, 77); + Coord(coord); + Next; + Res := id.T + ELSE + IF id = NIL THEN + Assert2((unit.Level = 3) & unit.typedecl, 42); + Coord(coord); + Next; + Res := NIL + ELSE + Assert2(id.iType = IDTYPE, 77); + Coord(coord); + Next; + Res := id.T + END + END + ELSE + Assert2(FALSE, 77) + END + END + RETURN Res +END IdType; + +PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER; +BEGIN + Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83) + RETURN RecSize + (Align - RecSize MOD Align) MOD Align +END FieldOffset; + +PROCEDURE Dim*(T: pTYPE): INTEGER; +VAR n: INTEGER; +BEGIN + n := 0; + WHILE (T.tType = TARRAY) & (T.Len = 0) DO + INC(n); + T := T.Base + END + RETURN n +END Dim; + +PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN); +VAR cur: FIELD; +BEGIN + cur := Tr.Fields.First(FIELD); + WHILE cur.T # NIL DO + cur := cur.Next(FIELD) + END; + WHILE cur # NIL DO + cur.T := Tf; + IF Rec THEN + IF Tf.Align > Tr.Align THEN + Tr.Align := Tf.Align + END; + IF Tr.Rec = record THEN + cur.Offset := FieldOffset(Tf.Align, Tr.Size); + Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83); + Tr.Size := cur.Offset + Tf.Size + ELSIF Tr.Rec = noalign THEN + cur.Offset := FieldOffset(1, Tr.Size); + Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83); + Tr.Size := cur.Offset + Tf.Size + ELSIF Tr.Rec = union THEN + IF Tf.Size > Tr.Size THEN + Tr.Size := Tf.Size + END; + cur.Offset := 0 + END + ELSE + Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1) + END; + cur := cur.Next(FIELD) + END +END SetFields; + +PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD; +VAR cur, Res: FIELD; +BEGIN + Res := NIL; + cur := T.Fields.First(FIELD); + WHILE (cur # NIL) & (cur.Name = Name) DO + Res := cur; + cur := NIL + ELSIF cur # NIL DO + cur := cur.Next(FIELD) + END + RETURN Res +END GetField; + +PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN; +VAR field: FIELD; res: BOOLEAN; +BEGIN + res := TRUE; + WHILE (T # NIL) & res DO + field := GetField(T, Name); + IF field # NIL THEN + IF (field.Unit = unit) OR field.Export THEN + res := FALSE + END + END; + T := T.Base + END + RETURN res +END Unique; + +PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN; + RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) & + (T.tType IN TSTRUCT)) +END notrecurs; + +PROCEDURE ReadFields(T: pTYPE); +VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN; +BEGIN + WHILE SCAN.tLex = lxIDENT DO + Name := SCAN.id; + Assert2(Unique(T, Name), 30); + NEW(field); + MemErr(field = NIL); + UTILS.Push(T.Fields, field); + field.Name := Name; + field.T := NIL; + field.Export := FALSE; + field.Unit := unit; + Next; + IF SCAN.tLex = lxMult THEN + Assert2(unit.Level = 3, 89); + field.Export := TRUE; + Next + END; + IF SCAN.tLex = lxComma THEN + NextCheck(lxIDENT) + ELSIF SCAN.tLex = lxColon THEN + NextCoord(coord); + id_T := SCAN.tLex = lxIDENT; + Tf:= pParseType(coord); + Assert(Tf # NIL, coord, 42); + Assert(notrecurs(id_T, Tf), coord, 96); + SetFields(T, Tf, TRUE); + IF SCAN.tLex = lxSemi THEN + NextCheck(lxIDENT) + ELSE + Assert2(SCAN.tLex = lxEND, 86) + END + ELSE + Assert2(FALSE, 85) + END + END +END ReadFields; + +PROCEDURE OpenBase*(T: pTYPE): pTYPE; +BEGIN + WHILE (T.tType = TARRAY) & (T.Len = 0) DO + T := T.Base + END + RETURN T +END OpenBase; + +PROCEDURE SetVars(T: pTYPE); +VAR cur: IDENT; n: INTEGER; +BEGIN + cur := unit.Idents.Last(IDENT); + WHILE cur.T = NIL DO + cur := cur.Prev(IDENT) + END; + cur := cur.Next(IDENT); + WHILE cur # NIL DO + cur.T := T; + IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN + n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD))) + ELSE + n := T.Size; + Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93); + n := n + UTILS.Align(n) + END; + IF cur.Level = 3 THEN + cur.Offset := ProgSize; + Assert2(ProgSize <= SCAN.maxINT - n, 93); + ProgSize := ProgSize + n; + Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93); + ProgSize := ProgSize + UTILS.Align(ProgSize) + ELSE + IF cur.VarKind = 0 THEN + cur.Offset := curBlock.ParamSize - curBlock.VarSize - n + ELSE + cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD))) + END + END; + Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93); + curBlock.VarSize := curBlock.VarSize + n; + Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93); + curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize); + IF cur.VarKind # 0 THEN + curBlock.ParamSize := curBlock.VarSize + END; + cur := cur.Next(IDENT) + END +END SetVars; + +PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE; +VAR nov: pTYPE; +BEGIN + IF NewType = NIL THEN + NEW(nov); + MemErr(nov = NIL) + ELSE + nov := NewType + END; + UTILS.Push(types, nov); + nov.tType := tType; + nov.Len := Len; + nov.Size := Size; + nov.Base := Base; + nov.Fields := NIL; + nov.Number := Number; + IF Fields THEN + nov.Fields := UTILS.CreateList() + END + RETURN nov +END CreateType; + +PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE; +VAR TA: pTYPE; +BEGIN + IF SCAN.tLex = lxARRAY THEN + NextCheck(lxOF); + Next; + TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL) + ELSE + Check(lxIDENT); + TA := IdType(coord); + Assert(TA # NIL, coord, 42); + END + RETURN TA +END FormalType; + +PROCEDURE Section(T: pTYPE); +VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD; + Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN; +BEGIN + proc := T = NIL; + IF proc THEN + T := curBlock.T + END; + Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84); + ByRef := FALSE; + IF SCAN.tLex = lxVAR THEN + ByRef := TRUE; + NextCheck(lxIDENT) + END; + cont := TRUE; + WHILE cont DO + Name := SCAN.id; + Assert2(GetField(T, Name) = NIL, 30); + NEW(field); + MemErr(field = NIL); + UTILS.Push(T.Fields, field); + field.Name := Name; + field.T := NIL; + field.ByRef := ByRef; + IF proc THEN + PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0); + INC(curBlock.ParamCount); + fp := unit.Idents.Last(IDENT); + IF ByRef THEN + fp.VarKind := paramvar + ELSE + fp.VarKind := param + END + END; + Next; + IF SCAN.tLex = lxComma THEN + NextCheck(lxIDENT) + ELSIF SCAN.tLex = lxColon THEN + Next; + Tf := FormalType(coord); + Assert(Dim(Tf) <= X86.ADIM, coord, 110); + SetFields(T, Tf, FALSE); + IF proc THEN + SetVars(Tf) + END; + cont := FALSE + ELSE + Assert2(FALSE, 85) + END + END +END Section; + +PROCEDURE ParamType(T: pTYPE); +VAR break: BOOLEAN; +BEGIN + IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN + break := FALSE; + REPEAT + Section(T); + IF SCAN.tLex = lxSemi THEN + Next + ELSE + break := TRUE + END + UNTIL break + END +END ParamType; + +PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE); +VAR nov: PTRBASE; +BEGIN + NEW(nov); + MemErr(nov = NIL); + nov.Name := Name; + nov.coord := coord; + nov.Ptr := T; + UTILS.Push(PtrBases, nov) +END AddPtrBase; + +PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE); +VAR coord: SCAN.TCoord; +BEGIN + IF SCAN.tLex = lxLRound THEN + Next; + ParamType(T); + Check(lxRRound); + Next; + IF SCAN.tLex = lxColon THEN + NextCheck(lxIDENT); + Res := IdType(coord); + Assert(Res # NIL, coord, 42); + Assert(~(Res.tType IN TSTRUCT), coord, 82) + END + END +END FormalList; + +PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN; +VAR res: BOOLEAN; +BEGIN + res := SCAN.tLex = lxLSquare; + IF res THEN + Next; + IF SCAN.Lex = "cdecl" THEN + Call := cdecl + ELSIF SCAN.Lex = "stdcall" THEN + Call := stdcall + ELSIF SCAN.Lex = "winapi" THEN + Assert2(winplatf, 50); + Call := winapi + ELSE + Assert2(FALSE, 44) + END; + NextCheck(lxRSquare); + Next; + ELSE + Call := defcall + END + RETURN res +END CallFlag; + +PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN; +VAR res: BOOLEAN; +BEGIN + res := SCAN.tLex = lxLSquare; + IF res THEN + Next; + IF SCAN.Lex = "union" THEN + rec := union + ELSIF SCAN.Lex = "noalign" THEN + rec := noalign + ELSE + Assert2(FALSE, 103) + END; + NextCheck(lxRSquare); + Next; + ELSE + rec := record + END + RETURN res +END RecFlag; + +PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE; +VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN; +BEGIN + CASE SCAN.tLex OF + |lxARRAY, lxComma: + IF SCAN.tLex = lxComma THEN + Assert2(Comma, 39) + END; + NextCoord(coord); + ConstExpr(v, T); + Assert(T.tType = TINTEGER, coord, 52); + Assert(v > 0.0D0, coord, 78); + nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType); + IF SCAN.tLex = lxComma THEN + nov.Base := StructType(TRUE, NIL) + ELSIF SCAN.tLex = lxOF THEN + NextCoord(coord); + id_T := SCAN.tLex = lxIDENT; + nov.Base := pParseType(coord); + Assert(nov.Base # NIL, coord, 42); + Assert(notrecurs(id_T, nov.Base), coord, 96) + ELSE + Assert2(FALSE, 79) + END; + Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83); + nov.Size := nov.Base.Size * nov.Len; + nov.Align := nov.Base.Align + |lxRECORD: + NextCoord(coord); + INC(RecCount); + nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType); + nov.Align := 1; + IF RecFlag(nov.Rec) THEN + Assert(unit.sys, coord, 111) + END; + Coord(coord); + IF SCAN.tLex = lxLRound THEN + NextCoord(coord2); + Check(lxIDENT); + nov.Base := IdType(coord); + Assert(nov.Base # NIL, coord, 42); + Assert(nov.Base.tType = TRECORD, coord, 80); + Assert(notrecurs(TRUE, nov.Base), coord, 96); + nov.Size := nov.Base.Size; + nov.Align := nov.Base.Align; + Check(lxRRound); + Next; + Assert(nov.Rec = record, coord, 112); + Assert(nov.Base.Rec = record, coord2, 113) + END; + ReadFields(nov); + Check(lxEND); + nov.Size := X86.Align(nov.Size, nov.Align); + IF nov.Base # NIL THEN + X86.AddRec(nov.Base.Number) + ELSE + X86.AddRec(0) + END; + Next + |lxPOINTER: + NextCheck(lxTO); + NextCoord(coord); + nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType); + nov.Align := 4; + nov.Base := pParseType(coord); + IF nov.Base = NIL THEN + Assert(unit.typedecl, coord, 42); + AddPtrBase(NamePtrBase, coord, nov) + ELSE + Assert(nov.Base.tType = TRECORD, coord, 81) + END + |lxPROCEDURE: + NextCoord(coord); + nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType); + IF CallFlag(nov.Call) THEN + Assert(unit.sys, coord, 111) + END; + nov.Align := 4; + FormalList(nov, nov.Base) + ELSE + Assert2(FALSE, 39) + END + RETURN nov +END StructType; + +PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE; +VAR Res: pTYPE; +BEGIN + IF SCAN.tLex = lxIDENT THEN + Res := IdType(coord) + ELSE + Res := StructType(FALSE, NIL) + END + RETURN Res +END ParseType; + +PROCEDURE PopBlock; +VAR cur: IDENT; n: INTEGER; +BEGIN + cur := unit.Idents.Last(IDENT); + n := 0; + WHILE cur.iType # IDGUARD DO + cur := cur.Prev(IDENT); + INC(n) + END; + cur := cur.Prev(IDENT); + INC(n); + unit.Idents.Count := unit.Idents.Count - n; + unit.Idents.Last := cur; + cur.Next := NIL; + DEC(unit.Level) +END PopBlock; + +PROCEDURE LinkPtr; +VAR cur: PTRBASE; id: IDENT; +BEGIN + cur := PtrBases.First(PTRBASE); + WHILE cur # NIL DO + id := GetIdent(cur.Name); + Assert(id # NIL, cur.coord, 42); + Assert(id.T.tType = TRECORD, cur.coord, 81); + cur.Ptr.Base := id.T; + cur := cur.Next(PTRBASE) + END; + UTILS.Clear(PtrBases) +END LinkPtr; + +PROCEDURE addproc; +VAR proc: Proc; +BEGIN + NEW(proc); + MemErr(proc = NIL); + proc.used := FALSE; + proc.Procs := UTILS.CreateList(); + UTILS.Push(procs, proc); + curproc := proc +END addproc; + +PROCEDURE DeclSeq; +VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER; + Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION; + + PROCEDURE IdentDef; + BEGIN + Name := SCAN.id; + Coord(coord); + Next; + Export := FALSE; + IF SCAN.tLex = lxMult THEN + Assert2(unit.Level = 3, 89); + Export := TRUE; + Next + END + END IdentDef; + +BEGIN + IF SCAN.tLex = lxCONST THEN + Next; + WHILE SCAN.tLex = lxIDENT DO + IdentDef; + PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0); + last := unit.Idents.Last(IDENT); + Check(lxEQ); + Next; + ConstExpr(Value, T); + Check(lxSemi); + last.Value := Value; + last.T := T; + Next + END + END; + IF SCAN.tLex = lxTYPE THEN + UTILS.Clear(PtrBases); + unit.typedecl := TRUE; + Next; + WHILE SCAN.tLex = lxIDENT DO + IdentDef; + PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0); + last := unit.Idents.Last(IDENT); + Check(lxEQ); + Next; + NEW(NewType); + MemErr(NewType = NIL); + last.T := NewType; + T := StructType(FALSE, NewType); + Check(lxSemi); + Next + END + END; + LinkPtr; + unit.typedecl := FALSE; + IF SCAN.tLex = lxVAR THEN + Next; + WHILE SCAN.tLex = lxIDENT DO + IdentDef; + PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0); + IF SCAN.tLex = lxComma THEN + NextCheck(lxIDENT) + ELSIF SCAN.tLex = lxColon THEN + NextCoord(coord); + T := ParseType(coord); + Assert(T # NIL, coord, 42); + SetVars(T); + Check(lxSemi); + Next + ELSE + Assert2(FALSE, 85) + END + END + END; + WHILE SCAN.tLex = lxPROCEDURE DO + NextCoord(coord); + IF CallFlag(Call) THEN + Assert(unit.Level = 3, coord, 45); + Assert(unit.sys, coord, 111) + END; + Check(lxIDENT); + IdentDef; + PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0); + id := unit.Idents.Last(IDENT); + addproc; + id.Proc := curproc; + IF id.Export & main THEN + IF Platform IN {1, 6} THEN + curproc.used := TRUE; + Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133) + END; + X86.ProcExport(id.Number, Name, X86.NewLabel()) + END; + id.Parent := curBlock; + curBlock := id; + Guard; + FormalList(NIL, curBlock.T.Base); + id.T.Call := Call; + Check(lxSemi); + Next; + DeclSeq; + id.LocalSize := id.VarSize - id.ParamSize; + X86.Label(X86.NewLabel()); + curproc.beg := X86.current; + X86.ProcBeg(id.Number, id.LocalSize, FALSE); + IF SCAN.tLex = lxBEGIN THEN + Next; + OpSeq + END; + func := curBlock.T.Base.tType # TVOID; + IF func THEN + Check(lxRETURN); + UTILS.UnitLine(UnitNumber, SCAN.coord.line); + NextCoord(coord); + Expr(e); + Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125); + IF e.eType = eVAR THEN + X86.Load(e.T.tType) + END + ELSE + Assert2(SCAN.tLex # lxRETURN, 123) + END; + Check(lxEND); + NextCheck(lxIDENT); + Assert2(SCAN.id = Name, 87); + NextCheck(lxSemi); + Next; + X86.ProcEnd(id.Number, (id.ParamSize + (id.Level - 3) * 4) * ORD(curBlock.T.Call IN {stdcall, winapi, defcall}), func, curBlock.T.Base.tType IN TFLOAT); + X86.Label(X86.NewLabel()); + curproc.end := X86.current; + PopBlock; + curBlock := curBlock.Parent; + curproc := curBlock.Proc(Proc); + END +END DeclSeq; + +PROCEDURE Rtl(u: UNIT); + + PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER); + VAR id: IDENT; + BEGIN + id := GetQIdent(u, SCAN.AddNode(name)); + id.Proc(Proc).used := TRUE; + IF id = NIL THEN + UTILS.ErrMsg(158); + UTILS.HALT(1) + END; + X86.AddRtlProc(num, id.Number) + END AddProc; + +BEGIN + AddProc("_newrec", X86._newrec); + AddProc("_disprec", X86._disprec); + AddProc("_rset", X86._rset); + AddProc("_inset", X86._inset); + AddProc("_saverec", X86._saverec); + AddProc("_checktype", X86._checktype); + AddProc("_strcmp", X86._strcmp); + AddProc("_lstrcmp", X86._lstrcmp); + AddProc("_rstrcmp", X86._rstrcmp); + AddProc("_savearr", X86._savearr); + AddProc("_arrayidx", X86._arrayidx); + AddProc("_arrayidx1", X86._arrayidx1); + AddProc("_arrayrot", X86._arrayrot); + AddProc("_assrt", X86._assrt); + AddProc("_strcopy", X86._strcopy); + AddProc("_init", X86._init); + AddProc("_close", X86._close); + AddProc("_halt", X86._halt); + AddProc("_length", X86._length); +END Rtl; + +PROCEDURE ImportList; +VAR cond: INTEGER; coord, namecoord: SCAN.TCoord; + name, alias: SCAN.NODE; u, self: UNIT; + FName: UTILS.STRING; + + PROCEDURE AddUnit(newcond: INTEGER); + VAR str: STRITEM; + BEGIN + u := GetModule(name); + IF u = NIL THEN + self := unit; + SCAN.Backup(unit.scanner); + COPY(name.Name, FName); + IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN + IF FName = "SYSTEM" THEN + unit := sys; + self.sys := TRUE + ELSE + Assert(FALSE, namecoord, 32) + END + END; + SCAN.Recover(self.scanner); + u := unit; + unit := self; + UTILS.SetFile(unit.File) + ELSE + Assert(u.Closed, namecoord, 31) + END; + PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0); + NEW(str); + MemErr(str = NIL); + str.Str := name.Name; + UTILS.Push(unit.Import, str); + cond := newcond + END AddUnit; + +BEGIN + cond := 0; + WHILE cond # 4 DO + Next; + CASE cond OF + |0: Check(lxIDENT); + name := SCAN.id; + Coord(coord); + Coord(namecoord); + alias := name; + cond := 1 + |1: CASE SCAN.tLex OF + |lxComma: AddUnit(0) + |lxSemi: AddUnit(4); Next + |lxAssign: cond := 2 + ELSE + Assert2(FALSE, 28) + END + |2: Check(lxIDENT); + name := SCAN.id; + Coord(namecoord); + cond := 3 + |3: CASE SCAN.tLex OF + |lxComma: AddUnit(0) + |lxSemi: AddUnit(4); Next + ELSE + Assert2(FALSE, 29) + END + ELSE + END + END +END ImportList; + +PROCEDURE Header(Name: SCAN.NODE); +BEGIN + NEW(unit); + MemErr(unit = NIL); + unit.Idents := UTILS.CreateList(); + unit.Level := 0; + unit.Name := Name; + Guard; Guard; + PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0); + Guard; + unit.IdentBegin := unit.Idents.Last(IDENT); + unit.Closed := TRUE +END Header; + +PROCEDURE Pseudo; +VAR temp: UNIT; +BEGIN + temp := unit; + Header(SCAN.AddNode("SYSTEM")); + PushSysProc("ADR", sysADR); + PushSysProc("SIZE", sysSIZE); + PushSysProc("TYPEID", sysTYPEID); + PushSysProc("GET", sysGET); + PushSysProc("PUT", sysPUT); + PushSysProc("CODE", sysCODE); + PushSysProc("MOVE", sysMOVE); + PushSysProc("INF", sysINF); + PushSysType("CARD16", TCARD16); + sys := unit; + unit := temp +END Pseudo; + +PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN; +VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord; +BEGIN + Res := FALSE; + name := Name1; + Name := Name1; + b := Path; + UTILS.concat(b, Name); + Name := b; + UTILS.concat(Name, Ext); + + IF SCAN.Open(Name, FHandle) THEN + NEW(unit); + MemErr(unit = NIL); + unit.sys := FALSE; + unit.Std := Path = Std; + UTILS.Push(prog, unit); + unit.Idents := UTILS.CreateList(); + unit.Import := UTILS.CreateList(); + NEW(unit.scanner); + MemErr(unit.scanner = NIL); + unit.Closed := FALSE; + unit.Level := 0; + unit.typedecl := FALSE; + COPY(Name, unit.File); + UTILS.SetFile(unit.File); + StIdent; + NextCheck(lxMODULE); + NextCheck(lxIDENT); + Assert2(UTILS.streq(SCAN.id.Name, name), 33); + unit.Name := SCAN.id; + coord := SCAN.coord; + PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0); + idmod := unit.Idents.Last(IDENT); + Guard; + NextCheck(lxSemi); + Next; + IF SCAN.tLex = lxIMPORT THEN + temp := main; + main := FALSE; + ImportList; + main := temp + END; + UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln; + X86.Module(idmod.Name.Name, idmod.Number); + UnitNumber := idmod.Number; + unit.IdentBegin := unit.Idents.Last(IDENT); + curBlock := idmod; + DeclSeq; + X86.ProcBeg(idmod.Number, 0, TRUE); + IF SCAN.tLex = lxBEGIN THEN + addproc; + curproc.used := TRUE; + Next; + OpSeq + END; + Check(lxEND); + NextCheck(lxIDENT); + Assert2(SCAN.id = unit.Name, 26); + NextCheck(lxDot); + X86.Leave; + unit.Closed := TRUE; + UTILS.Clear(unit.Import); + Res := TRUE + END + RETURN Res +END ReadModule; + +PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN; + OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES); +BEGIN + winplatf := windows; + Path := FilePath; + Main := NameFile; + ExtMain := ExtFile; + Std := StdPath; + OpSeq := OpSeqProc; + Expr := ExprProc; + AssComp := AssCompProc; + prog := UTILS.CreateList(); + PtrBases := UTILS.CreateList(); + types := UTILS.CreateList(); + procs := UTILS.CreateList(); + StTypes; + voidtype := sttypes[TVOID]; + Strings := UTILS.CreateList(); + Pseudo; + stypes := sttypes +END Program; + +PROCEDURE delfirstchar(VAR s: UTILS.STRING); +VAR i: INTEGER; +BEGIN + FOR i := 0 TO LENGTH(s) - 1 DO + s[i] := s[i + 1] + END +END delfirstchar; + +PROCEDURE DelProcs; +VAR cur: Proc; + + PROCEDURE ProcHandling(proc: Proc); + VAR cur: IDENT; p: Proc; + BEGIN + proc.used := TRUE; + cur := proc.Procs.First(IDENT); + WHILE cur # NIL DO + p := cur.Proc(Proc); + IF ~p.used THEN + ProcHandling(p) + END; + cur := cur.Next(IDENT) + END; + END ProcHandling; + +BEGIN + cur := procs.First(Proc); + WHILE cur # NIL DO + IF cur.used THEN + ProcHandling(cur) + END; + cur := cur.Next(Proc) + END; + cur := procs.First(Proc); + WHILE cur # NIL DO + IF ~cur.used THEN + X86.DelProc(cur.beg, cur.end) + END; + cur := cur.Next(Proc) + END +END DelProcs; + +PROCEDURE Compile*(platform, stksize: INTEGER); +VAR full, path, name, ext, temp, path2: UTILS.STRING; +BEGIN + Platform := platform; + main := FALSE; + IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN + Rtl(unit) + ELSE + UTILS.ErrMsg(65); + UTILS.HALT(1) + END; + main := TRUE; + IF ~ReadModule(Path, Main, ExtMain) THEN + path2 := Path; + UTILS.ParamStr(full, 0); + UTILS.Split(full, path, name, ext); + IF path[0] # 0X THEN + path[LENGTH(path) - 1] := 0X + END; + IF Path[0] = UTILS.Slash THEN + delfirstchar(Path) + END; + UTILS.concat(path, UTILS.Slash); + full := path; + UTILS.concat(full, Path); + Path := full; + IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN + delfirstchar(Path) + END; + IF ~ReadModule(Path, Main, ExtMain) THEN + UTILS.ErrMsg(64); + UTILS.OutString(path2); + UTILS.OutString(Main); + UTILS.OutString(ExtMain); + UTILS.Ln; + UTILS.HALT(1) + END + END; + temp := Path; + UTILS.concat(temp, Main); + IF platform IN {2, 3} THEN + UTILS.concat(temp, ".exe") + ELSIF platform = 1 THEN + UTILS.concat(temp, ".dll") + ELSIF platform = 4 THEN + UTILS.concat(temp, ".kex") + ELSIF platform = 6 THEN + UTILS.concat(temp, ".obj") + END; + IF platform IN {1, 2, 3, 4} THEN + stksize := stksize * 100000H + END; + DelProcs; + X86.Epilog(ProgSize, temp, stksize) +END Compile; + +BEGIN + pParseType := ParseType; + pReadModule := ReadModule; + zcoord.line := 0; + zcoord.col := 0 +END DECL. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/ELF.ob07 b/programs/develop/oberon07/Source/ELF.ob07 new file mode 100644 index 0000000000..fba6e3c1ba --- /dev/null +++ b/programs/develop/oberon07/Source/ELF.ob07 @@ -0,0 +1,295 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE ELF; + +IMPORT SYSTEM; + +CONST size* = 8346; + +PROCEDURE [stdcall] data; +BEGIN + SYSTEM.CODE("7F454C4601010100000000000000000002000300010000004086040834000000"); + SYSTEM.CODE("A41120000000000034002000080028001D001A00060000003400000034800408"); + SYSTEM.CODE("3480040800010000000100000500000004000000030000003401000034810408"); + SYSTEM.CODE("3481040813000000130000000400000001000000010000000000000000800408"); + SYSTEM.CODE("00800408240C1000240C10000500000000100000010000000C0F10000C9F1408"); + SYSTEM.CODE("0C9F1408540110009401900C060000000010000002000000200F1000209F1408"); + SYSTEM.CODE("209F1408D0000000D00000000600000004000000040000004801000048810408"); + SYSTEM.CODE("488104084400000044000000040000000400000051E574640000000000000000"); + SYSTEM.CODE("000000000000000000000000060000000400000052E574640C0F10000C9F1408"); + SYSTEM.CODE("0C9F1408F4000000F400000004000000010000002F6C69622F6C642D6C696E75"); + SYSTEM.CODE("782E736F2E320000040000001000000001000000474E55000000000002000000"); + SYSTEM.CODE("060000000F000000040000001400000003000000474E55006D648AA1A4FF8A62"); + SYSTEM.CODE("6855372198B3905D7B4527570300000005000000040000000700000092005000"); + SYSTEM.CODE("126388F68400000080044030050000000800000013000000AEC44D0F281D8C1C"); + SYSTEM.CODE("4701750FAC4BE3C086F0967C328E750F20CF09FD38F28B1C7C8B730F060204F9"); + SYSTEM.CODE("16EA76FE3CAD390D665561103F7E967C7D1B760F000000000000000000000000"); + SYSTEM.CODE("000000000C0000000000000000000000200000001B0000000000000000000000"); + SYSTEM.CODE("20000000A20000000000000000000000120000006C0000000000000000000000"); + SYSTEM.CODE("12000000360000008C85040800000000120000007900000080A0240804000000"); + SYSTEM.CODE("110018009C0000001C8604080000000012000000460000000C8C140804000000"); + SYSTEM.CODE("11000F00B40000007C8504080000000012000000730000009C85040800000000"); + SYSTEM.CODE("1200000080000000AC85040800000000120000008E00000060A0240804000000"); + SYSTEM.CODE("110018005A000000BC85040800000000120000002F000000CC85040800000000"); + SYSTEM.CODE("1200000095000000FC8504080000000012000000870000000C86040800000000"); + SYSTEM.CODE("120000006600000064A024080400000011001800550000002C86040800000000"); + SYSTEM.CODE("1200000060000000DC8504080000000012000000006C6962646C2E736F2E3200"); + SYSTEM.CODE("5F5F676D6F6E5F73746172745F5F005F4A765F5265676973746572436C617373"); + SYSTEM.CODE("657300646C6F70656E00646C73796D006C6962632E736F2E36005F494F5F7374"); + SYSTEM.CODE("64696E5F75736564006578697400666F70656E006674656C6C00737464696E00"); + SYSTEM.CODE("7072696E746600667365656B007374646F75740066636C6F7365006D616C6C6F"); + SYSTEM.CODE("630073746465727200667772697465006672656164005F5F6C6962635F737461"); + SYSTEM.CODE("72745F6D61696E006672656500474C4942435F322E3100474C4942435F322E30"); + SYSTEM.CODE("0000000000000000020002000300020002000100020002000400020004000500"); + SYSTEM.CODE("020002000200020002000000010002000100000010000000300000001169690D"); + SYSTEM.CODE("00000500B9000000100000001069690D00000300C30000000000000001000200"); + SYSTEM.CODE("3C00000010000000000000001169690D00000400B9000000100000001069690D"); + SYSTEM.CODE("00000200C300000000000000F09F14080601000060A02408050C000064A02408"); + SYSTEM.CODE("0511000080A024080506000000A014080701000004A014080703000008A01408"); + SYSTEM.CODE("070900000CA014080705000010A01408070A000014A01408070B000018A01408"); + SYSTEM.CODE("070D00001CA01408070E000020A014080713000024A014080704000028A01408"); + SYSTEM.CODE("070F00002CA014080710000030A014080707000034A01408071200005589E553"); + SYSTEM.CODE("83EC04E8000000005B81C3CC1A10008B93FCFFFFFF85D27405E81E000000E88D"); + SYSTEM.CODE("010000E878061000585BC9C3FF35F89F1408FF25FC9F140800000000FF2500A0"); + SYSTEM.CODE("14086800000000E9E0FFFFFFFF2504A014086808000000E9D0FFFFFFFF2508A0"); + SYSTEM.CODE("14086810000000E9C0FFFFFFFF250CA014086818000000E9B0FFFFFFFF2510A0"); + SYSTEM.CODE("14086820000000E9A0FFFFFFFF2514A014086828000000E990FFFFFFFF2518A0"); + SYSTEM.CODE("14086830000000E980FFFFFFFF251CA014086838000000E970FFFFFFFF2520A0"); + SYSTEM.CODE("14086840000000E960FFFFFFFF2524A014086848000000E950FFFFFFFF2528A0"); + SYSTEM.CODE("14086850000000E940FFFFFFFF252CA014086858000000E930FFFFFFFF2530A0"); + SYSTEM.CODE("14086860000000E920FFFFFFFF2534A014086868000000E910FFFFFF00000000"); + SYSTEM.CODE("31ED5E89E183E4F050545268B08B140868508B1408515668F4860408E80BFFFF"); + SYSTEM.CODE("FFF490909090909090909090909090905589E55383EC04803D84A0240800753F"); + SYSTEM.CODE("A188A02408BB189F140881EB149F1408C1FB0283EB0139D8731E8DB600000000"); + SYSTEM.CODE("83C001A388A02408FF1485149F1408A188A0240839D872E8C60584A024080183"); + SYSTEM.CODE("C4045B5DC38D7426008DBC27000000005589E583EC18A11C9F140885C07412B8"); + SYSTEM.CODE("0000000085C07409C704241C9F1408FFD0C9C3905589E583E4F0565383EC38C7"); + SYSTEM.CODE("44242CA0A024088B55088B44242C89108344242C048B550C8B44242C89108344"); + SYSTEM.CODE("242C048B55108B44242C89108344242C04BACC8504088B44242C89108344242C"); + SYSTEM.CODE("04BA8C8504088B44242C89108344242C04BA2C8604088B44242C89108344242C"); + SYSTEM.CODE("04A164A0240889C28B44242C89108344242C04A180A0240889C28B44242C8910"); + SYSTEM.CODE("8344242C04A160A0240889C28B44242C89108344242C04BA0C8604088B44242C"); + SYSTEM.CODE("89108344242C04BA7C8504088B44242C89108344242C04BABC8504088B44242C"); + SYSTEM.CODE("89108344242C04BAAC8504088B44242C89108344242C04BAFC8504088B44242C"); + SYSTEM.CODE("89108344242C04BA1C8604088B44242C89108344242C04BA9C8504088B44242C"); + SYSTEM.CODE("89108344242C04BADC8504088B44242C89108344242C048B35B8A02408BBF486"); + SYSTEM.CODE("0408B9A0A02408BA60A01408B8108C140889742410895C240C894C2408895424"); + SYSTEM.CODE("04890424E8B9FAEFFFB80000000083C4385B5E89EC5DC3909090909090909090"); + SYSTEM.CODE("9090909090905589E5575653E85A00000081C39914000083EC1CE8B3F9EFFF8D"); + SYSTEM.CODE("BB18FFFFFF8D8318FFFFFF29C7C1FF0285FF742431F68B4510894424088B450C"); + SYSTEM.CODE("894424048B4508890424FF94B318FFFFFF83C60139FE72DE83C41C5B5E5F5DC3"); + SYSTEM.CODE("8DB6000000005589E55DC38B1C24C3909090909090905589E55383EC04A10C9F"); + SYSTEM.CODE("140883F8FF7413BB0C9F1408669083EB04FFD08B0383F8FF75F483C4045B5DC3"); + SYSTEM.CODE("90905589E55383EC04E8000000005B81C3FC130000E86CFAEFFF595BC9C30300"); + SYSTEM.CODE("00000100020025750A25750A25750A25750A0000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000FFFFFFFF00000000FFFFFFFF000000000000000001000000010000000100"); + SYSTEM.CODE("00003C0000000C0000001C8504080D000000EC8B1408F5FEFF6F8C8104080500"); + SYSTEM.CODE("00003483040806000000F48104080A000000CD0000000B000000100000001500"); + SYSTEM.CODE("00000000000003000000F49F1408020000007000000014000000110000001700"); + SYSTEM.CODE("0000AC840408110000008C84040812000000200000001300000008000000FEFF"); + SYSTEM.CODE("FF6F2C840408FFFFFF6F02000000F0FFFF6F0284040800000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("00000000000000000000209F1408000000000000000062850408728504088285"); + SYSTEM.CODE("040892850408A2850408B2850408C2850408D2850408E2850408F28504080286"); + SYSTEM.CODE("0408128604082286040832860408000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000004743433A20285562756E74"); + SYSTEM.CODE("752F4C696E61726F20342E352E322D387562756E7475342920342E352E320047"); + SYSTEM.CODE("43433A20285562756E74752F4C696E61726F20342E352E322D387562756E7475"); + SYSTEM.CODE("332920342E352E3200002E73796D746162002E737472746162002E7368737472"); + SYSTEM.CODE("746162002E696E74657270002E6E6F74652E4142492D746167002E6E6F74652E"); + SYSTEM.CODE("676E752E6275696C642D6964002E676E752E68617368002E64796E73796D002E"); + SYSTEM.CODE("64796E737472002E676E752E76657273696F6E002E676E752E76657273696F6E"); + SYSTEM.CODE("5F72002E72656C2E64796E002E72656C2E706C74002E696E6974002E74657874"); + SYSTEM.CODE("002E66696E69002E726F64617461002E65685F6672616D65002E63746F727300"); + SYSTEM.CODE("2E64746F7273002E6A6372002E64796E616D6963002E676F74002E676F742E70"); + SYSTEM.CODE("6C74002E64617461002E627373002E636F6D6D656E7400000000000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000"); + SYSTEM.CODE("001B000000010000000200000034810408340100001300000000000000000000"); + SYSTEM.CODE("0001000000000000002300000007000000020000004881040848010000200000"); + SYSTEM.CODE("0000000000000000000400000000000000310000000700000002000000688104"); + SYSTEM.CODE("0868010000240000000000000000000000040000000000000044000000F6FFFF"); + SYSTEM.CODE("6F020000008C8104088C01000068000000050000000000000004000000040000"); + SYSTEM.CODE("004E0000000B00000002000000F4810408F40100004001000006000000010000"); + SYSTEM.CODE("0004000000100000005600000003000000020000003483040834030000CD0000"); + SYSTEM.CODE("00000000000000000001000000000000005E000000FFFFFF6F02000000028404"); + SYSTEM.CODE("080204000028000000050000000000000002000000020000006B000000FEFFFF"); + SYSTEM.CODE("6F020000002C8404082C04000060000000060000000200000004000000000000"); + SYSTEM.CODE("007A00000009000000020000008C8404088C0400002000000005000000000000"); + SYSTEM.CODE("000400000008000000830000000900000002000000AC840408AC040000700000"); + SYSTEM.CODE("00050000000C00000004000000080000008C00000001000000060000001C8504"); + SYSTEM.CODE("081C050000300000000000000000000000040000000000000087000000010000"); + SYSTEM.CODE("00060000004C8504084C050000F0000000000000000000000004000000040000"); + SYSTEM.CODE("009200000001000000060000004086040840060000AC05100000000000000000"); + SYSTEM.CODE("001000000000000000980000000100000006000000EC8B1408EC0B10001C0000"); + SYSTEM.CODE("00000000000000000004000000000000009E0000000100000002000000088C14"); + SYSTEM.CODE("08080C10001500000000000000000000000400000000000000A6000000010000"); + SYSTEM.CODE("0002000000208C1408200C100004000000000000000000000004000000000000"); + SYSTEM.CODE("00B000000001000000030000000C9F14080C0F10000800000000000000000000"); + SYSTEM.CODE("000400000000000000B70000000100000003000000149F1408140F1000080000"); + SYSTEM.CODE("0000000000000000000400000000000000BE00000001000000030000001C9F14"); + SYSTEM.CODE("081C0F10000400000000000000000000000400000000000000C3000000060000"); + SYSTEM.CODE("0003000000209F1408200F1000D0000000060000000000000004000000080000"); + SYSTEM.CODE("00CC0000000100000003000000F09F1408F00F10000400000000000000000000"); + SYSTEM.CODE("000400000004000000D10000000100000003000000F49F1408F40F1000440000"); + SYSTEM.CODE("0000000000000000000400000004000000DA000000010000000300000040A014"); + SYSTEM.CODE("08401010002000100000000000000000002000000000000000E0000000080000"); + SYSTEM.CODE("000300000060A02408601020004000800C000000000000000020000000000000"); + SYSTEM.CODE("00E5000000010000003000000000000000601020005400000000000000000000"); + SYSTEM.CODE("00010000000100000011000000030000000000000000000000B4102000EE0000"); + SYSTEM.CODE("0000000000000000000100000000000000010000000200000000000000000000"); + SYSTEM.CODE("002C162000000500001C0000002C000000040000001000000009000000030000"); + SYSTEM.CODE("0000000000000000002C1B2000F9020000000000000000000001000000000000"); + SYSTEM.CODE("0000000000000000000000000000000000000000003481040800000000030001"); + SYSTEM.CODE("0000000000488104080000000003000200000000006881040800000000030003"); + SYSTEM.CODE("00000000008C810408000000000300040000000000F481040800000000030005"); + SYSTEM.CODE("0000000000348304080000000003000600000000000284040800000000030007"); + SYSTEM.CODE("00000000002C8404080000000003000800000000008C84040800000000030009"); + SYSTEM.CODE("0000000000AC8404080000000003000A00000000001C8504080000000003000B"); + SYSTEM.CODE("00000000004C8504080000000003000C0000000000408604080000000003000D"); + SYSTEM.CODE("0000000000EC8B14080000000003000E0000000000088C14080000000003000F"); + SYSTEM.CODE("0000000000208C14080000000003001000000000000C9F140800000000030011"); + SYSTEM.CODE("0000000000149F14080000000003001200000000001C9F140800000000030013"); + SYSTEM.CODE("0000000000209F1408000000000300140000000000F09F140800000000030015"); + SYSTEM.CODE("0000000000F49F140800000000030016000000000040A0140800000000030017"); + SYSTEM.CODE("000000000060A024080000000003001800000000000000000000000000030019"); + SYSTEM.CODE("000100000000000000000000000400F1FF0C0000000C9F140800000000010011"); + SYSTEM.CODE("001A000000149F14080000000001001200280000001C9F140800000000010013"); + SYSTEM.CODE("0035000000708604080000000002000D004B00000084A0240801000000010018"); + SYSTEM.CODE("005A00000088A02408040000000100180068000000D08604080000000002000D"); + SYSTEM.CODE("000100000000000000000000000400F1FF74000000109F140800000000010011"); + SYSTEM.CODE("0081000000208C140800000000010010008F0000001C9F140800000000010013"); + SYSTEM.CODE("009B000000C08B14080000000002000D00B100000000000000000000000400F1"); + SYSTEM.CODE("FFB8000000F49F14080000000001001600CE0000000C9F140800000000000011"); + SYSTEM.CODE("00DF0000000C9F14080000000000001100F2000000209F140800000000010014"); + SYSTEM.CODE("00FB00000040A01408000000002000170006010000B08B14080500000012000D"); + SYSTEM.CODE("0016010000408604080000000012000D001D0100000000000000000000200000"); + SYSTEM.CODE("002C01000000000000000000002000000040010000088C14080400000011000F"); + SYSTEM.CODE("0047010000EC8B14080000000012000E004D0100000000000000000000120000"); + SYSTEM.CODE("006A0100000C8C14080400000011000F00790100007C85040800000000120000"); + SYSTEM.CODE("0089010000A0A024080000800C110018008E01000040A0140800000000100017"); + SYSTEM.CODE("009B0100008C8504080000000012000000AC0100009C85040800000000120000"); + SYSTEM.CODE("00BD010000AC8504080000000012000000CF01000060A0240804000000110018"); + SYSTEM.CODE("00E1010000BC8504080000000012000000F201000044A0140800000000110217"); + SYSTEM.CODE("00FF010000CC850408000000001200000011020000DC85040800000000120000"); + SYSTEM.CODE("0022020000189F140800000000110212002F020000508B14085A00000012000D"); + SYSTEM.CODE("003F02000000000000000000001200000051020000FC85040800000000120000"); + SYSTEM.CODE("006302000060A02408000000001000F1FF6F0200000C86040800000000120000"); + SYSTEM.CODE("008102000060A0140800001000110017008702000064A0240804000000110018"); + SYSTEM.CODE("0098020000A0A0A414000000001000F1FF9D02000080A0240804000000110018"); + SYSTEM.CODE("00AF0200001C8604080000000012000000C002000060A02408000000001000F1"); + SYSTEM.CODE("FFC70200002C8604080000000012000000D7020000B58B14080000000012020D"); + SYSTEM.CODE("00EE020000F48604084D04100012000D00F30200001C8504080000000012000B"); + SYSTEM.CODE("000063727473747566662E63005F5F43544F525F4C4953545F5F005F5F44544F"); + SYSTEM.CODE("525F4C4953545F5F005F5F4A43525F4C4953545F5F005F5F646F5F676C6F6261"); + SYSTEM.CODE("6C5F64746F72735F61757800636F6D706C657465642E363135350064746F725F"); + SYSTEM.CODE("6964782E36313537006672616D655F64756D6D79005F5F43544F525F454E445F"); + SYSTEM.CODE("5F005F5F4652414D455F454E445F5F005F5F4A43525F454E445F5F005F5F646F"); + SYSTEM.CODE("5F676C6F62616C5F63746F72735F6175780070726F672E63005F474C4F42414C"); + SYSTEM.CODE("5F4F46465345545F5441424C455F005F5F696E69745F61727261795F656E6400"); + SYSTEM.CODE("5F5F696E69745F61727261795F7374617274005F44594E414D49430064617461"); + SYSTEM.CODE("5F7374617274005F5F6C6962635F6373755F66696E69005F7374617274005F5F"); + SYSTEM.CODE("676D6F6E5F73746172745F5F005F4A765F5265676973746572436C6173736573"); + SYSTEM.CODE("005F66705F6877005F66696E69005F5F6C6962635F73746172745F6D61696E40"); + SYSTEM.CODE("40474C4942435F322E30005F494F5F737464696E5F7573656400667265654040"); + SYSTEM.CODE("474C4942435F322E300064617461005F5F646174615F737461727400646C7379"); + SYSTEM.CODE("6D4040474C4942435F322E3000667365656B4040474C4942435F322E30006663"); + SYSTEM.CODE("6C6F73654040474C4942435F322E31007374646572724040474C4942435F322E"); + SYSTEM.CODE("3000666F70656E4040474C4942435F322E31005F5F64736F5F68616E646C6500"); + SYSTEM.CODE("646C6F70656E4040474C4942435F322E31006674656C6C4040474C4942435F32"); + SYSTEM.CODE("2E30005F5F44544F525F454E445F5F005F5F6C6962635F6373755F696E697400"); + SYSTEM.CODE("7072696E74664040474C4942435F322E30006677726974654040474C4942435F"); + SYSTEM.CODE("322E30005F5F6273735F7374617274006D616C6C6F634040474C4942435F322E"); + SYSTEM.CODE("3000696461746100737464696E4040474C4942435F322E30005F656E64007374"); + SYSTEM.CODE("646F75744040474C4942435F322E300066726561644040474C4942435F322E30"); + SYSTEM.CODE("005F656461746100657869744040474C4942435F322E30005F5F693638362E67"); + SYSTEM.CODE("65745F70635F7468756E6B2E6278006D61696E005F696E697400"); +END data; + +PROCEDURE get*(): INTEGER; + RETURN SYSTEM.ADR(data) + 3 +END get; + +END ELF. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/ERRORS.ob07 b/programs/develop/oberon07/Source/ERRORS.ob07 new file mode 100644 index 0000000000..5eab9a82e8 --- /dev/null +++ b/programs/develop/oberon07/Source/ERRORS.ob07 @@ -0,0 +1,285 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE ERRORS; + +IMPORT H := HOST; + +TYPE + + STRING = ARRAY 1024 OF CHAR; + + CP = ARRAY 256 OF INTEGER; + +VAR + + cp: CP; + + +PROCEDURE utf8(code: INTEGER; VAR uchar: STRING); +BEGIN + uchar[0] := 0X; + IF code < 80H THEN + uchar[0] := CHR(code); + uchar[1] := 0X + ELSIF code < 800H THEN + uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H); + uchar[0] := CHR(ASR(code, 6) + 0C0H); + uchar[2] := 0X + ELSIF code < 10000H THEN + uchar[2] := CHR(ROR(LSL(code, 26), 26) + 80H); + code := ASR(code, 6); + uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H); + uchar[0] := CHR(ASR(code, 6) + 0E0H); + uchar[3] := 0X +(* + ELSIF code < 200000H THEN + ELSIF code < 4000000H THEN + ELSE *) + END +END utf8; + +PROCEDURE InitCP(VAR cp: CP); +VAR i: INTEGER; +BEGIN + FOR i := 0H TO 7FH DO + cp[i] := i + END +END InitCP; + +PROCEDURE Init8(VAR cp: CP; VAR n: INTEGER; a, b, c, d, e, f, g, h: INTEGER); +BEGIN + cp[n] := a; INC(n); + cp[n] := b; INC(n); + cp[n] := c; INC(n); + cp[n] := d; INC(n); + cp[n] := e; INC(n); + cp[n] := f; INC(n); + cp[n] := g; INC(n); + cp[n] := h; INC(n); +END Init8; + +PROCEDURE InitCP866(VAR cp: CP); +VAR n, i: INTEGER; +BEGIN + FOR i := 0410H TO 043FH DO + cp[i - 0410H + 80H] := i + END; + FOR i := 0440H TO 044FH DO + cp[i - 0440H + 0E0H] := i + END; + + n := 0B0H; + Init8(cp, n, 2591H, 2592H, 2593H, 2502H, 2524H, 2561H, 2562H, 2556H); + Init8(cp, n, 2555H, 2563H, 2551H, 2557H, 255DH, 255CH, 255BH, 2510H); + Init8(cp, n, 2514H, 2534H, 252CH, 251CH, 2500H, 253CH, 255EH, 255FH); + Init8(cp, n, 255AH, 2554H, 2569H, 2566H, 2560H, 2550H, 256CH, 2567H); + Init8(cp, n, 2568H, 2564H, 2565H, 2559H, 2558H, 2552H, 2553H, 256BH); + Init8(cp, n, 256AH, 2518H, 250CH, 2588H, 2584H, 258CH, 2590H, 2580H); + + n := 0F0H; + Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH); + Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H); + + InitCP(cp) +END InitCP866; + +PROCEDURE concat(VAR L: STRING; R: STRING); +VAR i, n, pos: INTEGER; +BEGIN + n := LENGTH(R); + i := 0; + pos := LENGTH(L); + WHILE (i <= n) & (pos < LEN(L)) DO + L[pos] := R[i]; + INC(pos); + INC(i) + END +END concat; + +PROCEDURE Utf8(VAR str: STRING); +VAR i: INTEGER; in, out, u: STRING; +BEGIN + in := str; + out := ""; + FOR i := 0 TO LENGTH(in) - 1 DO + utf8(cp[ORD(in[i])], u); + concat(out, u) + END; + str := out +END Utf8; + +PROCEDURE ErrorMsg*(code: INTEGER; VAR msg: ARRAY OF CHAR); +VAR str: STRING; +BEGIN + CASE code OF + | 1: str := "®¦Ё¤ « бм 'H' Ё«Ё 'X'" + | 2: str := "®¦Ё¤ « бм жЁда " + | 3: str := "бва®Є  ­Ґ ᮤҐа¦Ёв § Єалў о饩 Є ўлзЄЁ" + | 4: str := "­Ґ¤®ЇгбвЁ¬л© бЁ¬ў®«" + | 5: str := "楫®зЁб«Ґ­­®Ґ ЇҐаҐЇ®«­Ґ­ЁҐ" + | 6: str := "б«ЁиЄ®¬ Ў®«м讥 §­ зҐ­ЁҐ бЁ¬ў®«м­®© Є®­бв ­вл" + | 7: str := "ўҐйҐб⢥­­®Ґ ЇҐаҐЇ®«­Ґ­ЁҐ" + | 8: str := "ЇҐаҐЇ®«­Ґ­ЁҐ Ї®ап¤Є  ўҐйҐб⢥­­®Ј® зЁб« " + | 9: str := "ўҐйҐб⢥­­®Ґ  ­вЁЇҐаҐЇ®«­Ґ­ЁҐ" + | 10: str := "б«ЁиЄ®¬ ¤«Ё­­л© Ё¤Ґ­вЁдЁЄ в®а" + | 11: str := "б«ЁиЄ®¬ ¤«Ё­­ п бва®Є®ў п Є®­бв ­в " + + | 21: str := "®¦Ё¤ «®бм 'MODULE'" + | 22: str := "®¦Ё¤ «бп Ё¤Ґ­вЁдЁЄ в®а" + | 23: str := "®¦Ё¤ « бм ';'" + | 24: str := "®¦Ё¤ «®бм 'END'" + | 25: str := "®¦Ё¤ « бм '.'" + | 26: str := "Ё¤Ґ­вЁдЁЄ в®а ­Ґ б®ўЇ ¤ Ґв б Ё¬Ґ­Ґ¬ ¬®¤г«п" + | 27: str := "­Ґ®¦Ё¤ ­­л© Є®­Ґж д ©« " + | 28: str := "®¦Ё¤ « бм ',', ';' Ё«Ё ':='" + | 29: str := "®¦Ё¤ « бм ',' Ё«Ё ';'" + | 30: str := "Ё¤Ґ­вЁдЁЄ в®а ЇҐаҐ®ЇаҐ¤Ґ«Ґ­" + | 31: str := "жЁЄ«ЁзҐбЄЁ© Ё¬Ї®ав" + | 32: str := "¬®¤г«м ­Ґ ­ ©¤Ґ­ Ё«Ё ®иЁЎЄ  ¤®бвгЇ " + | 33: str := "Ё¬п ¬®¤г«п ­Ґ б®ўЇ ¤ Ґв б Ё¬Ґ­Ґ¬ д ©«  ¬®¤г«п" + | 34: str := "­ҐЇа ўЁ«м­л© д®а¬ в бва®ЄЁ ¬ иЁ­­ле Є®¤®ў" + | 35: str := "®¦Ё¤ «®бм '='" + | 36: str := "бЁ­в ЄбЁзҐбЄ п ®иЁЎЄ  ў ўла ¦Ґ­ЁЁ" + | 37: str := "®ЇҐа жЁп ­Ґ ЇаЁ¬Ґ­Ё¬ " + | 38: str := "®¦Ё¤ « бм ')'" + | 39: str := "®¦Ё¤ «oбм 'ARRAY', 'RECORD', 'POINTER' Ё«Ё 'PROCEDURE'" + | 40: str := "®¦Ё¤ «oбм 'TO'" + | 41: str := "®¦Ё¤ «oбм 'OF'" + | 42: str := "­Ґ®ЇаҐ¤Ґ«Ґ­­л© Ё¤Ґ­вЁдЁЄ в®а" + | 43: str := "вॡгҐвбп ЇҐаҐ¬Ґ­­ п, Їа®жҐ¤га  Ё«Ё бва®Є®ў п Є®­бв ­в " + | 44: str := "®¦Ё¤ «oбм 'cdecl', 'stdcall' Ё«Ё 'winapi'" + | 45: str := "д« Ј ўл§®ў  ­Ґ¤®ЇгбЄ Ґвбп ¤«п «®Є «м­ле Їа®жҐ¤га" + | 46: str := "¤Ґ«Ґ­ЁҐ ­  ­г«м" + | 47: str := "вॡгҐвбп Ё¤Ґ­вЁдЁЄ в®а вЁЇ -§ ЇЁбЁ Ё«Ё вЁЇ -гЄ § вҐ«п" + | 48: str := "楫®зЁб«Ґ­­®Ґ ¤Ґ«Ґ­ЁҐ ­  ­г«м" + | 49: str := "§­ зҐ­ЁҐ «Ґў®Ј® ®ЇҐа ­¤  ў­Ґ ¤Ё Ї §®­  0..31" + | 50: str := "д« Ј [winapi] ¤®бвгЇҐ­ в®«мЄ® ¤«п Ї« вд®а¬л Windows" + | 51: str := "®¦Ё¤ « бм '}'" + | 52: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  INTEGER" + | 53: str := "§­ зҐ­ЁҐ ўла ¦Ґ­Ёп ў­Ґ ¤Ё Ї §®­  0..31" + | 54: str := "«Ґў п Ја ­Ёж  ¤Ё Ї §®­  Ў®«миҐ Їа ў®©" + | 55: str := "вॡгҐвбп Є®­бв ­в  вЁЇ  CHAR" + | 56: str := "®¦Ё¤ « бм '('" + | 57: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ зЁб«®ў®Ј® вЁЇ " + + | 59: str := "­Ґ¤®бв в®з­® Ї а ¬Ґва®ў" + | 60: str := "­Ґ¤®ЇгбвЁ¬л© Ї а ¬Ґва" + | 61: str := "®¦Ё¤ « бм ','" + | 62: str := "вॡгҐвбп Є®­бв ­в­®Ґ ўла ¦Ґ­ЁҐ" + | 63: str := "вॡгҐвбп ЇҐаҐ¬Ґ­­ п" + | 64: str := "д ©« ­Ґ ­ ©¤Ґ­ Ё«Ё ®иЁЎЄ  ¤®бвгЇ " + | 65: str := "¬®¤г«м RTL ­Ґ ­ ©¤Ґ­" + | 66: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  REAL Ё«Ё LONGREAL" + | 67: str := "­Ґў®§¬®¦­® ᮧ¤ вм д ©«, ў®§¬®¦­® д ©« ®вЄалв Ё«Ё ¤ЁбЄ § йЁйҐ­ ®в § ЇЁбЁ" + | 68: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  CHAR, SET Ё«Ё BOOLEAN" + | 69: str := "­Ґў®§¬®¦­® § ЇЁб вм д ©«" + | 70: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  LONGREAL" + | 71: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  REAL" + | 72: str := "­Ґ¤®бв в®з­® Ї ¬пвЁ ¤«п § ўҐа襭Ёп Є®¬ЇЁ«пжЁЁ" + | 73: str := "Їа®жҐ¤га  ­Ґ ў®§ўа й ой п १г«мв в ­Ґ¤®ЇгбвЁ¬  ў ўла ¦Ґ­Ёпе" + | 74: str := "§­ зҐ­ЁҐ ўла ¦Ґ­Ёп ў­Ґ 楫®зЁб«Ґ­­®Ј® ¤Ё Ї §®­ " + | 75: str := "४габЁў­®Ґ ®ЇаҐ¤Ґ«Ґ­ЁҐ Є®­бв ­вл" + | 76: str := "§­ зҐ­ЁҐ ўла ¦Ґ­Ёп ў­Ґ ¤Ё Ї §®­  0..255" + | 77: str := "®¦Ё¤ «бп Ё¤Ґ­вЁдЁЄ в®а вЁЇ " + | 78: str := "¤«Ё­  вЁЇ -¬ ббЁў  ¤®«¦­  Ўлвм Ў®«миҐ ­г«п" + | 79: str := "®¦Ё¤ «®бм 'OF' Ё«Ё ','" + | 80: str := "®¦Ё¤ «бп Ё¤Ґ­вЁдЁЄ в®а вЁЇ -§ ЇЁбЁ" + | 81: str := "Ў §®ўл© вЁЇ вЁЇ -гЄ § вҐ«п ¤®«¦Ґ­ Ўлвм § ЇЁбмо" + | 82: str := "вЁЇ १г«мв в  Їа®жҐ¤гал ­Ґ ¬®¦Ґв Ўлвм § ЇЁбмо Ё«Ё ¬ ббЁў®¬" + | 83: str := "а §¬Ґа вЁЇ  б«ЁиЄ®¬ ўҐ«ЁЄ" + | 84: str := "®¦Ё¤ «бп Ё¤Ґ­вЁдЁЄ в®а Ё«Ё 'VAR'" + | 85: str := "®¦Ё¤ « бм ',' Ё«Ё ':'" + | 86: str := "®¦Ё¤ «®бм 'END' Ё«Ё ';'" + | 87: str := "Ё¤Ґ­вЁдЁЄ в®а ­Ґ б®ўЇ ¤ Ґв б Ё¬Ґ­Ґ¬ Їа®жҐ¤гал" + + | 89: str := "нЄбЇ®ав «®Є «м­®Ј® Ё¤Ґ­вЁдЁЄ в®а  ­Ґ¤®ЇгбвЁ¬" + | 90: str := "вЁЇ ARRAY Ё«Ё RECORD ­Ґ¤®ЇгбвЁ¬" + | 91: str := "вॡгҐвбп Ё¤Ґ­вЁдЁЄ в®а ўҐйҐб⢥­­®Ј® вЁЇ " + + | 93: str := "а §¬Ґа ¤ ­­ле б«ЁиЄ®¬ ўҐ«ЁЄ" + | 94: str := "бва®Є  ¤«Ё­л, ®в«Ёз­®© ®в 1 ­Ґ¤®ЇгбвЁ¬ " + | 95: str := "§­ зҐ­ЁҐ ўла ¦Ґ­Ёп ¤®«¦­® Ўлвм ў ¤Ё Ї §®­Ґ 0..127" + | 96: str := "­Ґ¤®ЇгбвЁ¬®Ґ ४габЁў­®Ґ ®ЇаҐ¤Ґ«Ґ­ЁҐ вЁЇ " + | 97: str := "­Ґ¤®бв в®з­® ўҐйҐб⢥­­ле ॣЁбва®ў, гЇа®бвЁвҐ ўла ¦Ґ­ЁҐ" + | 98: str := "®¦Ё¤ «®бм 'THEN'" + | 99: str := "Ї®«Ґ § ЇЁбЁ ­Ґ ­ ©¤Ґ­®" + |100: str := "¬ҐвЄ  ¤гЎ«Ёа®ў ­ " + |101: str := "Ё¤Ґ­вЁдЁЄ в®а вЁЇ  ­Ґ¤®ЇгбвЁ¬ ў ўла ¦Ґ­Ёпе" + |102: str := "вॡгҐвбп ¬ ббЁў" + |103: str := "®¦Ё¤ «oбм 'union' Ё«Ё 'noalign'" + |104: str := "вॡгҐвбп гЄ § вҐ«м" + |105: str := "вॡгҐвбп § ЇЁбм" + |106: str := "вॡгҐвбп Ё¤Ґ­вЁдЁЄ в®а вЁЇ -§ ЇЁбЁ" + |107: str := "вॡгҐвбп Ё¤Ґ­вЁдЁЄ в®а вЁЇ -гЄ § вҐ«п" + |108: str := "­Ґ¤®ЇгбвЁ¬ п ®еа ­  вЁЇ " + |109: str := "®¦Ё¤ « бм ']'" + |110: str := "а §¬Ґа­®бвм ®вЄалв®Ј® ¬ ббЁў  б«ЁиЄ®¬ ўҐ«ЁЄ " + |111: str := "бЁб⥬­лҐ д« ЈЁ вॡгов Ё¬Ї®ав  ¬®¤г«п SYSTEM" + |112: str := "а биЁаҐ­ЁҐ § ЇЁбЁ ­Ґ ¬®¦Ґв Ўлвм [noalign] Ё«Ё [union]" + |113: str := "Ў §®ўл© вЁЇ § ЇЁбЁ ­Ґ ¬®¦Ґв Ўлвм [noalign] Ё«Ё [union]" + |114: str := "­Ґб®ў¬ҐбвЁ¬л© Ї а ¬Ґва" + |115: str := "ЇҐаҐ¬Ґ­­ п ¤®бвгЇ­  в®«мЄ® ¤«п з⥭Ёп" + |116: str := "­Ґ«м§п ЁбЇ®«м§®ў вм «®Є «м­го Їа®жҐ¤гаг" + |117: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  BOOLEAN" + |118: str := "®¦Ё¤ «®бм 'DO'" + |119: str := "®¦Ё¤ «®бм 'UNTIL'" + |120: str := "®¦Ё¤ «®бм ':='" + |121: str := "а биЁаҐ­ЁҐ Ё¬Ґ­Ё д ©«  Ј« ў­®Ј® ¬®¤г«п ¤®«¦­® Ўлвм 'ob07'" + |122: str := "§­ зҐ­ЁҐ ўла ¦Ґ­Ёп ­Ґ ¬®¦Ґв Ўлвм а ў­л¬ ­г«о" + |123: str := "'RETURN' ­Ґ¤®ЇгбвЁ¬ ў Їа®жҐ¤гаҐ, ­Ґ ў®§ўа й о饩 १г«мв в" + |124: str := "®¦Ё¤ «®бм 'RETURN'" + |125: str := "вЁЇ ўла ¦Ґ­Ёп ­Ґ ᮮ⢥вбвўгҐв вЁЇг १г«мв в  Їа®жҐ¤гал" + |126: str := "вॡгҐвбп Ё¤Ґ­вЁдЁЄ в®а ЇҐаҐ¬Ґ­­®©" + |127: str := "бзҐвзЁЄ жЁЄ«  FOR ­Ґ ¤®«¦Ґ­ Ўлвм Ї а ¬Ґв஬" + |128: str := "вЁЇ ЇҐаҐ¬Ґ­­®© ¤®«¦Ґ­ Ўлвм INTEGER" + |129: str := "ЇҐаҐ¬Ґ­­ п ¤®«¦­  Ўлвм «®Є «м­®©" + |130: str := "­Ґ«м§п ЁбЇ®«м§®ў вм Є®­бв ­вг" + |131: str := "­Ґб®ў¬ҐбвЁ¬®бвм Ї® ЇаЁбў Ёў ­Ёо" + |132: str := "ўл§®ў Їа®жҐ¤гал-дг­ЄжЁЁ ¤®ЇгбЄ Ґвбп в®«мЄ® ў б®бв ўҐ ўла ¦Ґ­Ёп" + |133: str := "Ё¤Ґ­вЁдЁЄ в®ал 'lib_init' Ё 'version' § аҐ§ҐаўЁа®ў ­л" + + |138: str := "вЁЇ ЇҐаҐ¬Ґ­­®© ¤®«¦Ґ­ Ўлвм SET" + + |141: str := "вॡгҐвбп бва®Є  Ё«Ё бЁ¬ў®«м­л© ¬ ббЁў" + + |143: str := "вॡгҐвбп бЁ¬ў®«м­л© ¬ ббЁў" + + |145: str := "вЁЇ ЇҐаҐ¬Ґ­­®© ¤®«¦Ґ­ Ўлвм POINTER" + + |149: str := "вЁЇ ЇҐаҐ¬Ґ­­®© ¤®«¦Ґ­ Ўлвм REAL Ё«Ё LONGREAL" + |150: str := "вॡгҐвбп бва®Є®ў п Є®­бв ­в " + + |155: str := "®¦Ё¤ « бм '(' Ё«Ё ':='" + |156: str := "вॡгҐвбп ўла ¦Ґ­ЁҐ вЁЇ  INTEGER Ё«Ё CHAR" + |157: str := "®¦Ё¤ « бм ':'" + |158: str := "­Ґ ­ ©¤Ґ­  Їа®жҐ¤га  ў ¬®¤г«Ґ RTL" + |159: str := "­ аг襭ЁҐ Ја ­Ёж ¬ ббЁў " + |160: str := "®¦Ё¤ «бп Ё¤Ґ­вЁдЁЄ в®а Є®­бв ­вл" + |161: str := "вॡгҐвбп Є®­бв ­в  вЁЇ  INTEGER" + END; + IF H.OS = "LNX" THEN + Utf8(str) + END; + COPY(str, msg) +END ErrorMsg; + +BEGIN + InitCP866(cp) +END ERRORS. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/SCAN.ob07 b/programs/develop/oberon07/Source/SCAN.ob07 new file mode 100644 index 0000000000..7acc2c3216 --- /dev/null +++ b/programs/develop/oberon07/Source/SCAN.ob07 @@ -0,0 +1,699 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE SCAN; + +IMPORT UTILS, sys := SYSTEM; + +CONST + + Tab = 8; + maxINT* = 7FFFFFFFH; + minINT* = 80000000H; + maxREAL* = 3.39E38; + maxDBL* = 1.69D308; + minREAL* = 1.41E-45; + IDLENGTH = 255; + STRLENGTH* = 256; + + lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7; + lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8; + lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16; + lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23; + lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30; + lxUNTIL = 31; lxVAR = 32; lxWHILE = 33; + + lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58; + lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65; + lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70; + lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76; + + lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106; + lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120; + +TYPE + + TCoord* = RECORD line*, col*: INTEGER END; + + NODE* = POINTER TO RECORD + Left, Right: NODE; + tLex: INTEGER; + Name*: UTILS.STRING + END; + + SCANNER* = POINTER TO RECORD + File, ccol, cline, count, tLex, vINT: INTEGER; + coord: TCoord; + ch, vCHX: CHAR; + Lex: UTILS.STRING; + vFLT: LONGREAL; + id: NODE; + buf, bufpos: INTEGER; + CR, UTF8: BOOLEAN + END; + +VAR + + Lex*: UTILS.STRING; File, ccol, cline, count*, tLex*, vINT*: INTEGER; + coord*: TCoord; + vFLT*: LONGREAL; id*: NODE; ch, vCHX*: CHAR; + buf, bufpos: INTEGER; CR, UTF8: BOOLEAN; + Nodes: ARRAY 256 OF NODE; + _START*, _version*: NODE; + +PROCEDURE AddNode*(Name: UTILS.STRING): NODE; +VAR cur, res: NODE; + + PROCEDURE NewNode(Right: BOOLEAN); + BEGIN + NEW(res); + UTILS.MemErr(res = NIL); + res.Name := Name; + res.tLex := lxIDENT; + res.Left := NIL; + res.Right := NIL; + IF Right THEN + cur.Right := res + ELSE + cur.Left := res + END + END NewNode; + +BEGIN + res := NIL; + cur := Nodes[ORD(Name[0])]; + REPEAT + IF Name > cur.Name THEN + IF cur.Right # NIL THEN + cur := cur.Right + ELSE + NewNode(TRUE) + END + ELSIF Name < cur.Name THEN + IF cur.Left # NIL THEN + cur := cur.Left + ELSE + NewNode(FALSE) + END + ELSE + res := cur + END + UNTIL res # NIL + RETURN res +END AddNode; + +PROCEDURE Backup*(scanner: SCANNER); +BEGIN + scanner.File := File; + scanner.ccol := ccol; + scanner.cline := cline; + scanner.ch := ch; + scanner.Lex := Lex; + scanner.count := count; + scanner.coord := coord; + scanner.tLex := tLex; + scanner.vINT := vINT; + scanner.vFLT := vFLT; + scanner.vCHX := vCHX; + scanner.buf := buf; + scanner.bufpos := bufpos; + scanner.CR := CR; + scanner.UTF8 := UTF8 +END Backup; + +PROCEDURE Recover*(scanner: SCANNER); +BEGIN + File := scanner.File; + ccol := scanner.ccol; + cline := scanner.cline; + ch := scanner.ch; + Lex := scanner.Lex; + count := scanner.count; + coord := scanner.coord; + tLex := scanner.tLex; + vINT := scanner.vINT; + vFLT := scanner.vFLT; + vCHX := scanner.vCHX; + buf := scanner.buf; + bufpos := scanner.bufpos; + CR := scanner.CR; + UTF8 := scanner.UTF8 +END Recover; + +PROCEDURE Next; +VAR cr: BOOLEAN; +BEGIN + cr := FALSE; + sys.GET(bufpos, ch); + INC(ccol); + CASE ch OF + |0AX: IF ~CR THEN INC(cline) END; ccol := 0 + |0DX: INC(cline); ccol := 0; cr := TRUE + |09X: DEC(ccol); ccol := (ccol DIV Tab) * Tab + Tab + |80X..0BFX: IF UTF8 THEN DEC(ccol) END + ELSE + END; + CR := cr; + INC(bufpos) +END Next; + +PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN; +VAR n, size: INTEGER; c: CHAR; +BEGIN + File := UTILS.OpenF(FName); + FHandle := File; + IF File # 0 THEN + CR := FALSE; + UTF8 := FALSE; + ccol := 0; + cline := 1; + ch := 0X; + size := UTILS.FileSize(File); + buf := UTILS.GetMem(size + 1024); + UTILS.MemErr(buf = 0); + sys.PUT(buf + size, 0X); + n := UTILS.Read(File, buf, size); + UTILS.CloseF(File); + bufpos := buf; + sys.GET(buf, c); + IF c = 0EFX THEN + sys.GET(buf + 1, c); + IF c = 0BBX THEN + sys.GET(buf + 2, c); + IF c = 0BFX THEN + INC(bufpos, 3); + UTF8 := TRUE + END + END + END; + Next + END + RETURN (File # 0) & (n = size) +END Open; + +PROCEDURE Space(ch: CHAR): BOOLEAN; + RETURN (ch <= 20X) & (ch > 0X) +END Space; + +PROCEDURE Letter(ch: CHAR): BOOLEAN; + RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_") +END Letter; + +PROCEDURE Digit*(ch: CHAR): BOOLEAN; + RETURN (ch >= "0") & (ch <= "9") +END Digit; + +PROCEDURE HexDigit*(ch: CHAR): BOOLEAN; + RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9") +END HexDigit; + +PROCEDURE PutChar(ch: CHAR); +BEGIN + Lex[count] := ch; + IF ch # 0X THEN + INC(count) + END +END PutChar; + +PROCEDURE PutNext(ch: CHAR); +BEGIN + PutChar(ch); + Next +END PutNext; + +PROCEDURE Ident; +BEGIN + tLex := lxIDENT; + WHILE Letter(ch) OR Digit(ch) DO + PutNext(ch) + END; + PutChar(0X); + IF count > IDLENGTH THEN + tLex := lxERR10 + END +END Ident; + +PROCEDURE hex*(ch: CHAR): INTEGER; +VAR Res: INTEGER; +BEGIN + Res := ORD(ch); + CASE ch OF + |"0".."9": DEC(Res, ORD("0")) + |"A".."F": DEC(Res, ORD("A") - 10) + ELSE + END + RETURN Res +END hex; + +PROCEDURE StrToInt16(str: UTILS.STRING): INTEGER; +VAR i, res, n: INTEGER; flag: BOOLEAN; +BEGIN + res := 0; + i := 0; + n := 0; + WHILE str[i] = "0" DO + INC(i) + END; + flag := TRUE; + WHILE flag & (str[i] # "X") & (str[i] # "H") DO + INC(n); + IF n > 8 THEN + tLex := lxERR5; + flag := FALSE + ELSE + res := LSL(res, 4) + hex(str[i]); + INC(i) + END + END + RETURN res +END StrToInt16; + +PROCEDURE StrToChx(str: UTILS.STRING): CHAR; +VAR res: INTEGER; +BEGIN + res := StrToInt16(str); + IF (res < 0) OR (res > 0FFH) THEN + tLex := lxERR6; + res := 0 + END + RETURN CHR(res) +END StrToChx; + +PROCEDURE StrToInt*(str: UTILS.STRING): INTEGER; +VAR i, res: INTEGER; flag: BOOLEAN; +BEGIN + res := 0; + i := 0; + flag := TRUE; + WHILE flag & (str[i] # 0X) DO + IF res > maxINT DIV 10 THEN + tLex := lxERR5; + flag := FALSE; + res := 0 + ELSE + res := res * 10; + IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN + tLex := lxERR5; + flag := FALSE; + res := 0 + ELSE + res := res + (ORD(str[i]) - ORD("0")); + INC(i) + END + END + END + RETURN res +END StrToInt; + +PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL; +VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN; + + PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN); + BEGIN + tLex := e; + res := 0.0D0; + cont := FALSE + END Error; + + PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER); + BEGIN + IF UTILS.IsInf(res) THEN + Error(lxERR7, cont) + END; + INC(i) + END Inf; + + PROCEDURE part1(): BOOLEAN; + VAR cont: BOOLEAN; + BEGIN + res := 0.0D0; + i := 0; + d := 1.0D0; + nez := FALSE; + cont := TRUE; + WHILE cont & Digit(str[i]) DO + nez := nez OR (str[i] # "0"); + res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0"))); + Inf(cont, i) + END + RETURN cont + END part1; + + PROCEDURE part2(): BOOLEAN; + VAR cont: BOOLEAN; + BEGIN + INC(i); + cont := TRUE; + WHILE cont & Digit(str[i]) DO + nez := nez OR (str[i] # "0"); + d := d / 10.0D0; + res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d; + Inf(cont, i) + END + RETURN cont + END part2; + + PROCEDURE part3(): BOOLEAN; + VAR cont: BOOLEAN; + BEGIN + cont := TRUE; + IF str[i] = 0X THEN + IF res > LONG(maxREAL) THEN + Error(lxERR7, cont) + ELSIF nez & ((res = 0.0D0) OR (res < LONG(minREAL)) & (tLex = lxREAL)) THEN + Error(lxERR9, cont) + END + END + RETURN cont + END part3; + + PROCEDURE part4(): BOOLEAN; + VAR cont: BOOLEAN; + BEGIN + IF str[i] = "D" THEN + tLex := lxLONGREAL + END; + INC(i); + m := 10.0D0; + minus := FALSE; + IF str[i] = "+" THEN + INC(i) + ELSIF str[i] = "-" THEN + minus := TRUE; + INC(i); + m := 0.1D0 + END; + scale := 0; + cont := TRUE; + WHILE cont & Digit(str[i]) DO + IF scale > maxINT DIV 10 THEN + Error(lxERR8, cont) + ELSE + scale := scale * 10; + IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN + Error(lxERR8, cont) + ELSE + scale := scale + (ORD(str[i]) - ORD("0")); + INC(i) + END + END + END + RETURN cont + END part4; + + PROCEDURE part5(): BOOLEAN; + VAR cont: BOOLEAN; i: INTEGER; + BEGIN + cont := TRUE; + IF scale = maxINT THEN + Error(lxERR8, cont) + END; + i := 1; + WHILE cont & (i <= scale) DO + res := res * m; + Inf(cont, i) + END; + IF cont & (nez & (res = 0.0D0) OR (res > 0.0D0) & (res < LONG(minREAL)) & (tLex = lxREAL)) THEN + Error(lxERR9, cont) + ELSIF cont & (tLex = lxREAL) & (res > LONG(maxREAL)) THEN + Error(lxERR7, cont) + END + RETURN cont + END part5; + +BEGIN + IF part1() & part2() & part3() & part4() & part5() THEN END + RETURN res +END StrToFloat; + +PROCEDURE Number; +VAR nextchr: CHAR; +BEGIN + tLex := lxINT; + WHILE Digit(ch) DO + PutNext(ch) + END; + IF ch = "H" THEN + tLex := lxHEX + ELSIF ch = "X" THEN + tLex := lxCHX + END; + IF tLex # lxINT THEN + PutNext(ch) + ELSE + WHILE HexDigit(ch) DO + tLex := lxHEX; + PutNext(ch) + END; + IF tLex = lxHEX THEN + IF ch = "H" THEN + PutNext(ch) + ELSIF ch = "X" THEN + tLex := lxCHX; + PutNext(ch) + ELSE + tLex := lxERR1 + END + ELSIF ch = "." THEN + sys.GET(bufpos, nextchr); + IF nextchr # "." THEN + tLex := lxREAL; + PutNext(ch); + WHILE Digit(ch) DO + PutNext(ch) + END; + IF (ch = "E") OR (ch = "D") THEN + PutNext(ch); + IF (ch = "+") OR (ch = "-") THEN + PutNext(ch) + END; + IF ~Digit(ch) THEN + tLex := lxERR2 + ELSE + WHILE Digit(ch) DO + PutNext(ch) + END + END + END + END + END + END; + PutChar(0X) +END Number; + +PROCEDURE Delim(ch: CHAR): INTEGER; +VAR Res: INTEGER; +BEGIN + CASE ch OF + |"+": Res := lxPlus + |"-": Res := lxMinus + |"*": Res := lxMult + |"/": Res := lxSlash + |"~": Res := lxNot + |"&": Res := lxAnd + |",": Res := lxComma + |";": Res := lxSemi + |"|": Res := lxStick + |"[": Res := lxLSquare + |"{": Res := lxLCurly + |"^": Res := lxCaret + |"=": Res := lxEQ + |"#": Res := lxNE + |")": Res := lxRRound + |"]": Res := lxRSquare + |"}": Res := lxRCurly + |">": Res := lxGT + |"<": Res := lxLT + |":": Res := lxColon + ELSE + END + RETURN Res +END Delim; + +PROCEDURE Comment; +VAR c, level: INTEGER; cont: BOOLEAN; +BEGIN + c := 1; + level := 1; + cont := TRUE; + WHILE cont & (level > 0) DO + Next; + CASE ch OF + |"(": c := 2 + |")": IF c = 3 THEN DEC(level) END; c := 1 + |"*": IF c = 2 THEN INC(level); c := 1 ELSE c := 3 END + |0X : cont := FALSE + ELSE + c := 1 + END; + END; + IF cont THEN + Next + END +END Comment; + +PROCEDURE GetLex*; +BEGIN + WHILE Space(ch) DO + Next + END; + coord.col := ccol; + coord.line := cline; + count := 0; + CASE ch OF + |"A".."Z", "a".."z", "_": + Ident; + id := AddNode(Lex); + tLex := id.tLex; + |"0".."9": + Number; + CASE tLex OF + |lxINT: vINT := StrToInt(Lex) + |lxHEX: vINT := StrToInt16(Lex) + |lxCHX: vCHX := StrToChx(Lex) + |lxREAL: vFLT := StrToFloat(Lex) + ELSE + END + |22X: + tLex := lxSTRING; + Next; + WHILE (ch # 22X) & (ch >= 20X) DO + PutNext(ch) + END; + IF ch = 22X THEN + Next + ELSE + tLex := lxERR3 + END; + PutChar(0X); + INC(count); + IF count > STRLENGTH THEN + tLex := lxERR11 + END + |"/": + tLex := Delim(ch); + PutNext(ch); + IF ch = "/" THEN + WHILE (ch >= 20X) OR (ch = 9X) DO + PutNext(ch) + END; + GetLex + END; + PutChar(0X) + |">", "<", ":": + tLex := Delim(ch); + PutNext(ch); + IF ch = "=" THEN + CASE tLex OF + |lxLT: tLex := lxLE + |lxGT: tLex := lxGE + |lxColon: tLex := lxAssign + ELSE + END; + PutNext(ch) + END; + PutChar(0X) + |".": + tLex := lxDot; + PutNext(ch); + IF ch = "." THEN + tLex := lxDbl; + PutNext(ch) + END; + PutChar(0X) + |"(": + tLex := lxLRound; + PutNext(ch); + IF ch = "*" THEN + Comment; + GetLex + END; + PutChar(0X) + |"+", "-", "*", "~", "&", ",", ";", "|", + "[", "{", "^", "=", "#", ")", "]", "}": + tLex := Delim(ch); + PutChar(ch); + PutNext(0X) + |0X: + tLex := lxEOF; + PutChar(0X) + ELSE + tLex := lxERR4 + END +END GetLex; + +PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER); +VAR node: NODE; +BEGIN + node := AddNode(Name); + node.tLex := key +END AddNodeKey; + +PROCEDURE Init; +VAR i: INTEGER; node: NODE; +BEGIN + FOR i := 0 TO LEN(Nodes) - 1 DO + NEW(node); + UTILS.MemErr(node = NIL); + sys.PUT(sys.ADR(node.Name), i); + node.Left := NIL; + node.Right := NIL; + node.tLex := lxIDENT; + Nodes[i] := node + END; + _START := AddNode("lib_init"); + _version := AddNode("version"); + AddNodeKey("MOD", lxMOD); + AddNodeKey("ELSE", lxELSE); + AddNodeKey("RETURN", lxRETURN); + AddNodeKey("CASE", lxCASE); + AddNodeKey("IF", lxIF); + AddNodeKey("POINTER", lxPOINTER); + AddNodeKey("TYPE", lxTYPE); + AddNodeKey("BEGIN", lxBEGIN); + AddNodeKey("DIV", lxDIV); + AddNodeKey("FALSE", lxFALSE); + AddNodeKey("IN", lxIN); + AddNodeKey("NIL", lxNIL); + AddNodeKey("RECORD", lxRECORD); + AddNodeKey("TO", lxTO); + AddNodeKey("VAR", lxVAR); + AddNodeKey("ARRAY", lxARRAY); + AddNodeKey("DO", lxDO); + AddNodeKey("END", lxEND); + AddNodeKey("IS", lxIS); + AddNodeKey("OF", lxOF); + AddNodeKey("PROCEDURE", lxPROCEDURE); + AddNodeKey("THEN", lxTHEN); + AddNodeKey("WHILE", lxWHILE); + AddNodeKey("BY", lxBY); + AddNodeKey("CONST", lxCONST); + AddNodeKey("ELSIF", lxELSIF); + AddNodeKey("IMPORT", lxIMPORT); + AddNodeKey("MODULE", lxMODULE); + AddNodeKey("OR", lxOR); + AddNodeKey("REPEAT", lxREPEAT); + AddNodeKey("TRUE", lxTRUE); + AddNodeKey("UNTIL", lxUNTIL); + AddNodeKey("FOR", lxFOR) +END Init; + +BEGIN + Init +END SCAN. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/UTILS.ob07 b/programs/develop/oberon07/Source/UTILS.ob07 new file mode 100644 index 0000000000..b02a52ecc8 --- /dev/null +++ b/programs/develop/oberon07/Source/UTILS.ob07 @@ -0,0 +1,426 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE UTILS; + +IMPORT sys := SYSTEM, H := HOST, ERRORS; + +CONST + + OS* = H.OS; + Slash* = H.Slash; + Ext* = ".ob07"; + MAX_PATH = 1024; + MAX_PARAM = 1024; + Date* = 1451606400; (* 2016-01-01 *) + +TYPE + + STRING* = ARRAY MAX_PATH OF CHAR; + + ITEM* = POINTER TO rITEM; + + rITEM* = RECORD + Next*, Prev*: ITEM + END; + + LIST* = POINTER TO RECORD + First*, Last*: ITEM; + Count*: INTEGER + END; + + STRCONST* = POINTER TO RECORD (rITEM) + Str*: STRING; + Len*, Number*: INTEGER + END; + +VAR + + Params: ARRAY MAX_PARAM, 2 OF INTEGER; + ParamCount*, Line*, Unit*: INTEGER; + FileName: STRING; + +PROCEDURE SetFile*(F: STRING); +BEGIN + FileName := F +END SetFile; + +PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; + RETURN ABS(x) = sys.INF(LONGREAL) +END IsInf; + +PROCEDURE GetChar(adr: INTEGER): CHAR; +VAR res: CHAR; +BEGIN + sys.GET(adr, res) + RETURN res +END GetChar; + +PROCEDURE ParamParse(count: INTEGER); +VAR c: CHAR; cond, p: INTEGER; + + PROCEDURE ChangeCond(A, B, C: INTEGER); + BEGIN + cond := C; + CASE c OF + |0X: cond := 6 + |1X..20X: cond := A + |22X: cond := B + ELSE + END + END ChangeCond; + +BEGIN + p := H.GetCommandLine(); + cond := 0; + WHILE (count < MAX_PARAM) & (cond # 6) DO + c := GetChar(p); + CASE cond OF + |0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END + |4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END + |1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END + |3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END + ELSE + END; + INC(p) + END; + ParamCount := count - 1 +END ParamParse; + +PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER); +VAR i, j, len: INTEGER; c: CHAR; +BEGIN + j := 0; + IF n <= ParamCount THEN + len := LEN(str) - 1; + i := Params[n, 0]; + WHILE (j < len) & (i <= Params[n, 1]) DO + c := GetChar(i); + IF c # 22X THEN + str[j] := c; + INC(j) + END; + INC(i) + END + END; + str[j] := 0X +END ParamStr; + +PROCEDURE GetMem*(n: INTEGER): INTEGER; + RETURN H.malloc(n) +END GetMem; + +PROCEDURE CloseF*(F: INTEGER); +BEGIN + H.CloseFile(F) +END CloseF; + +PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER; + RETURN H.FileRW(F, Buffer, Count, FALSE) +END Read; + +PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER; + RETURN H.FileRW(F, Buffer, Count, TRUE) +END Write; + +PROCEDURE FileSize*(F: INTEGER): INTEGER; + RETURN H.FileSize(F) +END FileSize; + +PROCEDURE CharC*(x: CHAR); +VAR str: ARRAY 2 OF CHAR; +BEGIN + str[0] := x; + str[1] := 0X; + H.OutString(str) +END CharC; + +PROCEDURE Int*(x: INTEGER); +VAR i: INTEGER; buf: ARRAY 11 OF INTEGER; +BEGIN + i := 0; + REPEAT + buf[i] := x MOD 10; + x := x DIV 10; + INC(i) + UNTIL x = 0; + REPEAT + DEC(i); + CharC(CHR(buf[i] + ORD("0"))) + UNTIL i = 0 +END Int; + +PROCEDURE Ln*; +BEGIN + CharC(0DX); + CharC(0AX) +END Ln; + +PROCEDURE OutString*(str: ARRAY OF CHAR); +BEGIN + H.OutString(str) +END OutString; + +PROCEDURE ErrMsg*(code: INTEGER); +VAR str: ARRAY 1024 OF CHAR; +BEGIN + ERRORS.ErrorMsg(code, str); + OutString("error: ("); Int(code); OutString(") "); OutString(str); Ln +END ErrMsg; + +PROCEDURE ErrMsgPos*(line, col, code: INTEGER); +VAR s: STRING; +BEGIN + ErrMsg(code); + OutString("file: "); OutString(FileName); Ln; + OutString("line: "); Int(line); Ln; + OutString("pos: "); Int(col); Ln; +END ErrMsgPos; + +PROCEDURE UnitLine*(newUnit, newLine: INTEGER); +BEGIN + Unit := newUnit; + Line := newLine +END UnitLine; + +PROCEDURE min*(a, b: INTEGER): INTEGER; +BEGIN + IF a > b THEN + a := b + END + RETURN a +END min; + +PROCEDURE Align*(n: INTEGER): INTEGER; + RETURN (4 - n MOD 4) MOD 4 +END Align; + +PROCEDURE CAP(x: CHAR): CHAR; +BEGIN + IF (x >= "a") & (x <= "z") THEN + x := CHR(ORD(x) - 32) + END + RETURN x +END CAP; + +PROCEDURE streq*(a, b: ARRAY OF CHAR): BOOLEAN; +VAR i: INTEGER; +BEGIN + i := -1; + REPEAT + INC(i) + UNTIL (CAP(a[i]) # CAP(b[i])) OR (a[i] = 0X) OR (b[i] = 0X) + RETURN a[i] = b[i] +END streq; + +PROCEDURE concat*(VAR L: STRING; R: STRING); +VAR i, n, pos: INTEGER; +BEGIN + n := LENGTH(R); + i := 0; + pos := LENGTH(L); + WHILE (i <= n) & (pos < LEN(L)) DO + L[pos] := R[i]; + INC(pos); + INC(i) + END +END concat; + +PROCEDURE GetStr*(this: LIST; str: STRING): STRCONST; +VAR res: STRCONST; +BEGIN + res := this.First(STRCONST); + WHILE (res # NIL) & (res.Str # str) DO + res := res.Next(STRCONST) + END + RETURN res +END GetStr; + +PROCEDURE Push*(this: LIST; item: ITEM); +BEGIN + IF this.Count = 0 THEN + this.First := item; + item.Prev := NIL + ELSE + this.Last.Next := item; + item.Prev := this.Last + END; + INC(this.Count); + this.Last := item; + item.Next := NIL +END Push; + +PROCEDURE Insert*(this: LIST; item, prev: ITEM); +BEGIN + IF prev # this.Last THEN + item.Next := prev.Next; + item.Prev := prev; + prev.Next := item; + item.Next.Prev := item; + INC(this.Count) + ELSE + Push(this, item) + END +END Insert; + +PROCEDURE Clear*(this: LIST); +BEGIN + this.First := NIL; + this.Last := NIL; + this.Count := 0 +END Clear; + +PROCEDURE Revers(VAR str: STRING); +VAR a, b: INTEGER; c: CHAR; +BEGIN + a := 0; + b := LENGTH(str) - 1; + WHILE a < b DO + c := str[a]; + str[a] := str[b]; + str[b] := c; + INC(a); + DEC(b) + END +END Revers; + +PROCEDURE Split*(FName: STRING; VAR Path, Name, Ext: STRING); +VAR i, j, k: INTEGER; +BEGIN + i := LENGTH(FName) - 1; + j := 0; + WHILE (i >= 0) & (FName[i] # Slash) DO + Name[j] := FName[i]; + DEC(i); + INC(j) + END; + Name[j] := 0X; + Revers(Name); + j := 0; + k := LENGTH(Name) - 1; + WHILE (k >= 0) & (Name[k] # ".") DO + Ext[j] := Name[k]; + DEC(k); + INC(j) + END; + IF k >= 0 THEN + Name[k] := 0X; + Ext[j] := "."; + INC(j) + ELSE + j := 0 + END; + Ext[j] := 0X; + Revers(Ext); + FOR j := 0 TO i DO + Path[j] := FName[j] + END; + Path[i + 1] := 0X +END Split; + +PROCEDURE LinuxParam; +VAR p, i, str: INTEGER; c: CHAR; +BEGIN + p := H.GetCommandLine(); + sys.GET(p, ParamCount); + sys.GET(p + 4, p); + FOR i := 0 TO ParamCount - 1 DO + sys.GET(p + i * 4, str); + Params[i, 0] := str; + REPEAT + sys.GET(str, c); + INC(str) + UNTIL c = 0X; + Params[i, 1] := str - 1 + END; + DEC(ParamCount) +END LinuxParam; + +PROCEDURE Time*; +VAR sec, dsec: INTEGER; +BEGIN + OutString("elapsed time "); + H.Time(sec, dsec); + sec := sec - H.sec; + dsec := dsec - H.dsec; + dsec := dsec + sec * 100; + Int(dsec DIV 100); CharC("."); + dsec := dsec MOD 100; + IF dsec < 10 THEN + Int(0) + END; + Int(dsec); OutString(" sec"); Ln +END Time; + +PROCEDURE HALT*(n: INTEGER); +BEGIN + Time; + H.ExitProcess(n) +END HALT; + +PROCEDURE MemErr*(err: BOOLEAN); +BEGIN + IF err THEN + ErrMsg(72); + HALT(1) + END +END MemErr; + +PROCEDURE CreateList*(): LIST; +VAR nov: LIST; +BEGIN + NEW(nov); + MemErr(nov = NIL) + RETURN nov +END CreateList; + +PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER; + RETURN H.CreateFile(FName) +END CreateF; + +PROCEDURE OpenF*(FName: ARRAY OF CHAR(*; Mode: INTEGER*)): INTEGER; + RETURN H.OpenFile(FName) +END OpenF; + +PROCEDURE Init; +VAR p: INTEGER; + + PROCEDURE last(VAR p: INTEGER); + BEGIN + WHILE GetChar(p) # 0X DO INC(p) END; + DEC(p) + END last; + +BEGIN + H.init; + IF OS = "WIN" THEN + ParamParse(0) + ELSIF OS = "KOS" THEN + ParamParse(1); + Params[0, 0] := H.GetName(); + Params[0, 1] := Params[0, 0]; + last(Params[0, 1]) + ELSIF OS = "LNX" THEN + LinuxParam + END +END Init; + +BEGIN + Init +END UTILS. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/X86.ob07 b/programs/develop/oberon07/Source/X86.ob07 new file mode 100644 index 0000000000..9d4b28cbb0 --- /dev/null +++ b/programs/develop/oberon07/Source/X86.ob07 @@ -0,0 +1,1986 @@ +(* + Copyright 2016 Anton Krotov + + This file is part of Compiler. + + Compiler 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. + + Compiler 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 Compiler. If not, see . +*) + +MODULE X86; + +IMPORT UTILS, sys := SYSTEM, SCAN, ELF; + +CONST + + ADIM* = 5; + + lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; + lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76; + + TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; + TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14; + + stABS* = 1; stODD* = 2; stLEN* = 3; stLSL* = 4; stASR* = 5; stROR* = 6; stFLOOR* = 7; + stFLT* = 8; stORD* = 9; stCHR* = 10; stLONG* = 11; stSHORT* = 12; stINC* = 13; + stDEC* = 14; stINCL* = 15; stEXCL* = 16; stCOPY* = 17; stNEW* = 18; stASSERT* = 19; + stPACK* = 20; stUNPK* = 21; stDISPOSE* = 22; stFABS* = 23; stINC1* = 24; + stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29; + stLENGTH* = 30; + + sysMOVE* = 108; + + JMP* = 0E9X; CALL = 0E8X; + JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX; + + JCMD = 1; LCMD = 2; GCMD = 3; OCMD = 4; ECMD = 5; + PUSHEAX = 6; PUSHECX = 7; PUSHEDX = 8; POPEAX = 9; POPECX = 10; POPEDX = 11; + ICMP1 = 13; ICMP2 = 14; + + defcall = 0; stdcall = 1; cdecl = 2; winapi = 3; + + _rset* = 0; _inset* = 1; _saverec* = 2; _length* = 3; _checktype* = 4; _strcmp* = 5; + _lstrcmp* = 6; _rstrcmp* = 7; _savearr* = 8; _newrec* = 9; _disprec* = 10; _arrayidx* = 11; + _arrayrot* = 12; _assrt* = 13; _strcopy* = 14; _arrayidx1* = 15; _init* = 16; _close* = 17; _halt* = 18; + ASSRT = 19; hInstance = 20; SELFNAME = 21; RTABLE = 22;LoadLibrary = 23; GetProcAddress = 24; + Exports = 25; szSTART = 26; START = 27; szversion = 28; _floor = 29; HALT = 30; + + FREGS = 8; + +TYPE + + ASMLINE* = POINTER TO RECORD (UTILS.rITEM) + cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN + END; + + TFLT = ARRAY 2 OF INTEGER; + + TIDX* = ARRAY ADIM OF INTEGER; + + SECTIONNAME = ARRAY 8 OF CHAR; + + SECTION = RECORD + name: SECTIONNAME; + size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: INTEGER + END; + + HEADER = RECORD + msdos: ARRAY 180 OF CHAR; + typecomp, seccount: sys.CARD16; + time, reserved1, reserved2: INTEGER; + PEoptsize, infflags, PEfile, compver: sys.CARD16; + codesize, datasize, initdatasize, startadr, + codeadr, rdataadr, loadadr, secalign, filealign, + oldestver, version, oldestverNT, reserved3, + filesize, headersize, dllcrc: INTEGER; + UI, reserved4: sys.CARD16; + stksize, stkalloc, heapsize, heapalloc, reserved5, structcount: INTEGER; + structs: ARRAY 16 OF RECORD adr, size: INTEGER END; + sections: ARRAY 3 OF SECTION + END; + + COFFHEADER = RECORD + Machine: sys.CARD16; + NumberOfSections: sys.CARD16; + TimeDateStamp, + PointerToSymbolTable, + NumberOfSymbols: INTEGER; + SizeOfOptionalHeader, + Characteristics: sys.CARD16; + text, data, bss: SECTION + END; + + KOSHEADER = RECORD + menuet01: ARRAY 8 OF CHAR; + ver, start, size, mem, sp, param, path: INTEGER + END; + + ETABLE = RECORD + reserved1, time, reserved2, dllnameoffset, firstnum, adrcount, + namecount, arradroffset, arrnameptroffset, arrnumoffset: INTEGER; + arradr, arrnameptr: ARRAY 10000H OF INTEGER; + arrnum: ARRAY 10000H OF sys.CARD16; + text: ARRAY 1000000 OF CHAR; + textlen, size: INTEGER + END; + + RELOC = RECORD + Page, Size: INTEGER; + reloc: ARRAY 1024 OF sys.CARD16 + END; + +VAR asmlist: UTILS.LIST; start: ASMLINE; dll, con, gui, kos, elf, obj: BOOLEAN; + Lcount, reccount, topstk: INTEGER; recarray: ARRAY 2048 OF INTEGER; current*: ASMLINE; + callstk: ARRAY 1024, 2 OF ASMLINE; OutFile: UTILS.STRING; + Code: ARRAY 4000000 OF CHAR; ccount: INTEGER; Data: ARRAY 1000000 OF CHAR; dcount: INTEGER; + Labels: ARRAY 200000 OF INTEGER; rdata: ARRAY 400H OF INTEGER; Header: HEADER; etable: ETABLE; + ExecName: UTILS.STRING; LoadAdr: INTEGER; Reloc: ARRAY 200000 OF CHAR; rcount: INTEGER; + RtlProc: ARRAY 20 OF INTEGER; OutFilePos: INTEGER; RelocSection: SECTION; + fpu*: INTEGER; isfpu: BOOLEAN; maxfpu: INTEGER; fpucmd: ASMLINE; + kosexp: ARRAY 65536 OF RECORD Name: SCAN.NODE; Adr, NameLabel: INTEGER END; kosexpcount: INTEGER; + +PROCEDURE AddRtlProc*(idx, proc: INTEGER); +BEGIN + RtlProc[idx] := proc +END AddRtlProc; + +PROCEDURE IntToCard16(i: INTEGER): sys.CARD16; +VAR w: sys.CARD16; +BEGIN + sys.GET(sys.ADR(i), w) + RETURN w +END IntToCard16; + +PROCEDURE CopyStr(VAR Dest: ARRAY OF CHAR; Source: ARRAY OF CHAR; VAR di: INTEGER; si: INTEGER); +BEGIN + DEC(di); + REPEAT + INC(di); + Dest[di] := Source[si]; + INC(si) + UNTIL Dest[di] = 0X +END CopyStr; + +PROCEDURE exch(VAR a, b: INTEGER); +VAR c: INTEGER; +BEGIN + c := a; + a := b; + b := c +END exch; + +PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER); +VAR L, R: INTEGER; + + PROCEDURE strle(s1, s2: INTEGER): BOOLEAN; + VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER; + BEGIN + i := 0; + CopyStr(S1, Text, i, s1); + i := 0; + CopyStr(S2, Text, i, s2) + RETURN S1 <= S2 + END strle; + +BEGIN + IF LB < RB THEN + L := LB; + R := RB; + REPEAT + WHILE (L < RB) & strle(NamePtr[L], NamePtr[LB]) DO + INC(L) + END; + WHILE (R > LB) & strle(NamePtr[LB], NamePtr[R]) DO + DEC(R) + END; + IF L < R THEN + exch(NamePtr[L], NamePtr[R]); + exch(Adr[L], Adr[R]) + END + UNTIL L >= R; + IF R > LB THEN + exch(NamePtr[LB], NamePtr[R]); + exch(Adr[LB], Adr[R]); + Sort(NamePtr, Adr, Text, LB, R - 1) + END; + Sort(NamePtr, Adr, Text, R + 1, RB) + END +END Sort; + +PROCEDURE PackExport(Name: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN + Sort(etable.arrnameptr, etable.arradr, etable.text, 0, etable.namecount - 1); + FOR i := 0 TO etable.namecount - 1 DO + etable.arrnum[i] := IntToCard16(i) + END; + etable.size := 40 + etable.adrcount * 4 + etable.namecount * 6; + etable.arradroffset := 40; + etable.arrnameptroffset := 40 + etable.adrcount * 4; + etable.arrnumoffset := etable.arrnameptroffset + etable.namecount * 4; + etable.dllnameoffset := etable.size + etable.textlen; + CopyStr(etable.text, Name, etable.textlen, 0); + INC(etable.textlen); + FOR i := 0 TO etable.namecount - 1 DO + etable.arrnameptr[i] := etable.arrnameptr[i] + etable.size + END; + etable.size := etable.size + etable.textlen +END PackExport; + +PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER); +BEGIN + IF dll THEN + etable.arradr[etable.adrcount] := Number; + INC(etable.adrcount); + etable.arrnameptr[etable.namecount] := etable.textlen; + INC(etable.namecount); + CopyStr(etable.text, Name.Name, etable.textlen, 0); + INC(etable.textlen) + ELSIF obj THEN + kosexp[kosexpcount].Name := Name; + kosexp[kosexpcount].Adr := Number; + kosexp[kosexpcount].NameLabel := NameLabel; + INC(kosexpcount) + END +END ProcExport; + +PROCEDURE Err(code: INTEGER); +BEGIN + CASE code OF + |1: UTILS.ErrMsg(67); UTILS.OutString(OutFile) + |2: UTILS.ErrMsg(69); UTILS.OutString(OutFile) + ELSE + END; + UTILS.Ln; + UTILS.HALT(1) +END Err; + +PROCEDURE Align*(n, m: INTEGER): INTEGER; + RETURN n + (m - n MOD m) MOD m +END Align; + +PROCEDURE PutReloc(R: RELOC); +VAR i: INTEGER; +BEGIN + sys.PUT(sys.ADR(Reloc[rcount]), R.Page); + INC(rcount, 4); + sys.PUT(sys.ADR(Reloc[rcount]), R.Size); + INC(rcount, 4); + FOR i := 0 TO ASR(R.Size - 8, 1) - 1 DO + sys.PUT(sys.ADR(Reloc[rcount]), R.reloc[i]); + INC(rcount, 2) + END +END PutReloc; + +PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING); +VAR i, x, n: INTEGER; +BEGIN + n := LEN(chars) - 1; + i := 0; + WHILE (i < n) & (chars[i] # 0X) DO + x := SCAN.hex(chars[i]) * 16 + SCAN.hex(chars[i + 1]); + sys.PUT(adr, CHR(x)); + INC(adr); + INC(i, 2) + END +END InitArray; + +PROCEDURE WriteF(F, A, N: INTEGER); +BEGIN + IF UTILS.Write(F, A, N) # N THEN + Err(2) + END +END WriteF; + +PROCEDURE Write(A, N: INTEGER); +BEGIN + sys.MOVE(A, OutFilePos, N); + OutFilePos := OutFilePos + N +END Write; + +PROCEDURE Fill(n: INTEGER; c: CHAR); +VAR i: INTEGER; +BEGIN + FOR i := 1 TO n DO + Write(sys.ADR(c), 1) + END +END Fill; + +PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER); +BEGIN + Section.name := name; + Section.size := size; + Section.adr := adr; + Section.sizealign := sizealign; + Section.OAPfile := OAPfile; + Section.attrflags := attrflags; +END SetSection; + +PROCEDURE WritePE(FName: ARRAY OF CHAR; stksize, codesize, datasize, rdatasize, gsize: INTEGER); +CONST textattr = 60000020H; rdataattr = 40000040H; dataattr = 0C0000040H; relocattr = 42000040H; +VAR i, F, adr, acodesize, compver, version, stkalloc, heapsize, heapalloc, filesize, filebuf: INTEGER; + cur: ASMLINE; +BEGIN + + compver := 0; + version := 0; + stkalloc := stksize; + heapsize := 100000H; + heapalloc := 100000H; + acodesize := Align(codesize, 1000H) + 1000H; + adr := sys.ADR(rdata); + filesize := acodesize + Align(rdatasize, 1000H) + Align(datasize, 1000H) + Align(rcount, 1000H); + + InitArray(adr, "5000000040000000000000003400000000000000000000006200000000000000"); + InitArray(adr, "0000000000000000000000000000000000000000500000004000000000000000"); + InitArray(adr, "A4014C6F61644C6962726172794100001F0147657450726F6341646472657373"); + InitArray(adr, "00006B65726E656C33322E646C6C0000"); + + rdata[ 0] := acodesize + 50H; + rdata[ 1] := acodesize + 40H; + rdata[ 3] := acodesize + 34H; + rdata[ 6] := acodesize + 62H; + rdata[ 7] := acodesize; + rdata[13] := acodesize + 50H; + rdata[14] := acodesize + 40H; + + adr := sys.ADR(Header.msdos); + InitArray(adr, "4D5A90000300000004000000FFFF0000B8000000000000004000000000000000"); + InitArray(adr, "00000000000000000000000000000000000000000000000000000000B0000000"); + InitArray(adr, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F"); + InitArray(adr, "742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000"); + InitArray(adr, "5DCF9F8719AEF1D419AEF1D419AEF1D497B1E2D413AEF1D4E58EE3D418AEF1D4"); + InitArray(adr, "5269636819AEF1D4000000000000000050450000"); + Header.typecomp := IntToCard16(014CH); + IF dll THEN + Header.seccount := IntToCard16(0004H); + Header.infflags := IntToCard16(210EH) + ELSE + Header.seccount := IntToCard16(0003H); + Header.infflags := IntToCard16(010FH) + END; + Header.time := UTILS.Date; + Header.PEoptsize := IntToCard16(00E0H); + Header.PEfile := IntToCard16(010BH); + Header.compver := IntToCard16(compver); + Header.codesize := Align(codesize, 200H); + Header.datasize := Align(datasize + gsize, 200H) + Align(rdatasize, 200H) + Align(rcount, 200H); + Header.startadr := 1000H; + Header.codeadr := 1000H; + Header.rdataadr := Header.codeadr + Align(codesize, 1000H); + Header.loadadr := LoadAdr; + Header.secalign := 1000H; + Header.filealign := 0200H; + Header.oldestver := 0004H; + Header.version := version; + Header.oldestverNT := 0004H; + Header.filesize := Align(codesize, 1000H) + Align(datasize + gsize, 1000H) + Align(rdatasize, 1000H) + Align(rcount, 1000H) + 1000H; + Header.headersize := 0400H; + Header.UI := IntToCard16(ORD(con) + 2); + Header.stksize := stksize; + Header.stkalloc := stkalloc; + Header.heapsize := heapsize; + Header.heapalloc := heapalloc; + Header.structcount := 10H; + IF dll THEN + Header.structs[0].adr := Header.rdataadr + 0DAH; + Header.structs[0].size := etable.size + END; + + Header.structs[1].adr := Header.rdataadr + 0CH; + Header.structs[1].size := 28H; + Header.structs[12].adr := Header.rdataadr; + Header.structs[12].size := 0CH; + + SetSection(Header.sections[0], ".text", codesize, 1000H, Align(codesize, 200H), 400H, textattr); + SetSection(Header.sections[1], ".rdata", rdatasize, Align(codesize, 1000H) + 1000H, Align(rdatasize, 200H), + Align(codesize, 200H) + 400H, rdataattr); + SetSection(Header.sections[2], ".data", datasize + gsize, Align(codesize, 1000H) + Align(rdatasize, 1000H) + 1000H, + Align(datasize, 200H), Align(codesize, 200H) + Align(rdatasize, 200H) + 400H, dataattr); + + IF dll THEN + SetSection(RelocSection, ".reloc", rcount, Header.sections[2].adr + Align(datasize + gsize, 1000H), Align(rcount, 200H), + Header.sections[2].OAPfile + Align(datasize, 200H), relocattr); + Header.structs[5].adr := RelocSection.adr; + Header.structs[5].size := rcount + END; + + F := UTILS.CreateF(FName); + IF F = 0 THEN + Err(1) + END; + OutFilePos := UTILS.GetMem(filesize); + filebuf := OutFilePos; + UTILS.MemErr(OutFilePos = 0); + + Write(sys.ADR(Header), sys.SIZE(HEADER)); + IF dll THEN + Write(sys.ADR(RelocSection), sys.SIZE(SECTION)); + Fill(Align(sys.SIZE(HEADER) + sys.SIZE(SECTION), 200H) - (sys.SIZE(HEADER) + sys.SIZE(SECTION)), 0X) + ELSE + Fill(Align(sys.SIZE(HEADER), 200H) - sys.SIZE(HEADER), 0X) + END; + + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + Write(sys.ADR(Code[cur.cmd]), cur.clen); + cur := cur.Next(ASMLINE) + END; + Fill(Align(codesize, 200H) - codesize, 0X); + Write(sys.ADR(rdata), 0DAH); + IF dll THEN + etable.time := Header.time; + Write(sys.ADR(etable), 40); + Write(sys.ADR(etable.arradr), etable.adrcount * 4); + Write(sys.ADR(etable.arrnameptr), etable.namecount * 4); + Write(sys.ADR(etable.arrnum), etable.namecount * 2); + Write(sys.ADR(etable.text), etable.textlen) + END; + Fill(Align(rdatasize, 200H) - rdatasize, 0X); + Write(sys.ADR(Data), datasize); + Fill(Align(datasize, 200H) - datasize, 0X); + IF dll THEN + Write(sys.ADR(Reloc), rcount); + Fill(Align(rcount, 200H) - rcount, 0X) + END; + WriteF(F, filebuf, OutFilePos - filebuf); + UTILS.CloseF(F) +END WritePE; + +PROCEDURE New; +VAR nov: ASMLINE; +BEGIN + NEW(nov); + UTILS.MemErr(nov = NIL); + nov.cmd := ccount; + UTILS.Insert(asmlist, nov, current); + current := current.Next(ASMLINE) +END New; + +PROCEDURE Empty(varadr: INTEGER); +BEGIN + New; + current.clen := 0; + current.tcmd := ECMD; + current.varadr := varadr +END Empty; + +PROCEDURE OutByte(byte: INTEGER); +BEGIN + New; + current.clen := 1; + Code[ccount] := CHR(byte); + INC(ccount) +END OutByte; + +PROCEDURE OutInt(int: INTEGER); +BEGIN + New; + current.clen := 4; + sys.PUT(sys.ADR(Code[ccount]), int); + INC(ccount, 4) +END OutInt; + +PROCEDURE PushEAX; +BEGIN + OutByte(50H); + current.tcmd := PUSHEAX +END PushEAX; + +PROCEDURE PushECX; +BEGIN + OutByte(51H); + current.tcmd := PUSHECX +END PushECX; + +PROCEDURE PushEDX; +BEGIN + OutByte(52H); + current.tcmd := PUSHEDX +END PushEDX; + +PROCEDURE PopEAX; +BEGIN + OutByte(58H); + current.tcmd := POPEAX +END PopEAX; + +PROCEDURE PopECX; +BEGIN + OutByte(59H); + current.tcmd := POPECX +END PopECX; + +PROCEDURE PopEDX; +BEGIN + OutByte(5AH); + current.tcmd := POPEDX +END PopEDX; + +PROCEDURE OutCode(cmd: UTILS.STRING); +VAR a, b: INTEGER; +BEGIN + New; + a := sys.ADR(Code[ccount]); + b := a; + InitArray(a, cmd); + ccount := a - b + ccount; + current.clen := a - b +END OutCode; + +PROCEDURE Del*(last: ASMLINE); +BEGIN + last.Next := current.Next; + IF current = asmlist.Last THEN + asmlist.Last := last + END; + current := last +END Del; + +PROCEDURE NewLabel*(): INTEGER; +BEGIN + INC(Lcount) + RETURN Lcount +END NewLabel; + +PROCEDURE PushCall*(asmline: ASMLINE); +BEGIN + New; + callstk[topstk][0] := asmline; + callstk[topstk][1] := current; + INC(topstk) +END PushCall; + +PROCEDURE Param*; +BEGIN + current := callstk[topstk - 1][0] +END Param; + +PROCEDURE EndCall*; +BEGIN + current := callstk[topstk - 1][1]; + DEC(topstk) +END EndCall; + +PROCEDURE Init*(UI: INTEGER); +VAR nov: ASMLINE; +BEGIN + dcount := 4; + dll := UI = 1; + gui := UI = 2; + con := UI = 3; + kos := UI = 4; + elf := UI = 5; + obj := UI = 6; + Lcount := HALT; + asmlist := UTILS.CreateList(); + NEW(nov); + UTILS.MemErr(nov = NIL); + UTILS.Push(asmlist, nov); + current := nov; +END Init; + +PROCEDURE datastr(str: UTILS.STRING); +VAR i, n: INTEGER; +BEGIN + i := 0; + n := LEN(str); + WHILE (i < n) & (str[i] # 0X) DO + Data[dcount] := str[i]; + INC(dcount); + INC(i) + END; + Data[dcount] := 0X; + INC(dcount) +END datastr; + +PROCEDURE dataint(n: INTEGER); +BEGIN + sys.PUT(sys.ADR(Data[dcount]), n); + INC(dcount, 4) +END dataint; + +PROCEDURE jmp*(jamp: CHAR; label: INTEGER); +VAR n: INTEGER; +BEGIN + New; + CASE jamp OF + |JMP, CALL: + n := 5 + |JE, JLE, JGE, JG, JL, JNE: + Code[ccount] := 0FX; + INC(ccount); + n := 6 + ELSE + END; + current.clen := n; + Code[ccount] := jamp; + INC(ccount); + current.codeadr := sys.ADR(Code[ccount]); + current.varadr := sys.ADR(Labels[label]); + current.tcmd := JCMD; + current.short := TRUE; + INC(ccount, 4) +END jmp; + +PROCEDURE jmplong(jamp: CHAR; label: INTEGER); +BEGIN + jmp(jamp, label); + current.short := FALSE +END jmplong; + +PROCEDURE Label*(label: INTEGER); +BEGIN + New; + current.varadr := sys.ADR(Labels[label]); + current.tcmd := LCMD +END Label; + +PROCEDURE CmdN(Number: INTEGER); +BEGIN + New; + current.clen := 4; + current.codeadr := sys.ADR(Code[ccount]); + current.varadr := sys.ADR(Labels[Number]); + current.tcmd := OCMD; + INC(ccount, 4) +END CmdN; + +PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER); +BEGIN + IF (n <= 127) & (n >= -128) THEN + OutCode(bytecode); + OutByte(n) + ELSE + OutCode(intcode); + OutInt(n) + END +END IntByte; + +PROCEDURE DropFpu*(long: BOOLEAN); +BEGIN + IF long THEN + OutCode("83EC08DD1C24") + ELSE + OutCode("83EC04D91C24") + END; + DEC(fpu) +END DropFpu; + +PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER); +BEGIN + IF callconv = cdecl THEN + OutCode("81C4"); + OutInt(parsize) + END; + IF func THEN + IF float THEN + OutCode("83EC08DD1C24") + ELSE + PushEAX + END + END +END AfterRet; + +PROCEDURE FpuSave(local: INTEGER); +VAR i: INTEGER; +BEGIN + IF fpu > maxfpu THEN + maxfpu := fpu + END; + FOR i := 1 TO fpu DO + IntByte("DD5D", "DD9D", -local - i * 8) + END +END FpuSave; + +PROCEDURE Incfpu; +BEGIN + IF fpu >= FREGS THEN + UTILS.ErrMsgPos(SCAN.coord.line, SCAN.coord.col, 97); + UTILS.HALT(1) + END; + INC(fpu); + isfpu := TRUE +END Incfpu; + +PROCEDURE FpuLoad(local: INTEGER; float: BOOLEAN); +VAR i: INTEGER; +BEGIN + FOR i := fpu TO 1 BY -1 DO + IntByte("DD45", "DD85", -local - i * 8) + END; + IF float THEN + Incfpu; + OutCode("DD042483C408") + END +END FpuLoad; + +PROCEDURE Call*(proc: INTEGER; func, float: BOOLEAN; callconv, ccall, bases, level, parsize, local: INTEGER); +VAR i: INTEGER; +BEGIN + IF ccall # 0 THEN + FOR i := level TO level - bases + ORD(ccall = 1) + 1 BY -1 DO + IntByte("FF75", "FFB5", 4 * i + 4) + END; + IF ccall = 1 THEN + OutByte(55H) + END + END; + FpuSave(local); + jmplong(CALL, proc); + AfterRet(func, float, callconv, parsize); + FpuLoad(local, func & float) +END Call; + +PROCEDURE CallRTL(Proc: INTEGER); +BEGIN + New; + current.clen := 5; + Code[ccount] := CALL; + INC(ccount); + current.codeadr := sys.ADR(Code[ccount]); + current.varadr := sys.ADR(RtlProc[Proc]); + current.tcmd := JCMD; + INC(ccount, 4) +END CallRTL; + +PROCEDURE PushInt*(n: INTEGER); +BEGIN + OutByte(68H); + CmdN(n) +END PushInt; + +PROCEDURE Prolog*(exename: UTILS.STRING); +BEGIN + ExecName := exename; + Labels[hInstance] := -dcount; + dataint(0); + Labels[SELFNAME] := -dcount; + datastr(exename); + Label(START); + IF dll THEN + OutCode("558BEC837D0C007507"); + CallRTL(_close); + OutCode("EB06837D0C017409B801000000C9C20C00") + ELSIF obj THEN + OutCode("558BEC") + END; + start := asmlist.Last(ASMLINE) +END Prolog; + +PROCEDURE AddRec*(base: INTEGER); +BEGIN + INC(reccount); + recarray[reccount] := base +END AddRec; + +PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER; +VAR cur: ASMLINE; c: INTEGER; +BEGIN + c := ORD(Code[current.Prev.Prev(ASMLINE).cmd]); + IF inv THEN + IF ODD(c) THEN + DEC(c) + ELSE + INC(c) + END + END; + cur := current; + REPEAT + cur.tcmd := 0; + cur.clen := 0; + cur := cur.Prev(ASMLINE) + UNTIL cur.tcmd = ICMP1; + cur.tcmd := 0; + cur.clen := 0 + RETURN c - 16 +END CmpOpt; + +PROCEDURE ifwh*(L: INTEGER); +VAR c: INTEGER; +BEGIN + IF current.Prev(ASMLINE).tcmd = ICMP2 THEN + c := CmpOpt(TRUE); + OutCode("5A583BC2"); + jmp(CHR(c), L) + ELSE + PopECX; + OutCode("85C9"); + jmp(JE, L) + END +END ifwh; + +PROCEDURE PushConst*(Number: INTEGER); +BEGIN + IntByte("6A", "68", Number); + current.Prev(ASMLINE).varadr := Number +END PushConst; + +PROCEDURE IfWhile*(L: INTEGER; orop: BOOLEAN); +VAR c, L1: INTEGER; +BEGIN + L1 := NewLabel(); + IF current.Prev(ASMLINE).tcmd = ICMP2 THEN + c := CmpOpt(orop); + OutCode("5A583BC2"); + jmp(CHR(c), L1); + PushConst(ORD(orop)) + ELSE + PopECX; + OutCode("85C9"); + IF orop THEN + jmp(JE, L1) + ELSE + jmp(JNE, L1) + END; + PushECX + END; + jmp(JMP, L); + Label(L1) +END IfWhile; + +PROCEDURE newrec*; +BEGIN + CallRTL(_newrec) +END newrec; + +PROCEDURE disprec*; +BEGIN + CallRTL(_disprec) +END disprec; + +PROCEDURE String*(Number, Len: INTEGER; str: UTILS.STRING); +BEGIN + Labels[Number] := -dcount; + IF Len > 1 THEN + datastr(str) + ELSIF Len = 1 THEN + dataint(ORD(str[0])) + ELSE + dataint(0) + END +END String; + +PROCEDURE InsertFpuInit; +VAR t: ASMLINE; +BEGIN + IF isfpu THEN + t := current; + current := fpucmd; + IF maxfpu > 0 THEN + OutCode("83EC"); + OutByte(maxfpu * 8) + END; + OutCode("DBE3"); + current := t + END +END InsertFpuInit; + +PROCEDURE ProcBeg*(Number, Local: INTEGER; Module: BOOLEAN); +VAR i: INTEGER; +BEGIN + IF Module THEN + OutCode("EB0C"); + Label(Number + 3); + PushInt(Number + 2); + jmplong(JMP, HALT); + Label(Number + 1) + ELSE + Label(Number) + END; + OutCode("558BEC"); + IF Local > 12 THEN + IntByte("83EC", "81EC", Local); + OutCode("8BD733C08BFCB9"); + OutInt(ASR(Local, 2)); + OutCode("9CFCF3AB8BFA9D") + ELSE + FOR i := 4 TO Local BY 4 DO + OutCode("6A00") + END + END; + fpucmd := current; + fpu := 0; + maxfpu := 0; + isfpu := FALSE +END ProcBeg; + +PROCEDURE Leave*; +BEGIN + OutByte(0C9H); + InsertFpuInit +END Leave; + +PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN); +BEGIN + IF func & ~float THEN + PopEAX + END; + OutByte(0C9H); + IF Param = 0 THEN + OutByte(0C3H) + ELSE + OutByte(0C2H); + OutByte(Param MOD 256); + OutByte(ASR(Param, 8)) + END; + InsertFpuInit +END ProcEnd; + +PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER); +BEGIN + String(Number + 2, LENGTH(Name), Name); + jmplong(JMP, Number + 1) +END Module; + +PROCEDURE Asm*(s: UTILS.STRING); +BEGIN + OutCode(s) +END Asm; + +PROCEDURE GlobalAdr*(offset: INTEGER); +BEGIN + OutByte(0BAH); + OutInt(offset); + current.codeadr := sys.ADR(Code[ccount - 4]); + current.tcmd := GCMD; + PushEDX +END GlobalAdr; + +PROCEDURE Mono*(Number: INTEGER); +BEGIN + PopEDX; + PushInt(Number) +END Mono; + +PROCEDURE StrMono*; +BEGIN + PopEDX; + OutCode("6A02"); + PushEDX +END StrMono; + +PROCEDURE Not*; +BEGIN + PopECX; + OutCode("85C90F94C1"); + PushECX +END Not; + +PROCEDURE NegSet*; +BEGIN + OutCode("F71424") +END NegSet; + +PROCEDURE Int*(Op: INTEGER); +BEGIN + PopEDX; + CASE Op OF + |lxPlus: OutCode("011424") + |lxMinus: OutCode("291424") + |lxMult: OutCode("58F7EA"); PushEAX + ELSE + END +END Int; + +PROCEDURE Set*(Op: INTEGER); +BEGIN + PopEDX; + OutByte(58H); + CASE Op OF + |lxPlus: OutByte(0BH) + |lxMinus: OutCode("F7D223") + |lxMult: OutByte(23H) + |lxSlash: OutByte(33H) + ELSE + END; + OutByte(0C2H); + PushEAX +END Set; + +PROCEDURE Setfpu*(newfpu: INTEGER); +BEGIN + fpu := newfpu +END Setfpu; + +PROCEDURE PushFlt*(x: LONGREAL); +VAR f: TFLT; L: INTEGER; +BEGIN + sys.PUT(sys.ADR(f), x); + Incfpu; + IF x = 0.0D0 THEN + OutCode("D9EE") + ELSIF x = 1.0D0 THEN + OutCode("D9E8") + ELSE + L := NewLabel(); + Labels[L] := -dcount; + dataint(f[0]); + dataint(f[1]); + OutByte(0BAH); + CmdN(L); + OutCode("DD02") + END +END PushFlt; + +PROCEDURE farith*(op: INTEGER); +VAR n: INTEGER; +BEGIN + OutByte(0DEH); + CASE op OF + |lxPlus: n := 0C1H + |lxMinus: n := 0E9H + |lxMult: n := 0C9H + |lxSlash: n := 0F9H + ELSE + END; + OutByte(n); + DEC(fpu) +END farith; + +PROCEDURE fcmp*(Op: INTEGER); +VAR n: INTEGER; +BEGIN + OutCode("33C9DED9DFE09E0F"); + CASE Op OF + |lxEQ: n := 94H + |lxNE: n := 95H + |lxLT: n := 97H + |lxGT: n := 92H + |lxLE: n := 93H + |lxGE: n := 96H + ELSE + END; + DEC(fpu, 2); + OutByte(n); + OutByte(0C1H); + PushECX +END fcmp; + +PROCEDURE fneg*; +BEGIN + OutCode("D9E0") +END fneg; + +PROCEDURE OnError*(n: INTEGER); +BEGIN + OutByte(68H); + OutInt(LSL(UTILS.Line, 4) + n); + jmplong(JMP, UTILS.Unit + 3) +END OnError; + +PROCEDURE idivmod*(opmod: BOOLEAN); +BEGIN + PopECX; + IF opmod THEN + OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A") + ELSE + OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A") + END; + OnError(8) +END idivmod; + +PROCEDURE rset*; +BEGIN + CallRTL(_rset); + PushEAX +END rset; + +PROCEDURE inset*; +BEGIN + CallRTL(_inset); + PushEAX +END inset; + +PROCEDURE Dup*; +BEGIN + PopEDX; + PushEDX; + PushEDX +END Dup; + +PROCEDURE Inclusion*(Op: INTEGER); +BEGIN + PopEDX; + PopEAX; + IF Op = lxLE THEN + PushEDX + ELSE + PushEAX + END; + OutCode("0BC25933C8E3046A00EB026A01") +END Inclusion; + +PROCEDURE NegInt*; +BEGIN + OutCode("F71C24") +END NegInt; + +PROCEDURE CmpInt*(Op: INTEGER); +VAR n: INTEGER; +BEGIN + OutCode("33C95A583BC20F"); current.tcmd := ICMP1; + CASE Op OF + |lxEQ: n := 94H + |lxNE: n := 95H + |lxLT: n := 9CH + |lxGT: n := 9FH + |lxLE: n := 9EH + |lxGE: n := 9DH + ELSE + END; + OutByte(n); + OutByte(0C1H); current.tcmd := ICMP2; + PushECX; +END CmpInt; + +PROCEDURE CallVar*(func, float: BOOLEAN; callconv, parsize, local: INTEGER); +BEGIN + PopEDX; + OutCode("8B1285D2750A"); + OnError(2); + FpuSave(local); + OutCode("FFD2"); + AfterRet(func, float, callconv, parsize); + FpuLoad(local, func & float) +END CallVar; + +PROCEDURE LocalAdr*(offset, bases: INTEGER); +BEGIN + IF bases = 0 THEN + Empty(offset); + OutCode("8BD5") + ELSE + IntByte("8B55", "8B95", 4 * bases + 4) + END; + IntByte("83C2", "81C2", offset); + PushEDX; + IF bases = 0 THEN + Empty(offset) + END +END LocalAdr; + +PROCEDURE Field*(offset: INTEGER); +BEGIN + IF offset # 0 THEN + IntByte("830424", "810424", offset) + END +END Field; + +PROCEDURE DerefType*(n: INTEGER); +BEGIN + IntByte("8B5424", "8B9424", n); + OutCode("FF72FC") +END DerefType; + +PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN); +BEGIN + IF Check THEN + PopEAX; + OutCode("85C074"); + IF T <= 127 THEN + OutByte(9) + ELSE + OutByte(12) + END; + PushEAX + END; + PushConst(T); + PushEAX; + CallRTL(_checktype); + IF Check THEN + PushEAX + ELSE + OutCode("85C0750A"); + OnError(3) + END +END Guard; + +PROCEDURE StProc*(proc: INTEGER); +BEGIN + CASE proc OF + |stINC: PopEDX; OutCode("590111") + |stDEC: PopEDX; OutCode("592911") + |stINC1: PopEDX; OutCode("FF02") + |stDEC1: PopEDX; OutCode("FF0A") + |stINCL: PopEDX; OutCode("580910") + |stEXCL: PopEDX; OutCode("582110") + |stPACK: OutCode("DB04245A5ADD02D9FDDD1A"); isfpu := TRUE + |stPACK1: OutCode("DB04245A5AD902D9FDD91A"); isfpu := TRUE + |stUNPK: PopEDX; OutCode("59DD01D9F4DD19DB1A"); isfpu := TRUE + |stUNPK1: PopEDX; OutCode("59D901D9F4D919DB1A"); isfpu := TRUE + |stCOPY: CallRTL(_strcopy) + |sysMOVE: CallRTL(_savearr) + ELSE + END +END StProc; + +PROCEDURE Assert*(proc, assrt: INTEGER); +BEGIN + PopEDX; + OutCode("85D2751368"); + OutInt(UTILS.Line * 16 + 1); + PushInt(UTILS.Unit + 2); + IF proc = stASSERT THEN + OutCode("6A026A") + ELSE + OutCode("6A016A") + END; + OutByte(assrt); + jmplong(JMP, ASSRT) +END Assert; + +PROCEDURE StFunc*(func: INTEGER); +BEGIN + CASE func OF + |stABS: PopEDX; OutCode("85D27D02F7DA"); PushEDX + |stFABS: OutCode("D9E1") + |stFLT: OutCode("DB0424"); PopEAX; Incfpu; + |stFLOOR: jmplong(CALL, _floor); PushEAX; DEC(fpu) + |stODD: OutCode("83242401") + |stROR: PopECX; OutCode("58D3C8"); PushEAX + |stASR: PopECX; OutCode("58D3F8"); PushEAX + |stLSL: PopECX; OutCode("58D3E0"); PushEAX + |stLSR: PopECX; OutCode("58D3E8"); PushEAX + |stORD: PopEDX; OutCode("85D274036A015A"); PushEDX + |stLENGTH: CallRTL(_length); PushEAX + ELSE + END +END StFunc; + +PROCEDURE Load*(T: INTEGER); +VAR lastcmd: ASMLINE; offset: INTEGER; + + PROCEDURE del; + BEGIN + lastcmd.tcmd := 0; + offset := lastcmd.varadr; + lastcmd := lastcmd.Prev(ASMLINE); + WHILE lastcmd.tcmd # ECMD DO + lastcmd.clen := 0; + lastcmd.tcmd := 0; + lastcmd := lastcmd.Prev(ASMLINE) + END; + lastcmd.tcmd := 0 + END del; + +BEGIN + lastcmd := current; + CASE T OF + |TINTEGER, TSET, TPOINTER, TPROC: + IF lastcmd.tcmd = ECMD THEN + del; + IntByte("8B55", "8B95", offset); + PushEDX + ELSE + PopEDX; + OutCode("FF32") + END + |TCHAR, TBOOLEAN: + IF lastcmd.tcmd = ECMD THEN + del; + OutCode("33D28A"); + IntByte("55", "95", offset); + PushEDX + ELSE + PopEDX; + OutCode("33C98A0A"); + PushECX + END + |TLONGREAL: + IF lastcmd.tcmd = ECMD THEN + del; + IntByte("DD45", "DD85", offset) + ELSE + PopEDX; + OutCode("DD02") + END; + Incfpu + |TREAL: + IF lastcmd.tcmd = ECMD THEN + del; + IntByte("D945", "D985", offset) + ELSE + PopEDX; + OutCode("D902") + END; + Incfpu + |TCARD16: + IF lastcmd.tcmd = ECMD THEN + del; + OutCode("33D2668B"); + IntByte("55", "95", offset); + PushEDX + ELSE + PopEDX; + OutCode("33C9668B0A"); + PushECX + END + ELSE + END +END Load; + +PROCEDURE Save*(T: INTEGER); +BEGIN + CASE T OF + |TINTEGER, TSET, TPOINTER, TPROC: + PopEDX; + OutCode("588910") + |TCHAR, TSTRING, TBOOLEAN: + PopEDX; + OutCode("588810") + |TCARD16: + PopEDX; + OutCode("58668910") + |TLONGREAL: + PopEDX; + OutCode("DD1A"); + DEC(fpu) + |TREAL: + PopEDX; + OutCode("D91A"); + DEC(fpu) + |TRECORD: + CallRTL(_saverec); + OutCode("85C0750A"); + OnError(4) + |TARRAY: + CallRTL(_savearr) + ELSE + END +END Save; + +PROCEDURE OpenArray*(A: TIDX; n: INTEGER); +VAR i: INTEGER; +BEGIN + PopEDX; + FOR i := n - 1 TO 0 BY -1 DO + PushConst(A[i]) + END; + PushEDX +END OpenArray; + +PROCEDURE OpenIdx*(n: INTEGER); +BEGIN + OutByte(54H); + IF n > 1 THEN + PushConst(n); + CallRTL(_arrayidx) + ELSE + CallRTL(_arrayidx1) + END; + PopEDX; + OutCode("85D2750A"); + OnError(5); + PushEDX; +END OpenIdx; + +PROCEDURE FixIdx*(len, size: INTEGER); +BEGIN + PopEDX; + IntByte("5983FA", "5981FA", len); + OutCode("720A"); + OnError(5); + IF size > 1 THEN + IntByte("6BD2", "69D2", size) + END; + OutCode("03D1"); + PushEDX +END FixIdx; + +PROCEDURE Idx*; +BEGIN + PopEDX; + PopECX; + OutCode("03D1"); + PushEDX +END Idx; + +PROCEDURE DupLoadCheck*; +BEGIN + PopEDX; + OutCode("528B125285D2750A"); + OnError(6) +END DupLoadCheck; + +PROCEDURE DupLoad*; +BEGIN + PopEDX; + OutCode("528B12"); + PushEDX; +END DupLoad; + +PROCEDURE CheckNIL*; +BEGIN + PopEDX; + OutCode("85D2750A"); + OnError(6); + PushEDX; +END CheckNIL; + +PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER); +VAR i: INTEGER; +BEGIN + FOR i := n - 1 TO 0 BY -1 DO + PushConst(A[i]) + END; + OutByte(54H); + PushConst(n); + PushConst(m); + CallRTL(_arrayrot) +END ExtArray; + +PROCEDURE ADR*(dim: INTEGER); +BEGIN + IF dim > 0 THEN + PopEDX; + OutCode("83C4"); + OutByte(dim * 4); + PushEDX + END +END ADR; + +PROCEDURE Len*(dim: INTEGER); +BEGIN + PopEDX; + IF dim < 0 THEN + PushConst(-dim) + ELSIF dim > 1 THEN + PopEDX; + OutCode("83C4"); + OutByte((dim - 1) * 4); + PushEDX + END +END Len; + +PROCEDURE For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER); +BEGIN + LEnd := NewLabel(); + LBeg := NewLabel(); + Label(LBeg); + OutCode("8B14248B4424043910"); + IF inc THEN + jmp(JG, LEnd) + ELSE + jmp(JL, LEnd) + END +END For; + +PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER); +BEGIN + OutCode("8B542404"); + IF step = 1 THEN + OutCode("FF02") + ELSIF step = -1 THEN + OutCode("FF0A") + ELSE + IntByte("8302", "8102", step) + END; + jmp(JMP, LBeg); + Label(LEnd); + OutCode("83C408") +END NextFor; + +PROCEDURE CaseLabel*(a, b, LBeg: INTEGER); +VAR L: INTEGER; +BEGIN + L := NewLabel(); + IntByte("83FA", "81FA", a); + IF a = b THEN + jmp(JNE, L) + ELSE + jmp(JL, L); + IntByte("83FA", "81FA", b); + jmp(JG, L) + END; + jmp(JMP, LBeg); + Label(L) +END CaseLabel; + +PROCEDURE Drop*; +BEGIN + PopEDX +END Drop; + +PROCEDURE strcmp*(Op, LR: INTEGER); +BEGIN + CASE Op OF + |lxEQ: PushConst(0) + |lxNE: PushConst(1) + |lxLT: PushConst(2) + |lxGT: PushConst(3) + |lxLE: PushConst(4) + |lxGE: PushConst(5) + ELSE + END; + CASE LR OF + |-1: CallRTL(_lstrcmp) + | 0: CallRTL(_strcmp) + | 1: CallRTL(_rstrcmp) + ELSE + END; + PushEAX +END strcmp; + +PROCEDURE Optimization; +VAR cur: ASMLINE; flag: BOOLEAN; +BEGIN + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + flag := FALSE; + CASE cur.tcmd OF + |PUSHEAX: + flag := cur.Next(ASMLINE).tcmd = POPEAX + |PUSHECX: + flag := cur.Next(ASMLINE).tcmd = POPECX + |PUSHEDX: + flag := cur.Next(ASMLINE).tcmd = POPEDX + ELSE + END; + IF flag THEN + cur.clen := 0; + cur.tcmd := 0; + cur := cur.Next(ASMLINE); + cur.clen := 0; + cur.tcmd := 0 + END; + cur := cur.Next(ASMLINE) + END +END Optimization; + +PROCEDURE WriteKOS(FName: ARRAY OF CHAR; stk, size, datasize, gsize: INTEGER; obj: BOOLEAN); +CONST strsize = 2048; +VAR Header: KOSHEADER; F, i, filesize, filebuf, a, sec, adr, size2: INTEGER; cur: ASMLINE; + Coff: COFFHEADER; sym: ARRAY 18 * 4 OF CHAR; FileName: UTILS.STRING; +BEGIN + F := UTILS.CreateF(FName); + IF F <= 0 THEN + Err(1) + END; + OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H); + filebuf := OutFilePos; + UTILS.MemErr(OutFilePos = 0); + + IF ~obj THEN + Header.menuet01 := "MENUET01"; + Header.ver := 1; + Header.start := sys.SIZE(KOSHEADER); + Header.size := Align(size, 4) + datasize; + Header.mem := Header.size + stk + gsize + strsize * 2 + 1000H; + Header.sp := Header.size + gsize + stk; + Header.param := Header.sp; + Header.path := Header.param + strsize; + + Write(sys.ADR(Header), sys.SIZE(KOSHEADER)); + + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + Write(sys.ADR(Code[cur.cmd]), cur.clen); + cur := cur.Next(ASMLINE) + END; + Fill(Align(size, 4) - size, 0X); + Write(sys.ADR(Data), datasize); + WriteF(F, filebuf, OutFilePos - filebuf) + + ELSE + + size2 := size; + size := Align(size, 4) - sys.SIZE(KOSHEADER); + Coff.Machine := IntToCard16(014CH); + Coff.NumberOfSections := IntToCard16(3); + Coff.TimeDateStamp := UTILS.Date; + Coff.SizeOfOptionalHeader := IntToCard16(0); + Coff.Characteristics := IntToCard16(0184H); + + Coff.text.name := ".flat"; + Coff.text.size := 0; + Coff.text.adr := 0; + Coff.text.sizealign := size; + Coff.text.OAPfile := 8CH; + Coff.text.reserved6 := size + datasize + 8CH; + Coff.text.reserved7 := 0; + Coff.text.attrflags := 40300020H; + + Coff.data.name := ".data"; + Coff.data.size := 0; + Coff.data.adr := 0; + Coff.data.sizealign := datasize; + Coff.data.OAPfile := size + 8CH; + Coff.data.reserved6 := 0; + Coff.data.reserved7 := 0; + Coff.data.reserved8 := 0; + Coff.data.attrflags := 0C0300040H; + + Coff.bss.name := ".bss"; + Coff.bss.size := 0; + Coff.bss.adr := 0; + Coff.bss.sizealign := gsize; + Coff.bss.OAPfile := 0; + Coff.bss.reserved6 := 0; + Coff.bss.reserved7 := 0; + Coff.bss.reserved8 := 0; + Coff.bss.attrflags := 0C03000C0H; + + size := Align(size2, 4); + rcount := 0; + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + IF cur.tcmd IN {OCMD, GCMD} THEN + sys.GET(sys.ADR(Code[cur.cmd]), a); + IF a < size THEN + a := a - sys.SIZE(KOSHEADER); + sec := 1 + ELSIF a < size + datasize THEN + a := a - size; + sec := 2 + ELSE + a := a - size - datasize; + sec := 3 + END; + sys.PUT(sys.ADR(Code[cur.cmd]), a); + sys.PUT(sys.ADR(Reloc[rcount]), cur.adr - sys.SIZE(KOSHEADER)); + INC(rcount, 4); + sys.PUT(sys.ADR(Reloc[rcount]), sec); + INC(rcount, 4); + sys.PUT(sys.ADR(Reloc[rcount]), 06X); INC(rcount); + sys.PUT(sys.ADR(Reloc[rcount]), 00X); INC(rcount); + END; + Write(sys.ADR(Code[cur.cmd]), cur.clen); + cur := cur.Next(ASMLINE) + END; + size := size2; + Fill(Align(size, 4) - size2, 0X); + Write(sys.ADR(Data), datasize); + Coff.text.reserved8 := rcount DIV 10; + Coff.PointerToSymbolTable := Coff.text.reserved6 + rcount; + Coff.NumberOfSymbols := 4; + + WriteF(F, sys.ADR(Coff), sys.SIZE(COFFHEADER)); + WriteF(F, filebuf, OutFilePos - filebuf); + WriteF(F, sys.ADR(Reloc), rcount); + + adr := sys.ADR(sym); + InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300"); + InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300"); + sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER)); + + WriteF(F, sys.ADR(sym), LEN(sym)); + i := 4; + WriteF(F, sys.ADR(i), 4) + END; + UTILS.CloseF(F) +END WriteKOS; + +PROCEDURE WriteELF(FName: ARRAY OF CHAR; code, data, glob: INTEGER); +VAR F, delta, filebuf: INTEGER; cur: ASMLINE; bytes: ARRAY 817H + 55FH + 4900 OF CHAR; + + PROCEDURE Add(offset: INTEGER); + VAR m: INTEGER; + BEGIN + sys.GET(sys.ADR(bytes[offset]), m); + sys.PUT(sys.ADR(bytes[offset]), m + delta) + END Add; + + PROCEDURE Sub(offset: INTEGER); + VAR m: INTEGER; + BEGIN + sys.GET(sys.ADR(bytes[offset]), m); + sys.PUT(sys.ADR(bytes[offset]), m - delta) + END Sub; + + PROCEDURE Add8(a1, a2, a3, a4, a5, a6, a7, a8: INTEGER); + BEGIN + Add(a1); Add(a2); Add(a3); Add(a4); + Add(a5); Add(a6); Add(a7); Add(a8) + END Add8; + +BEGIN + sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size); + + DEC(code, 13); + + delta := Align(data, 1000H) - 100000H; + Add8(0020H, 00A4H, 00A8H, 0258H, 02B8H, 0308H, 0494H, 049CH); + Add8(04A4H, 0679H, 0681H, 06A4H, 06B0H, 06BAH, 0703H, 0762H); + Add8(0774H, 0786H, 0819H, 0823H, 17C5H, 17E5H, 17E9H, 1811H); + Add8(1839H, 1861H, 1889H, 1A25H, 1A95H, 1AA5H, 1C05H, 1C55H); + Add(1CE5H); Add(1D09H); Add(1D15H); Add(1D25H); Add(1D35H); Add(1D55H); + + delta := Align(glob, 1000H) - 3200000H; + Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H); + + delta := Align(code, 1000H) - 100000H; + Add8(0020H, 0084H, 0088H, 0098H, 009CH, 00A0H, 00B8H, 00BCH); + Add8(00C0H, 0118H, 011CH, 0120H, 0258H, 0278H, 02B8H, 0308H); + Add8(048CH, 0494H, 049CH, 04A4H, 04ACH, 04B4H, 04BCH, 04C4H); + Add8(04CCH, 04D4H, 04DCH, 04E4H, 04ECH, 04F4H, 04FCH, 0504H); + Add8(050CH, 0514H, 052BH, 0544H, 054EH, 0554H, 055EH, 056EH); + Add8(057EH, 058EH, 059EH, 05AEH, 05BEH, 05CEH, 05DEH, 05EEH); + Add8(05FEH, 060EH, 061EH, 062EH, 064CH, 0651H, 0679H, 0681H); + Add8(0686H, 068CH, 06A4H, 06ABH, 06B0H, 06BAH, 06D7H, 06EBH); + Add8(0703H, 0762H, 0774H, 0786H, 0819H, 0823H, 0828H, 082DH); + Add8(1635H, 1655H, 1659H, 167DH, 1681H, 16A5H, 16A9H, 16CDH); + Add8(16D1H, 16F5H, 16F9H, 171DH, 1721H, 1745H, 1749H, 176DH); + Add8(1771H, 1795H, 1799H, 17BDH, 17C1H, 17E5H, 17E9H, 1811H); + Add8(1839H, 1861H, 1889H, 1985H, 1995H, 19A5H, 19B5H, 19C5H); + Add8(19D5H, 19E5H, 19F5H, 1A05H, 1A15H, 1A25H, 1A55H, 1A65H); + Add8(1A75H, 1A95H, 1AA5H, 1AD5H, 1AE5H, 1AF5H, 1B05H, 1B25H); + Add8(1B35H, 1B45H, 1B55H, 1B65H, 1B75H, 1BB5H, 1BC5H, 1BE5H); + Add8(1C05H, 1C15H, 1C55H, 1C75H, 1CA5H, 1CB5H, 1CE5H, 1D05H); + Add8(1D15H, 1D25H, 1D35H, 1D55H, 1D75H, 1D89H, 08DEH, 08E8H); + Sub(0845H); Sub(087BH); Sub(0916H); Add(0C52H); Add(0C8AH); Add(0D0AH); + + OutFilePos := UTILS.GetMem(code + data + 8000H); + filebuf := OutFilePos; + UTILS.MemErr(OutFilePos = 0); + + Write(sys.ADR(bytes), 817H); + Fill(2DDH, 90X); + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + Write(sys.ADR(Code[cur.cmd]), cur.clen); + cur := cur.Next(ASMLINE) + END; + Fill(Align(code, 1000H) - code, 90X); + Write(sys.ADR(bytes[817H]), 55FH); + Write(sys.ADR(Data), data); + Fill(Align(data, 1000H) - data, 0X); + Write(sys.ADR(bytes[817H + 55FH + 55FH]), 0DC5H); + + F := UTILS.CreateF(FName); + IF F <= 0 THEN + Err(1) + END; + WriteF(F, filebuf, OutFilePos - filebuf); + UTILS.CloseF(F) +END WriteELF; + +PROCEDURE DelProc*(beg, end: ASMLINE); +BEGIN + WHILE beg # end DO + beg.clen := 0; + beg.tcmd := 0; + beg := beg.Next(ASMLINE) + END; + beg.clen := 0; + beg.tcmd := 0 +END DelProc; + +PROCEDURE FixLabels*(FName: ARRAY OF CHAR; stk, gsize, glob: INTEGER); +VAR size, asize, i, rdatasize, RCount, n, temp, temp2, temp3: INTEGER; cur: ASMLINE; R: RELOC; c: CHAR; +BEGIN + dcount := Align(dcount, 4); + IF dll THEN + LoadAdr := 10000000H; + PackExport(ExecName) + ELSIF con OR gui THEN + LoadAdr := 400000H + ELSIF kos OR obj THEN + LoadAdr := sys.SIZE(KOSHEADER) + ELSIF elf THEN + LoadAdr := 134514420 + 1024; + INC(gsize, 1024) + END; + + IF dll OR con OR gui THEN + rdatasize := 0DAH + etable.size; + size := 1000H + LoadAdr; + ELSIF kos OR elf OR obj THEN + rdatasize := 0; + size := LoadAdr + END; + + Optimization; + temp2 := size; + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + cur.adr := size; + IF cur.tcmd = LCMD THEN + sys.PUT(cur.varadr, size) + END; + size := size + cur.clen; + cur := cur.Next(ASMLINE) + END; + + size := temp2; + cur := asmlist.First(ASMLINE); + WHILE cur # NIL DO + cur.adr := size; + IF cur.tcmd = LCMD THEN + sys.PUT(cur.varadr, size) + ELSIF (cur.tcmd = JCMD) & cur.short THEN + sys.GET(cur.varadr, i); + temp3 := i - cur.Next(ASMLINE).adr; + IF (-131 <= temp3) & (temp3 <= 123) THEN + sys.GET(cur(ASMLINE).codeadr - 1, c); + IF c = JMP THEN + sys.PUT(cur(ASMLINE).codeadr - 1, 0EBX) + ELSE (*JE, JNE, JLE, JGE, JG, JL*) + sys.PUT(cur(ASMLINE).codeadr - 2, ORD(c) - 16); + sys.PUT(cur(ASMLINE).codeadr - 1, temp3); + DEC(cur(ASMLINE).codeadr) + END; + cur.clen := 2 + END + END; + size := size + cur.clen; + cur := cur.Next(ASMLINE) + END; + + IF dll OR con OR gui THEN + asize := Align(size, 1000H) + ELSIF kos OR obj THEN + asize := Align(size, 4) + ELSIF elf THEN + asize := 134514420 + 6508 + Align(size - 13 - LoadAdr, 1000H) + END; + + FOR i := 0 TO Lcount DO + IF Labels[i] < 0 THEN + Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H) + END + END; + + temp := dcount; + IF elf THEN + asize := asize + Align(dcount, 1000H) + 64 + 1024; + sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024); + dcount := 0 + END; + + IF dll THEN + asize := asize - LoadAdr + 0DAH; + FOR i := 0 TO etable.namecount - 1 DO + etable.arradr[i] := Labels[etable.arradr[i]] - LoadAdr; + etable.arrnameptr[i] := etable.arrnameptr[i] + asize + END; + etable.arradroffset := etable.arradroffset + asize; + etable.arrnameptroffset := etable.arrnameptroffset + asize; + etable.arrnumoffset := etable.arrnumoffset + asize; + etable.dllnameoffset := etable.dllnameoffset + asize; + asize := asize + LoadAdr - 0DAH + END; + IF dll OR con OR gui THEN + Labels[LoadLibrary] := asize + 4; + Labels[GetProcAddress] := asize; + R.Page := 0; + R.Size := 0; + RCount := 0; + END; + cur := asmlist.First(ASMLINE); + + FOR i := 0 TO LEN(RtlProc) - 1 DO + RtlProc[i] := Labels[RtlProc[i]] + END; + + temp3 := asize + Align(rdatasize, 1000H) + dcount; + WHILE cur # NIL DO + CASE cur.tcmd OF + |JCMD: + sys.GET(cur.varadr, i); + sys.PUT(cur.codeadr, i - cur.Next(ASMLINE).adr) + |GCMD: + sys.GET(cur.codeadr, i); + sys.PUT(cur.codeadr, i + temp3) + |OCMD: + sys.MOVE(cur.varadr, cur.codeadr, 4) + ELSE + END; + IF dll & (cur.tcmd IN {GCMD, OCMD}) THEN + n := cur.adr - LoadAdr; + IF ASR(n, 12) = ASR(R.Page, 12) THEN + R.reloc[RCount] := IntToCard16(n MOD 1000H + 3000H); + INC(RCount); + INC(R.Size, 2) + ELSE + IF R.Size # 0 THEN + PutReloc(R) + END; + R.Page := ASR(n, 12) * 1000H; + R.Size := 10; + R.reloc[0] := IntToCard16(n MOD 1000H + 3000H); + RCount := 1 + END + END; + cur := cur.Next(ASMLINE) + END; + IF R.Size # 0 THEN + PutReloc(R) + END; + IF dll OR con OR gui THEN + WritePE(FName, stk, size - 1000H - LoadAdr, dcount, rdatasize, gsize) + ELSIF kos OR obj THEN + WriteKOS(FName, Align(stk, 4), size, dcount, gsize, obj) + ELSIF elf THEN + WriteELF(FName, size - LoadAdr, temp, gsize) + END +END FixLabels; + +PROCEDURE OutStringZ(str: ARRAY OF CHAR); +VAR i: INTEGER; +BEGIN + New; + current.clen := LENGTH(str); + FOR i := 0 TO current.clen - 1 DO + Code[ccount] := str[i]; + INC(ccount) + END; + Code[ccount] := 0X; + INC(ccount); + INC(current.clen) +END OutStringZ; + +PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER); +VAR i, glob: INTEGER; +BEGIN + glob := 0; + gsize := Align(gsize, 4) + 4; + COPY(FName, OutFile); + Labels[RTABLE] := -dcount; + dataint(recarray[0]); + FOR i := 1 TO reccount DO + dataint(recarray[i]) + END; + current := start; + IF con OR gui OR dll THEN + PushInt(LoadLibrary); + PushInt(GetProcAddress); + OutCode("5859FF31FF3054") + ELSIF elf THEN + OutCode("6800000000"); + glob := current.cmd; + ELSIF kos OR obj THEN + OutByte(54H) + END; + GlobalAdr(0); + PushConst(ASR(gsize, 2)); + PushInt(RTABLE); + PushInt(SELFNAME); + CallRTL(_init); + current := asmlist.Last(ASMLINE); + IF dll THEN + OutCode("B801000000C9C20C00") + END; + IF obj THEN + OutCode("B801000000C9C20000") + END; + OutCode("EB05"); + Label(ASSRT); + CallRTL(_assrt); + OutCode("EB09"); + Label(HALT); + OutCode("6A006A00"); + CallRTL(_assrt); + OutCode("6A00"); + CallRTL(_halt); + Label(_floor); + OutCode("83EC06D93C2466812424FFF366810C24FFF7D92C2483C402D9FCDB1C2458C3"); + IF obj THEN + Label(Exports); + CmdN(szSTART); CmdN(START); + CmdN(szversion); OutInt(stk); + FOR i := 0 TO kosexpcount - 1 DO + CmdN(kosexp[i].NameLabel); CmdN(kosexp[i].Adr) + END; + OutInt(0); + Label(szSTART); OutStringZ("lib_init"); + Label(szversion); OutStringZ("version"); + FOR i := 0 TO kosexpcount - 1 DO + Label(kosexp[i].NameLabel); + OutStringZ(kosexp[i].Name.Name) + END + END; + FixLabels(FName, stk, gsize, glob) +END Epilog; + +END X86. \ No newline at end of file